path: root/flexo.lisp

;;;; flexo.lisp

(in-package #:flexo)

;;; DYNAMIC VARS

(defvar *auto-refresh-key* nil
  "Set when interactively building a site with auto-refresh turned on.")

(defvar *development-acceptor* nil
  "Hunchentoot acceptor for the dev server.")

(defvar *content* nil
  "Dynamic hash-table, bound before building a site.  All instances of
  subclasses of content are automatically inserted into this index.")

(defvar *site* nil
  "Dynamic hash-table, bound before building a site. A collection of
  artifacts, indexed by the url path of the artifact.")

(defvar *host* nil
  "Dynamic string, bound before building a site, that holds the url of
  the host, including the transfer protocol (https/http/etc).")

;;; HACKING ON A SITE

(defgeneric content-equivlanet-p (a b)
  (:documentation "T if artifacts A and B should be thought of as having equivalent content."))

(defmethod content-equivlanet-p (a b) 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 *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 (site backup)
  "A site has changed since backed up if either the asset table or the
artifact tables have changed."
  (not (tables-equal-p site backup :test 'content-equivlanet-p)))

(defun run-recipe (recipe)
  "Runs the RECIPE, a function of zero arguments, in a fresh context
   and returns the site hash table it built.

   Recipes are functions of zero arguments run entirely for their side
   affects on two dynamic variables: *CONTENT* and *ARTIFACTS* both of
   of which hold hash tables. These two variables are referred to as
   the build context of the recipe.

   Whenever a subclass of CONTENT or ARTIFACT is instantiated, it is
   added to the correct hash table.  These hash tables are used under
   the hood by the content and artifact retrieval utility functions -
   e.g. FIND-CONTENT, ARTIFACTS-WITH-CLASS, and so on."
  (let ((*site* (make-hash-table :test 'equal))
        (*content* (make-hash-table :test 'equal)))
    (funcall recipe)
    *site*))

(defun hack-on
    (recipe location &key (port 4242) (rebuild-freqeuncy 1) (auto-refresh t) log-to-repl)
  (ensure-directories-exist location)
  (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)))
           (*host* (format nil "http://localhost:~a" port))
           (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*))


;;; CONTENT

(defclass content ()
  ((keywords
    :reader content-keywords
    :initarg :keywords
    :initform nil
    :documentation "A list of content keywords that may be used to
    look up this piece of content."))
  (:documentation
   "The base class for all raw content. CONTENT instances represent
   unprocessed, unadorned files, database queries, or any source of
   content data that FLEXO can import and use to create and publish
   site artifacts."))

(defmethod initialize-instance :after ((content content) &key)
  (dolist (key (content-keywords content))
    (when *content*
      (if (gethash key *content*)
          (pushnew content (gethash key *content*))
          (setf (gethash key *content*)
                (list content))))))

(defclass file (content)
  ((filepath
    :reader filepath
    :initarg :filepath
    :initform (error "FILE must have a FILEPATH slot value."))
   (mod-time
    :accessor mod-time
    :initarg :mod-time)))

(defmethod initialize-instance :after ((content file) &key)
  (when *content* 
    (setf (gethash (filepath content) *content*)
          content
          (mod-time content)
          (file-write-date (filepath content)))))

;;; ARTIFACTS

(defclass artifact ()
  ((url
    :accessor artifact-url-path
    :initarg :url
    :initform (error "An artifact needs a url")
    :documentation "A URL path, relative to the site root, from where
    this artifact is to be served."))
  (:documentation
   "ARTIFACT instances represent what flexo publishes: i.e. pages and
   files to be served from some web root."))

(defmethod initialize-instance :after ((artifact artifact) &key)
  (when *site*
    (setf (gethash (artifact-url-path artifact) *site*)
          artifact)))

(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. "))

(defmethod content-equivlanet-p ((a template-generated-text) (b template-generated-text))
  (equal (generated-text a) (generated-text b)))


(defclass spinneret-page (template-generated-text) ()
  (:documentation "An artifact generated from a spinneret template
  representing an entire web page.."))

(defclass ps-script (template-generated-text) ()
  (:documentation "An artifact generated from a collection of
  parenscript expressions holding a javascript script."))

(defclass lass-sheet (template-generated-text) ()
  (:documentation "An artifact generated from LASS expressions that
  holds CSS content."))

(defclass rss-feed (template-generated-text) ()
  (:documentation "An artifact that holds an XML document representing
  an RSS feed"))

;;; CONTENT AND ARTIFACT RETRIEVAL PROTOCOL

(defun content-with-tags (&rest tags)
  "Content utility function to locate all content with all of the
   supplied keyword tags"
  (when *content*
    (let ((tagged (gethash (first tags) *content*)))
      (dolist (tag (rest tags) tagged)
        (setf tagged
              (intersection tagged (gethash tag *content*)))))))

(defun find-content (pred)
  "Generic content query. PRED is a preedicate of one argument, and is
   passed a CONTENT instance. Returns a list of instances for which
   PRED returns non NIL."
  (when *content*
    (loop :for instance :being :the :hash-value :of *content*
          :when (funcall pred instance)
            :collect instance)))

(defun content-with-class (class)
  "Return all content that has been classified with CLASS."
  (find-content (lambda (ob) (typep ob class))))

(defun lookup-content (key)
  "Looks up KEY in *CONTENT*.  key cna be a PATHNAME or a KEYWORD"
  (when *content*
    (gethash key *content*)))

(defun content-with-filepath-like (regex)
  "Returns all FILE content instances whose filepath matches the
   supplied regular expression."
  (find-content
   (lambda (content)
     (and (typep content 'file)
          (ppcre:scan regex (namestring (filepath content)))))))

(defun find-artifacts (pred)
  "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 *site*
    (loop :for instance :being :the :hash-value :of *site*
          :when (funcall pred instance)
            :collect instance)))

(defun artifacts-with-class (class)
  "Returns a list of instances of CLASS from the *ARTIFACT* store."
  (find-artifacts
   (lambda (artifact) (typep artifact class))))

(defun artifacts-with-urlpath-like (regex)
  "Returns a list of instances of artifacts whose url path matches the
   supplied regex."
  (find-artifacts
   (lambda (artifact)
     (ppcre:scan regex (artifact-url-path artifact)))))

;;; ARTIFACT TEMPLATE AND CREATION MACROS

(defmacro spinneret-page (url &body spinneret-code)
  "Creates a SPINNERET-PAGE instance with the given url path by
   expanding the SPINNERET template in BODY."
  (let ((body (inject-autorefresh-into-spinneret-body spinneret-code)))
    `(make-instance
      'spinneret-page
      :url ,url
      :text (with-html-string ,@body))))

(defmacro define-spinneret-page (pagename url-string &body spinneret-code)
  "Defines a function of zero arguments that creates a SPINNERET-PAGE
  artifact with the provided URL-STRING by expanding the SPINNERET
  template in BODY.  Suitable for defining single-pages that can be
  called within a recipe."
  `(defun ,pagename ()
     (spinneret-page ,url-string ,@spinneret-code)))

(defmacro define-spinneret-template
    (template-name (url-arg &rest lambda-list-def) &body spinneret-code)
  "Defines a function that creates an instance of SPINNERET-PAGE from a
   reusable template."
  `(defun ,template-name (,url-arg ,@lambda-list-def)
     (spinneret-page ,url-arg
       ,@spinneret-code)))

(defmacro ps-script (url &body parenscript-code)
  "Creates a PS-SCRIPT instance with given URL by expanding the
   PARENSCRIPT template in BODY."
  `(make-instance
    'ps-script
    :url ,url
    :text (ps:ps ,@parenscript-code)))

(defmacro define-ps-script (name url-string &body parenscript-code)
  "Defines a thunk named NAME that, when called, creates an instance
   of PS-SCRIPT.  Intended to be used to define named scripts that can
   be called within a site building recipe. Keeping the script
   definition outside of the body of the recipe supports interactive
   development."
  `(defun ,name ()
     (ps-script ,url-string
       ,@parenscript-code)))

(defmacro lass-sheet (url &body lass-code)
  "Creates a LASS-SHEET instance with URL by expanding the LASS template in BODY."
  `(make-instance
    'lass-sheet
    :url ,url
    :text (lass:compile-and-write '(:let () ,@lass-code))))

(defmacro define-lass-sheet (name url &body lass-code)
  "Defines a thunk named NAME that, when called, creates an instance
   of LASS-SHEET.  Intended to be used to define named stylesheets
   that can be called within a single site building recipe. Keepng the
   sheet defintion outside the body of the recipe supports interactive
   development."
  `(defun ,name ()
     (lass-sheet ,url ,@lass-code)))

(defmacro define-lass-template
    (template-name (url-arg &rest keyword-args) &body lass-code)
  "Defines a function that produces an instance of LASS-SHEET from a
   reusable template. 

   The KEYWORD-ARGS must be a list of pairs of the sort that would
   appear after &KEY in a DEFUN's lambda list.  Single variables are
   not allowed, only pairs.  Moreover, string, symbol, and numeric
   literals are the only permitted values.

   Example:
   (define-lass-template my-style (url (bg \"#fab\") (size \"1.2em\")) 
     (body 
       :background #(bg) 
       :font-size #(size)))  
   "
  (let ((arg-names
          (mapcar #'first keyword-args)))
    `(defun ,template-name (,url-arg &key ,@keyword-args)
       (lass-sheet ,url-arg
         (list* :let (mapcar #'list ',arg-names (list ,@arg-names))
                ',lass-code)))))

(defclass file-artifact (artifact file) ()
  (:documentation
   "Meant to be extended by all artifacts that are also files on
    disk."))

(defmethod content-equivlanet-p ((a file-artifact) (b file-artifact))
  (equal (mod-time a) (mod-time b)))

;;; SITE BUILDING TOOLS

(defun add-file (path class &rest keywords)
  "Creates an instance of CLASS, which must be a subclass of FILE,
  using the upplied path. Supplies this piece of content (which may or
  maynot also be an ARTIFACT) with KEYWORDS for later retrieval."
  (assert (subtypep class 'file) () "~s is not a subclass of FLEXO:FILE" class)
  (assert (uiop:file-exists-p path) () "~s does not exist on disk" path)
  (make-instance class
                 :filepath path
                 :keywords keywords))

(defun sane-file-name (path)
  "Returns the string representation of the filename in the pathname
  PATH. A sane representation includes the file extension, if present."
  (if (pathname-type path)
      (format nil "~a.~a" (pathname-name path) (pathname-type path))
      (pathname-name path)))

(defun add-files-matching (directory-path regex class &rest keywords)
  "Given a root directory and a regular expression REGEX, call
   ADD-FILE with the supplied CLASS and KEYWORDS for each file
  filename (including extension) whose namestring is matched by the REGEX."
  (dolist (path (uiop:directory-files directory-path))
    (when (ppcre:scan regex  (sane-file-name path))
      (apply #'add-file path class keywords)))
  (dolist (subdir (uiop:subdirectories directory-path))
    (apply #'add-files-matching subdir regex class keywords)))

;;; PUBLISH PROTOCOL

(defgeneric publish (artifact location)
  (:documentation "Publish the given artifact in the given location."))

(defmethod publish ((artifact file-artifact) (location pathname))
  (let ((path (uiop:merge-pathnames*
               (uiop:relativize-pathname-directory (artifact-url-path artifact))
               location)))
    (ensure-directories-exist path)
    (uiop:copy-file (filepath artifact)  path)))

(defmethod publish ((generated template-generated-text) (location pathname))
  (let ((path
          (uiop:merge-pathnames*
           (uiop:relativize-pathname-directory  (artifact-url-path generated))
           location)))
    (ensure-directories-exist path)
    (alexandria:write-string-into-file
     (generated-text generated)
     path
     :if-exists :supersede
     :external-format :utf8)))

(defun publish-site (site location)
  "SITE is a hashtable keyed by url paths whose values are ARTIFACT
   intances. LOCATION is a publication location.  Calls PUBLISH under
   the hood."
  (loop for artifact being the hash-value of site
        do (publish artifact location)))

(defun build-and-publish (recipe location host)
  "RECIPE is a function of zero arguments that builds a site in a
   fresh context and, if successful, publishes that site to
   LOCATION. Calls PUBLISH under the hood on each ARTIFACT created in
   the recipe."
  (let ((*host* host))
    (publish-site (run-recipe recipe) location)))