Store data using CLSQL rather than custom files.

darcs-hash:b736c3a1a111f001b4db43c5d869d42cdf032f94

9 files changed, 192 insertions, 147 deletions

diff --git a/defpackage.lisp b/defpackage.lisp
index cc828b3..72ba573 100644
--- a/defpackage.lisp
+++ b/defpackage.lisp
@@ -23,4 +23,5 @@
 (defpackage #:mulk.journal
   (:nicknames #:journal)
   (:use #:cl #:fad #:iterate #:markdown #:yaclml #:http #:alexandria
-        #:xml-emitter #:split-sequence))
+        #:xml-emitter #:split-sequence #:clsql)
+  (:shadow #:format-date))
diff --git a/globals.lisp b/globals.lisp
index cf69230..9d5f1f7 100644
--- a/globals.lisp
+++ b/globals.lisp
@@ -57,14 +57,11 @@
 
 (defparameter *script-filename* nil)
 
-(defparameter *journal-entries* nil
-  "A list of JOURNAL-ENTRY objects.")
-
 (defparameter *script-dir* nil
   "The directory which all the Lisp code lives in.")
 
+(defparameter *data-dir* nil
+  "The directory which all the journal data lives in.")
+
 (defparameter *cache-dir* nil
   "The directory used for caching generated markup.")
-
-(defparameter *entry-dir* nil
-  "The directory containing the journal entry data files.")
diff --git a/journal-content.lisp b/journal-content.lisp
index 12ff5a3..65a8a59 100644
--- a/journal-content.lisp
+++ b/journal-content.lisp
@@ -24,83 +24,173 @@
 
 
 ;;; (@* "Class definitions")
-(defclass journal-entry ()
-  ((id :type (integer 0)
+(clsql:def-view-class journal-entry ()
+  ((id :db-kind :key
+       :type integer
+       :db-constraints :not-null
        :accessor id-of
        :initarg :id)
-   (uuid :type string
+   (uuid :type (string 36)
+         :db-constraints :not-null
          :accessor uuid-of
          :initarg :uuid)
-   (file :type (or null pathname)
-         :accessor file-of
-         :initarg :file)
    (title :type string
+          :db-constraints :not-null
           :accessor title-of
           :initarg :title
           :initform "")
-   (date :type (integer 0)
+   (date :type universal-time
+         :db-constraints :not-null
          :accessor date-of
          :initarg :date)
-   (last-modification :type (or null (integer 0))
+   (last-modification :type integer
                       :accessor last-modification-of
                       :initarg :last-modification
                       :initform nil)
    (body :type string
+         :db-constraints :not-null
          :accessor body-of
          :initarg :body
          :initform "")
-   (categories :type list
+   (categories :db-kind :join
+               :db-constraints :not-null
                :accessor categories-of
                :initarg :categories
-               :initform '())
-   (comments :type list
-             :accessor comments-about
+               :initform '()
+               :db-info (:join-class journal-category
+                         :home-key id
+                         :foreign-key entry-id
+                         :set t))
+   (comments :db-kind :join
+             :db-constraints :not-null
+             :accessor %comments-about
              :initarg :comments
-             :initform '())))
+             :db-info (:join-class journal-comment
+                       :home-key id
+                       :foreign-key entry-id
+                       :set t))))
 
 
-(defclass journal-comment ()
-  ((id :type (integer 0)
+(clsql:def-view-class journal-comment ()
+  ((id :db-kind :key
+       :type integer
+       :db-constraints :not-null
        :accessor id-of
        :initarg :id)
-   (uuid :type string
+   (entry-id :db-kind :key
+             :type integer
+             :db-constraints :not-null
+             :accessor id-of
+             :initarg :entry-id)
+   (entry :db-kind :join
+          :db-constraints :not-null
+          :accessor entry-of
+          :initarg :entries
+          :initform '()
+          :db-info (:join-class journal-entry
+                    :home-key entry-id
+                    :foreign-key id
+                    :set nil))
+   (uuid :type (string 36)
+         :db-constraints :not-null
          :accessor uuid-of
          :initarg :uuid)
-   (date :type (integer 0)
+   (date :type universal-time
+         :db-constraints :not-null
          :accessor date-of
          :initarg :date)
    (body :type string
+         :db-constraints :not-null
          :accessor body-of
          :initarg :body
          :initform "")
-   (author :type (or null string)
+   (author :type string
            :accessor author-of
            :initarg :author
            :initform nil)
-   (email :type (or null string)
+   (email :type string
           :accessor email-of
           :initarg :email
           :initform nil)
-   (website :type (or null string)
+   (website :type string
             :accessor website-of
             :initarg :website
             :initform nil)))
 
 
+(clsql:def-view-class journal-category ()
+  ((id :db-kind :key
+       :type integer
+       :db-constraints :not-null
+       :accessor id-of
+       :initarg :id)
+   (uuid :type (string 36)
+         :db-constraints :not-null
+         :accessor uuid-of
+         :initarg :uuid)
+   (entries :db-kind :join
+            :db-constraints :not-null
+            :accessor entries-in
+            :initarg :entries
+            :initform '()
+            :db-info (:join-class journal-entry
+                      :home-key id
+                      :foreign-key catogory-ids
+                      :set t))))
+
+
 ;; (@* "Journal entry operations")
-(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))
+(defgeneric comments-about (thing &key ordered-p))
+(defgeneric (setf comments-about) (new-value thing &key ordered-p))
+
+(defmethod comments-about ((journal-entry journal-entry) &key ordered-p)
+  #.(locally-enable-sql-reader-syntax)
+  (prog1 (if ordered-p
+             (mapcar #'car
+                     (select 'journal-comment 'journal-entry
+                             :where [= [slot-value 'journal-comment 'entry-id]
+                                       [slot-value 'journal-entry 'id]]
+                             :order-by '([journal-comment.date])
+                             :flatp t))
+             (%comments-about journal-entry))
+    #.(restore-sql-reader-syntax-state)))
+
+
+(defmethod (setf comments-about) (new-value
+                                  (journal-entry journal-entry)
+                                  &key ordered-p)
+  (declare (ignore ordered-p))
+  (setf (%comments-about journal-entry) new-value))
+
+
+(defun make-journal-entry-id ()
+  #.(locally-enable-sql-reader-syntax)
+  (prog1
+      (1+ (or (single-object (select [max [slot-value 'journal-entry 'id]]
+                                     :from [journal-entry]
+                                     :flatp t))
+              -1))
+    #.(restore-sql-reader-syntax-state)))
+
+
+(defun make-journal-comment-id ()
+  #.(locally-enable-sql-reader-syntax)
+  (prog1
+      (1+ (or (single-object (select [max [slot-value 'journal-comment 'id]]
+                                     :from [journal-comment]
+                                     :flatp t))
+              -1))
+    #.(restore-sql-reader-syntax-state)))
 
 
 (defun find-entry (number)
-  (find number *journal-entries* :key #'id-of))
+  #.(locally-enable-sql-reader-syntax)
+  (prog1
+    (single-object (select 'journal-entry
+                           :where [= [slot-value 'journal-entry 'id] number]
+                           :flatp t)
+                   nil)
+    #.(restore-sql-reader-syntax-state)))
 
 
 (defun journal-markup->html (markup)
@@ -126,73 +216,12 @@
            (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)))
-        (let ((comments (member :comments data)))
-          (when comments
-            (setf (second comments)
-                  (mapcar #'(lambda (comment-record)
-                              (apply #'make-instance
-                                     'journal-comment
-                                     comment-record))
-                          (second comments)))))
-        (apply #'make-instance 'journal-entry :file filename data)))))
-
-
-(defun find-journal-entry-files ()
-  (let ((journal-entry-files (list)))
-    (when (file-exists-p *entry-dir*)
-      (walk-directory *entry-dir*
-                      #'(lambda (x)
-                          (push x journal-entry-files))
-                      :test (complement #'directory-pathname-p)))
-    journal-entry-files))
-
-
-(defun read-journal-entries ()
-  (let ((journal-entry-files (find-journal-entry-files)))
-    (sort (mapcar #'read-journal-entry journal-entry-files)
-          #'>=
-          :key #'id-of)))
-
-
 (defun compute-journal-last-modified-date ()
+  #.(locally-enable-sql-reader-syntax)
   #-clisp (get-universal-time)
   #+clisp
   (max (compute-script-last-modified-date)
-       (loop for file in (find-journal-entry-files)
-              maximize (posix:file-stat-mtime (posix:file-stat file)))))
-
-
-(defun write-out-entry (entry)
-  (assert (file-of entry))
-  (with-open-file (out (file-of entry) :direction :output
-                                       :if-exists :supersede
-                                       :external-format #+clisp charset:utf-8
-                                                        #+sbcl :utf-8)
-    (with-slots (id uuid date last-modification body title categories comments)
-        entry
-      (write `(:id ,id
-               :uuid ,uuid
-               :date ,date
-               :last-modification ,last-modification
-               :title ,title
-               :categories ,categories
-               :body ,body
-               :comments ,(loop for comment in comments
-                             collect
-                               (with-slots (id uuid date author body email
-                                            website)
-                                   comment
-                                 `(:id ,id
-                                   :uuid ,uuid
-                                   :date ,date
-                                   :author ,author
-                                   :email ,email
-                                   :website ,website
-                                   :body ,body))))
-             :stream out))))
+       (select [max [slot-value 'journal-entry 'last-modification]])
+       (select [max [slot-value 'journal-entry 'date]])
+       (select [max [slot-value 'journal-comment 'date]]))
+  #.(restore-sql-reader-syntax-state))
diff --git a/journal.lisp b/journal.lisp
index 47ad91c..efe753c 100755
--- a/journal.lisp
+++ b/journal.lisp
@@ -47,6 +47,7 @@
 
 
 (defun show-atom-feed ()
+  #.(locally-enable-sql-reader-syntax)
   (http-add-header "Last-Modified" (http-timestamp (compute-journal-last-modified-date)))
   (http-add-header "Content-Language" "de")
   (http-send-headers "application/atom+xml; charset=UTF-8")
@@ -60,18 +61,16 @@
       (with-tag ("feed" '(("xmlns" "http://www.w3.org/2005/Atom")))
         (emit-simple-tags :title "Kompottkins Weisheiten"
                           :updated (atom-time
-                                    (max (reduce #'max *journal-entries*
-                                                 :key #'date-of
-                                                 :initial-value 0)
-                                         (reduce #'(lambda (x y)
-                                                     (cond ((and x y)
-                                                            (max x y))
-                                                           (x x)
-                                                           (y y)
-                                                           (t 0)))
-                                                 *journal-entries*
-                                                 :key #'last-modification-of
-                                                 :initial-value 0)))
+                                    (max (or (single-object
+                                               (select [max [slot-value 'journal-entry 'date]]
+                                                       :from [journal-entry]
+                                                       :flatp t))
+                                             0)
+                                         (or (single-object
+                                               (select [max [slot-value 'journal-entry 'last-modification]]
+                                                       :from [journal-entry]
+                                                       :flatp t))
+                                             0)))
                           :id "urn:uuid:88ad4730-90bc-4cc1-9e1f-d4cdb9ce177c")
         (with-tag ("subtitle")
           (xml-as-is "Geschwafel eines libertärsozialistischen Geeks"))
@@ -84,9 +83,9 @@
                             ("type" "application/atom+xml")
                             ("href" ,(link-to :view-atom-feed :absolute t)))))
 
-        (dolist (journal-entry (sort (copy-list *journal-entries*)
-                                     #'>
-                                     :key #'date-of))
+        (dolist (journal-entry (select 'journal-entry
+                                       :order-by '(([date] :desc))
+                                       :flatp t))
           (with-slots (title date body categories last-modification id)
               journal-entry
             (with-tag ("entry")
@@ -104,7 +103,8 @@
                                      ("xml:lang" "de")
                                      ("xml:base" ,(link-to :index :absolute t))))
                 (with-tag ("div" '(("xmlns" "http://www.w3.org/1999/xhtml")))
-                  (xml-as-is (journal-markup->html (body-of journal-entry))))))))))))
+                  (xml-as-is (journal-markup->html (body-of journal-entry)))))))))))
+  #.(restore-sql-reader-syntax-state))
 
 
 (let ((scanner (ppcre:create-scanner "(\\n|\\r|\\r\\n)(\\n|\\r|\\r\\n)+")))
@@ -170,9 +170,8 @@
   (when (and comments-p (not (null (comments-about journal-entry))))
     (<:div :class :journal-comments
      (<:h2 "Kommentare")
-     (dolist (comment (sort (copy-list (comments-about journal-entry))
-                            #'<
-                            :key #'date-of))
+     (dolist (comment (comments-about journal-entry
+                                      :ordered-p t))
        (with-slots (author body date id email website)
            comment
          (<:div :class :journal-comment
@@ -233,6 +232,7 @@
 
 
 (defun show-web-journal ()
+  #.(locally-enable-sql-reader-syntax)
   ;; 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.
@@ -273,9 +273,8 @@
     (<:div :id :contents
      (case *action*
        ((:index nil)
-        (mapc #'show-journal-entry (sort (copy-list *journal-entries*)
-                                         #'>
-                                         :key #'date-of)))
+        (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))))
     (<:div :id :navigation))
@@ -292,5 +291,6 @@
              (<: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)))))))
+  #.(restore-sql-reader-syntax-state))
 
diff --git a/main.lisp b/main.lisp
index 0684a60..7e22c96 100644
--- a/main.lisp
+++ b/main.lisp
@@ -59,10 +59,20 @@
                                  "/home/mulk/Dokumente/Projekte/Mulkblog/journal.cgi")))
          (*script-dir*      (make-pathname
                              :directory (pathname-directory *script-filename*)))
-         (*cache-dir*       (merge-pathnames #p"cache/" *script-dir*))
-         (*entry-dir*       (merge-pathnames #p"journal-entries/" *script-dir*))
-         (*journal-entries* (read-journal-entries)))
-    (funcall func)))
+         (*data-dir*        (if (eq *site* :mst-plus)
+                                *script-dir*
+                                #p"/home/protected/journal/"))
+         (*cache-dir*       (merge-pathnames #p"cache/" *data-dir*))
+         (database-file     (merge-pathnames #p"journal.sqlite3" *data-dir*)))
+    (clsql-uffi::load-uffi-foreign-library)
+    (uffi:load-foreign-library (merge-pathnames "clsql_uffi.so"
+                                                *script-dir*))
+    (uffi:load-foreign-library #p"/usr/lib/libsqlite3.so")
+    (clsql:with-database (db (list (namestring database-file))
+                             :database-type :sqlite3
+                             :make-default t)
+      (assert db)
+      (funcall func))))
 
 
 #+clisp
@@ -72,19 +82,21 @@
       (ext:letf ((custom:*terminal-encoding* (ext:make-encoding
                                               :charset charset:utf-8)))
         (case *action*
-          (:post-comment   (let ((entry (find-entry *post-number*)))
-                             (push (make-instance 'journal-comment
-                                    :id (1+ (reduce #'max (comments-about entry)
-                                                    :key #'id-of
-                                                    :initial-value -1))
-                                    :uuid    (make-uuid)
-                                    :date    (get-universal-time)
-                                    :author  (getf *query* :author)
-                                    :email   (getf *query* :email)
-                                    :website (getf *query* :website)
-                                    :body    (getf *query* :comment-body))
-                                   (comments-about entry))
-                             (write-out-entry entry))
+          (: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))
           (otherwise       (show-web-journal)))))))
diff --git a/make-clisp-package.sh b/make-clisp-package.sh
index 48647e8..7884e24 100755
--- a/make-clisp-package.sh
+++ b/make-clisp-package.sh
@@ -1,5 +1,5 @@
 #! /bin/sh
 cd ~
-for x in Downloads/Darcs/{metabang-bind,iterate,cl-markdown,cl-containers,defsystem-compatibility,alexandria,lw-compat,moptilities,metatilities,Bese/arnesi_dev,Bese/yaclml,asdf-system-connections,closer-mop,parenscript} .clc/site/{xml-emitter-1.0.2,lisp-cgi-utils-0.9,cl-utilities-1.2.4} /usr/share/common-lisp/source/{asdf,cl-fad,cl-ppcre,slime,split-sequence}; do
+for x in Downloads/Git/clsql Downloads/Darcs/{metabang-bind,iterate,cl-markdown,cl-containers,defsystem-compatibility,alexandria,lw-compat,moptilities,metatilities,Bese/arnesi_dev,Bese/yaclml,asdf-system-connections,closer-mop,parenscript} .clc/site/{xml-emitter-1.0.2,lisp-cgi-utils-0.9,cl-utilities-1.2.4} /usr/share/common-lisp/source/{asdf,cl-fad,cl-ppcre,slime,split-sequence}; do
 	find "$x" -not -regex ".*/_darcs/.*" \( -regex ".*\\.lisp" -or -regex ".*\\.asd" -or -regex "COPYING" -or -regex "index.lml" \)
-done | tar -T - -cjf - | ssh -t mulk_benkard@ssh.phx.nearlyfreespeech.net 'mkdir -p /tmp/clisp-stuff && cd /tmp/clisp-stuff && tar xjf - && mkdir -p /tmp/asdf && cd /tmp/asdf && find ../clisp-stuff -name "*.asd" | xargs -I "{}" ln -sf "{}" . && cd ../clisp-stuff && mkdir -p /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/images && touch /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/index.lml && clisp -x "(load \"usr/share/common-lisp/source/asdf/asdf.lisp\")" -x "(let ((asdf:*central-registry* (quote (#p\"/tmp/asdf/\")))) (dolist (x (list :cl-ppcre :cl-fad :iterate :cl-markdown :parenscript :yaclml :lisp-cgi-utils :alexandria :xml-emitter :split-sequence)) (asdf:oos (quote asdf:load-op) x)) (saveinitmem \"lispinit.mem\"))" && gzip -f lispinit.mem && mv lispinit.mem.gz /home/private/ && rm -rf /tmp/clisp-stuff && rm -rf /tmp/asdf'
+done | tar -T - -cjf - | ssh -t mulk_benkard@ssh.phx.nearlyfreespeech.net 'mkdir -p /tmp/clisp-stuff && cd /tmp/clisp-stuff && tar xjf - && mkdir -p /tmp/asdf && cd /tmp/asdf && find ../clisp-stuff -name "*.asd" | xargs -I "{}" ln -sf "{}" . && cd ../clisp-stuff && mkdir -p /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/images && touch /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/index.lml && clisp -x "(load \"usr/share/common-lisp/source/asdf/asdf.lisp\")" -x "(let ((asdf:*central-registry* (quote (#p\"/tmp/asdf/\")))) (dolist (x (list :cl-ppcre :cl-fad :iterate :cl-markdown :parenscript :yaclml :lisp-cgi-utils :alexandria :xml-emitter :split-sequence :clsql :clsql-sqlite3)) (asdf:oos (quote asdf:load-op) x)) (saveinitmem \"lispinit.mem\"))" && gzip -f lispinit.mem && mv lispinit.mem.gz /home/private/ && rm -rf /tmp/clisp-stuff && rm -rf /tmp/asdf'
diff --git a/make-core-image.sh b/make-core-image.sh
index 28cbb9a..6eb467b 100755
--- a/make-core-image.sh
+++ b/make-core-image.sh
@@ -2,7 +2,7 @@
 clisp -q -q -on-error exit <<EOF
 (dolist (system '(:cl-ppcre :cl-fad :iterate :cl-markdown :parenscript
                   :yaclml :lisp-cgi-utils :alexandria :xml-emitter
-                  :split-sequence))
+                  :split-sequence :clsql :clsql-sqlite3))
   (clc:clc-require system))
 (saveinitmem "lispinit.mem")
 (quit)
diff --git a/mulk-journal.asd b/mulk-journal.asd
index ae3b7c5..8dad08c 100644
--- a/mulk-journal.asd
+++ b/mulk-journal.asd
@@ -25,7 +25,7 @@
   :licence     "Affero General Public License, version 1 or higher"
   :depends-on  (#:cl-ppcre #:cl-fad #:iterate #:cl-markdown #:parenscript
                 #:yaclml #:lisp-cgi-utils #:alexandria #:xml-emitter
-                #:split-sequence)
+                #:split-sequence #:clsql #:clsql-uffi #:clsql-sqlite3)
   :components  ((:file "defpackage")
                 (:file "macros")
                 (:file "globals")
diff --git a/utils.lisp b/utils.lisp
index 34da533..d4a2d77 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -197,3 +197,9 @@ ELEMENT-TYPE as the stream's."
            destination date-control-string universal-time
            (and time-zone-supplied-p time-zone))))
 
+
+(defun single-object (list &optional (errorp t))
+  (assert (null (cdr list)))
+  (when errorp
+    (assert (not (null list))))
+  (first list))