Enable WSSE authentication.

Ignore-this: a6ac88e1116f63a79ef8ccb4598b6280

darcs-hash:cc2c4916527d57c382cf2c342da04a7fd2b475ed

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)
diff --git a/main.lisp b/main.lisp
index 96fd57b..137c78d 100644
--- a/main.lisp
+++ b/main.lisp
@@ -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))
diff --git a/utils.lisp b/utils.lisp
index 574d9f2..57ebbe6 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -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