Resize images asynchronously

.gitignore

@@ -13,6 +13,7 @@ example/tags/
 example/2*
 example/A-Non-Post-Scribble-Page*
 example/img/posts/
+example/img/resized/
 
 # Emacs / DrRacket backups & auto save files
 *~

example/.frogrc

@@ -1,4 +1,6 @@
-# Required: Should NOT end in trailing slash.
+# -*- conf -*-
+
+# Required: Should NOT end in trailing slash.  
 scheme/host = http://www.example.com
 
 # A path prepended to URIs, including those specified here in .frogrc
@@ -117,3 +119,20 @@ python-executable = python
 pygments-linenos? = true
 ## CSS class for the wrapping <div> tag (default: 'highlight').
 pygments-cssclass = source
+
+# Serve responsive images.
+#
+# Make use of the img srcset attribute to serve images inside elements
+# of class "figure" (such as image referenced from Markdown) at three
+# different sizes. Depends on having ImageMagick installed.
+responsive-images? = true
+
+# Subdirectory of where to put resized images. Defaults to "resized".
+# The directory will be created but the parent "img" directory must exist.
+#image-output-dir = resized
+
+# Value of the img "sizes" attribute.
+# Defaults to "(max-width: <image width>px) 100vw, <image width>px"
+# If your blog's main column is narrower than the page width on wide
+# clients you may want to have something like:
+#image-sizes-attr = (max-width: <columnn width>) 100vw, <column width>

example/_src/posts/2013-06-19-a-scribble-post.scrbl

@@ -110,3 +110,9 @@ function foo() {
   return 7;
 }
 }
+
+@subsection[#:style 'unnumbered]{B SubSection}
+
+A responsive big black image:
+
+@image["img/800px-image.gif" #:style "img-responsive"]

example/_src/posts/2016-08-12-a-blog-post-featuring-a-big-image.md

@@ -0,0 +1,7 @@
+    Title: A blog post featuring a big image
+    Date: 2016-08-12T02:43:56
+    Tags: images, responsive
+
+The below `img` tag should come with _srcset_ and _sizes_ definitions:
+
+![Image title](/img/800px-image.gif)

frog/enhance-body.rkt

@@ -13,18 +13,162 @@
          "html.rkt"
          "params.rkt"
          "pygments.rkt"
-         "xexpr-map.rkt")
+         "xexpr-map.rkt"
+         "verbosity.rkt"
+         "paths.rkt"
+         "responsive-images.rkt")
 
 (provide enhance-body)
 
 (module+ test (require rackunit))
 
 (define (enhance-body xs)
   (~> xs
+      responsive-images
       syntax-highlight
       add-racket-doc-links
       auto-embed-tweets))
 
