summary refs log tree commit diff stats
path: root/boudin.scm
diff options
context:
space:
mode:
Diffstat (limited to 'boudin.scm')
-rwxr-xr-xboudin.scm286
1 files changed, 174 insertions, 112 deletions
diff --git a/boudin.scm b/boudin.scm index 082542b..ac22682 100755 --- a/boudin.scm +++ b/boudin.scm
@@ -16,6 +16,7 @@ boudin --- a little static site generator
16 (chicanery) 16 (chicanery)
17 (atom) 17 (atom)
18 (html-parser) 18 (html-parser)
19 (scss)
19 (srfi 37) 20 (srfi 37)
20 (srfi 152) 21 (srfi 152)
21 (sxpath)) 22 (sxpath))
@@ -97,31 +98,41 @@ boudin --- a little static site generator
97 (cons (string-append "<p>" (car pars) "</p>\n") 98 (cons (string-append "<p>" (car pars) "</p>\n")
98 acc)))))) 99 acc))))))
99 100
101(define (preprocess-text str) #| string -> string
102 Preprocess STR before passing it to `expand-string'.
103 For example, replace all '#' with '##' unless followed by a '{' or '('.
104 |#
105 (set! str (irregex-replace/all
106 '(or (: #\# #\# (look-ahead (or #\{ #\()))
107 (: #\# (look-ahead (~ #\{ #\()))
108 (: #\# eos))
109 str
110 "##"))
111 #; (set! str (irregex-replace/all ; XXX: missing end paren
112 '(: #\@ #\()
113 str
114 "#(sxml->html `("))
115 ;; Return transformed string
116 str)
117
100(define (expand-string str) #| string -> string 118(define (expand-string str) #| string -> string
101 Expand STR by passing it in a port to CHICKEN's #<# string interpolation. 119 Expand STR by passing it in a port to CHICKEN's #<# string interpolation.
102 Yes, this is as cursed as it sounds. 120 Yes, this is as cursed as it sounds.
103 121
104 To make it slightly less so, all # are duplicated to escape them, except for 122 To make it slightly less so, all # are duplicated to escape them, except for
105 those before ( and {. To escape /those/, double them. |# 123 those before ( and {. To escape /those/, double them. |#
106 (let* ((escaped (irregex-replace/all 124 (let* ((delim (let loop ((attempt (number->string (pseudo-random-real))))
107 '(or (: #\# #\# (look-ahead (or #\{ #\()))
108 (: #\# (look-ahead (~ #\{ #\()))
109 (: #\# eos))
110 str
111 "##"))
112 (delim (let loop ((attempt (number->string (pseudo-random-real))))
113 (if (irregex-search attempt str) 125 (if (irregex-search attempt str)
114 (loop (number->string (pseudo-random-real))) 126 (loop (number->string (pseudo-random-real)))
115 attempt))) 127 attempt)))
116 (template (make-concatenated-port 128 (template (make-concatenated-port
117 (open-input-string (string-append "#<#" delim "\n")) 129 (open-input-string (string-append "#<#" delim "\n"))
118 (open-input-string escaped) 130 (open-input-string (preprocess-text str))
119 (open-input-string (string-append "\n" delim "\n")))) 131 (open-input-string (string-append "\n" delim "\n"))))
120 (expanded (let ((x (open-output-string))) 132 (expanded (with-output-to-string
121 (display (eval (read template) 133 (lambda ()
122 (interaction-environment)) 134 (display (eval (read template)
123 x) 135 (interaction-environment)))))))
124 (get-output-string x))))
125 (irregex-replace/all '(: "#<unspecified>" 136 (irregex-replace/all '(: "#<unspecified>"
126 (* whitespace)) 137 (* whitespace))
127 expanded 138 expanded
@@ -149,7 +160,9 @@ boudin --- a little static site generator
149 (source-path page-source-path) 160 (source-path page-source-path)
150 (dest-path page-dest-path (setter page-dest-path))) 161 (dest-path page-dest-path (setter page-dest-path)))
151 162
152(define (%read-port port) 163(define (%read-port port) #| port -> string
164 Read PORT until it hits eof and return the results as a string.
165 |#
153 (let ((chunk-size 512)) 166 (let ((chunk-size 512))
154 (let loop ((next (read-string chunk-size port)) 167 (let loop ((next (read-string chunk-size port))
155 (blank? #f) 168 (blank? #f)
@@ -168,7 +181,10 @@ boudin --- a little static site generator
168 blank? 181 blank?
169 (cons next acc))))))) 182 (cons next acc)))))))
170 183
171(define read-port 184(define read-port #| (optional port) -> string
185 Read PORT completely, returning the results as a string.
186 PORT defaults to `current-input-port'.
187 |#
172 (case-lambda 188 (case-lambda
173 (() (%read-port (current-input-port))) 189 (() (%read-port (current-input-port)))
174 ((p) (%read-port p)))) 190 ((p) (%read-port p))))
@@ -184,7 +200,7 @@ boudin --- a little static site generator
184 source 200 source
185 dest 201 dest
186 file 202 file
187 (transform-path file (output-directory))))) 203 (transform-path file (build-directory)))))
188 204
189(define (extract-meta tree) #| sxml -> alist 205(define (extract-meta tree) #| sxml -> alist
190 Extract metadata from TREE's comments. 206 Extract metadata from TREE's comments.
@@ -271,85 +287,100 @@ boudin --- a little static site generator
271(define page-template 287(define page-template
272 (make-parameter 288 (make-parameter
273 (lambda (page) 289 (lambda (page)
274 (sxml->html 290 `(html (@ (lang "en"))
275 `(html (@ (lang "en")) 291 (head (title ,(page-meta-ref page "title" "[untitled]"))
276 (head (title ,(page-meta-ref page "title" "[untitled]"))) 292 (meta (@ (name "viewport")
277 (body ,(let ((title (page-meta-ref page "title" #f))) 293 (content "initial-scale=1.0"))))
278 (if title `(h1 ,title) "")) 294 (body ,(let ((title (page-meta-ref page "title" #f)))
279 ,@(cdr (page-dest page)))))))) 295 (if title `(h1 ,title) ""))
296 ,@(cdr (page-dest page)))))))
280 297
281(define index-template 298(define index-template
282 (make-parameter 299 (make-parameter
283 (lambda pages 300 (lambda pages
284 (sxml->html 301 `(html (@ (lang "en"))
285 `(html (@ (lang "en")) 302 (head (title ,(site-name)))
286 (head (title ,(site-name))) 303 (body (h1 ,(site-name))
287 (body (h1 ,(site-name)) 304 (ul
288 (ul 305 ,@(map (lambda (pg)
289 ,@(map (lambda (pg) 306 `(li (a (@ (href ,(page-url pg)))
290 `(li (a (@ (href ,(page-url pg))) 307 ,(page-meta-ref pg
291 ,(page-meta-ref pg 308 "title"
292 "title" 309 (pathname-file
293 (pathname-file 310 (page-source-path pg))))))
294 (page-source-path pg)))))) 311 pages)))))))
295 pages))))))))
296 312
297(define feed-template 313(define feed-template
298 (make-parameter 314 (make-parameter
299 (lambda pages 315 (lambda pages
300 (with-output-to-string 316 (make-atom-doc
301 (lambda () 317 (make-feed
302 (write-atom-doc 318 title: (make-title (site-name))
303 (make-atom-doc 319 id: (site-base-url)
304 (make-feed 320 updated: (publish-time) ; I don't like these semantics ..
305 title: (make-title (site-name)) 321 authors: (list (make-author name: (site-author)
306 id: (site-base-url) 322 uri: (site-base-url)))
307 updated: (publish-time) ; I don't like these semantics .. 323 links: (list (make-link type: 'html
308 authors: (list (make-author name: (site-author) 324 uri-language: "en"
309 uri: (site-base-url))) 325 uri: (site-base-url))
310 links: (list (make-link type: 'html 326 (make-link relation: "self"
311 uri-language: "en" 327 type: "application/atom+xml"
312 uri: (site-base-url)) 328 uri: (make-pathname
313 (make-link relation: "self" 329 (site-base-url) "feed" "xml")))
314 type: "application/atom+xml" 330 rights: (make-rights (site-rights))
315 uri: (make-pathname 331 generator: (make-generator "Boudin"
316 (site-base-url) "feed" "xml"))) 332 uri: "https://git.acdw.net/boudin"
317 rights: (make-rights (site-rights)) 333 version: "0.1.0")
318 generator: (make-generator "Boudin" 334 entries: (map (lambda (pg)
319 uri: "https://git.acdw.net/boudin" 335 (make-entry
320 version: "0.1.0") 336 title: (make-title
321 entries: (map (lambda (pg) 337 (page-meta-ref pg "title" "[untitled]"))
322 (make-entry 338 links: (list (make-link type: 'html
323 title: (make-title 339 uri: (page-url pg)))
324 (page-meta-ref pg "title" "[untitled]")) 340 id: (page-url pg)
325 links: (list (make-link type: 'html 341 updated: (page-guess-updated pg)
326 uri: (page-url pg))) 342 ;;published:
327 id: (page-url pg) 343 content:
328 updated: (page-guess-updated pg) 344 `(atom:content (@ (type "html"))
329 ;;published: 345 ,(cdr (page-dest pg)))))
330 content: 346 pages))))))
331 `(atom:content (@ (type "html"))
332 ,(cdr (page-dest pg)))))
333 pages)))))))))
334
335;;; Collecting pages from a directory
336
337(define (collect-pages dir ext)
338 (map file->page
339 (glob (make-pathname dir "*" ext))))
340 347
341;;; Publishing 348;;; Publishing
342 349
343(define (apply-template template pages) 350(define (write-style)
344 (apply template (if (list? pages) 351 (print-log "writing style")
345 pages 352 (with-output-to-file (make-pathname (build-directory) "style" "css")
346 (list pages)))) 353 (lambda () (write-css (site-style)))))
354
355(define (write-page page)
356 (print-log "writing " (or (page-meta-ref page "title" #f)
357 (page-source-path page)))
358 (create-directory (pathname-directory (page-dest-path page)) 'parents)
359 (with-output-to-file (page-dest-path page)
360 (lambda () (sxml-display-as-html ((page-template) page)))))
361
362(define (write-index pages)
363 (print-log "writing index")
364 (with-output-to-file (make-pathname (build-directory) "index" "html")
365 (lambda () (sxml-display-as-html (apply (index-template) pages)))))
366
367(define (write-feed pages)
368 (print-log "writing feed")
369 (with-output-to-file (make-pathname (build-directory) "feed" "xml")
370 (lambda () (write-atom-doc (apply (feed-template) pages)))))
347 371
348;;; Configuration 372;;; Configuration
349 373
350(define output-directory 374;; Build configuration
375
376(define build-directory
351 (make-parameter "out/")) 377 (make-parameter "out/"))
352 378
379(define build-config
380 (make-parameter "config.scm"))
381
382;; Site configuration
383
353(define site-name 384(define site-name
354 (make-parameter "[A boudin web site]")) 385 (make-parameter "[A boudin web site]"))
355 386
@@ -362,58 +393,89 @@ boudin --- a little static site generator
362(define site-rights 393(define site-rights
363 (make-parameter (string-append "(C) " (site-author)))) 394 (make-parameter (string-append "(C) " (site-author))))
364 395
396(define site-style
397 (make-parameter
398 `(css+ (body (font "20px/1.4 sans-serif")
399 (max-width "48em")
400 (padding "1em")
401 (margin auto)))))
402
365;;; Options & Operands (SRFI 37) 403;;; Options & Operands (SRFI 37)
366 404
367(define (die error-code message . args) 405(define (print-log . xs)
368 (with-output-to-port (current-error-port) 406 (with-output-to-port (current-error-port)
369 (apply print message args) 407 (lambda () (apply print xs))))
370 (exit error-code))) 408
409(define (die error-code . xs)
410 (apply print-log xs)
411 (exit error-code))
371 412
372(define usage #<<END 413(define usage
373Usage: boudin [OPTIONS] 414 (string-append
374Options: 415 "Usage: boudin [OPTIONS] FILE ...\n"
375-h, --help show this help and exit 416 "Options:\n"
376-C dir, --directory dir build site in DIR instead of current directory 417 "-h, --help show this help and exit\n"
377END 418 "-o DIR, --output DIR build site to DIR (default: out/)\n"
378) 419 "Operands:\n"
420 "FILE ... files to build\n"))
379 421
380(define opt/help 422(define opt/help
381 (option '(#\h "help") ; Names 423 (option '(#\h "help") ; Names
382 #f ; Required arg? 424 #f ; Required arg?
383 #f ; Optional arg? 425 #f ; Optional arg?
384 (lambda _ ; Option proc (opt name arg seeds ...) 426 (lambda _ ; Option proc (opt name arg seeds ...)
385 (with-output-to-port (current-error-port) 427 (die 0 usage))))
386 (lambda () (print usage)))
387 (exit))))
388 428
389(define opt/directory 429(define opt/build-directory
390 (option '(#\C "directory") #t #f 430 (option '(#\o "output") #t #f
391 (lambda (opt name arg seeds) 431 (lambda (opt name arg seeds)
392 (if (directory-exists? arg) 432 (build-directory arg)
393 (change-directory arg) 433 seeds)))
394 (error "Directory doesn't exist" arg)) 434
435(define opt/build-config
436 (option '(#\c "config") #t #f
437 (lambda (opt name arg seeds)
438 (build-config arg)
395 seeds))) 439 seeds)))
396 440
397(define (process-args args) 441(define (process-args args)
398 (args-fold args 442 (let ((pages '()))
399 ;; Options 443 (args-fold args
400 (list opt/help 444 ;; Options
401 opt/directory) 445 (list opt/help
402 ;; Unrecognized option proc (option name arg seeds ...) 446 opt/build-directory
403 (lambda (_ name _ _) 447 opt/build-config)
404 (die 1 "Unrecognized option: -" name "\n" usage)) 448 ;; Unrecognized option proc (option name arg seeds ...)
405 ;; Operand proc (operand seeds ...) 449 (lambda (_ name _ _)
406 (lambda (name _) 450 (die 1 "Unrecognized option: -" name "\n" usage))
407 (die 1 "Unrecognized operand: " name "\n" usage)) 451 ;; Operand proc (operand seeds ...)
408 ;; Seeds 452 (lambda (name seeds)
409 '())) 453 (if (file-exists? name)
454 (set! pages (cons (file->page name) pages))
455 (die 2 "Page not found: " name))
456 seeds)
457 ;; Seeds
458 '())
459 pages))
410 460
411;;; Main entry point 461;;; Main entry point
412 462
463(define pages (make-parameter #f))
464
413(define (main args) 465(define (main args)
414 (process-args args) 466 (parameterize ((pages (process-args args)))
415 ;; TODO ... 467 (unless (pages)
416 #f) 468 (die 0 "No pages to process. Abort."))
469 ;; Check for files, create directories
470 (if (file-exists? (build-config))
471 (load (build-config))
472 (print-log "No config.scm found; using default config"))
473 (create-directory (build-directory) 'parents)
474 ;; Build the site
475 (write-style) ; TODO: copy static assets (?)
476 (for-each write-page (pages))
477 (write-index (pages))
478 (write-feed (pages))))
417 479
418(cond-expand 480(cond-expand
419 ((or chicken-script compiling) 481 ((or chicken-script compiling)