blob: 004e7507dc8177285f2f1754d65786bf207fe676 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
(declare (module (boudin page))
(export make-page
page-content
page-meta
page-meta-set!
page-output
page-ref
page-set!
page-slug
page-template
page-updated
page-url
page-writer
page?)
(import (boudin site)
(boudin util)
(chicken file posix)
(chicken file)
(chicken pathname)
(chicken time posix)
(srfi 1)))
(define-record-type page
(make-page content output template writer meta)
page?
(content page-content)
(output page-output)
(template page-template)
(writer page-writer)
(meta page-meta page-meta-set!))
(define (page-ref pg k)
(assoc-ref k (or (page-meta pg) '())))
(define (page-set! pg k v)
(page-meta-set! pg (cons (cons k v)
(page-meta pg))))
(define (*urlify path)
(normalize-pathname
(make-pathname (list (string-append "https://" (site-host))
(pathname-strip-extension path))
"index.html")))
(define (page-url pg) ; foo.html => http://site.com/foo/index.html
(or (page-ref pg "url") ; memoization
(let ((url (*urlify (page-ref pg "source"))))
(page-set! pg "url" url)
url)))
(define (*slugify url) ; I don't love how this is written..
(let-values (((_ _ dirs) (decompose-directory url)))
(let loop ((this (car dirs))
(rest (cdr dirs)))
(if (null? (cdr rest))
(make-pathname (list "/" this) #f)
(loop (car rest)
(cdr rest))))))
(define (page-slug pg) ; http://site.com/foo/index.html => /foo/
(or (page-ref pg "slug") ; memoization
(let ((slug (*slugify (page-url pg))))
(page-set! pg "slug" slug)
slug)))
(define (*page-mtime pg)
(let ((file (page-ref pg "source")))
(and file
(file-exists? file)
(time->string (seconds->utc-time (file-modification-time file))))))
(define (page-updated pg)
(let ((meta-date (page-ref pg "date")))
(or (and meta-date ; memoization
(find (lambda (fmt) (string->time meta-date fmt))
(site-date-formats)))
(*page-mtime pg)
(site-build-time))))
|
