summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-09-29 17:58:58 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-09-29 17:58:58 +0200
commit7f829dbfba7de43bbc2402b12ea476c63a2ef1f0 (patch)
treed4c2f8d285951b7a5a29ed9188fa533d84c80f94
parent29945a7ea76b60795b8dc6d6267924bfa4459357 (diff)
Store data using CLSQL rather than custom files.
darcs-hash:b736c3a1a111f001b4db43c5d869d42cdf032f94
-rw-r--r--defpackage.lisp3
-rw-r--r--globals.lisp9
-rw-r--r--journal-content.lisp221
-rwxr-xr-xjournal.lisp46
-rw-r--r--main.lisp46
-rwxr-xr-xmake-clisp-package.sh4
-rwxr-xr-xmake-core-image.sh2
-rw-r--r--mulk-journal.asd2
-rw-r--r--utils.lisp6
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&#xE4;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))