diff options
| -rw-r--r-- | mulkcms-hunchentoot.lisp | 48 | ||||
| -rw-r--r-- | mulkcms.lisp | 57 |
2 files changed, 58 insertions, 47 deletions
diff --git a/mulkcms-hunchentoot.lisp b/mulkcms-hunchentoot.lisp index 762d181..a2e5a15 100644 --- a/mulkcms-hunchentoot.lisp +++ b/mulkcms-hunchentoot.lisp @@ -14,6 +14,9 @@ (not (directory-pathname-p file)) (lambda () (handle-static-file file))))) +(defun handle-authorization-page () + (hunchentoot:require-authorization "MulkCMS")) + (defun dispatch-mulkcms-request (request) (let* ((relative-path (subseq (script-name request) 1)) (mulkcms::*use-ssl-p* (equal (header-in* :x-use-ssl) @@ -25,26 +28,31 @@ (mulkcms::*request-method* (hunchentoot:request-method*)) (mulkcms::*headers* - (hunchentoot::headers-in*))) - (let ((result (mulkcms::find-request-handler relative-path - (append (get-parameters*) - (post-parameters*)) - (header-in* :accept-language)))) - (typecase result - (cons - (when-let (content-type (getf result :content-type)) - (setf (hunchentoot:content-type*) content-type)) - (when-let (headers (getf result :headers)) - (dolist (header headers) - (setf (hunchentoot:header-out (car header)) - (cdr header)))) - (when-let (return-code (getf result :return-code)) - (setf (hunchentoot:return-code*) return-code) - ;;(hunchentoot:abort-request-handler) - ) - (getf result :body)) - (t - result))))) + (hunchentoot::headers-in*)) + (mulkcms::*authorization-page-handler* + #'handle-authorization-page)) + (multiple-value-bind + (mulkcms::*user-name* mulkcms::*password*) + (hunchentoot:authorization) + (let ((result (mulkcms::find-request-handler relative-path + (append (get-parameters*) + (post-parameters*)) + (header-in* :accept-language)))) + (typecase result + (cons + (when-let (content-type (getf result :content-type)) + (setf (hunchentoot:content-type*) content-type)) + (when-let (headers (getf result :headers)) + (dolist (header headers) + (setf (hunchentoot:header-out (car header)) + (cdr header)))) + (when-let (return-code (getf result :return-code)) + (setf (hunchentoot:return-code*) return-code) + ;;(hunchentoot:abort-request-handler) + ) + (getf result :body)) + (t + result)))))) (defun setup-handlers () (setq *dispatch-table* diff --git a/mulkcms.lisp b/mulkcms.lisp index 01e11cf..45fdac6 100644 --- a/mulkcms.lisp +++ b/mulkcms.lisp @@ -12,6 +12,9 @@ (defvar *real-remote-addr*) (defvar *request-method*) (defvar *headers*) +(defvar *user-name*) +(defvar *password*) +(defvar *authorization-page-handler*) (unless (member "html-human-date" *template-formatters* :key #'car :test #'equal) (setq *template-formatters* @@ -577,7 +580,7 @@ "journal/feed" "journal/feed") :test #'string=) (dynamic-lambda (*propagated-params* *base-uri* *use-ssl-p* *request-method* - *headers*) () + *headers* *user-name* *password*) () (with-db (with-cache (path (query "SELECT max(date) FROM article_revisions" :single) @@ -761,27 +764,25 @@ ,@options)) (defun call-with-authorization (thunk &key require) - (multiple-value-bind (user-name password) - (hunchentoot:authorization) - (with-db - (let ((user-id (query (format nil - "SELECT id - FROM users u - JOIN passwords p ON u.id = p.user - WHERE p.password = $2 - AND u.name = $1 - AND ~A" - (ecase require - ((nil) "true") - ((:admin) "u.status = 'admin'") - ((:trusted) "u.status IN ('trusted', 'admin')") - ((:approved) "u.status IN ('approved', 'trusted', 'admin')"))) - user-name - password - :single))) - (if user-id - (funcall thunk user-id) - (hunchentoot:require-authorization "MulkCMS")))))) + (with-db + (let ((user-id (query (format nil + "SELECT id + FROM users u + JOIN passwords p ON u.id = p.user + WHERE p.password = $2 + AND u.name = $1 + AND ~A" + (ecase require + ((nil) "true") + ((:admin) "u.status = 'admin'") + ((:trusted) "u.status IN ('trusted', 'admin')") + ((:approved) "u.status IN ('approved', 'trusted', 'admin')"))) + *user-name* + *password* + :single))) + (if user-id + (funcall thunk user-id) + (funcall *authorization-page-handler*))))) (defun parse-row-or-array (string) (let ((output (list))) @@ -829,7 +830,8 @@ *requested-characteristics*)) (declare (ignore characteristics action)) (when (string= path "admin/comments") - (dynamic-lambda (*propagated-params* *base-uri* *use-ssl-p*) () + (dynamic-lambda (*user-name* *password* *propagated-params* *base-uri* + *use-ssl-p*) () (with-authorization (user-id :require :admin) (declare (ignore user-id)) (with-db @@ -877,7 +879,7 @@ *requested-characteristics*)) (declare (ignore characteristics action)) (when (string= path "admin/articles") - (dynamic-lambda (*propagated-params* *base-uri* *use-ssl-p*) () + (dynamic-lambda (*user-name* *password* *propagated-params* *base-uri* *use-ssl-p*) () (with-authorization (user-id :require :admin) (with-db (labels ((paramify-revision-row (row article-id) @@ -982,7 +984,7 @@ :single))) (ecase action (:edit - (dynamic-lambda (*propagated-params* *base-uri* *use-ssl-p*) () + (dynamic-lambda (*user-name* *password* *propagated-params* *base-uri* *use-ssl-p*) () (with-authorization (user-id :require :admin) (with-db (with-transaction () @@ -1082,7 +1084,8 @@ :characteristics-label "Characteristics")))))))) (:view (dynamic-lambda (*propagated-params* *base-uri* *use-ssl-p* *headers* - *real-remote-addr* *user-agent* *request-method*) () + *real-remote-addr* *user-agent* *request-method* + *user-name* *password*) () (with-db (with-cache (path (query "SELECT max(date) @@ -1196,7 +1199,7 @@ (defun find-transaction-key-handler (path) (when (string= path "RPC/generate-transaction-key") - (dynamic-lambda (*propagated-params* *base-uri* *use-ssl-p*) () + (dynamic-lambda (*user-name* *password* *propagated-params* *base-uri* *use-ssl-p*) () (with-db (list :content-type "text/plain; charset=utf-8" :body (format nil "~D" |