duper.scm (2591B)
1 (define-module (duper) 2 #:use-module (haunt post) 3 4 #:use-module (ice-9 match) 5 #:use-module (ice-9 textual-ports) 6 #:use-module (sxml match) 7 #:use-module (sxml simple) 8 9 #:use-module (srfi srfi-19) 10 11 #:re-export (xml->sxml)) 12 13 (define (svg-uns sxml) 14 (sxml-match sxml 15 ((ns:svg (@ . ,a) . ,r) `(svg (@ ,@a) ,(map svg-uns r))) 16 ((ns:defs (@ . ,a) . ,r) `(defs (@ ,@a) ,(map svg-uns r))) 17 ((ns:style (@ . ,a) . ,r) `(style (@ ,@a) ,(map svg-uns r))) 18 ((ns:g (@ . ,a) . ,r) `(g (@ ,@a) ,(map svg-uns r))) 19 ((ns:path (@ . ,a) . ,r) `(path (@ ,@a) ,(map svg-uns r))) 20 (,default default))) 21 22 (define (load-svg path) 23 (let* ((ns "http://www.w3.org/2000/svg") 24 (sxml (with-input-from-file path 25 (lambda () (xml->sxml #:trim-whitespace? #t 26 #:namespaces 27 `((ns . ,ns))))))) 28 (svg-uns (caddr sxml)))) 29 30 (define-public (post-date->string post) 31 (date->string (post-date post)"~Y-~m-~d")) 32 33 (define-public (make-slug post) 34 (string-append/shared 35 (post-date->string post) "-" (post-slug-v2 post))) 36 37 (begin 38 (define* (duper-photos names ext #:optional (thumbnail-prefix "-thumb")) 39 `(ul (@ (class "media-container")) 40 ,@(map (lambda (name) 41 (let ((href (string-append name ext)) 42 (src (string-append name thumbnail-prefix ext))) 43 `(li (a (@ (href ,href)) 44 (img (@ (src ,src))))))) 45 names))) 46 (export duper-photos)) 47 48 (define-public (duper-gallery-template post medias) 49 (let ((media-src (lambda (media) 50 (sxml-match media 51 ((img (@ (src ,src))) src))))) 52 `((h2 (a (@ (href ,(string-append "/blog/" (make-slug post) ".html"))) 53 ,(post-title post))) 54 (ul (@ (class "media-container")) 55 ,@(map (lambda (media) 56 `(li (a (@ (href ,(media-src media))) 57 ,media))) 58 medias))))) 59 60 (define-public (urls xs) 61 `(ul ,@(map (match-lambda 62 ((to . desc) `(li (a (@ (href ,to)) ,desc)))) 63 xs))) 64 65 (define-public (url to desc) 66 (urls `((,to . ,desc)))) 67 68 (define-public make-date* 69 (@ (haunt skribe utils) make-date*)) 70 71 (define-public mail 72 "contact@duché-perché.fr") 73 74 (define-public sxml-logo 75 (sxml-match (load-svg "assets/logo.svg") 76 ((svg (@ . ,a) . ,r) `(svg (@ (class "logo") ,@a) ,r)))) 77 78 (define-public sxml-blason 79 (sxml-match (load-svg "assets/blason.svg") 80 ((svg (@ . ,a) . ,r) `(svg (@ (class "blason") ,@a) ,r)))) 81 82 (define-public url-geo 83 (url "https://osm.org/go/0AyeOPWT1-?m=" 84 "afficher sur la carte")) 85 86 (define-public url-mailto 87 (url (string-append "mailto:" mail) 88 mail)) 89 90 91 ;;; AUTHORS 92 93 (define-public leirda "Adriel Dumas--Jondeau")