Fix Atom posting and putting behaviour.

Ignore-this: 699e88b96861c768a840e5697d34d537

darcs-hash:f336d3040ad229cc6c7b6f1fbcfe70e30b774435

1 files changed, 29 insertions, 23 deletions

diff --git a/main.lisp b/main.lisp
index 137c78d..88685e1 100644
--- a/main.lisp
+++ b/main.lisp
@@ -250,11 +250,11 @@
                             (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")
+       (cond ((eq *method* :get)
               (if *post-number*
                   (show-atom-entry)
                   (show-atom-feed :include-edit-links t :full-content t)))
-             ((member *method* '("POST" "PUT") :test 'equal)
+             ((member *method* '(:post :put))
               (with-transaction ()
                 (let* ((entry (if (string= *method* "PUT")
                                   (find-entry *post-number*)
@@ -268,27 +268,33 @@
                   (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)))))
+                  (flet ((tag-equal (tag1 tag2)
+                           (equal (if (consp tag1) (car tag1) tag1)
+                                  (if (consp tag2) (car tag2) tag2))))
+                    (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 #'tag-equal))
+                           (content (caddr content-element))
+                           (title-element (find "title" entry-elements :key 'car :test #'tag-equal))
+                           (title-type (cadr (assoc "type" (cadr title-element))))
+                           (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)
+                  (setq *post-number* (id-of entry))))
+              (show-atom-entry))
+             (t (debug-log "Oops. Method was:") (debug-log *method*)))))
     (:view-atom-feed (show-atom-feed))
     (:view-comment-feed (show-comment-feed))
     (:view-debugging-page (show-debugging-page))