Support posting and editing journal entries.

darcs-hash:e7a6041bdeeddcd098313a6c21491cefbaedbb21

5 files changed, 193 insertions, 55 deletions

diff --git a/journal-admin.cgi b/journal-admin.cgi
new file mode 100755
index 0000000..10ac2f5
--- /dev/null
+++ b/journal-admin.cgi
@@ -0,0 +1,11 @@
+#! /bin/sh
+DIR=`dirname "$0"`
+if test -e /home/mulk; then
+    # MST-plus.
+    LISPINIT_DIR="$DIR"
+else
+    # NearlyFreeSpeech.NET.
+    LISPINIT_DIR=/home/protected/journal
+fi
+
+exec clisp -M "$LISPINIT_DIR/lispinit.mem.gz" "$DIR/run.lisp" --admin-mode
diff --git a/journal.cgi b/journal.cgi
index 675d117..43082f4 100755
--- a/journal.cgi
+++ b/journal.cgi
@@ -8,4 +8,4 @@ else
     LISPINIT_DIR=/home/protected/journal
 fi
 
-exec clisp -M "$LISPINIT_DIR/lispinit.mem.gz" "$DIR/run.lisp" "$@"
+exec clisp -M "$LISPINIT_DIR/lispinit.mem.gz" "$DIR/run.lisp"
diff --git a/journal.lisp b/journal.lisp
index fa56b3f..5da6fe1 100755
--- a/journal.lisp
+++ b/journal.lisp
@@ -38,9 +38,12 @@
       (case action
         (:index "")
         (:view-atom-feed (values "/feed"))
-        (:view (values "/~D" post-id))
-        (:edit (values "/~D?action=edit" post-id))
+        (:view (if post-id
+                   (values "/~D" post-id)
+                   "/"))
+        ((:edit :preview) (values "/~D/preview" post-id))
         (:post-comment (values "/~D" post-id))
+        (:save (values "/~D/save" post-id))
         (:css (if (eq *site* :mst-plus)
                   "/../../journal.css"
                   "/../journal.css"))))))
@@ -120,20 +123,29 @@
 
 
 (defun show-journal-entry (journal-entry &key (comments-p nil))
+  (with-slots (id title body categories date) journal-entry
+     (show-journal-entry-with-components id title body categories date
+                                         (comments-about journal-entry
+                                                         :ordered-p t)
+                                         comments-p)))
+
+
+(defun show-journal-entry-with-components (id title body categories
+                                           posting-date comments comments-p)
   (<:div :class :journal-entry
-   (<:h2 (<:a :href (link-to :view :post-id (id-of journal-entry))
-              (<:as-html (title-of journal-entry))))
+   (<:h2 (<:a :href (link-to :view :post-id id)
+              (<:as-html title)))
     (<:div :class :journal-entry-header
      (<:span :class :journal-entry-date
       (<:as-html
        (format-date nil "%@day-of-week, den %day.%mon.%yr, %hr:%2min."
-                    (date-of journal-entry))))
-     (unless (null (categories-of journal-entry))
+                    posting-date)))
+     (unless (null categories)
        (<:span :class :journal-entry-category
         (<:as-html
          (format nil "Abgeheftet unter ...")))))
     (<:div :class :journal-entry-body
-     (<:as-is (journal-markup->html (body-of journal-entry))))
+     (<:as-is (journal-markup->html body)))
     (<:div :class :journal-entry-footer
      (<:form :class :journal-entry-delete-button-form
              :style "display: inline;"
@@ -145,32 +157,29 @@
                 :value "delete")
        (<:input :type "hidden"
                 :name "id"
-                :value (prin1-to-string (id-of journal-entry)))
+                :value (prin1-to-string id))
        (<:button :type "submit"
                  (<:as-is "L&ouml;schen"))))
      " | "
