Further decouple the core from Hunchentoot.

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"