src/images.lisp

   1 (uiop:define-package #:lw2.images
   2   (:use #:cl #:iterate #:split-sequence #:lw2.conditions #:lw2.html-reader #:lw2.utils #:lw2.hash-utils #:lw2.lmdb)
   3   (:import-from #:alexandria #:when-let #:when-let*))
   4
   5 (in-package #:lw2.images)
   6
   7 (defparameter *wrapper-program* #+linux '("choom" "-n" "1000" "--") #-linux nil)
   8
   9 (sb-ext:defglobal *image-convert-semaphore* (sb-thread:make-semaphore :count 2))
  10
  11 (defmacro run-program (program-args &rest lisp-args)
  12   `(uiop:run-program (append *wrapper-program* (list ,@program-args)) ,@lisp-args))
  13
  14 (defun image-statistics (image-filename)
  15   (let* ((result-list (with-semaphore (*image-convert-semaphore*)
  16                         (run-program ("convert" image-filename "-format" "%w %h\\n" "info:")
  17                                      :output (lambda (stream)
  18                                                (let ((width-height (split-sequence #\Space (read-line stream)))
  19                                                      (animation-frames 1))
  20                                                  (iter (while (read-line stream nil))
  21                                                        (incf animation-frames))
  22                                                  (list* animation-frames width-height))))))
  23          (mime-type (run-program ("file" "--brief" "--mime-type" image-filename) :output (lambda (stream) (read-line stream)))))
  24     (destructuring-bind (animation-frames width height) result-list
  25       (alist :width (parse-integer width)
  26              :height (parse-integer height)
  27              :animation-frames animation-frames
  28              :mime-type mime-type))))
  29
  30 (defun string-to-brightness (color-string)
  31   (let ((color-value (parse-integer color-string :radix 16)))
  32     (cond ((= (length color-string) 8) ; 8-bit rgba
  33            (* 3 (ldb (byte 8 24) color-value)))
  34           ((= (length color-string) 6) ; 8-bit rgb
  35            (+ (ldb (byte 8 0) color-value)
  36               (ldb (byte 8 8) color-value)
  37               (ldb (byte 8 16) color-value)))
  38           ((= (length color-string) 16) ; 16-bit rgba
  39            (floor
  40             (* 3 (ldb (byte 16 48) color-value))
  41             256))
  42           ((= (length color-string) 12) ; 16-bit rgb
  43            (floor
  44             (+ (ldb (byte 16 0) color-value)
  45                (ldb (byte 16 16) color-value)
  46                (ldb (byte 16 32) color-value))
  47             256)))))
  48
  49 (defun image-invertible (image-filename)
  50   (let ((histogram-list nil)
  51         (background-pixels 0)
  52         (background-brightness 0)
  53         (total-pixels 0)
  54         (total-brightness 0.0d0))
  55     (with-semaphore (*image-convert-semaphore*)
  56       (run-program ("convert" image-filename "-format" "%c" "histogram:info:")
  57                    :output (lambda (stream)
  58                              (iterate (for line next (read-line stream nil))
  59                                       (while line)
  60                                       (multiple-value-bind (match? strings) (ppcre:scan-to-strings "^\\s*(\\d+):" line :sharedp t)
  61                                         (when match?
  62                                           (let ((pixel-count (parse-integer (svref strings 0))))
  63                                             (push pixel-count histogram-list)
  64                                             (incf total-pixels pixel-count)
  65                                             (multiple-value-bind (match? strings) (ppcre:scan-to-strings "#([0-9a-fA-F]+)" line :sharedp t)
  66                                               (when match?
  67                                                 (let ((brightness (string-to-brightness (svref strings 0))))
  68                                                   (incf total-brightness (* pixel-count (/ brightness (* 3 255.0d0))))
  69                                                   (when (> pixel-count background-pixels)
  70                                                     (setf background-pixels pixel-count
  71                                                           background-brightness brightness))))))))))))
  72     (setf histogram-list (sort histogram-list #'>))
  73     (let ((tenth (first (nthcdr 10 histogram-list))))
  74       (and histogram-list
  75            (> (/ (float background-pixels) (float total-pixels)) 0.3333333)
  76            (> (/ total-brightness total-pixels) 0.5d0)
  77            (> background-brightness (* 3 192))
  78            (or (not tenth)
  79                (> (first histogram-list) (* 10 tenth)))))))
  80
  81 (defun invert-image (input output)
  82   (with-semaphore (*image-convert-semaphore*)
  83     (run-program ("convert" input "-colorspace" "Lab" "-channel" "R" "-negate" "-gamma" "2.2" "-colorspace" "sRGB" output))))
  84
  85 (defun download-file (uri target)
  86   (sb-sys:with-deadline (:seconds 60)
  87     (with-open-file (out-stream target :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
  88       (with-open-stream (in-stream (dex:get uri :want-stream t :force-binary t :keep-alive nil :connect-timeout 30 :headers '((:accept . "image/*,*/*"))))
  89         (alexandria:copy-stream in-stream out-stream)))))
  90
  91 (defun download-file-with-wayback-fallback (uri target)
  92   (handler-case
  93       (download-file uri target)
  94     (error (c)
  95       (let ((wayback-uri (lw2.legacy-archive:wayback-unmodified-url uri)))
  96         (if wayback-uri
  97             (download-file wayback-uri target)
  98             (error c))))))
  99
 100 (define-cache-database 'lw2.backend-modules:backend-lmdb-cache "dynamic-content-images" "cached-images")
 101
 102 (sb-ext:defglobal *image-threads* (make-hash-table :test 'equal :synchronized t))
 103 (defparameter *current-version* 3)
 104
 105 (defun filename-to-uri (filename)
 106   (concatenate 'base-string "/proxy-assets/" filename))
 107
 108 (defun uri-to-pathname (uri)
 109   (concatenate 'base-string "www" uri))
 110
 111 (defun process-image (uri)
 112   (let* ((filename (multiple-value-bind (r1 r2) (city-hash:city-hash-128 (babel:string-to-octets uri)) (format nil "~32R" (dpb r1 (byte 64 64) r2))))
 113          (proxy-uri (filename-to-uri filename))
 114          (pathname (uri-to-pathname proxy-uri)))
 115     (download-file-with-wayback-fallback uri pathname)
 116     (let* ((image-statistics (image-statistics pathname))
 117            (inverted-uri (and (eq 1 (cdr (assoc :animation-frames image-statistics)))
 118                               (image-invertible pathname)
 119                               (concatenate 'base-string proxy-uri "-inverted")))
 120            (inverted-pathname (and inverted-uri (uri-to-pathname inverted-uri))))
 121       (when inverted-uri (invert-image pathname inverted-pathname))
 122       (alist* :version *current-version*
 123               :uri uri
 124               :filename filename
 125               :proxy-uri proxy-uri
 126               :inverted-uri inverted-uri
 127               image-statistics))))
 128
 129 (defun image-uri-data (uri)
 130   (let ((key (hash-string uri)))
 131     (labels ((make-image-thread ()
 132                (let ((thread
 133                       (sb-ext:with-locked-hash-table (*image-threads*)
 134                         (or (gethash uri *image-threads*)
 135                             (setf (gethash uri *image-threads*)
 136                                   (lw2.backend::make-thread-with-current-backend
 137                                    (lambda ()
 138                                      (log-and-ignore-errors ; FIXME figure out how to handle errors here
 139                                       (unwind-protect
 140                                            (let ((result (process-image uri)))
 141                                              (cache-put "dynamic-content-images" key result :key-type :byte-vector :value-type :json)
 142                                              (alist-bind ((filename string) (mime-type string)) result
 143                                                          (cache-put "cached-images" filename (alist :mime-type mime-type) :value-type :json))
 144                                              result)
 145                                         (remhash uri *image-threads*))))
 146                                    :name "image processing thread"))))))
 147                  (sb-thread:join-thread thread))))
 148       (let ((cached-data (cache-get "dynamic-content-images" key :key-type :byte-vector :value-type :json)))
 149         (alist-bind ((proxy-uri (or null simple-string))
 150                      (inverted-uri (or null simple-string))
 151                      (version))
 152                     cached-data
 153           (if (and cached-data (eql version *current-version*)
 154                    proxy-uri (probe-file (uri-to-pathname proxy-uri))
 155                    (or (not inverted-uri) (probe-file (uri-to-pathname inverted-uri))))
 156               cached-data
 157               (make-image-thread)))))))
 158
 159 (defun dynamic-image (uri container-tag-name container-attributes img-attributes)
 160   (declare (simple-string uri container-tag-name))
 161   (let ((image-data
 162          (log-and-ignore-errors
 163           (sb-sys:with-deadline (:seconds 5)
 164             (image-uri-data uri)))))
 165     (alist-bind ((proxy-uri (or null simple-string))
 166                  (inverted-uri (or null simple-string))
 167                  (width (or null fixnum))
 168                  (height (or null fixnum)))
 169                 image-data
 170       (labels ((write-attributes (attrs predicate stream)
 171                  (iter (for (attr . value) in attrs)
 172                        (declare (type (or null simple-string) attr value))
 173                        (when (and attr (funcall predicate attr))
 174                          (write-char #\Space stream)
 175                          (write-string attr stream)
 176                          (when value
 177                            (write-string "='" stream)
 178                            (plump:encode-entities value stream)
 179                            (write-char #\' stream)))))
 180                (finish-tag (attrs predicate stream)
 181                  (write-attributes attrs predicate stream)
 182                  (write-char #\> stream)))
 183       (with-html-stream-output (:stream stream)
 184         (write-char #\< stream)
 185         (write-string container-tag-name stream)
 186         (when (and width height)
 187           (write-char #\Space stream)
 188           (format stream "style='--aspect-ratio: ~F; max-width: ~Dpx'"
 189                   (/ (float width)
 190                      (float height))
 191                   width))
 192         (finish-tag container-attributes (lambda (attr) (not (string-equal attr "style"))) stream)
 193         (let ((encoded-uri (plump:encode-entities uri))
 194               (predicate (lambda (attr) (string-equal attr "alt"))))
 195           (cond
 196             (inverted-uri
 197              (format stream "<picture style='display: var(--invertible-display)' data-original-src='~A'><source srcset='~A' media='(prefers-color-scheme: dark)'><img src='~A' loading='lazy'"
 198                       encoded-uri
 199                       inverted-uri
 200                       (or proxy-uri encoded-uri))
 201              (finish-tag img-attributes predicate stream)
 202              (format stream "</picture><img style='display: var(--inverted-display)' loading='lazy' src='~A'"
 203                      inverted-uri)
 204              (finish-tag img-attributes predicate stream))
 205             (:otherwise
 206               (format stream "<img src='~A' data-original-src='~A' loading='lazy'"
 207                       (or proxy-uri encoded-uri) encoded-uri)
 208               (finish-tag img-attributes predicate stream))))
 209         (format stream "</~A>" container-tag-name))))))
 210