+(define responsive-images
+  (let ([magick-notice-displayed? #f])
+    (λ (xs)
+      (define (remote-host url)
+        (url-host (string->url url)))
+      (define (do-it xs)
+        (for/list ([x xs])
+          (match x
+            [`(div ([class ,classes])
+                   (img ,(list-no-order `[src ,url] attrs ...))
+                   ,content ...)
+             #:when (and (regexp-match #px"\\bfigure\\b" classes)
+                         (not (remote-host url)))
+             (let ([sizes-attr (assq 'sizes attrs)])
+               `(div ([class ,classes])
+                     (img ([class "img-responsive"] ; Add Bootstrap class
+                           ,@(make-responsive url (cond [sizes-attr => second]
+                                                        [#t #f]))
+                           ,@(if sizes-attr
+                                 (remove sizes-attr attrs)
+                                 attrs)))
+                     ,@content))
+             ]
+            ;; xexpr-map?
+            [`(p () (img ,(list-no-order `[src ,url] `[class ,classes] attrs ...)))
+             #:when (and (regexp-match #px"\\bimg-responsive\\b" classes)
+                         (not (remote-host url)))
+             `(p () (img ([class ,classes]
+                          ,@(make-responsive url #f) ; TODO honor custom sizes?
+                          ,@attrs)))]
+            [x x])))
+      (cond [(current-responsive-images?)
+             (if magick-available?
+                 (do-it xs)
+                 (begin
+                   (unless magick-notice-displayed?
+                     (prn1 "ImageMagick not found. Omitting img srcset attributes.")
+                     (set! magick-notice-displayed? #t))
+                   xs))]
+            [else xs]))))
+
+
+(module+ test
+  (parameterize ([top example]
+                 [current-responsive-images? #t]
+                 [current-image-output-dir "resized"]
+                 [current-image-sizes-attr #f]
+                 [current-image-sizes '(320 600 1200)]
+                 [current-image-default-size 600]
+                 [current-verbosity 0])
+    (test-equal? "Remote images"
+                 (responsive-images
+                  '((div ((class "figure")) (img ((src "//somehost.com/img/file.jpg"))))))
+                 ;; Don't resize remote images. Or should we fetch it and resize it?
+                 '((div ((class "figure")) (img ((src "//somehost.com/img/file.jpg"))))))
+    (when magick-available?
+      (test-equal? "Element-specific custom sizes attribute"
+                   (responsive-images
+                    '((div ([class "figure"])
+                           (img ([src "/img/1x1.gif"]
+                                 [sizes "some-custom-size-spec"])))))
+                   '((div ((class "figure"))
+                          (img ([class "img-responsive"]
+                                [src "/img/1x1.gif"]
+                                [srcset "/img/1x1.gif 2w"]
+                                [sizes "some-custom-size-spec"])))))
+      (test-equal? "Img with img-responsive class inside p tag"
+                   (responsive-images
+                    '((p () (img ([src "/img/1x1.gif"]
+                                  [alt ""]
+                                  [class "img-responsive among-others"]
+                                  [foo-attr "bar"])))))
+                   '((p () (img ([class "img-responsive among-others"]
+                                 [src "/img/1x1.gif"]
+                                 [srcset "/img/1x1.gif 2w"]
+                                 [sizes "(max-width: 2px) 100vw, 2px"]
+                                 [alt ""]
+                                 [foo-attr "bar"])))))
+      (test-equal? "Image bigger than maximum size"
+                   (responsive-images
+                    '((div ([class "figure pull-right"])
+                           (img ([src "/img/1300px-image.gif"] (alt "")))
+                           (p ([class "caption"]) "some text"))))
+                   `((div ((class "figure pull-right"))
+                          (img ([class "img-responsive"]
+                                [src "/img/resized/600/1300px-image.gif"]
+                                [srcset
+                                 ,(string-join
+                                   (for/list ([s (current-image-sizes)])
+                                     (format "/img/resized/~a/1300px-image.gif ~aw" s s))
+                                   ", ")]
+                                [sizes "(max-width: 1300px) 100vw, 1300px"]
+                                (alt "")))
+                          (p ((class "caption")) "some text"))))
+      (test-equal? "Image smaller than biggest size but bigger than smallest size"
+                   (responsive-images
+                    '((div ((class "figure"))
+                           (img ((src "/img/800px-image.gif") (alt "")))
+                           (p ((class "caption")) "some text"))))
+                   `((div ((class "figure"))
+                          (img ([class "img-responsive"]
+                                (src ,(format "/img/resized/~a/800px-image.gif"
+                                              (current-image-default-size)))
+                                (srcset
+                                 ,(string-append
+                                   (string-join
+                                    (for/list ([s '(320 600)])
+                                      (format "/img/resized/~a/800px-image.gif ~aw" s s))
+                                    ", ")
+                                  ", /img/800px-image.gif 800w"))
+                                (sizes "(max-width: 800px) 100vw, 800px")
+                                (alt "")))
+                          (p ((class "caption")) "some text"))))
+      (test-equal? "Image equal to a one of the sizes specified"
+                   (responsive-images
+                    '((div ((class "figure"))
+                           (img ((src "/img/600px-image.gif") (alt "")))
+                           (p ((class "caption")) "some text"))))
+                   '((div ((class "figure"))
+                          (img ([class "img-responsive"]
+                                (src "/img/600px-image.gif")
+                                (srcset "/img/resized/320/600px-image.gif 320w, /img/600px-image.gif 600w")
+                                (sizes "(max-width: 600px) 100vw, 600px")
+                                (alt "")))
+                          (p ((class "caption")) "some text"))))
+      (test-equal? "Image smaller than smallest size"
+                   (responsive-images
+                    '((div ((class "figure"))
+                           (img ((src "/img/1x1.gif") (alt ""))) ; Tiny image
+                           (p ((class "caption")) "some text"))))
+                   '((div ((class "figure"))
+                          (img ([class "img-responsive"]
+                                (src "/img/1x1.gif")
+                                (srcset "/img/1x1.gif 2w")
+                                (sizes "(max-width: 2px) 100vw, 2px")
+                                (alt "")))
+                          (p ((class "caption")) "some text"))))
+      (wait-resize-images)
+      (clean-resized-images))))
+
 (define (syntax-highlight xs)
   (for/list ([x xs])
     (match x
@@ -131,6 +275,7 @@
                                  "&hide_thread=true"))))
          (define js (call/input-url oembed-url get-pure-port read-json))
          (define html ('html js))
+
          (cond [html (~>> (with-input-from-string html read-html-as-xexprs)
                           (append '(div ([class "embed-tweet"]))))]
                [else x])]

frog/frog.rkt

@@ -25,7 +25,8 @@
          "tags.rkt"
          "util.rkt"
          "verbosity.rkt"
-         "watch-dir.rkt")
+         "watch-dir.rkt"
+         "responsive-images.rkt")
 (provide serve)
 
 (module+ test
@@ -64,7 +65,12 @@
                                [output-dir "."]
                                [python-executable "python"]
                                [pygments-linenos? #t]
-                               [pygments-cssclass "source"])
+                               [pygments-cssclass "source"]
+                               [responsive-images? #f]
+                               [image-output-dir "resized"]
+                               [image-sizes-attr #f]
+                               [image-sizes '(320 768 1024)]
+                               [image-default-size 768])
       (define watch? #f)
       (define port 3000)
       (define root
@@ -312,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)))
 
 ;;----------------------------------------------------------------------------
 
@@ -351,7 +359,8 @@
   (clean-post-output-files)
   (clean-non-post-output-files)
   (clean-tag-output-files)
-  (clean-serialized-posts))
+  (clean-serialized-posts)
+  (clean-resized-images))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

frog/params.rkt

@@ -40,3 +40,8 @@
 (define current-python-executable (make-parameter "python"))
 (define current-pygments-linenos? (make-parameter #t))
 (define current-pygments-cssclass (make-parameter "source"))
+(define current-responsive-images? (make-parameter #f))
+(define current-image-output-dir (make-parameter "resized"))
+(define current-image-sizes-attr (make-parameter #f))
+(define current-image-sizes (make-parameter '(320 768 1024)))
+(define current-image-default-size (make-parameter 768))