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