src/resources.lisp

   1 (uiop:define-package #:lw2.resources
   2   (:use #:cl #:iterate #:lw2-viewer.config #:lw2.utils #:lw2.sites #:lw2.context)
   3   (:import-from #:alexandria #:with-gensyms #:when-let #:appendf)
   4   (:export #:*page-resources* #:with-page-resources #:require-resource #:generate-versioned-link #:with-resource-bindings #:call-with-fonts-source-resources #:site-resources)
   5   (:recycle #:lw2-viewer)
   6   (:unintern #:fonts-source-resources))
   7
   8 (in-package #:lw2.resources)
   9
  10 (defparameter *page-resources* nil)
  11 (defparameter *link-header* (constantly nil))
  12 (defparameter *style-tags* (constantly nil))
  13 (defparameter *script-tags* (constantly nil))
  14 (defparameter *async-script-tags* (constantly nil))
  15
  16 (defparameter *push-option* nil)
  17
  18 (defmacro with-page-resources (&body body)
  19   `(let* ((*link-header* *link-header*)
  20           (*style-tags* *style-tags*)
  21           (*script-tags* *script-tags*)
  22           (*async-script-tags* *async-script-tags*)
  23           (*push-option* (when (hunchentoot:cookie-in "push") "nopush"))
  24           (*page-resources* (site-resources *current-site*)))
  25      (dynamic-flet ((fn () ,@body))
  26        (call-with-site-resources *current-site* #'fn))))
  27
  28 (defmacro with-appended-functions ((&rest clauses) &body body)
  29   `(let* ,(iter (for (old-function new-name lambda-list . inner-body) in clauses)
  30                 (let ((old-function-name (gensym)))
  31                   (collect `(,old-function-name ,old-function))
  32                   (collect `(,new-name (lambda ,lambda-list (funcall ,old-function-name ,@lambda-list) ,@inner-body)))))
  33      ,@body))
  34
  35 (defun require-resource (type &rest args)
  36   (push (list* type args) *page-resources*))
  37
  38 (defun generate-versioned-link (file)
  39   (let* ((filename (format nil "www~A" file)))
  40     (format nil "~A?v=~A" file (universal-time-to-unix (file-write-date filename)))))
  41
  42 (defgeneric call-with-fonts-source-resources (site fn))
  43
  44 (defun output-link-header-element (stream uri type)
  45   (multiple-value-bind (rel type as push-option)
  46       (case type
  47         (:preconnect (values "preconnect"))
  48         (:stylesheet (values "preload" "text/css" "style" *push-option*))
  49         (:script (values "preload" "text/javascript" "script" *push-option*)))
  50     (format stream "<~A>;rel=~A~@[;type=~A~]~@[;as=~A~]~@[;~A~]" uri rel type as push-option)))
  51
  52 (defun output-style-tag (stream uri media class)
  53   (format stream "<link rel=\"stylesheet\" href=\"~A\"~@[ media=\"~A\"~]~@[ class=\"~A\"~]>" uri media class))
  54
  55 (defun output-script-tag (stream uri &key async)
  56   (format stream "<script src=\"~A\"~:[~; async~]></script>" uri async))
  57
  58 (eval-when (:compile-toplevel :load-toplevel :execute)
  59   (defun preconnect-resource-forms (stream uri)
  60     (alist :link-header `((funcall delimit) (output-link-header-element ,stream ,uri :preconnect))))
  61
  62   (defun style-resource-forms (stream uri &optional media class)
  63     (with-gensyms (versioned-uri)
  64       (alist :bindings `((,versioned-uri (generate-versioned-link ,uri)))
  65              :link-header `((funcall delimit) (output-link-header-element ,stream ,versioned-uri :stylesheet))
  66              :style-tags `((output-style-tag ,stream ,versioned-uri ,media ,class)))))
  67
  68   (defun script-resource-forms (stream uri &rest args &key async)
  69     (with-gensyms (versioned-uri)
  70       (alist :bindings `((,versioned-uri (generate-versioned-link ,uri)))
  71              :link-header `((funcall delimit) (output-link-header-element ,stream ,versioned-uri :script))
  72              (if async :async-script-tags :script-tags) `((output-script-tag ,stream ,versioned-uri ,@args))))))
  73
  74 (defmacro with-resource-bindings ((&rest clauses) &body body)
  75   (let ((forms (make-hash-table :test 'eq)))
  76     (iter (for (resource-type . params) in clauses)
  77           (iter (for (form-type . form-body) in (apply (case resource-type
  78                                                          (:preconnect #'preconnect-resource-forms)
  79                                                          (:style #'style-resource-forms)
  80                                                          (:script #'script-resource-forms))
  81                                                        'stream params))
  82                 (appendf (gethash form-type forms) form-body)))
  83     `(let* ,(gethash :bindings forms)
  84        ,(let (w-a-f-clauses special-names lexical-names)
  85              (iter (for (form-type special-name lexical-name extra-lambda-list)
  86                         in '((:link-header *link-header* link-header-fn (delimit))
  87                              (:style-tags *style-tags* style-tags-fn nil)
  88                              (:script-tags *script-tags* script-tags-fn nil)
  89                              (:async-script-tags *async-script-tags* async-script-tags-fn nil)))
  90                    (when-let ((form-body (gethash form-type forms)))
  91                              (push `(,special-name ,lexical-name (stream ,@extra-lambda-list) ,@form-body) w-a-f-clauses)
  92                              (push special-name special-names)
  93                              (push lexical-name lexical-names)))
  94              `(with-appended-functions ,(reverse w-a-f-clauses)
  95                 ,(when body `(declare (dynamic-extent ,@lexical-names)))
  96                 (setf ,@(iter (for special in special-names) (for lexical in lexical-names)
  97                               (collect special) (collect lexical)))
  98                 ,@body)))))
  99
 100 (defgeneric call-with-site-resources (site fn)
 101   (:method ((site site) fn)
 102     (with-resource-bindings ((:script "/head.js")
 103                              (:script "/script.js" :async t))
 104       (call-with-fonts-source-resources (site-fonts-source site) fn))))
 105
 106 (defgeneric site-resources (site)
 107   (:method-combination append :most-specific-first)
 108   (:method append ((s site))
 109     (labels ((gen-inner (theme os &optional dark-preference)
 110                (with-resource-bindings ((:style (format nil "/css/style~@[-~A~].~A.css" theme os)
 111                                                 (if dark-preference "(prefers-color-scheme: dark)")
 112                                                 "theme"))))
 113              (gen-theme (theme os)
 114                (if theme
 115                    (gen-inner theme os)
 116                    (progn (gen-inner nil os)
 117                           (gen-inner "dark" os t)))))
 118       (let* ((ua (hunchentoot:header-in* :user-agent))
 119              (theme (or (and *preview* (nonempty-string (hunchentoot:get-parameter "theme")))
 120                         (nonempty-string (hunchentoot:cookie-in "theme"))))
 121              (os (cond ((search "Windows" ua) "windows")
 122                        ((search "Mac OS" ua) "mac")
 123                        (t "linux"))))
 124         (handler-case (gen-theme theme os)
 125           (serious-condition () (gen-theme nil os)))
 126         *html-global-resources*))))
 127
 128 (sb-ext:defglobal *static-assets* nil)
 129
 130 (let ((new-static-assets (make-hash-table :test 'equal)))
 131   (flet ((defres (uri content-type)
 132            (vector (concatenate 'string "www" uri) content-type)))
 133     (loop for system in '("mac" "windows" "linux") nconc
 134          (loop for theme in '(nil "dark" "grey" "ultramodern" "zero" "brutalist" "rts" "classic" "less")
 135             do (let ((uri (format nil "/css/style~@[-~A~].~A.css" theme system)))
 136                  (setf (gethash uri new-static-assets) (defres uri "text/css")))))
 137     (loop for (uri content-type) in
 138          '(("/fonts.css" "text/css")
 139            ("/arbital.css" "text/css")
 140            ("/head.js" "text/javascript")
 141            ("/script.js" "text/javascript")
 142            ("/assets/favicon.ico" "image/x-icon")
 143            ("/assets/telegraph.jpg" "image/jpeg")
 144            ("/assets/popup.svg" "image/svg+xml"))
 145        do (setf (gethash uri new-static-assets) (defres uri content-type))))
 146   (setf *static-assets* new-static-assets))
 147
 148 (hunchentoot:define-easy-handler
 149     (view-versioned-resource
 150      :uri (lambda (r)
 151             (when-let ((asset-data (gethash (hunchentoot:script-name r) *static-assets*)))
 152               (let ((file (svref asset-data 0))
 153                     (content-type (svref asset-data 1)))
 154                 (when (assoc "v" (hunchentoot:get-parameters r) :test #'string=)
 155                   (setf (hunchentoot:header-out "Cache-Control") #.(format nil "public, max-age=~A, immutable" (- (expt 2 31) 1))))
 156                 (hunchentoot:handle-static-file file content-type))
 157               t)))
 158     nil)