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* #:inverted-media-query #: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 (defun inverted-media-query ()
  19   (alexandria:switch ((hunchentoot:cookie-in "dark-mode") :test #'string-equal)
  20                      ("dark" "all")
  21                      ("light" "not all")
  22                      (t "all and (prefers-color-scheme: dark)")))
  23
  24 (defmacro with-page-resources (&body body)
  25   `(let* ((*link-header* *link-header*)
  26           (*style-tags* *style-tags*)
  27           (*script-tags* *script-tags*)
  28           (*async-script-tags* *async-script-tags*)
  29           (*push-option* (when (hunchentoot:cookie-in "push") "nopush"))
  30           (*page-resources* (site-resources *current-site*)))
  31      (dynamic-flet ((fn () ,@body))
  32        (call-with-site-resources *current-site* #'fn))))
  33
  34 (defmacro with-appended-functions ((&rest clauses) &body body)
  35   `(let* ,(iter (for (old-function new-name lambda-list . inner-body) in clauses)
  36                 (let ((old-function-name (gensym)))
  37                   (collect `(,old-function-name ,old-function))
  38                   (collect `(,new-name (lambda ,lambda-list (funcall ,old-function-name ,@lambda-list) ,@inner-body)))))
  39      ,@body))
  40
  41 (defun require-resource (type &rest args)
  42   (push (list* type args) *page-resources*))
  43
  44 (defun generate-versioned-link (file)
  45   (let* ((filename (format nil "www~A" file)))
  46     (or (ignore-errors (format nil "~A?v=~A" file (universal-time-to-unix (file-write-date filename))))
  47         file)))
  48
  49 (defgeneric call-with-fonts-source-resources (site fn))
  50
  51 (defun output-link-header-element (stream uri type)
  52   (multiple-value-bind (rel type as push-option)
  53       (case type
  54         (:preconnect (values "preconnect"))
  55         (:stylesheet (values "preload" "text/css" "style" *push-option*))
  56         (:script (values "preload" "text/javascript" "script" *push-option*)))
  57     (format stream "<~A>;rel=~A~@[;type=~A~]~@[;as=~A~]~@[;~A~]" uri rel type as push-option)))
  58
  59 (defun output-style-tag (stream uri media class)
  60   (format stream "<link rel=\"stylesheet\" href=\"~A\"~@[ media=\"~A\"~]~@[ class=\"~A\"~]>" uri media class))
  61
  62 (defun output-script-tag (stream uri &key async)
  63   (format stream "<script src=\"~A\"~:[~; async~]></script>" uri async))
  64
  65 (eval-when (:compile-toplevel :load-toplevel :execute)
  66   (defun preconnect-resource-forms (stream uri)
  67     (alist :link-header `((funcall delimit) (output-link-header-element ,stream ,uri :preconnect))))
  68
  69   (defun style-resource-forms (stream uri &optional media class)
  70     (with-gensyms (versioned-uri)
  71       (alist :bindings `((,versioned-uri (generate-versioned-link ,uri)))
  72              :link-header `((funcall delimit) (output-link-header-element ,stream ,versioned-uri :stylesheet))
  73              :style-tags `((output-style-tag ,stream ,versioned-uri ,media ,class)))))
  74
  75   (defun script-resource-forms (stream uri &rest args &key async)
  76     (with-gensyms (versioned-uri)
  77       (alist :bindings `((,versioned-uri (generate-versioned-link ,uri)))
  78              :link-header `((funcall delimit) (output-link-header-element ,stream ,versioned-uri :script))
  79              (if async :async-script-tags :script-tags) `((output-script-tag ,stream ,versioned-uri ,@args))))))
  80
  81 (defmacro with-resource-bindings ((&rest clauses) &body body)
  82   (let ((forms (make-hash-table :test 'eq)))
  83     (iter (for (resource-type . params) in clauses)
  84           (iter (for (form-type . form-body) in (apply (case resource-type
  85                                                          (:preconnect #'preconnect-resource-forms)
  86                                                          (:style #'style-resource-forms)
  87                                                          (:script #'script-resource-forms))
  88                                                        'stream params))
  89                 (appendf (gethash form-type forms) form-body)))
  90     `(let* ,(gethash :bindings forms)
  91        ,(let (w-a-f-clauses special-names lexical-names)
  92              (iter (for (form-type special-name lexical-name extra-lambda-list)
  93                         in '((:link-header *link-header* link-header-fn (delimit))
  94                              (:style-tags *style-tags* style-tags-fn nil)
  95                              (:script-tags *script-tags* script-tags-fn nil)
  96                              (:async-script-tags *async-script-tags* async-script-tags-fn nil)))
  97                    (when-let ((form-body (gethash form-type forms)))
  98                              (push `(,special-name ,lexical-name (stream ,@extra-lambda-list) ,@form-body) w-a-f-clauses)
  99                              (push special-name special-names)
 100                              (push lexical-name lexical-names)))
 101              `(with-appended-functions ,(reverse w-a-f-clauses)
 102                 ,(when body `(declare (dynamic-extent ,@lexical-names)))
 103                 (setf ,@(iter (for special in special-names) (for lexical in lexical-names)
 104                               (collect special) (collect lexical)))
 105                 ,@body)))))
 106
 107 (defgeneric call-with-site-resources (site fn)
 108   (:method ((site site) fn)
 109     (with-resource-bindings ((:script "/head.js")
 110                              (:script "/script.js" :async t))
 111       (call-with-fonts-source-resources (site-fonts-source site) fn))))
 112
 113 (defgeneric site-resources (site)
 114   (:method-combination append :most-specific-first)
 115   (:method append ((s site))
 116     (labels ((gen-theme (theme os)
 117                (let* ((basename (format nil "~@[-~A~].~A.css" theme os))
 118                       (filename (format nil "www/css/style~A" basename))
 119                       (version (universal-time-to-unix (file-write-date filename)))
 120                       (baseurl (format nil "~A?v=~A" basename version)))
 121                  (with-resource-bindings ((:style (format nil "/generated-css/style~A" baseurl) nil "theme")
 122                                           (:style (format nil "/generated-css/colors~A" baseurl) nil "theme light-mode")
 123                                           (:style (format nil "/generated-css/inverted~A" baseurl) (inverted-media-query) "theme dark-mode"))))))
 124       (let* ((ua (hunchentoot:header-in* :user-agent))
 125              (theme (or (and *preview* (nonempty-string (hunchentoot:get-parameter "theme")))
 126                         (nonempty-string (hunchentoot:cookie-in "theme"))))
 127              (theme (if (string= theme "default") nil theme))
 128              (os (cond ((search "Windows" ua) "windows")
 129                        ((search "Mac OS" ua) "mac")
 130                        (t "linux"))))
 131         (handler-case (gen-theme theme os)
 132           (serious-condition () (gen-theme nil os)))
 133         *html-global-resources*))))
 134
 135 (sb-ext:defglobal *static-assets* nil)
 136
 137 (let ((new-static-assets (make-hash-table :test 'equal)))
 138   (flet ((defres (uri content-type)
 139            (vector (concatenate 'string "www" uri) content-type)))
 140     (loop for system in '("mac" "windows" "linux") nconc
 141          (loop for theme in '(nil "dark" "grey" "ultramodern" "zero" "brutalist" "rts" "classic" "less")
 142             do (let ((uri (format nil "/css/style~@[-~A~].~A.css" theme system)))
 143                  (setf (gethash uri new-static-assets) (defres uri "text/css")))))
 144     (loop for (uri content-type) in
 145          '(("/fonts.css" "text/css")
 146            ("/arbital.css" "text/css")
 147            ("/head.js" "text/javascript")
 148            ("/script.js" "text/javascript")
 149            ("/assets/favicon.ico" "image/x-icon")
 150            ("/assets/telegraph.jpg" "image/jpeg")
 151            ("/assets/popup.svg" "image/svg+xml"))
 152        do (setf (gethash uri new-static-assets) (defres uri content-type))))
 153   (setf *static-assets* new-static-assets))
 154
 155 (hunchentoot:define-easy-handler
 156     (view-versioned-resource
 157      :uri (lambda (r)
 158             (when-let ((asset-data (gethash (hunchentoot:script-name r) *static-assets*)))
 159               (let ((file (svref asset-data 0))
 160                     (content-type (svref asset-data 1)))
 161                 (when (assoc "v" (hunchentoot:get-parameters r) :test #'string=)
 162                   (setf (hunchentoot:header-out "Cache-Control") #.(format nil "public, max-age=~A, immutable" (- (expt 2 31) 1))))
 163                 (hunchentoot:handle-static-file file content-type))
 164               t)))
 165     nil)
 166
 167 (defun process-css-line (in-line)
 168   (macrolet ((override (name)
 169                `(let ((reg-matches (nth-value 1 (ppcre:scan-to-strings ,(format nil "~A:\\s*(.*?)\\s*(?:;|\\*/|$)" name) in-line))))
 170                   (if (>= (length reg-matches) 1) (aref reg-matches 0)))))
 171     (let* ((invert-override (override "invert-override"))
 172            (gamma-override (override "gamma-override"))
 173            (backgroundp (to-boolean (ppcre:scan "background" in-line)))
 174            (gamma (cond (gamma-override (parse-float:parse-float gamma-override :type 'double-float))
 175                         (backgroundp 1.6d0)
 176                         (t 2.2d0))))
 177       (values
 178        (format nil "--theme~A-color"
 179                (cond (invert-override (format nil "-override-~A" (multiple-value-call #'lw2.colors::safe-color-name (lw2.colors::decode-css-color invert-override))))
 180                      (gamma-override (format nil "-gamma-~F" gamma))
 181                      (backgroundp "-bg")
 182                      (t "")))
 183        invert-override
 184        gamma))))
 185
 186 (defun output-tweakable-css (file out-stream)
 187   (with-open-file (in-stream file)
 188     (loop for in-line = (read-line in-stream nil)
 189        while in-line
 190        do (let* ((variable-prefix (process-css-line in-line))
 191                  (out-line (ppcre:regex-replace-all
 192                             lw2.colors::-css-color-scanner-
 193                             in-line
 194                             (lambda (target-string start end match-start match-end reg-starts reg-ends)
 195                               (declare (ignore start end reg-starts reg-ends))
 196                               (let ((color-string (substring target-string match-start match-end)))
 197                                 (format nil "var(~A-~A)"
 198                                         variable-prefix
 199                                         (multiple-value-call #'lw2.colors::safe-color-name (lw2.colors::decode-css-color color-string))))))))
 200             (write-line out-line out-stream)))))
 201
 202 (defun output-css-colors (file out-stream invert)
 203   (let ((used-colors (make-hash-table :test 'equal)))
 204     (with-open-file (in-stream file)
 205       (format out-stream ":root {~%")
 206       (loop for in-line = (read-line in-stream nil)
 207          while in-line
 208          do (multiple-value-bind (variable-prefix invert-override gamma)
 209                 (process-css-line in-line)
 210               (ppcre:do-matches-as-strings (color-string lw2.colors::-css-color-scanner- in-line)
 211                 (multiple-value-bind (r g b a) (lw2.colors::decode-css-color color-string)
 212                   (let ((color-name (format nil "~A-~A"
 213                                             variable-prefix
 214                                             (lw2.colors::safe-color-name r g b a))))
 215                     (unless (gethash color-name used-colors)
 216                       (setf (gethash color-name used-colors) t)
 217                       (format out-stream "~A: ~A;~%"
 218                               color-name
 219                               (if invert
 220                                   (or invert-override
 221                                       (multiple-value-call #'lw2.colors::encode-css-color (lw2.colors::perceptual-invert-rgba r g b a gamma)))
 222                                   color-string))))))))))
 223   (format out-stream "}~%"))
 224
 225 (hunchentoot:define-easy-handler
 226     (view-generated-css
 227      :uri (lambda (r)
 228             (let ((regs (nth-value 1 (ppcre:scan-to-strings "^/generated-css/(style|colors|inverted)([-.][a-z.-]+)$" (hunchentoot:script-name r)))))
 229               (when (= (length regs) 2)
 230                 (setf (hunchentoot:header-out "Content-Type") "text/css")
 231                 (when (assoc "v" (hunchentoot:get-parameters r) :test #'string=)
 232                   (setf (hunchentoot:header-out "Cache-Control") #.(format nil "public, max-age=~A, immutable" (- (expt 2 31) 1))))
 233                 (let ((file (format nil "www/css/style~A" (aref regs 1)))
 234                       (out-stream (flex:make-flexi-stream (hunchentoot:send-headers) :external-format :utf-8)))
 235                 (cond
 236                   ((string= (aref regs 0) "style")
 237                    (output-tweakable-css file out-stream))
 238                   ((string= (aref regs 0) "colors")
 239                    (output-css-colors file out-stream nil))
 240                   ((string= (aref regs 0) "inverted")
 241                    (output-css-colors file out-stream t))))
 242                 t))))
 243     nil)