Cache FORMAT-DATE results for faster page generation.

darcs-hash:2efe2fb7b5c7637c31d56be210624a48f61755ec

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))))
+