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