;;;-*- Mode: Lisp; Package: HTTP-DEMO -*- (in-package :http-user) ; ; Cookies demo ; ; Global variable to store passwords (defparameter *password-file* nil) (defun lookup-user (name) (assoc name *password-file* :test #'equal)) (defun digest-user (username password) (md5:md5-digest-hexadecimal-string (concatenate 'string username password))) (defun create-user (name password) (push (cons name (digest-user name password)) *password-file*)) ; General macro to emit a page with additional headers (defmacro with-headers-page ((stream title &key headers) &body body) "Provides the response function to emit a page body." `(with-successful-response (,stream :html :additional-headers ,headers) (with-html-document (:stream ,stream) (with-document-preamble (:stream ,stream) (declare-title ,title :stream ,stream)) (with-document-body (:stream ,stream) (with-section-heading (,title :stream ,stream) ,@body))))) ; Displaying the login page (defun display-login-page (url stream &optional error) "Form function to display a login form." (declare (ignore url)) (with-headers-page (stream "Login") (when error (with-paragraph (:stream stream :style "color:red") (write-string error stream))) (with-fillout-form (:post "/login.html" :stream stream) (with-paragraph (:stream stream) (accept-input 'string "name" :label "User Name:" :stream stream :size 36)) (with-paragraph (:stream stream) (accept-input 'password "password" :label "Password:" :stream stream :size 36) (accept-input 'submit-button "Login" :display-string "Login" :stream stream))))) (defun respond-to-login (url stream alist) "Response function to process the login." (bind-query-values (name password) (url alist) (let ((user (lookup-user name)) (digest (digest-user name password))) (if (or (null user) (not (equal digest (cdr user)))) (display-login-page url stream "Invalid user name and/or password.") ;; Successful login (let ((title "Successful login") (cookie (http:set-cookie-http-headers (:name name :expires nil :domain ".localhost" :path "/") (:digest digest :expires nil :domain ".localhost" :path "/")))) (with-headers-page (stream title :headers cookie) (with-paragraph (:stream stream) (write-string "Welcome!" stream)) (note-anchor "Continue" :reference "/user.html" :stream stream))))))) (defun in-n-days (n) (+ (get-universal-time) (* 60 60 24 n))) (export-url "http://localhost:8000/login.html" :html-computed-form :form-function 'display-login-page :response-function 'respond-to-login) ; Alternative version with an automatic redirect (defun respond-to-login (url stream alist) "Response function to process the login." (bind-query-values (name password) (url alist) (let ((user (lookup-user name)) (digest (digest-user name password))) (if (or (null user) (not (equal digest (cdr user)))) (display-login-page url stream "Invalid user name and/or password.") ;; Successful login (let ((title "Successful login") (cookie (http:set-cookie-http-headers (:name name :expires nil :domain ".localhost" :path "/") (:digest digest :expires nil :domain ".localhost" :path "/"))) (refresh (list :refresh "1;URL=/user.html"))) (with-headers-page (stream title :headers (append cookie refresh)) (with-paragraph (:stream stream) (write-string "Logging in..." stream)))))))) ; Returns user info (name . digest) (defmacro with-valid-user ((user url stream) &body body) `(http:with-cookie-values ((name digest)) (let ((,user (valid-login name digest ,url ,stream))) (when ,user ,@body)))) (defun valid-login (name digest url stream) (cond ((null name) (display-login-page url stream "You need to login to access this page.") nil) (t (let ((user (lookup-user name))) (cond ((or (null user) (not (equal (cdr user) digest))) (display-login-page url stream "Invalid user/password.") nil) (t user)))))) (defun write-user-page (url stream) (with-valid-user (user url stream) (with-headers-page (stream "User Page") (with-paragraph (:stream stream) (format stream "User ~a page" (car user))) (note-anchor "Log out" :reference "/logout.html" :stream stream)))) (export-url "http://localhost:8000/user.html" :computed :response-function 'write-user-page) ; Logout page - clears both the cookies (defun write-logout-page (url stream) (declare (ignore url)) (let ((headers (http:set-cookie-http-headers (:name "" :expires 0 :domain ".localhost" :path "/") (:digest "" :expires 0 :domain ".localhost" :path "/")))) (with-headers-page (stream "Logout" :headers headers) (with-paragraph (:stream stream) (write-string "Logged out" stream))))) (export-url "http://localhost:8000/logout.html" :computed :response-function 'write-logout-page)