diff options
| -rw-r--r-- | globals.lisp | 3 | ||||
| -rw-r--r-- | main.lisp | 87 | ||||
| -rw-r--r-- | utils.lisp | 32 |
3 files changed, 81 insertions, 41 deletions
diff --git a/globals.lisp b/globals.lisp index e039217..e832646 100644 --- a/globals.lisp +++ b/globals.lisp @@ -79,4 +79,5 @@ (defparameter *site-root* nil) (defparameter *if-modified-since* nil) - +(defparameter *wsse* nil) +(defparameter *wsse-key* nil) @@ -59,6 +59,8 @@ (*method* (keywordify (gethash "REQUEST_METHOD" *http-env*))) (*if-modified-since* #+clisp (ext:getenv "HTTP_IF_MODIFIED_SINCE") #-clisp nil) + (*wsse* #+clisp (ext:getenv "HTTP_X_WSSE") + #-clisp nil) (*script-filename* (pathname-as-file (or (gethash "SCRIPT_FILENAME" *http-env*) "/home/mulk/Dokumente/Projekte/Mulkblog/journal.cgi"))) @@ -78,6 +80,10 @@ "wordpress-api-key.key" *data-dir*)) (read-line file))) + (*wsse-key* (with-open-file (file (merge-pathnames + "wsse.key" + *data-dir*)) + (read-line file))) (database-file (merge-pathnames #p"journal.sqlite3" *data-dir*)) (sqlite-library (merge-pathnames #p"libsqlite3.so" (ecase *site* @@ -145,46 +151,6 @@ :where [= [id] id] :av-pairs `((spam_p "t"))))) (show-moderation-page))) - (:view-atom-entry - (cond ((string= *method* "GET") - (if *post-number* - (show-atom-entry) - (show-atom-feed :include-edit-links t :full-content t))) - ((member *method* '("POST" "PUT") :test 'equal) - (with-transaction () - (let* ((entry (if (string= *method* "PUT") - (find-entry *post-number*) - (make-instance 'journal-entry - :id (make-journal-entry-id) - :uuid (make-uuid) - :date (get-universal-time) - :last-modification nil - :categories () - :comments ())))) - (when (string= *method* "PUT") - (setf (last-modification-of entry) - (get-universal-time))) - (let* ((post-data (with-output-to-string (out) - (loop for line = (read-line *standard-input* nil nil nil) - while line - do (write-line line out)))) - (xml (xmls:parse post-data)) - (entry-elements (cddr xml)) - (content-element (find "content" entry-elements :key 'car :test 'equal)) - (content (caddr content-element)) - (title-element (find "title" entry-elements :key 'cat :test 'equal)) - (content-type (cadr (assoc "type" (cadr content-element)))) - (content-mode (cadr (assoc "type" (cadr content-element))))) - (when content-element - (setf (body-of entry) (etypecase content - (null "") - (cons (xmls:toxml content :indent t)) - (string content)))) - (when title-element - (setf (title-of entry) (or (caddr title-element) ""))) - (setf (entry-type-of entry) "html")) - (update-records-from-instance entry))) - (show-atom-entry)))) (otherwise (show-web-journal))) #.(restore-sql-reader-syntax-state)) @@ -282,6 +248,47 @@ (format t "<?xml version=\"1.0\" encoding=\"utf-8\"?>~&<response>~&<error>0</error>~&</response>")) (t (format t "<?xml version=\"1.0\" encoding=\"utf-8\"?>~&<response>~&<error>1</error>~&<message>No URI was provided.</message>~&</response>")))))) + (:view-atom-entry + (with-wsse-authentication () + (cond ((string= *method* "GET") + (if *post-number* + (show-atom-entry) + (show-atom-feed :include-edit-links t :full-content t))) + ((member *method* '("POST" "PUT") :test 'equal) + (with-transaction () + (let* ((entry (if (string= *method* "PUT") + (find-entry *post-number*) + (make-instance 'journal-entry + :id (make-journal-entry-id) + :uuid (make-uuid) + :date (get-universal-time) + :last-modification nil + :categories () + :comments ())))) + (when (string= *method* "PUT") + (setf (last-modification-of entry) + (get-universal-time))) + (let* ((post-data (with-output-to-string (out) + (loop for line = (read-line *standard-input* nil nil nil) + while line + do (write-line line out)))) + (xml (xmls:parse post-data)) + (entry-elements (cddr xml)) + (content-element (find "content" entry-elements :key 'car :test 'equal)) + (content (caddr content-element)) + (title-element (find "title" entry-elements :key 'cat :test 'equal)) + (content-type (cadr (assoc "type" (cadr content-element)))) + (content-mode (cadr (assoc "type" (cadr content-element))))) + (when content-element + (setf (body-of entry) (etypecase content + (null "") + (cons (xmls:toxml content :indent t)) + (string content)))) + (when title-element + (setf (title-of entry) (or (caddr title-element) ""))) + (setf (entry-type-of entry) "html")) + (update-records-from-instance entry))) + (show-atom-entry))))) (:view-atom-feed (show-atom-feed)) (:view-comment-feed (show-comment-feed)) (:view-debugging-page (show-debugging-page)) @@ -381,3 +381,35 @@ ELEMENT-TYPE as the stream's." (ext:quit 0)))) #-clisp nil) + + +(defun call-with-wsse-authentication (thunk) + (let ((params (list))) + (ppcre:do-scans (start end regstarts regends "(\\w+)=\"(.*?)\"" *wsse*) + (setf params (acons (subseq *wsse* (elt regstarts 0) (elt regends 0)) + (subseq *wsse* (elt regstarts 1) (elt regends 1)) + params))) + (let* ((timestamp (cdr (assoc "created" params :test 'equalp))) + (time (cybertiggyr-time:parse-time timestamp)) + (nonce (cdr (assoc "nonce" params :test 'equalp))) + (user (cdr (assoc "username" params :test 'equalp))) + (their-digest (cdr (assoc "passworddigest" params :test 'equalp))) + (our-digest (cl-base64:string-to-base64-string + (ironclad:digest-sequence + 'ironclad:sha1 + (format nil "~A~A~A" nonce timestamp *wsse-key*))))) + (declare (ignore user)) + (if (and (string= their-digest our-digest) + (<= (abs (- (get-universal-time) time)) (* 5 60))) + (funcall thunk) + (progn + (http-add-header "Status" "401 Unauthorized") + (http-add-header "WWW-Authenticate" "WSSE realm=\"Mulk Journal\", profile=\"UsernameToken\"") + (http-add-header "X-Authentication-Message" + (if (string= their-digest our-digest) + "Time stamp too old." + "Wrong user name or password."))))))) + + +(defmacro with-wsse-authentication (() &body body) + `(call-with-wsse-authentication (lambda () ,@body)))
\ No newline at end of file |