summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--mulkcms-hunchentoot.lisp48
-rw-r--r--mulkcms.lisp57
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"