Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Resize images asynchronously #1

Open
wants to merge 2 commits into
base: srcset
Choose a base branch
from
Open

Resize images asynchronously #1

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
f99986e
Spawn Imagemagick processes asynchronously
gerdint Oct 30, 2016
b6c8f11
Add process pool to lower memory usage
gerdint Nov 7, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions frog/enhance-body.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -166,6 +166,7 @@
(sizes "(max-width: 2px) 100vw, 2px")
(alt "")))
(p ((class "caption")) "some text"))))
(wait-resize-images)
(clean-resized-images))))

(define (syntax-highlight xs)
Expand Down
4 changes: 3 additions & 1 deletion frog/frog.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -318,7 +318,9 @@
(map full-uri
(append (map post-uri-path (filter linked-post?
(hash-values new-posts)))
non-post-pages))))))
non-post-pages)))))
(when (current-responsive-images?)
(wait-resize-images)))

;;----------------------------------------------------------------------------

Expand Down
128 changes: 104 additions & 24 deletions frog/responsive-images.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,49 +10,128 @@
racket/port
racket/system
racket/string
(only-in racket/future processor-count)
(only-in racket/match match-let-values)
rackjure/threading
rackjure/str
"params.rkt"
"util.rkt"
"verbosity.rkt"
"paths.rkt")

(provide make-responsive clean-resized-images magick-available?)
(provide make-responsive wait-resize-images clean-resized-images magick-available?)

(module+ test
(require rackunit))

(define *max-jobs* (* 1.5 (processor-count))) ; Arbitrary heuristic

;; Depend on ImageMagick
(define identify (find-executable-path "identify"))
(define mogrify (find-executable-path "mogrify"))

(define magick-available? (and identify mogrify))

(module+ test
(require rackunit))

(define (image-width path)
(~> (with-output-to-string
(λ ()
(system* identify "-format" "%w" path)))
string-trim
string->number))
(if (file-exists? path)
(~> (with-output-to-string
(λ ()
(system* identify "-format" "%w" path)))
string-trim
string->number)
(raise-argument-error 'image-width "Existing file" path)))

(module+ test
(when magick-available?
(parameterize ([top example])
(parameterize ([top example]
[current-verbosity 99])
(check-eq? (image-width (build-path (www/img-path) "800px-image.gif")) 800))))

(define/contract (resize-image in new-width out-path)
(path? number? path? . -> . boolean?)
(prn1 "Shrinking ~a to ~a pixels... " (abs->rel/www in) new-width)
(struct job (input out-path width) #:transparent)

(define (magick-args j)
;; Imagemagick options from
;; https://www.smashingmagazine.com/2015/06/efficient-image-resizing-with-imagemagick/
(apply system* mogrify
`("-filter" "Triangle" "-define" "filter:support=2"
"-unsharp" "0.25x0.08+8.3+0.045" "-dither" "None" "-posterize" "136"
"-quality" "82" "-define" "jpeg:fancy-upsampling=off"
"-define" "png:compression-filter=5" "-define" "png:compression-level=9"
"-define" "png:compression-strategy=1" "-define" "png:exclude-chunk=all"
"-interlace" "none" "-colorspace" "sRGB"
"-thumbnail" ,(number->string new-width)
"-path" ,out-path ,in)))
;; https://www.smashingmagazine.com/2015/06/efficient-image-resizing-with-
;; imagemagick/
`("-filter" "Triangle"
"-define" "filter:support=2"
"-unsharp" "0.25x0.08+8.3+0.045"
"-dither" "None"
"-posterize" "136"
"-quality" "82"
"-define" "jpeg:fancy-upsampling=off"
"-define" "png:compression-filter=5"
"-define" "png:compression-level=9"
"-define" "png:compression-strategy=1"
"-define" "png:exclude-chunk=all"
"-interlace" "none"
"-colorspace" "sRGB"
"-thumbnail" ,(number->string (job-width j))
"-path" ,(job-out-path j)
,(job-input j)))

(define master-worker
(thread
(λ ()
(define (start-job j)
(match-let-values ([(proc _ _ _) (apply subprocess
(current-output-port)
(current-input-port)
(current-error-port)
mogrify (magick-args j))])
proc))
;; N.B: Config parameters set in the main thread are reset here
;; so make sure we do not rely on them. In particular prn1 and
;; prn2 will not output anything.
(let ([finish #f]
[mailbox (thread-receive-evt)])
(let loop ([queue '()]
[procs '()])
(let ([res (apply sync mailbox procs)])
(cond
[(subprocess? res) ; Process terminated?
(let ([status (subprocess-status res)])
(unless (zero? status)
(eprintf "~a terminated with non-zero exit code: ~a\n"
mogrify status)))
(let ([next-procs (remq res procs)])
(if (not (empty? queue))
(begin
(let ([proc (start-job (first queue))])
(loop (rest queue) (cons proc next-procs))))
(unless (and (empty? next-procs) finish)
(loop queue next-procs))))]
[(eq? res mailbox)
(let ([msg (thread-receive)])
(cond
[(eq? msg 'finish)
(set! finish #t)
(unless (empty? procs)
(displayln "Waiting for ImageMagick processes to finish.")
(loop queue procs))]
[(job? msg)
(let ([j msg])
(if (>= (length procs) *max-jobs*)
(loop (append queue (list j)) procs) ; FIFO queue semantics
(let ([proc (start-job j)])
(loop queue (cons proc procs)))))]))]
[else
(error "Unknown sync result: " res)
(loop queue procs)])))))))

(define/contract (resize-image input new-width out-path)
(path? number? path? . -> . void?)
(prn1 "Shrinking ~a to ~a pixels asynchronously." (abs->rel/www input) new-width)
;; One problem with the async approach is that if Frog is killed before
;; subprocesses are finished they will not be triggered again if Frog is
;; invoked again and the source post has not been touched. Ideally we would
;; trap SIGINT and write out unfinished work to disk, or at least
;; detect that work was finished prematurely and clean and restart everything.
(thread-send master-worker (job input out-path new-width)))

(define (wait-resize-images)
(thread-send master-worker 'finish)
(thread-wait master-worker))

(module+ test
(when magick-available?
Expand All @@ -63,6 +142,7 @@
(test-eq? "resize"
(begin
(resize-image (build-path (www/img-path) "600px-image.gif") 10 tmp)
(wait-resize-images)
(image-width output))
10)
(delete-file* output))))
Expand Down Expand Up @@ -106,7 +186,7 @@
orig))))
(define srcset-string
(string-join
(for/list ([srcdef srcset])
(for/list ([srcdef srcset])
(format "~a ~aw" (~> (car srcdef)
abs->rel/www string->path
uri-encode-path path->string)
Expand Down