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