summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--.repl4
-rw-r--r--boudin.egg3
-rw-r--r--lib/config.sld16
-rw-r--r--lib/types.sld17
-rw-r--r--lib/types.sls91
-rw-r--r--lib/util.sld38
6 files changed, 160 insertions, 9 deletions
diff --git a/.repl b/.repl index 229237b..2d1a330 100644 --- a/.repl +++ b/.repl
@@ -1,4 +1,6 @@
1;; -*- scheme -*- 1;; -*- scheme -*-
2(import (beaker system)) 2(import (beaker system))
3 3
4(print "> (load-system \"boudin.egg\")") 4(define (setup-repl)
5 (load-system "boudin.egg")
6 )
diff --git a/boudin.egg b/boudin.egg index e9ca2dc..0978ec3 100644 --- a/boudin.egg +++ b/boudin.egg
@@ -5,8 +5,9 @@
5 (version "0.0.0") 5 (version "0.0.0")
6 (license "God Willing License") 6 (license "God Willing License")
7 7
8 (dependencies chicanery r7rs utf8 8 (dependencies r7rs utf8
9 html-parser 9 html-parser
10 srfi-1
10 srfi-152) 11 srfi-152)
11 12
12 (component-options 13 (component-options
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 ))