summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--globals.lisp3
-rw-r--r--main.lisp87
-rw-r--r--utils.lisp32
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