summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--globals.lisp10
-rw-r--r--journal-content.lisp55
-rwxr-xr-xjournal.lisp29
-rw-r--r--main.lisp4
-rwxr-xr-xrun.lisp11
-rw-r--r--utils.lisp104
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))))
diff --git a/main.lisp b/main.lisp
index f27a989..4fb7467 100644
--- a/main.lisp
+++ b/main.lisp
@@ -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)))
diff --git a/run.lisp b/run.lisp
index df60d76..1730bfa 100755
--- a/run.lisp
+++ b/run.lisp
@@ -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
diff --git a/utils.lisp b/utils.lisp
index 842bb0f..e61f0f5 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -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))))
+