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
*))
5 (in-package #:lw2.images
)
7 (sb-ext:defglobal
*image-convert-semaphore
* (sb-thread:make-semaphore
:count
2))
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
)))
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
))))
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
35 (* 3 (ldb (byte 16 48) color-value
))
37 ((= (length color-string
) 12) ; 16-bit rgb
39 (+ (ldb (byte 16 0) color-value
)
40 (ldb (byte 16 16) color-value
)
41 (ldb (byte 16 32) color-value
))
44 (defun image-invertible (image-filename)
45 (let ((histogram-list nil
)
47 (background-brightness 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
))
55 (multiple-value-bind (match? strings
) (ppcre:scan-to-strings
"^\\s*(\\d+):" line
:sharedp t
)
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
)
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
))))
70 (> (/ (float background-pixels
) (float total-pixels
)) 0.3333333)
71 (> (/ total-brightness total-pixels
) 0.5d0
)
72 (> background-brightness
(* 3 192))
74 (> (first histogram-list
) (* 10 tenth
)))))))
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
))))
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 (multiple-value-bind (in-stream status
) (drakma:http-request uri
:want-stream t
:force-binary t
:connection-timeout
30 :accept
"image/*,*/*")
84 (unless (= status
200) (error "HTTP error ~A" status
))
86 (alexandria:copy-stream in-stream out-stream
)
87 (close in-stream
))))))
89 (defun download-file-with-wayback-fallback (uri target
)
91 (download-file uri target
)
93 (let ((wayback-uri (lw2.legacy-archive
:wayback-unmodified-url uri
)))
95 (download-file wayback-uri target
)
98 (define-cache-database 'lw2.backend-modules
:backend-lmdb-cache
"dynamic-content-images" "cached-images")
100 (sb-ext:defglobal
*image-threads
* (make-hash-table :test
'equal
:synchronized t
))
101 (defparameter *current-version
* 3)
103 (defun process-image (uri)
104 (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
))))
105 (proxy-uri (format nil
"/proxy-assets/~A" filename
))
106 (pathname (format nil
"www~A" proxy-uri
)))
107 (download-file-with-wayback-fallback uri pathname
)
108 (let* ((image-statistics (image-statistics pathname
))
109 (inverted-uri (and (eq 1 (cdr (assoc :animation-frames image-statistics
)))
110 (image-invertible pathname
)
111 (format nil
"~A-inverted" proxy-uri
)))
112 (inverted-pathname (and inverted-uri
(format nil
"www~A" inverted-uri
))))
113 (when inverted-uri
(invert-image pathname inverted-pathname
))
114 (alist* :version
*current-version
*
118 :inverted-uri inverted-uri
121 (defun image-uri-data (uri)
122 (let ((key (hash-string uri
)))
123 (labels ((make-image-thread ()
125 (sb-ext:with-locked-hash-table
(*image-threads
*)
126 (or (gethash uri
*image-threads
*)
127 (setf (gethash uri
*image-threads
*)
128 (lw2.backend
::make-thread-with-current-backend
130 (log-and-ignore-errors ; FIXME figure out how to handle errors here
132 (let ((result (process-image uri
)))
133 (cache-put "dynamic-content-images" key result
:key-type
:byte-vector
:value-type
:json
)
134 (alist-bind ((filename string
) (mime-type string
)) result
135 (cache-put "cached-images" filename
(alist :mime-type mime-type
) :value-type
:json
))
137 (remhash uri
*image-threads
*))))
138 :name
"image processing thread"))))))
139 (sb-thread:join-thread thread
))))
140 (let ((cached-data (cache-get "dynamic-content-images" key
:key-type
:byte-vector
:value-type
:json
)))
141 (if (and cached-data
(eql (cdr (assoc :version cached-data
)) *current-version
*))
143 (make-image-thread))))))
145 (defun dynamic-image (uri container-tag-name container-attributes
)
146 (declare (simple-string uri container-tag-name
))
148 (log-and-ignore-errors
149 (sb-sys:with-deadline
(:seconds
5)
150 (image-uri-data uri
)))))
151 (alist-bind ((proxy-uri (or null simple-string
))
152 (inverted-uri (or null simple-string
))
153 (width (or null fixnum
))
154 (height (or null fixnum
)))
156 (with-html-stream-output (:stream stream
)
157 (write-char #\
< stream
)
158 (write-string container-tag-name stream
)
159 (with-delimited-writer (stream delimit
:begin
" " :between
" ")
160 (when (and width height
)
162 (format stream
"style='--aspect-ratio: ~F; max-width: ~Dpx'"
166 (iter (for (attr . value
) in container-attributes
)
167 (declare (type (or null simple-string
) attr value
))
168 (unless (string-equal attr
"style")
170 (write-string attr stream
)
171 (write-string "='" stream
)
172 (plump:encode-entities value stream
)
173 (write-char #\' stream
))))
174 (let ((encoded-uri (plump:encode-entities uri
)))
176 (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'>"
179 (or proxy-uri encoded-uri
)
181 (format stream
"><img src='~A' data-original-src='~A'>"
182 (or proxy-uri encoded-uri
) encoded-uri
)))
183 (format stream
"</~A>" container-tag-name
)))))