summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-10-05 15:24:00 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-10-05 15:24:00 +0200
commite6b65cb7b6c16d1fb9ecb86260dddb1fc0c4b115 (patch)
tree71a11ce4bef2b308a34fb4fca0a169c7f651eedd
parent6f902003195726be98e6961111bcf0e9251a9023 (diff)
Support posting and editing journal entries.
darcs-hash:e7a6041bdeeddcd098313a6c21491cefbaedbb21
-rwxr-xr-xjournal-admin.cgi11
-rwxr-xr-xjournal.cgi2
-rwxr-xr-xjournal.lisp145
-rw-r--r--macros.lisp4
-rw-r--r--main.lisp86
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