From 6d2d0321bcb716a51733f640a8ca8460214f7dd5 Mon Sep 17 00:00:00 2001 From: Tobias Gerdin Date: Sun, 28 Aug 2016 20:44:54 +0200 Subject: [PATCH] Add support for responsive images MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add the srcset and sizes attribute to img tags whose class is 'img-responsive' or whose parent element class is 'figure' (default Markdown behavior). Each image is made avaiable in three version (roughly intended to match a mobile, 1x desktop and 2x/hi-dpi desktop clients). Images are cached in a configurable directory. In practice the above means that images in Markdown posts are made responsive by default, and for Scribble posts the "img-responsive" class can be added like so: @image["img/some-image.gif" #:style "img-responsive"] See example/.frogrc for documentation on added parameters. There are also two additional parameters controlling resized image sizes and the default size, see bottom of frog/params.rkt. Depends on ImageMagick® for size identification and scaling. --- .gitignore | 1 + example/.frogrc | 21 ++- .../posts/2013-06-19-a-scribble-post.scrbl | 6 + ...08-12-a-blog-post-featuring-a-big-image.md | 7 + example/img/1300px-image.gif | Bin 0 -> 2328 bytes example/img/600px-image.gif | Bin 0 -> 985 bytes example/img/800px-image.gif | Bin 0 -> 1353 bytes frog/enhance-body.rkt | 146 +++++++++++++++++- frog/frog.rkt | 13 +- frog/params.rkt | 5 + frog/responsive-images.rkt | 133 ++++++++++++++++ frog/util.rkt | 13 +- 12 files changed, 339 insertions(+), 6 deletions(-) create mode 100644 example/_src/posts/2016-08-12-a-blog-post-featuring-a-big-image.md create mode 100644 example/img/1300px-image.gif create mode 100644 example/img/600px-image.gif create mode 100644 example/img/800px-image.gif create mode 100644 frog/responsive-images.rkt diff --git a/.gitignore b/.gitignore index c146d02c..fec4707f 100644 --- a/.gitignore +++ b/.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 *~ diff --git a/example/.frogrc b/example/.frogrc index 98a12f77..cea22570 100644 --- a/example/.frogrc +++ b/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
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: px) 100vw, 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: ) 100vw, diff --git a/example/_src/posts/2013-06-19-a-scribble-post.scrbl b/example/_src/posts/2013-06-19-a-scribble-post.scrbl index 43ef2eff..0b4dab97 100644 --- a/example/_src/posts/2013-06-19-a-scribble-post.scrbl +++ b/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"] diff --git a/example/_src/posts/2016-08-12-a-blog-post-featuring-a-big-image.md b/example/_src/posts/2016-08-12-a-blog-post-featuring-a-big-image.md new file mode 100644 index 00000000..522c446c --- /dev/null +++ b/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) diff --git a/example/img/1300px-image.gif b/example/img/1300px-image.gif new file mode 100644 index 0000000000000000000000000000000000000000..0be15ae687d7380a866f91ca8115b9919539b932 GIT binary patch literal 2328 zcmXYmc~sMf0f1dcx7_JE*0oAW+p!)H5^JedK+<)tg@B~%T-Pck9;lc*A$I~%i<NVt!j9N~sU5jm2OC?X;tQAE^`Ln-wDO!m6B?~m_&?|omTeYt7#?#NdoUwyph z|GfJm;(vwx)xVxKuY?LU4GurLs?;(Gw#@XbppVU_o|#wFdhKli_~2s3&8Mmd%dTf3 zGy-QQ+WQ^9yCB{-&>O1*vg7Sn7JIb}u|z zwT97eez+<1yIi6CTz$vT#KY&1w?5jO_WePT;(SBr@U2HLplf3ji90A_pjg*spY$%n z*2N{I@1#n=5`DL0YGDN)g-y=LqDhsdh92j%Zx!)&{FZG$(DPLnjJ+eb{V$QxxRlIn zMuED_WOdC1LMRNLKq50`8m-yp_5{P|_2m~2N5I!6%hy-*9Yw55ltMnP>{mp_?dXwz zTs06AsecPPR67cCo4A8*iU13c1fY1)H=^6P$zp7pVYZ7Bukc8p$YX@E4G4b zw*UzZqcs^NiTSWkbz=?N^*efjPxa%*tZwm3*ha%dQ;wr}3%JoZ*-D%0%7=eun(pK- zO!k7GnP+;XE6Xq8n;P$2Duk~~QEqCQy`o%~RDjsrJU3hvx6`WJ+%i8>nj{G!5-ks} zRi~Gvs1jSfHw-(w3y?`|zFQXRlvS0~9=P2jSqUMNJ09Qd2iFnQ$(@V$oh3;!)RwNL zM`QY(HuaY7r~c_~Nf?#V^Zd!2qlBPI>0SQCH`Oge6RfK*mKLUL8iFnKay7KF5=QSj z^a?6<*Wuqq%Xb}t;f8koh)RL%E_^*Rb@$OXvgNyvtz``DJ|0~F*&}~Xow`Tyewlm^ z5NjIR1LCZZy~+)))V->WGxELa#K6#AO-cxobK(nBTF%KYqZK))h`8aLpE6UR`-;BF zOxt(*+ib;Lj)yl!*hw z2ebttXm0rt6fw8rSTvAZ3E=FxRq7Pj!Rk|)#Dg_wvVnuO#SHtwy0QWorM^;4q%_o) z0Ti9iWT)s&Rv6XL>>^T)Z8HGX)D^H(&DIc%*4T$ir!@^kgCSb89p|96xKiMB%V=gg zy>&brq_<5n9Q5{?0yv{%R-Ml1oG$|zU0#!e(H*eDnLUfHbY}0<8IWmR4mg;$PzcVt z_zF6Mb?J8)C94mHcd{;{2ncrn>!b|!l{d&r_P|=ElRX$MLvV)P(`0al-`6TR_E@u% z)jJ%PJ9%Y^@G3d;5r-TvQt6!kEaj$)eQE^9!_z~{)OahWO_6=zp@5Z-e z6>oe8bA)#@TZZIM?9puF-`cNL@h2(f5&jgzh7?S5+}i}V`5u*EMjRXwcnZQu;hiJs zOyS*Q7`1Q~z`KO^)C81h?i4AMDY}1#tQO4|GhLzwWipibVWlQh{HRu|7JGGOmw3Ts zLrHwi?o5fl&7+nCx`HlA&>BWbANQe2(kBBLjdanDcT0bE5zzTdqa;%PFXLoQ{?kdO zJO9~?3|;ViRzoUyF|XAWEPKuFf|Y;`En8i5lVmTSdNi`oa?mXchr;NKYhbKH5!mwI zpyd}MVp)d~wDR9#AeSIS){#g<`Kx&OB?N`_W0bG__XJ4aYXGY-23r9o$@?O8tfN?3 z1)L1I{HC3CEWuELWXdl`d0EGkeHCaKr2iclTfP-r`3H@>KPHx~$e>mJQ46{9A(0Ji zH&llHWR_pSQrKXYukz0}$iRAlt<1qzz2%kG8m(%b2Qs+H&Q@~`Rc{C7gUMdD zM(V4=gdszp!#F1jvDNRQ6+>HNIVY90>c3#1!>L5hsUk!5U-63J3<~F`QeX841gQOM zfKybBt@((guy5CKP8(=7ab&3DJ3Hr$#ZVK^R5-G{oU=W?8oUhZ+y%=!*N?6JSfg;} z#O9rM(rQ1^LPv6mdBtOf+E2}j5gH}0WZGBznGNb<0ePi!*t*Sbg^R1pyWpeMC3&E3 zp*^o`$xyc?sBlZYdD>N99U%<8dI-iXkBG1T8ydJ;7|X3d(Chym!oaS{iQLLaWBoty zz%?a>TNUN6|B3(`Jppj5W8xdqNWf^3j$4DJH>8tc*U#CxwF$Lsh3-q>~A2+ zU}NPlUj5d1-9I(JSamF~A%m{_mlk%Tp2*W}H|qXv25uNAJbjj5_a7Tn*=ua z%ws^%GZ$|bxxtwwouJo8H%mNl&vU!Lx@0ux2SLxOS72N9n`L46oi%Xb#Ry#EVYKp2 zM4a#vg3n0p5<8rq6$KB-a8#l(q*GZ@W3X%Y87Oc&X=o0?CX zmG`k!ks~Y6eAb4TUk{3$Ik=YdZsmM}UNk~uw3K)d4>mbOF0QHNLQwf2c|qis23oXX z#IuK=!^Kw%ah3|S>fzQn@iisGQiVZ2N=+A!7MUzHc-5l}s`z?oz*0v*dcOw6W7W9U z29nCVT`#_2V6^JV$c675;&F?q)yPyWWG#qq_5@nZGNf-8Tr$y*YirV|d^vHFTTVt> zix%n6O_xlLnc7;-DnE@XnVJr?wcC&Z7ATpX!?kz1RROMEa@)sf@Ae>rLWg8#$<*E( zR0X9A63=R&-4;eZJ_MKEiNJSULaQGa#!2rYm>rifs3-Dt>1?FA;|gB=L`jw2iwbrO j5>SgLK-YS={|^`_I7nD%c!-#&xX9S( z_y`#(IZ0V*d5M{+xyjk-`3V{-I!an`U)E>J4;(@dyAW^yUW|_`wJW_ zJWO0{e2ko|yv*F}{0to}JxyJ0eT|*1z0KY2{S6*2K2Bb4evY25zRuq6{th26KTlt8 ze~+K9zt7+A{|_*rz<~q{8a#+Fp~8g>8#;UlF`~qY6f0W1h%uwa{*4?vdi)47q{xvZ zOPV~1GNsCuEL*yK2{We5nKWzKyoocX&Ye7a`uqtrsL-KAiyA$OG^x_1Oq)7=3N@kh3pcLZxpeE=y^A-m-o1SL`uz(y zu;9Uj3mZO+II-fzj2kC~%Rzm7e-_U+ue zd;bnTy!i3t%bP!sKE3+&?AyD44?n*A`Sk1CzmGq^{{8&^`}_Y7V1NP+NML~m9*AIq z3NFZCgAP6jVT2M+NMVH*UWj3a8g9s8haP?iVu&J+NMea5o`_m9*eVVvdS*YY_rZj3vIO0PD^dI)?SNk zw%TsXZMWWj3vRgLj!SO2=AMggy6UdWZoBTj3vayg&P#8-_TGzczWVOVZ@>Qj3vj>! z4@_{u1|N)Y!U`|UaKjEi3~|H~PfT&e7GI2U#u{(TamOBi406aKk4$pOCZCLQ$||qS za?38i40Fsf&rEa8Hs6eM&N}bRbI(5i40O;!4^4E@MjwrI(n>GQbkj~h4RzE~Pfaxk H1poj$zlrv! literal 0 HcmV?d00001 diff --git a/example/img/800px-image.gif b/example/img/800px-image.gif new file mode 100644 index 0000000000000000000000000000000000000000..d0941388cb5c861a7e39d33363dff86bf51e86d7 GIT binary patch literal 1353 zcmV-P1-AM}Nk%w1VITt_1MmO<00000001HR1ONa4001li0000W10Vwc0{(=LsmtvT zqnxzbi?iOm`wxcVNS5Y_rs~SJ?hD8AOxN~}=lag~{tpZahs2`sh)gP%%%<}RjY_A~ zs`ZM^YPa03_X`e-$K-YS={|^`_I7nD%c!-#&xX9S( z_y`#(IZ0V*d5M{+xyjk-`3V{-I!an`U)E>J4;(@dyAW^yUW|_`wJW_ zJWO0{e2ko|yv*F}{0to}JxyJ0eT|*1z0KY2{S6*2K2Bb4evY25zRuq6{th26KTlt8 ze~+K9zt7+A{|_*rz<~q{8a#+Fp~8g>8#;UlF`~qY6f0W1h%uwa{*4?vdi)47q{xvZ zOPV~1GNsCuEL*yK2{We5nKWzKyoocX&Ye7a`uqtrsL-KAiyA$OG^x_1Oq)7=3N@kh3pcLZxpeE=y^A-m-o1SL`uz(y zu;9Uj3mZO+II-fzj2kC~%Rzm7e-_U+ue zd;bnTy!i3t%bP!sKE3+&?AyD44?n*A`Sk1CzmGq^{{8&^`}_Y7V1NP+NML~m9*AIq z3NFZCgAP6jVT2M+NMVH*UWj3a8g9s8haP?iVu&J+NMea5o`_m9*h2LvdS*YY_rZj3vIO0PD^dI)?SNk zw%TsXZMWWj3vRgLj!SO2=AMggy6UdWZoBTj3vayg&P#8-_TGzczWVOVZ@>Qj3vj>! z4@_{u1|N)Y!U`|UaKjEi3~|H~PfT&e7GI2U#u{(TamOBi406aKk4$pOCZCLQ$||qS za?38i40Fsf&rEa8Hs6eM&N}bRbI(5i40O;!4^4E@MjwrI(n>GQbkj~h4RzE~Pfc~z zR$q;E)>?1Pb=O{h4R+XKk4<*jW}l6A+G?-OcH3^h4R_pf&rNsTcHfP6-g@uNci(>h z4S3*!4^DXDh98c2;)*ZMc;k*g4teB~PySAM<(6NLdFGmL&Uxpae-3)+qK{5`>878K zdg`jL&U)*vzYcrsvd>O??Y7^Jd+xgL&U^2^{|$`R1RGe){UK&wl&vzYl->^3P9y{r2CFfByRK z&wu~^{|~?b3UGh~ET91oh` 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")))) + (clean-resized-images)))) + (define (syntax-highlight xs) (for/list ([x xs]) (match x @@ -131,6 +274,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])] diff --git a/frog/frog.rkt b/frog/frog.rkt index 575d6941..aaf4f5a4 100644 --- a/frog/frog.rkt +++ b/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 @@ -351,7 +357,8 @@ (clean-post-output-files) (clean-non-post-output-files) (clean-tag-output-files) - (clean-serialized-posts)) + (clean-serialized-posts) + (clean-resized-images)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/frog/params.rkt b/frog/params.rkt index 8dcb0b8d..4ac63648 100644 --- a/frog/params.rkt +++ b/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)) diff --git a/frog/responsive-images.rkt b/frog/responsive-images.rkt new file mode 100644 index 00000000..b461a8e2 --- /dev/null +++ b/frog/responsive-images.rkt @@ -0,0 +1,133 @@ +#lang racket/base + +(require net/url + racket/contract/base + racket/contract/region + racket/file + racket/function + racket/list + racket/path + racket/port + racket/system + racket/string + rackjure/threading + "params.rkt" + "util.rkt" + "verbosity.rkt" + "paths.rkt") + +(provide make-responsive clean-resized-images magick-available?) + +;; 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)) + +(module+ test + (when magick-available? + (parameterize ([top example]) + (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) + ;; 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))) + +(module+ test + (when magick-available? + (parameterize ([top example] + [current-verbosity 0]) + (define tmp (find-system-path 'temp-dir)) + (define output (build-path tmp "600px-image.gif")) + (test-eq? "resize" + (begin + (resize-image (build-path (www/img-path) "600px-image.gif") 10 tmp) + (image-width output)) + 10) + (delete-file* output)))) + +(define/contract (get-images image-path) + (path? . -> . (values pair? (listof pair?))) + (define resized-dir (build-path* (www/img-path) (current-image-output-dir))) + (unless (directory-exists? resized-dir) + (make-directory resized-dir)) + (let* ([orig-size (image-width image-path)] + [sizes (filter ((curry >) orig-size) (current-image-sizes))]) + (values (cons image-path orig-size) + (append (for/list ([width sizes]) + (define output-dir (build-path* resized-dir + (number->string width))) + (define output (build-path output-dir + (file-name-from-path image-path))) + (unless (directory-exists? output-dir) + (make-directory output-dir)) + (unless (and (file-exists? output) + (< (file-or-directory-modify-seconds image-path) + (file-or-directory-modify-seconds output))) + ;; TODO Spawn asynchronously to enable utilizing more cores + (resize-image image-path width output-dir)) + (cons output width)) + (if (< (length sizes) (length (current-image-sizes))) + (list (cons image-path orig-size)) + '()))))) + +(define default-image-idx + (for/or ([v (current-image-sizes)] + [ix (in-naturals)]) + (and (= v (current-image-default-size)) ix))) + +(define/contract (make-responsive path sizes) + (path-string? (or/c string? #f) . -> . (listof pair?)) + (define image-path (build-path (www-path) (path->relative-path path))) + (define-values (orig srcset) (get-images image-path)) + (define src (abs->rel/www (car (if (> (length srcset) default-image-idx) + (list-ref srcset default-image-idx) + orig)))) + (define srcset-string + (string-join + (for/list ([srcdef srcset]) + (format "~a ~aw" (~> (car srcdef) + abs->rel/www string->path + uri-encode-path path->string) + (cdr srcdef))) + ", ")) + `([src ,src] + [srcset ,srcset-string] + ,(let ((orig-width (cdr orig))) + `[sizes ,(or sizes + (current-image-sizes-attr) + (format "(max-width: ~apx) 100vw, ~apx" + orig-width orig-width))]))) + +(define/contract (clean-resized-images) + (-> any) + (let ([out-dir (build-path* (www/img-path) (current-image-output-dir))]) + (when (directory-exists? out-dir) + (fold-files (λ (path type v) + (when (eq? type 'file) + (delete-file path) + (prn2 "Deleted ~a" (abs->rel/www path)))) + '() out-dir #f) + (for-each delete-directory (directory-list out-dir #:build? #t)) + (delete-directory out-dir)))) diff --git a/frog/util.rkt b/frog/util.rkt index 79b32461..3874b02e 100644 --- a/frog/util.rkt +++ b/frog/util.rkt @@ -4,8 +4,9 @@ racket/function racket/pretty rackjure/threading + (only-in net/uri-codec uri-path-segment-encode) (only-in markdown display-xexpr) - "verbosity.rkt") + "verbosity.rkt") (provide (all-defined-out)) @@ -68,3 +69,13 @@ (check-equal? (our-encode "Here's a question--how many hyphens???") "Here-s-a-question-how-many-hyphens")) +;; URI encode path to handle spaces and non-ascii characters +(define (uri-encode-path path) + ;; (absolute-path? . -> . path?) + (let ([ps (for/list ([ps (explode-path path)]) + (uri-path-segment-encode (path->string ps)))]) + (apply build-path "/" (cdr ps)))) + +(module+ test + (check-equal? (uri-encode-path (string->path "/dir/other dir/file name.ext")) + (string->path "/dir/other%20dir/file%20name.ext")))