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