src/fonts.lisp

   1 (uiop:define-package #:lw2.fonts
   2   (:use #:cl #:iterate #:sb-thread #:lw2.fonts-modules #:lw2.html-reader #:lw2.utils #:lw2.resources)
   3   (:export #:fonts-source #:google-fonts-source #:obormot-fonts-source
   4            #:generate-fonts-html-headers)
   5   (:recycle #:lw2-viewer))
   6
   7 (in-package #:lw2.fonts)
   8
   9 (named-readtables:in-readtable html-reader)
  10
  11 ;;;; google-fonts-source
  12
  13 (defmethod call-with-fonts-source-resources ((fonts-source google-fonts-source) fn)
  14   (funcall fn))
  15
  16 (defmethod generate-fonts-html-headers ((fonts-source google-fonts-source))
  17   <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.7.2/css/all.css" integrity="sha384-fnmOCqbTlWIlj8LyTjo7mOUStjsKC4pOpQbqyi7RrhN7udi9RwhKkMHpvLbHG9Sr" crossorigin="anonymous">
  18   <link rel="stylesheet" href="https://fonts.googleapis.com/css?family=PT+Serif:400,400i,700,700i|Assistant:400,600,800">)
  19
  20 ;;;; obormot-fonts-source
  21
  22 (defparameter *obormot-fonts-stylesheet-uris*
  23   '("https://fonts.obormot.net/?fonts=InconsolataGW,CharterGW,ConcourseGW,MundoSans,SourceSansPro,Raleway,ProximaNova,TiredOfCourier,AnonymousPro,InputSans,InputSansNarrow,InputSansCondensed,GaramondPremierPro,TriplicateCode,TradeGothic,NewsGothicBT,Caecilia,SourceSerifPro,SourceCodePro"
  24     "https://fonts.obormot.net/?fonts=BitmapFonts,FontAwesomeGW,GW-Symbols&base64encode=1"))
  25 ;(defparameter *obormot-fonts-stylesheet-uris* '("https://fonts.greaterwrong.com/?fonts=*"))
  26
  27 (defvar *fonts-redirect-data* nil)
  28 (declaim (type (or null (unsigned-byte 63)) *fonts-redirect-last-update*))
  29 (sb-ext:defglobal *fonts-redirect-last-update* nil)
  30 (sb-ext:defglobal *fonts-redirect-lock* (make-mutex))
  31 (sb-ext:defglobal *fonts-redirect-thread* nil)
  32
  33 (defun update-obormot-fonts ()
  34   (with-atomic-file-replacement (out-stream (asdf:system-relative-pathname :lw2-viewer "www/fonts.css") :element-type 'character)
  35     (iter
  36      (for uri in *obormot-fonts-stylesheet-uris*)
  37      (for response = (dex:get uri
  38                               :headers (alist "referer" (lw2.sites::site-uri (first lw2.sites::*sites*)) "accept" "text/css,*/*;q=0.1")
  39                               :force-string t
  40                               :keep-alive nil))
  41      (with-input-from-string (in-stream response)
  42        (iter (for line in-stream in-stream using #'read-line)
  43              (for replaced = (ppcre:regex-replace "url\\(['\"](?=https?://fonts.obormot.net/)" line "\\&https://fonts.greaterwrong.com/"))
  44              (write-string replaced out-stream)
  45              (terpri out-stream)))))
  46   (setf *fonts-redirect-last-update* (get-unix-time)))
  47
  48 (defun update-obormot-fonts-async ()
  49   (unless *fonts-redirect-thread*
  50     (setf *fonts-redirect-thread*
  51           (make-thread (lambda ()
  52                          (update-obormot-fonts)
  53                          (setf *fonts-redirect-thread* nil))
  54                        :name "obormot fonts update"))))
  55
  56 (defun maybe-update-obormot-fonts ()
  57   (let ((current-time (get-unix-time)))
  58     (with-mutex (*fonts-redirect-lock*)
  59       (let ((last-update *fonts-redirect-last-update*))
  60         (if last-update
  61             (when (>= current-time (+ last-update (* 60 60)))
  62               (update-obormot-fonts-async))
  63             (update-obormot-fonts))))))
  64
  65 (defmethod call-with-fonts-source-resources ((fonts-source obormot-fonts-source) fn)
  66   (maybe-update-obormot-fonts)
  67   (with-resource-bindings ((:preconnect "https://s3.amazonaws.com/")
  68                            (:style "/fonts.css"))
  69     (funcall fn)))
  70
  71 (defmethod generate-fonts-html-headers ((fonts-source obormot-fonts-source))
  72   nil)