diff options
| -rw-r--r-- | globals.lisp | 10 | ||||
| -rw-r--r-- | journal-content.lisp | 55 | ||||
| -rwxr-xr-x | journal.lisp | 29 | ||||
| -rw-r--r-- | main.lisp | 4 | ||||
| -rwxr-xr-x | run.lisp | 11 | ||||
| -rw-r--r-- | utils.lisp | 104 |
6 files changed, 145 insertions, 68 deletions
diff --git a/globals.lisp b/globals.lisp index 1764089..cf69230 100644 --- a/globals.lisp +++ b/globals.lisp @@ -60,5 +60,11 @@ (defparameter *journal-entries* nil "A list of JOURNAL-ENTRY objects.") -(defparameter *cgi-p* nil - "Whether we have been called as a CGI script or not.") +(defparameter *script-dir* nil + "The directory which all the Lisp code 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 c914269..12ff5a3 100644 --- a/journal-content.lisp +++ b/journal-content.lisp @@ -143,11 +143,56 @@ (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 () #-clisp (get-universal-time) #+clisp - (loop for file in (list* *script-filename* ;; journal.cgi - (merge-pathnames (make-pathname :type "lisp") - *script-filename*) ;; journal.lisp - (find-journal-entry-files)) - maximize (posix:file-stat-mtime (posix:file-stat file)))) + (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)))) diff --git a/journal.lisp b/journal.lisp index 6db96e3..5353de1 100755 --- a/journal.lisp +++ b/journal.lisp @@ -292,32 +292,3 @@ (<:p "Type " (<:em (<:as-html (type-of y))) ".") (<:pre (<:as-html (prin1-to-string y)))))))) - -(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)))) @@ -57,6 +57,10 @@ (*script-filename* (pathname-as-file (or (gethash "SCRIPT_FILENAME" *http-env*) "/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))) @@ -42,13 +42,12 @@ ;;; security restrictions. Then again, loading all the dependencies ;;; individually rather than using a core image would certainly be too ;;; slow for any serious CGI usage, anyway, so what the heck. -(ignore-errors - (unless (asdf:find-system :mulk-journal nil) - (let ((*package* (find-package :asdf))) - (load "mulk-journal.asd"))) +(unless (asdf:find-system :mulk-journal nil) + (let ((*package* (find-package :asdf))) + (load "mulk-journal.asd"))) - (unless (find-package '#:mulk.journal) - (asdf:oos 'load-source-simple-op '#:mulk-journal))) + +(asdf:oos 'load-source-simple-op '#:mulk-journal) #+clisp @@ -67,30 +67,6 @@ markup) -(defun find-journal-entry-files () - (let ((directory - (make-pathname - :directory (pathname-directory - (merge-pathnames - (make-pathname :directory '(:relative "journal-entries") - :name nil) - *script-filename*)))) - (journal-entry-files (list))) - (when (file-exists-p directory) - (walk-directory directory - #'(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))) - - (defmacro regex-case (string &body clauses) (once-only (string) `(cond ,@(loop for (keys . forms) in clauses @@ -118,8 +94,8 @@ (6 "Sonntag"))) -(defun format-date (destination date-control-string universal-time - &optional (time-zone nil time-zone-supplied-p)) +(defun %real-format-date (destination date-control-string universal-time + &optional (time-zone nil time-zone-supplied-p)) "Format DATE according to the description given by DATE-FORMAT-STRING. Recognised format directives are: %day, %mon, %yr, %day-of-week, %zone, @@ -165,3 +141,79 @@ after another in any arbitrary order." (format out control value) (format out "~A" (subseq substring offset))) (format out "~A" substring)))))))))) + + +(defun compute-script-last-modified-date () + #-clisp (get-universal-time) + #+clisp + (loop for file in (list* *script-filename* ;; journal.cgi + (remove-if-not #'(lambda (p) + (equal "lisp" + (pathname-type p))) + (list-directory *script-dir*))) + maximize (posix:file-stat-mtime (posix:file-stat file)))) + + +(defun read-to-array (stream &key (initial-length 128)) + "Read elements from a stream repeatedly until the end of file is +reached and write the results into a newly created array of the same +ELEMENT-TYPE as the stream's." + (do* ((buffer (make-array (list initial-length) + :element-type (stream-element-type stream) + :adjustable t + :fill-pointer t)) + (last-unmodified (read-sequence buffer stream) + (read-sequence buffer stream :start old-length)) + (read-elements last-unmodified + (- last-unmodified old-length)) + (old-length initial-length length) + (length (ceiling (* 1.5 old-length)) + (ceiling (* 1.5 old-length)))) + ((< last-unmodified old-length) + (setf (fill-pointer buffer) last-unmodified) + buffer) + (setf buffer (adjust-array buffer (list length) + :fill-pointer length)))) + + +(defun call-with-result-cache (cache-id fun &key (younger-than nil younger-p)) + (let ((cache-file (merge-pathnames (make-pathname :name (format nil + "CACHE-~A" + cache-id)) + *cache-dir*))) + (if (and (file-exists-p cache-file) + #-clisp nil + #+clisp (or (not younger-p) + (> (posix:file-stat-mtime (posix:file-stat cache-file)) + younger-than))) + (with-open-file (in cache-file + :direction :input + :external-format #+clisp charset:utf-8 + #+sbcl :utf-8) + (read-to-array in)) + (with-open-file (out cache-file + :direction :output + :if-exists :supersede + :external-format #+clisp charset:utf-8 + #+sbcl :utf-8) + (let ((string (funcall fun))) + (princ string out) + string))))) + + +(defmacro with-result-cache ((cache-id &key (younger-than nil younger-than-p)) + &body body) + `(call-with-result-cache ,cache-id + #'(lambda () ,@body) + ,@(and younger-than-p `(:younger-than ,younger-than)))) + + +(defun format-date (destination date-control-string universal-time + &optional (time-zone nil time-zone-supplied-p)) + (with-result-cache ((format nil "date-format-~D-~A-~A" + universal-time date-control-string time-zone) + :younger-than (compute-script-last-modified-date)) + (apply #'%real-format-date + destination date-control-string universal-time + (and time-zone-supplied-p time-zone)))) + |