diff options
| -rw-r--r-- | defpackage.lisp | 3 | ||||
| -rw-r--r-- | globals.lisp | 9 | ||||
| -rw-r--r-- | journal-content.lisp | 221 | ||||
| -rwxr-xr-x | journal.lisp | 46 | ||||
| -rw-r--r-- | main.lisp | 46 | ||||
| -rwxr-xr-x | make-clisp-package.sh | 4 | ||||
| -rwxr-xr-x | make-core-image.sh | 2 | ||||
| -rw-r--r-- | mulk-journal.asd | 2 | ||||
| -rw-r--r-- | utils.lisp | 6 |
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)) @@ -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") @@ -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)) |