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 (defparameter *wrapper-program
* #+linux
'("choom" "-n" "1000" "--") #-linux nil
)
9 (sb-ext:defglobal
*image-convert-semaphore
* (sb-thread:make-semaphore
:count
2))
11 (defmacro run-program
(program-args &rest lisp-args
)
12 `(uiop:run-program
(append *wrapper-program
* (list ,@program-args
)) ,@lisp-args
))
14 (defun mime-type (image-filename)
15 (run-program ("file" "--brief" "--mime-type" image-filename
) :output
(lambda (stream) (read-line stream
))))
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
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
45 (* 3 (ldb (byte 16 48) color-value
))
47 ((= (length color-string
) 12) ; 16-bit rgb
49 (+ (ldb (byte 16 0) color-value
)
50 (ldb (byte 16 16) color-value
)
51 (ldb (byte 16 32) color-value
))
54 (defun image-invertible (image-filename)
55 (let ((histogram-list nil
)
57 (background-brightness 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
))
65 (multiple-value-bind (match? strings
) (ppcre:scan-to-strings
"^\\s*(\\d+):" line
:sharedp t
)
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
)
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
))))
80 (> (/ (float background-pixels
) (float total-pixels
)) 0.3333333)
81 (> (/ total-brightness total-pixels
) 0.5d0
)
82 (> background-brightness
(* 3 192))
84 (> (first histogram-list
) (* 10 tenth
)))))))
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
))))
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
)))))
96 (defun download-file-with-wayback-fallback (uri target
)
98 (download-file uri target
)
100 (let ((wayback-uri (lw2.legacy-archive
:wayback-unmodified-url uri
)))
102 (download-file wayback-uri target
)
105 (define-cache-database 'lw2.backend-modules
:backend-lmdb-cache
"dynamic-content-images" "cached-images")
107 (sb-ext:defglobal
*image-threads
* (make-hash-table :test
'equal
:synchronized t
))
108 (defparameter *current-version
* 4)
110 (defun filename-to-uri (filename)
111 (concatenate 'base-string
"/proxy-assets/" filename
))
113 (defun uri-to-pathname (uri)
114 (concatenate 'base-string
"www" uri
))
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
)
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
*
134 :inverted-uri inverted-uri
136 (alist :version
*current-version
*
140 :mime-type
(mime-type pathname
)
143 (defun image-uri-data (uri)
144 (let ((key (hash-string uri
)))
145 (labels ((make-image-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
152 (log-and-ignore-errors ; FIXME figure out how to handle errors here
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
))
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
))
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
))))
171 (make-image-thread)))))))
173 (defun dynamic-image (uri container-tag-name container-attributes img-attributes
)
174 (declare (simple-string uri container-tag-name
))
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
)))
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
)
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'"
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"))))
211 (format stream
"<picture class='invertible' data-original-src='~A'><source srcset='~A' media='~A'><img src='~A' loading='lazy'"
214 (lw2.resources
:inverted-media-query
)
215 (or proxy-uri encoded-uri
))
216 (finish-tag img-attributes predicate stream
)
217 (format stream
"</picture>"))
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
))))))