diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/config.sld | 16 | ||||
-rw-r--r-- | lib/types.sld | 17 | ||||
-rw-r--r-- | lib/types.sls | 91 | ||||
-rw-r--r-- | lib/util.sld | 38 |
4 files changed, 155 insertions, 7 deletions
diff --git a/lib/config.sld b/lib/config.sld index bdd6ef5..f2c00df 100644 --- a/lib/config.sld +++ b/lib/config.sld | |||
@@ -8,12 +8,15 @@ | |||
8 | (boudin schmaltz) | 8 | (boudin schmaltz) |
9 | ;; not portable | 9 | ;; not portable |
10 | (chicken pathname) | 10 | (chicken pathname) |
11 | (chicken time posix) | ||
11 | (html-parser) | 12 | (html-parser) |
12 | ) | 13 | ) |
13 | 14 | ||
14 | (export site-url site-dest | 15 | (export site-url site-dest |
15 | page-path-transformers page-text-transformers | 16 | page-path-transformers page-text-transformers |
16 | page-template index-template feed-template) | 17 | page-date-formats |
18 | page-template index-template feed-template | ||
19 | build-time) | ||
17 | 20 | ||
18 | (begin | 21 | (begin |
19 | ;; Site information | 22 | ;; Site information |
@@ -42,4 +45,13 @@ | |||
42 | (make-parameter 'todo)) | 45 | (make-parameter 'todo)) |
43 | (define feed-template | 46 | (define feed-template |
44 | (make-parameter 'todo)) | 47 | (make-parameter 'todo)) |
45 | )) | 48 | ;; Miscellaneous |
49 | (define page-date-formats | ||
50 | (make-parameter (list "%Y-%m-%d" | ||
51 | "%Y-%m-%d%n%H:%M" | ||
52 | "%Y-%m-%d%n%I:%M%n%p"))) | ||
53 | ;; Not actually configuration, but state ... meh | ||
54 | (define build-time | ||
55 | (make-parameter | ||
56 | (time->string (seconds->utc-time) "%FT%TZ")))) | ||
57 | ) | ||
diff --git a/lib/types.sld b/lib/types.sld index 791ff53..b7ce12c 100644 --- a/lib/types.sld +++ b/lib/types.sld | |||
@@ -1,11 +1,18 @@ | |||
1 | (define-library (boudin types) | 1 | (define-library (boudin types) |
2 | (import (scheme base) | 2 | (import (scheme base) |
3 | (scheme case-lambda) | 3 | (scheme case-lambda) |
4 | (scheme cxr) | ||
4 | (scheme file) | 5 | (scheme file) |
6 | (scheme write) | ||
5 | (boudin config) | 7 | (boudin config) |
6 | (boudin util) | 8 | (boudin util) |
9 | (srfi 1) | ||
10 | (srfi 152) | ||
7 | ;; non-portable bits | 11 | ;; non-portable bits |
12 | (chicken file) | ||
13 | (chicken file posix) | ||
8 | (chicken pathname) | 14 | (chicken pathname) |
15 | (chicken time posix) | ||
9 | (html-parser) | 16 | (html-parser) |
10 | ) | 17 | ) |
11 | 18 | ||
@@ -15,10 +22,18 @@ | |||
15 | page-path page-dest page-text page-sxml page-meta | 22 | page-path page-dest page-text page-sxml page-meta |
16 | set-page-dest! set-page-text! set-page-sxml! set-page-meta! | 23 | set-page-dest! set-page-text! set-page-sxml! set-page-meta! |
17 | extract-metadata page-ref page-set! | 24 | extract-metadata page-ref page-set! |
18 | page-url page-slug | 25 | page-url page-slug page-updated |
19 | read-page write-page | 26 | read-page write-page |
20 | ;; indeces | 27 | ;; indeces |
28 | make-index index? | ||
29 | index-dest index-template index-writer index-pages index-meta | ||
30 | set-index-dest! set-index-template! set-index-writer! set-index-pages! | ||
31 | set-index-meta! | ||
32 | index-ref index-set! index-push! | ||
33 | index-for-each | ||
34 | write-index | ||
21 | ;; static files | 35 | ;; static files |
36 | static-copy | ||
22 | ) | 37 | ) |
23 | 38 | ||
24 | (include "lib/types.sls")) | 39 | (include "lib/types.sls")) |
diff --git a/lib/types.sls b/lib/types.sls index 2b4da5d..3f6c07f 100644 --- a/lib/types.sls +++ b/lib/types.sls | |||
@@ -1,7 +1,9 @@ | |||
1 | ;;; (boudin types) --- pages, indeces, and static files | 1 | ;;; (boudin types) --- pages, indeces, and static files |
2 | 2 | ;; | |
3 | ;; All paths are relative to the site directory unless otherwise noted | 3 | ;; All paths are relative to the site directory unless otherwise noted |
4 | 4 | ||
5 | ;;; Pages | ||
6 | |||
5 | (define-record-type page | 7 | (define-record-type page |
6 | (make-page path ; Input path | 8 | (make-page path ; Input path |
7 | dest ; Output path (rel. to output directory) | 9 | dest ; Output path (rel. to output directory) |
@@ -17,14 +19,33 @@ | |||
17 | (meta page-meta set-page-meta!)) | 19 | (meta page-meta set-page-meta!)) |
18 | 20 | ||
19 | (define (page-ref pg key) | 21 | (define (page-ref pg key) |
20 | (assoc-ref key (page-meta pg) (identity #f))) | 22 | (assoc-ref key (page-meta pg) (lambda _ #f))) |
21 | 23 | ||
22 | (define (page-set! pg key val) | 24 | (define (page-set! pg key val) |
23 | (set-page-meta! pg (cons (cons key val) | 25 | (set-page-meta! pg (cons (cons key val) |
24 | (page-meta pg)))) | 26 | (page-meta pg)))) |
25 | 27 | ||
26 | (define (extract-metadata sxml) | 28 | (define (extract-metadata sxml) |
27 | #f) | 29 | (let loop ((tree sxml) |
30 | (acc '())) | ||
31 | (cond | ||
32 | ((not (pair? tree)) | ||
33 | (reverse acc)) | ||
34 | ((and (list? (car tree)) | ||
35 | (eq? (caar tree) '*COMMENT*)) | ||
36 | (loop (cdr tree) | ||
37 | (map (lambda (ln) | ||
38 | (let ((kv (string-split ln ":" 'infix 1))) | ||
39 | (cons (string-trim-both (car kv)) | ||
40 | (string-trim (cdr kv))))) | ||
41 | (string-split (cadar tree) "\n")))) | ||
42 | ((list? (car tree)) | ||
43 | (loop (cdr tree) | ||
44 | (let ((subtree (loop (car tree) '()))) | ||
45 | (if (null? subtree) | ||
46 | acc | ||
47 | (cons subtree acc))))) | ||
48 | (else (loop (cdr tree) acc))))) | ||
28 | 49 | ||
29 | (define (*urlify path) | 50 | (define (*urlify path) |
30 | (normalize-pathname | 51 | (normalize-pathname |
@@ -53,6 +74,20 @@ | |||
53 | (page-set! pg "slug" slug) | 74 | (page-set! pg "slug" slug) |
54 | slug))) | 75 | slug))) |
55 | 76 | ||
77 | (define (*page-mtime pg) | ||
78 | (let ((file (page-path pg))) | ||
79 | (and file | ||
80 | (file-exists? file) | ||
81 | (time->string (seconds->utc-time (file-modification-time file)))))) | ||
82 | |||
83 | (define (page-updated pg) | ||
84 | (let ((meta-date (page-ref pg "date"))) | ||
85 | (or (and meta-date | ||
86 | (find (lambda (fmt) (string->time meta-date fmt)) | ||
87 | (page-date-formats))) | ||
88 | (*page-mtime pg) | ||
89 | (build-time)))) | ||
90 | |||
56 | (define (read-page path) | 91 | (define (read-page path) |
57 | (let ((pg (make-page path #f #f #f #f))) | 92 | (let ((pg (make-page path #f #f #f #f))) |
58 | (set-page-dest! pg ((apply o (page-path-transformers)) path)) | 93 | (set-page-dest! pg ((apply o (page-path-transformers)) path)) |
@@ -69,4 +104,54 @@ | |||
69 | (sxml-display-as-html ((eval/q (page-template)) pg) port)))) | 104 | (sxml-display-as-html ((eval/q (page-template)) pg) port)))) |
70 | 105 | ||
71 | 106 | ||
107 | ;;; Indeces | ||
108 | ;; These are generated pages from collections of other pages. Think index.html, | ||
109 | ;; feed.xml, possibly tag indeces and the like. These pages don't have a source | ||
110 | ;; file, but they have a destination and a template. Because there are | ||
111 | ;; different file formats here and ... stuff, there's also a slot for the index | ||
112 | ;; writer function. Finally, pages and meta are the pages and various other | ||
113 | ;; metadata of the index. | ||
114 | |||
115 | (define-record-type index | ||
116 | (make-index dest ; Relative to (site-dest) | ||
117 | template ; Template to put pages in | ||
118 | writer ; Proc to write sxml out to a file | ||
119 | pages ; Input pages | ||
120 | meta ; Various other metadata | ||
121 | ) | ||
122 | index? | ||
123 | (dest index-dest set-index-dest!) | ||
124 | (template index-template set-index-template!) | ||
125 | (writer index-writer set-index-writer!) | ||
126 | (pages index-pages set-index-pages!) | ||
127 | (meta index-meta set-index-meta!)) | ||
128 | |||
129 | (define (index-ref idx key) | ||
130 | (assoc-ref key (index-meta idx) (lambda _ #f))) | ||
131 | |||
132 | (define (index-set! idx key val) | ||
133 | (set-index-meta! idx (cons (cons key val) | ||
134 | (index-meta idx)))) | ||
135 | |||
136 | (define (index-push! idx pg) | ||
137 | (set-index-pages! idx (cons pg (index-pages idx)))) | ||
138 | |||
139 | (define (index-for-each idx proc) | ||
140 | (for-each proc (index-pages idx))) | ||
141 | |||
142 | (define write-index | ||
143 | (case-lambda | ||
144 | ((idx) (call-with-output-file (index-dest idx) | ||
145 | (lambda (port) (write-index idx (current-output-port))))) | ||
146 | ((idx port) | ||
147 | ((index-writer idx) ((index-template idx) (index-pages idx)) port)))) | ||
148 | |||
149 | |||
150 | ;;; Static files | ||
151 | ;; These are simply copied from the input to the output, possibly with a changed | ||
152 | ;; path. Because these are just files, we don't need a record type. | ||
72 | 153 | ||
154 | (define (static-copy path) | ||
155 | (copy-file path | ||
156 | (make-pathname (site-dest) path) | ||
157 | 'clobber)) | ||
diff --git a/lib/util.sld b/lib/util.sld index 64c633e..fe407a2 100644 --- a/lib/util.sld +++ b/lib/util.sld | |||
@@ -7,9 +7,12 @@ | |||
7 | 7 | ||
8 | (export identity | 8 | (export identity |
9 | o | 9 | o |
10 | constantly | ||
10 | assoc-ref | 11 | assoc-ref |
11 | slurp | 12 | slurp |
12 | eval/q) | 13 | eval/q |
14 | intersperse | ||
15 | string-intersperse) | ||
13 | 16 | ||
14 | (begin | 17 | (begin |
15 | (define (identity x) x) | 18 | (define (identity x) x) |
@@ -24,6 +27,9 @@ | |||
24 | h | 27 | h |
25 | (lambda (x) (h ((loop t) x)))))))) | 28 | (lambda (x) (h ((loop t) x)))))))) |
26 | 29 | ||
30 | (define (constantly x) | ||
31 | (lambda _ x)) | ||
32 | |||
27 | (define assoc-ref | 33 | (define assoc-ref |
28 | (case-lambda | 34 | (case-lambda |
29 | ((key alist) | 35 | ((key alist) |
@@ -47,4 +53,34 @@ | |||
47 | (define (eval/q form env) ; this is probably a bad idea | 53 | (define (eval/q form env) ; this is probably a bad idea |
48 | (eval (list 'quasiquote form) env)) | 54 | (eval (list 'quasiquote form) env)) |
49 | 55 | ||
56 | (define (intersperse xs delim) | ||
57 | (if (null? xs) | ||
58 | '() | ||
59 | (let loop ((acc (list (car xs))) | ||
60 | (rest (cdr xs))) | ||
61 | (if (null? rest) | ||
62 | (reverse acc) | ||
63 | (loop (cons (car rest) (cons delim acc)) | ||
64 | (cdr rest)))))) | ||
65 | |||
66 | (define (string-intersperse ss delim) | ||
67 | (apply string-append (intersperse ss delim))) | ||
68 | |||
69 | (define index | ||
70 | (case-lambda | ||
71 | ((xs needle) | ||
72 | (index xs needle eq? (constantly #f))) | ||
73 | ((xs needle comparator) | ||
74 | (index xs needle comparator (constantly #f))) | ||
75 | ((xs needle comparator fail) | ||
76 | (let loop ((i 0) | ||
77 | (xs xs)) | ||
78 | (cond | ||
79 | ((null? xs) (fail)) | ||
80 | ((comparator (car xs) needle) i) | ||
81 | (else (loop (+ i 1) (cdr xs)))))))) | ||
82 | |||
83 | (define (string-index str ch) | ||
84 | (index (string->list str) ch)) | ||
85 | |||
50 | )) | 86 | )) |