|
- ;;;
- ;;; See http://diary.wshito.com/comp/lisp/clack/lack-middleware-session/
- ;;; for explanation.
- ;;;
-
- (ql:quickload 'clack)
- (ql:quickload 'lack)
-
- (defun starts-with (str prefix)
- (when (>= (length str) (length prefix))
- (string= (subseq str 0 (length prefix)) prefix)))
-
- ;;; Middleware to proctect the secure area
- ;;; :uidが設定されていない場合,protected-pathにアクセスすると
- ;;; redirect関数を呼び出してログインページへリダイレクトする.
- (defun secure-mw (redirect protected-path)
- (lambda (app)
- (lambda (env)
- ;; preprocessing
- (let* ((url (getf env :path-info))
- (session (getf env :lack.session))
- (uid (gethash :uid session)))
- (if (and (null uid)
- (dolist (prefix protected-path)
- (when (starts-with url prefix) (return t))))
- (progn
- ;;当初のアクセス先をセッション変数に保存
- (setf (gethash :prev-url session) url)
- (funcall redirect))
- (funcall app env))))))
-
- ;;; ログインページへリダイレクトするレスポンスを返す.
- (defun redirect-to-login-page ()
- '(303 (:location "/login") ("")))
-
- (defun get-uid (env)
- (gethash :uid (getf env :lack.session)))
-
- (defun get-session-id (env)
- (getf (getf env :lack.session.options) :id))
-
- (defun get-change-id (env)
- (format nil "~A" (getf (getf env :lack.session.options) :change-id)))
-
- (defun page-header (env)
- `("<html><h1>Lack Session Middleware Test</h1>
- <h2>--- Login Logout Example ---</h2>
- <ul>
- <li>Access any directories. Any directories under '<b>/private</b>' needs to be logged in to access.</li>
- <li>Session ID: " ,(get-session-id env) "</li>
- <li>:change-id = " ,(get-change-id env) "</li>
- </ul>
- <hr />"))
-
- (defun status (uid)
- (if uid
- `("<p>You are logged in as " ,uid ". (<a href='/logout'>logout</a>)</p>")
- `("<p><a href='/login'>Login</a></p>")))
-
- (defun page-footer ()
- '("</html>"))
-
- (defun login-form ()
- ;; /auth にuidとpasswdをPOST
- '("<p>Use '<b>wshito</b>' for username, '<b>mypass</b>' for password.</p>
- <form action='/auth' method='post'>
- <p>Username:
- <input type='text' name='uname' maxlength='32' autocomplete='OFF' /></p>
- <p>Password:
- <input type='password' name='passwd' maxlength='32' autocomplete='OFF' /></p>
- <p><input type='submit' value='Login' /></p>
- </form>"))
-
- ;;; ログインページ
- (defparameter *login*
- (lambda (env)
- (let ((uid (get-uid env)))
- `(200 (:content-type "text/html")
- ,(append (page-header env)
- (if uid
- (list "<p>You are already logged in as " uid ".</p>")
- (login-form))
- (page-footer))))))
-
- ;;; ログアウトページ
- (defparameter *logout*
- (lambda (env)
- (setf (getf (getf env :lack.session.options) :expire) t)
- `(200 (:content-type "text/html")
- ,(append (page-header env)
- (list "<p>You have logged out.</p>")
- (page-footer)))))
-
- ;;; 認証関数
- (defun authenticate (name password)
- (and (string= name "wshito")
- (string= password "mypass")))
-
- ;;; :body-parameters内にはPOSTで送られたパラメータが,ドット対
- ;;; のリストとして保持されている.この場合だと,
- ;;; (("uname" . "wshito") ("passwd" . "mypass"))
- (defparameter *auth*
- (lambda (env)
- (let* ((params (getf env :body-parameters))
- (name (cdr (assoc "uname" params :test #'string=)))
- (pass (cdr (assoc "passwd" params :test #'string=))))
- (if (and (= (length params) 2)
- (authenticate name pass))
- (let* ((session (getf env :lack.session))
- (url (gethash :prev-url session "/")))
- (setf (gethash :uid session "/") name)
- (setf (getf (getf env :lack.session.options) :change-id) t)
- `(303 (:location ,url) ("")))
- (redirect-to-login-page)))))
-
- ;;; ログインが必要なprivateエリア
- (defparameter *private*
- (lambda (env)
- (let* ((session (getf env :lack.session))
- (uid (gethash :uid session nil))
- ;; /privateにmountしているのでpathには/privateが含まれない
- (path (concatenate 'string "/private" (getf env :path-info))))
- `(200 (:content-type "text/html")
- ,(append (page-header env)
- (status uid)
- (list "<p>Private Area: path = " path "</p>")
- (page-footer))))))
-
- ;;;
- ;;; Main App
- ;;;
- (defparameter *sample-app*
- (lambda (env)
- (let* ((session (getf env :lack.session))
- (uid (gethash :uid session))
- (path (getf env :path-info)))
- (when (null uid) (setf (gethash :prev-url session) path))
- `(200 (:content-type "text/html")
- ,(append (page-header env)
- (status uid)
- (list "<p>path = " path "</p>")
- (page-footer))))))
-
- ;;;
- ;;; Creates Lack Application
- ;;; builderチェーンの最後だけが1重lambdaで,それ以外は2重lambda.
- ;;; builderされ*app*に渡される内容は外側のlambda式がfuncallで呼びだされた
- ;;; 後の結果.外側のlambdaはbuilder時に実行される.
- (defparameter *app*
- (lack:builder
- :session
- (secure-mw #'redirect-to-login-page '("/private"))
- (:mount "/login" *login*)
- (:mount "/auth" *auth*)
- (:mount "/logout" *logout*)
- (:mount "/private" *private*)
- *sample-app*))
-
- ;;;
- ;;; Starts the Web server
- ;;;
- (defparameter *handler*
- (clack:clackup *app*))
-
- ;;;
- ;;; Stops the Web server
- ;;;
- ;; (clack:stop *handler*)
|