injecting refresh into spinneret templates

1 files changed, 139 insertions, 42 deletions

diff --git a/flexo.lisp b/flexo.lisp
index 182c24f..63f3b36 100644
--- a/flexo.lisp
+++ b/flexo.lisp
@@ -73,7 +73,7 @@
 
 ;;; ARTIFACTS
 
-(defvar *artifacts* nil
+(defvar *site* nil
   "Dynamic hash-table, bound before building a site. A collection of
   artifacts, indexed by the url path of the artifact.")
 
@@ -81,8 +81,8 @@
   "Generic artifact query. PRED is a preedicate of one argument, and is
    passed an ARTIFACT instance. Returns a list of instances for which
    PRED returns non NIL."
-  (when *artifacts*
-    (loop :for instance :being :the :hash-value :of *artifacts*
+  (when *site*
+    (loop :for instance :being :the :hash-value :of *site*
           :when (funcall pred instance)
             :collect instance)))
 
@@ -110,30 +110,33 @@
    files to be served from some web root."))
 
 (defmethod initialize-instance :after ((artifact artifact) &key)
-  (when *artifacts*
+  (when *site*
     (setf (gethash (url-path artifact) *site*)
           artifact)))
 
-
-
-(defclass html ()
-  ((html
-    :reader html
-    :initarg :html
-    :initform (error "HTML content required")
-    :documentation "A UTF8 formatted string holding HTML content.")))
-
-(defclass spinneret-page (artifact html) ()
+(defclass template-generated-text (artifact)
+  ((text
+    :reader generated-text
+    :initarg :text
+    :initform (error "TEXT content required")
+    :documentation "A UTF8 formatted string holding content generated
+    from a template."))
+  (:documentation "A class that represents content that has been
+  generated by some kind of lisp template. e.g. spinenret, lass,
+  paranscript. "))
+
+(defclass spinneret-page (template-generated-text) ()
   (:documentation "An artifact generated from a spinneret template
   representing an entire web page.."))
 
 (defmacro spinneret-page (url &body body)
   "Creates a page instance with the given url path and expdning the
 spinneret template in BODY."
-  `(make-instance
-   'page
-   :url ,url
-   :html (with-html-string ,@body)))
+  (let ((body (inject-autorefresh-into-spinneret-body body)))
+    `(make-instance
+      'spinneret-page
+      :url ,url
+      :text (with-html-string ,@body))))
 
 (defmacro define-spinneret-template
     (template-name (url-arg &rest lambda-list-def) &body template-body)
@@ -142,14 +145,7 @@ spinneret template in BODY."
      (spinneret-page ,url-arg
        ,@template-body)))
 
-(defclass javascript ()
-  ((javascript
-    :reader javascript
-    :initarg :javascript
-    :initform (error "JAVASCRIPT content required")
-    :documentation "A UTF8 strign holding textual Javascript.")))
-
-(defclass ps-script (artifact javascript) ()
+(defclass ps-script (template-generated-text) ()
   (:documentation "An artifact generated from a collection of
   parenscript expressions holding a javascript script."))
 
@@ -157,16 +153,9 @@ spinneret template in BODY."
   `(make-instance
     'ps-script
     :url ,url
-    :javascript (ps:ps ,@body)))
-
-(defclass css ()
-  ((css
-    :reader css
-    :initarg :css
-    :initform (error "CSS content required.")
-    :documentation "A UTF8 string holding textual css content.")))
+    :text (ps:ps ,@body)))
 
-(defclass lass-css (artifact css) ()
+(defclass lass-css (template-generated-text) ()
   (:documentation "An artifact generated from LASS expressions that
   holds CSS content."))
 
@@ -174,7 +163,7 @@ spinneret template in BODY."
   `(make-instance
     'lass-css
     :url ,url
-    :css (lass:compile-and-write ,@body)))
+    :text (lass:compile-and-write ,@body)))
 
 (defmacro define-lass-template
     (template-name (url-arg &rest keyword-args) &body template-body)
@@ -198,13 +187,121 @@ spinneret template in BODY."
   (uiop:copy-file (filepath artifact)
                   (uiop:merge-pathnames* (url-path artifact) location)))
 
-(defmethod publish ((page page) (location pathname))
+(defmethod publish ((generated template-generated-text) (location pathname))
   (alexandria:write-string-into-file
-   (page-html page)
-   (uiop:merge-pathnames* (url-path page) location)
+   (generated-text generated)
+   (uiop:merge-pathnames* (url-path generated) location)
    :if-exists :supersede
    :external-format :utf8))
 
-(defun publish-site-to (location)
-  (dolist (a *artifacts*)
-    (publish a location)))
+(defun publish-site (site location)
+  (loop for artifact being the hash-value of site
+        do (publish artifact location)))
+
+;;; hacking
+
+(defvar *auto-refresh-key* nil)
+
+(defun make-auto-refresh-key ()
+  (symbol-name (gensym "auto-refresh-")))
+
+(defun mark-autorefresh-true (directory)
+  (when *auto-refresh-key*
+    (alexandria:write-string-into-file
+     "true"
+     (format nil "~a/~a.json" directory *auto-refresh-key*)
+     :if-exists :supersede )))
+
+(defun mark-autorefresh-false (directory)
+  (when *auto-refresh-key*
+    (alexandria:write-string-into-file
+     "false"
+     (format nil "~a/~a.json" directory *auto-refresh-key*)
+     :if-exists :supersede )))
+
+(defun inject-autorefresh-into-spinneret-body (spinneret-template-form)
+  (labels ((inject-into-body (tree)
+             (cond
+               ((and (consp tree) (eql :body (first tree)))
+                (list* :body '(flexo::auto-refresh-script) (rest tree)))
+
+               ((consp tree)
+                (mapcar #'inject-into-body tree))
+
+               (t tree))))
+    (inject-into-body spinneret-template-form)))
+
+(defun auto-refresh-script ()
+  (when flexo::*auto-refresh-key*
+    (with-html 
+      (:script
+       (ps:ps
+         (let ((poll-url (+ "/" (ps:lisp flexo::*auto-refresh-key*) ".json")))
+           (set-interval
+            (lambda ()
+              (let ((fetched (fetch poll-url)))
+                (ps:chain fetched
+                          (then (lambda (resp) (ps:chain resp (json))))
+                          (then (lambda (json)
+                                  (when json (ps:chain location (reload))))))))
+            1000)))))))
+
+(defun table-subset-p (tab1 tab2 &key (test 'equal))
+  "TEST compares values"
+  (loop :for key :being :the :hash-key :of tab1
+        :when (or (not (gethash key tab2))
+                  (not (funcall test
+                                (gethash key tab1)
+                                (gethash key tab2))))
+          :do (return nil)
+        :finally (return t)))
+
+(defun tables-equal-p (tab1 tab2 &key (test 'equal))
+  (and (table-subset-p tab1 tab2 :test test)
+       (table-subset-p tab2 tab1 :test test)))
+
+(defun site-changed-p (backup)
+  "A site has changed since backed up if either the asset table or the
+artifact tables have changed."
+  (not (tables-equal-p backup *site*)))
+
+(defvar *development-acceptor* nil
+  "Hunchentoot acceptor for the dev server.")
+
+(defun run-recipe (recipe)
+  "Runs the recipe in a fresh context and returns the site hash table it built."
+  (let ((*site* (make-hash-table))
+        (*content* (make-hash-table)))
+    (funcall recipe)
+    *site*))
+
+(defun hack-on
+    (recipe location &key (port 4242) (rebuild-freqeuncy 1) (auto-refresh t) log-to-repl)
+  (setf *development-acceptor*
+        (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor
+                                          :port port
+                                          :document-root location
+                                          :access-log-destination log-to-repl)))
+  (bt:make-thread
+   (lambda () 
+     (let ((*auto-refresh-key* (when auto-refresh (make-auto-refresh-key)))
+           (the-site (run-recipe recipe)))
+       (format t "Start Hacking on localhost port ~a~%" port)
+       (loop :while (hunchentoot:started-p  *development-acceptor*)
+             :do
+                (let ((candidate-site (run-recipe recipe)))
+                  (cond
+                    ((site-changed-p the-site candidate-site)
+                     (setf the-site candidate-site)
+                     (publish-site the-site  location)
+                     (mark-autorefresh-true location))
+
+                    (*auto-refresh-key*
+                     (mark-autorefresh-false location)))
+
+                  (sleep rebuild-freqeuncy)))
+       (format t "Stopped Hacking~%")))))
+
+(defun stop-hacking ()
+  "Stop the deveopment server."
+  (hunchentoot:stop *development-acceptor*))