From e90cc72980014bb8e113033c38058ae26a6ed1b8 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Thu, 8 Oct 2009 22:18:50 +0200
Subject: Enable WSSE authentication.

Ignore-this: a6ac88e1116f63a79ef8ccb4598b6280

darcs-hash:cc2c4916527d57c382cf2c342da04a7fd2b475ed
---
 main.lisp | 87 ++++++++++++++++++++++++++++++++++-----------------------------
 1 file changed, 47 insertions(+), 40 deletions(-)

(limited to 'main.lisp')

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))
-- 
cgit v1.2.3