-     (<:form :class :journal-entry-delete-button-form
+     (<:form :class :journal-entry-edit-button-form
              :style "display: inline;"
              :method "get"
-             :action (link-to :index)
+             :action (link-to :edit :post-id id)
       (<:div :style "display: inline;"
        (<:input :type "hidden"
-                :name "action"
-                :value "edit")
-       (<:input :type "hidden"
                 :name "id"
-                :value (prin1-to-string (id-of journal-entry)))
+                :value (prin1-to-string id))
        (<:button :type "submit"
                  (<:as-is "Bearbeiten"))))
      " | "
-     (<:a :href (link-to :view :post-id (id-of journal-entry))
+     (<:a :href (link-to :view :post-id id)
           (<:as-is
-           (format nil "~D Kommentar~:*~[e~;~:;e~]" (length (comments-about journal-entry)))))))
+           (format nil "~D Kommentar~:*~[e~;~:;e~]" (length comments))))))
 
-  (when (and comments-p (not (null (comments-about journal-entry))))
+  (when (and comments-p (not (null comments)))
     (<:div :class :journal-comments
      (<:h2 "Kommentare")
-     (dolist (comment (comments-about journal-entry :ordered-p t))
+     (dolist (comment comments)
        (with-slots (author body date id email website)
            comment
          (<:div :class :journal-comment
@@ -192,7 +201,7 @@
      (<:p (<:strong "Hinweis an Spammer: ")
           (<:as-is "Hyperlinks werden so erzeugt, da&szlig; sie von Suchmaschinen
                     nicht beachtet werden.  Sparen Sie sich also die M&uuml;he."))
-     (<:form :action (link-to :view :post-id (id-of journal-entry))
+     (<:form :action (link-to :view :post-id id)
              :method "post"
              :accept-charset #+(or) "ISO-10646-UTF-1"
                              "UTF-8"
@@ -201,7 +210,7 @@
       (<:div :style "display: none"
        (<:input :type "hidden"
                 :name "id"
-                :value (prin1-to-string (id-of journal-entry)))
+                :value (prin1-to-string id))
        (<:input :type "hidden"
                 :name "action"
                 :value "post-comment"))
@@ -233,8 +242,7 @@
         (<:as-is "Ver&ouml;ffentlichen")))))))
 
 
-(defun show-web-journal ()
-  #.(locally-enable-sql-reader-syntax)
+(defun call-with-web-journal (page-title thunk)
   ;; TODO: Check how to make Squid not wait for the CGI script's
   ;;       termination, which makes generating a Last-Modified header
   ;;       feel slower to the end user rather than faster.
@@ -248,9 +256,8 @@
    (<:head
     (<:title
      (<:as-html
-      (if (member *action* '(:view :edit :preview :post-comment))
-          (format nil "~A -- Kompottkins Weisheiten"
-                  (title-of (find-entry *post-number*)))
+      (if page-title
+          (format nil "~A -- Kompottkins Weisheiten" page-title)
           "Kompottkins Weisheiten")))
     (<:link :rel "alternate"
             :type "application/atom+xml"
@@ -273,17 +280,13 @@
           "NEU!  Jetzt mit mehr als 3 % Uptime!")))
       (<:as-is " &bull;&bull;&bull;")))
     (<:div :id :contents
-     (case *action*
-       ((:index nil)
-        (mapc #'show-journal-entry
-              (select 'journal-entry :order-by '(([date] :desc)) :flatp t)))
-       ((:view :post-comment)
-        (show-journal-entry (find-entry *post-number*) :comments-p t))))
+     (funcall thunk))
     (<:div :id :navigation))
 
 
     (when *debugging-p*
       (loop for (x . y) in `(("Action" . ,*action*)
+                             ("Entry ID" . ,*post-number*)
                              ("Request method" . ,*method*)
                              ("Query" . ,*query*)
                              ("Query string" . ,(http-get-query-string))
@@ -294,10 +297,87 @@
              (<:hr)
              (<:h2 (<:as-html x))
              (<:p "Type " (<:em (<:as-html (type-of y))) ".")
-             (<:pre (<:as-html (prin1-to-string y)))))))
+             (<:pre (<:as-html (prin1-to-string y))))))))
+
+
+(defun show-web-journal ()
+  #.(locally-enable-sql-reader-syntax)
+  (with-web-journal ((if (member *action* '(:view :edit :preview :post-comment
+                                            :save-entry))
+                         (title-of (find-entry *post-number*))
+                         nil))
+    (case *action*
+      ((:index nil)
+       (mapc #'show-journal-entry
+             (select 'journal-entry :order-by '(([date] :desc)) :flatp t)))
+      ((:view :post-comment :save-entry)
+       (show-journal-entry (find-entry *post-number*) :comments-p t))))
   #.(restore-sql-reader-syntax-state))
 
 
+(defun preview-entry (title body id)
+  (with-web-journal (title)
+    (<:form :action (link-to :save :post-id id)
+            :method "post"
+            :accept-charset "UTF-8"
+            :enctype "application/x-www-form-urlencoded"
+      (when id
+        (<:input :type "hidden"
+                 :name "id"
+                 :value (prin1-to-string id)))
+      (<:input :type "hidden"
+               :name "title"
+               :value title)
+      (<:input :type "hidden"
+               :name "body"
+               :value body)
+      (<:div
+       (<:button :type "submit"
+        (<:as-is "Ver&ouml;ffentlichen"))))
+    (show-journal-entry-with-components (or id -1)
+                                        title
+                                        body
+                                        nil
+                                        (get-universal-time)
+                                        nil
+                                        nil)
+    ;; Editor here.
+    (<:form :action (link-to :preview :post-id id)
+            :method "post"
+            :accept-charset "UTF-8"
+            :enctype "application/x-www-form-urlencoded"
+      (<:div :style "display: none"
+       (when id
+         (<:input :type "hidden"
+                  :name "id"
+                  :value (prin1-to-string id))))
+      (<:div :style "display: table"
+       (<:div :style "display: table-row"
+        (<:div :style "display: table-cell; vertical-align: top"
+         (<:label :for "entry-title-editor"
+                  :style "vertical-align: top"
+          (<:as-is "&Uuml;berschrift: ")))
+        (<:div :style "display: table-cell;"
+         (<:input :type "text"
+                  :name "title"
+                  :value title
+                  :id "entry-title-editor")))
+       (<:div :style "display: table-row"
+        (<:div :style "display: table-cell; vertical-align: top"
+         (<:label :for "entry-body-editor"
+                  :style "vertical-align: top"
+          (<:as-html "Kommentar: ")))
+        (<:div :style "display: table-cell"
+         (<:textarea :name "body"
+                     :id "entry-body-editor"
+                     :rows 20
+                     :cols 65
+           (<:as-html body)))))
+      (<:div
+       (<:button :type "submit"
+        (<:as-is "Vorschau"))))))
+
+
 (defun show-debugging-page ()
   (http-add-header "Content-Language" "de")
   (http-send-headers "text/html; charset=UTF-8")
@@ -306,6 +386,7 @@
           :lang "de"
     (when *debugging-p*
       (loop for (x . y) in `(("Action" . ,*action*)
+                             ("Entry ID" . ,*post-number*)
                              ("Request method" . ,*method*)
                              ("Query" . ,*query*)
                              ("Query string" . ,(http-get-query-string))
diff --git a/macros.lisp b/macros.lisp
index 179adca..a17891f 100644
--- a/macros.lisp
+++ b/macros.lisp
@@ -34,6 +34,10 @@
   (emit-close-tag "html"))
 
 
+(defmacro with-web-journal ((page-title) &body body)
+  `(call-with-web-journal ,page-title #'(lambda () ,@body)))
+
+
 (defmacro with-result-cache ((cache-id &key (younger-than nil younger-than-p))
                              &body body)
   `(call-with-result-cache ,cache-id
diff --git a/main.lisp b/main.lisp
index a16e1ed..90487cd 100644
--- a/main.lisp
+++ b/main.lisp
@@ -46,9 +46,11 @@
                                                (getf *query* :id ""))
                                            :junk-allowed t  #|| :radix 12 ||#))
          (*action*          (or (keywordify (getf *query* :action))
-                                (cond (*post-number*                      :view)
-                                      ((string= "feed" (first *subpath*)) :view-atom-feed)
+                                (cond ((string= "feed" (first *subpath*)) :view-atom-feed)
                                       ((string= "debug" (first *subpath*)) :view-debugging-page)
+                                      ((string= "preview" (car (last *subpath*))) :preview-entry)
+                                      ((string= "save" (car (last *subpath*))) :save-entry)
+                                      (*post-number*                      :view)
                                       (t                                  nil))))
          (*method*          (keywordify (gethash "REQUEST_METHOD" *http-env*)))
          (*script-filename* (pathname-as-file
@@ -79,32 +81,72 @@
       (funcall func))))
 
 
+(defun dispatch-admin-action ()
+  (case *action*
+    (:preview-entry (let ((entry (and *post-number*
+                                      (find-entry *post-number*))))
+                      (preview-entry (or (getf *query* :title nil)
+                                         (and entry (title-of entry))
+                                         "")
+                                     (or (getf *query* :body nil)
+                                         (and entry (body-of entry))
+                                         "")
+                                     *post-number*)))
+    (:save-entry (with-transaction ()
+                   (let* ((entry (if *post-number*
+                                     (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 *post-number*
+                       (setf (last-modification-of entry)
+                             (get-universal-time)))
+                     (setf *post-number* (id-of entry))
+                     (setf (body-of entry) (getf *query* :body)
+                           (title-of entry) (getf *query* :title))
+                     (update-records-from-instance entry)))
+                 (show-web-journal))
+    (otherwise (show-web-journal))))
+
+
+(defun dispatch-user-action ()
+  (case *action*
+    (:post-comment   (with-transaction ()
+                       (let* ((entry (find-entry *post-number*))
+                              (comment
+                               (make-instance 'journal-comment
+                                  :id       (make-journal-comment-id)
+                                  :uuid     (make-uuid)
+                                  :entry-id (id-of entry)
+                                  :date     (get-universal-time)
+                                  :author   (getf *query* :author)
+                                  :email    (getf *query* :email)
+                                  :website  (getf *query* :website)
+                                  :body     (getf *query* :comment-body))))
+                         (push comment (comments-about entry))
+                         (update-records-from-instance comment)
+                         (update-records-from-instance entry)))
+                     (show-web-journal))
+    (:view-atom-feed (show-atom-feed))
+    (:view-debugging-page (show-debugging-page))
+    (otherwise       (show-web-journal))))
+
+
 #+clisp
 (defun journal-main ()
   (ext:letf ((custom:*terminal-encoding* (ext:make-encoding
                                           :charset charset:utf-8)))
     (with-initialised-journal
       (let ((*random-state* (make-random-state t)))
-        (case *action*
-          (:post-comment   (with-transaction ()
-                             (let* ((entry (find-entry *post-number*))
-                                    (comment
-                                     (make-instance 'journal-comment
-                                        :id       (make-journal-comment-id)
-                                        :uuid     (make-uuid)
-                                        :entry-id (id-of entry)
-                                        :date     (get-universal-time)
-                                        :author   (getf *query* :author)
-                                        :email    (getf *query* :email)
-                                        :website  (getf *query* :website)
-                                        :body     (getf *query* :comment-body))))
-                               (push comment (comments-about entry))
-                               (update-records-from-instance comment)
-                               (update-records-from-instance entry)))
-                           (show-web-journal))
-          (:view-atom-feed (show-atom-feed))
-          (:view-debugging-page (show-debugging-page))
-          (otherwise       (show-web-journal)))))))
+        (if (member "--admin-mode"
+                    (coerce (ext:argv) 'list)
+                    :test #'string=)
+            (dispatch-admin-action)
+            (dispatch-user-action))))))
 
 
 #+clisp