Add the capability to actually display journal entries.

darcs-hash:84a7299dd046dd8be87a7ff406aaff3cec092abf

1 files changed, 147 insertions, 21 deletions

diff --git a/journal.lisp b/journal.lisp
index 9bc71e6..35008ef 100755
--- a/journal.lisp
+++ b/journal.lisp
@@ -46,32 +46,158 @@
 
 (defparameter *action*
   (keywordify (getf *query* :action))
-  "One of NIL, :INDEX, :VIEW, :POST, :EDIT, and :PREVIEW.")
+  "One of NIL, :INDEX, :VIEW-ATOM-FEED, :VIEW, :POST, :EDIT, and :PREVIEW.")
 
-(defparameter *entry-number*
-  (parse-integer (getf *query* :entry "")
+(defparameter *post-number*
+  (parse-integer (getf *query* :post "")
                  :junk-allowed t  #|| :radix 12 ||#)
-  "The identification number of the blog entry to be acted upon.
+  "The identification number of the journal entry to be acted upon.
    May be NIL.")
 
 (defparameter *method*
   (keywordify (gethash "REQUEST_METHOD" (http-get-env-vars)))
   "One of :GET, :POST, :PUT, and :DELETE.")
 
-
-(http-add-header "Content-type" "text/html; charset=UTF-8")
-(http-send-headers)
-
-
-(<:html
- (<:body
-  (loop for (x . y) in `(("Action" . ,*action*)
-                         ("Request method" . ,*method*)
-                         ("Query" . ,*query*)
-                         ("Query string" . ,(http-get-query-string))
-                         ("Environment" . ,(http-get-env-vars)))
-        do (<:p
-            (<:hr)
-            (<:h2 (<:as-html x))
-            (<:p "Type " (<:em (<:as-html (type-of y))) ".")
-            (<:pre (<:as-html (prin1-to-string y)))))))
+(defparameter *journal-entries*
+  '()
+  "A list of JOURNAL-ENTRY objects.")
+
+(defparameter *http-env*
+  (http-get-env-vars)
+  "A hash table of HTTP environment variables.")
+
+
+(defclass journal-entry ()
+  ((id :type (integer 0)
+       :accessor id-of
+       :initarg :id)
+   (title :type string
+          :accessor title-of
+          :initarg :title
+          :initform "")
+   (body :type string
+         :accessor body-of
+         :initarg :body
+         :initform "")
+   (categories :type list
+               :accessor categories-of
+               :initarg :categories
+               :initform '())))
+
+
+(defmethod shared-initialize ((journal-entry journal-entry) slot-names
+                              &key)
+  (with-slots (id) journal-entry
+    (when (or (eq slot-names t)
+              (member 'id slot-names))
+      (setf id (1+ (reduce #'max *journal-entries*
+                           :key #'id-of
+                           :initial-value -1)))))
+  (call-next-method))
+
+
+(defun journal-markup->html (markup)
+  (if (string= "" markup)
+      markup
+      (handler-bind
+          ((error   ;; method-call-type-error or not
+            ;; Work around a weird bug in cl-markdown or CLISP.  (I
+            ;; don't know which.)
+            #'(lambda (c)
+                (declare (ignore c))
+                #+nil (<:as-html
+                       (with-output-to-string (s)
+                         (system::pretty-print-condition c s)))
+                (invoke-restart 'return nil))))
+        (with-output-to-string (s)
+          ;; Normally, we shouldn't need to create our own stream to
+          ;; write into, but this is, of course, yet another
+          ;; CLISP/Markdown hack, because Markdown's default
+          ;; *OUTPUT-STREAM* seems to spontaneously close itself, making
+          ;; everything break when Markdown tries to render more stuff.
+          (markdown markup :stream s)))))
+
+
+(defun read-journal-entry (filename)
+  (with-open-file (file filename :direction :input
+                                 :external-format #+clisp charset:utf-8
+                                                  #+sbcl :utf-8)
+    (let ((*read-eval* nil))
+      (let ((data (read file)))
+        (apply #'make-instance 'journal-entry data)))))
+
+
+(defun read-journal-entries ()
+  (let ((directory
+         (make-pathname
+          :directory (pathname-directory
+                      (merge-pathnames
+                       (make-pathname :directory '(:relative "journal-entries")
+                                      :name nil)
+                       (pathname-as-file
+                        (or (gethash "SCRIPT_FILENAME" *http-env*)
+                            "/home/mulk/Dokumente/Projekte/Mulkblog/journal.cgi"))))))
+        (journal-entries (list)))
+    (when (file-exists-p directory)
+      (walk-directory directory
+                      #'(lambda (x)
+                          (push (read-journal-entry x) journal-entries))
+                      :test (complement #'directory-pathname-p)))
+    (sort journal-entries #'>= :key #'id-of)))
+
+
+(defun show-atom-feed ()
+  (http-add-header "Content-type" "text/xml; charset=UTF-8")
+  (http-send-headers))
+
+
+(defun show-web-journal ()
+  (http-add-header "Content-type" "text/html; charset=UTF-8")
+  (http-send-headers)
+
+  (<:html
+   (<:body
+    (<:h1 :id :main-title "Kompottkins Weisheiten")
+    (<:div :id :contents
+     (if (or (null *action*)
+             (eq *action* :index))
+         (dolist (journal-entry *journal-entries*)
+           (<:div :class :journal-entry
+            (<:h2 (<:as-html (title-of journal-entry)))
+            (<:as-is (journal-markup->html (body-of journal-entry)))))))
+    (<:div :id :navigation)
+
+    (loop for (x . y) in `(("Action" . ,*action*)
+                           ("Request method" . ,*method*)
+                           ("Query" . ,*query*)
+                           ("Query string" . ,(http-get-query-string))
+                           ("Environment" . ,(http-get-env-vars)))
+       do (<:p
+           (<:hr)
+           (<:h2 (<:as-html x))
+           (<:p "Type " (<:em (<:as-html (type-of y))) ".")
+           (<:pre (<:as-html (prin1-to-string y))))))))
+
+
+(defun main ()
+  (let ((*journal-entries* (read-journal-entries)))
+    (case *action*
+      (:view-atom-feed (show-atom-feed))
+      (otherwise       (show-web-journal)))))
+
+
+(handler-bind
+    ((error #'
+      (lambda (e)
+        (<:html
+         (<:head
+          (<:title "Kompottkins Weisheiten: Fehler"))
+         (<:body
+          (<:h1 "Kompottkins Weisheiten: Fehlerbericht")
+          (<:p "Leider ist waehrend der Bearbeitung Ihrer Anfrage ein
+                Fehler aufgetreten.  Wir bitten dies zu entschuldigen.
+                Ein detaillierter Fehlerbericht folgt.")
+          (<:pre (<:as-html (with-output-to-string (out)
+                              #+clisp (system::pretty-print-condition e out)
+                              #+clisp (system::print-backtrace :out out)))))))))
+  (main))