summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--.repl3
-rw-r--r--Makefile18
-rw-r--r--boudin.egg65
-rw-r--r--boudin.page.instances.scm79
-rw-r--r--boudin.page.scm78
-rw-r--r--boudin.page.write.scm114
-rw-r--r--boudin.scm71
-rw-r--r--boudin.site.scm46
-rw-r--r--boudin.sld7
-rw-r--r--boudin.util.scm68
-rw-r--r--lib/config.sld45
-rw-r--r--lib/schmaltz.sld17
-rw-r--r--lib/schmaltz.sls103
-rw-r--r--lib/types.sld24
-rw-r--r--lib/types.sls72
-rw-r--r--lib/util.sld50
-rw-r--r--test/foo.html3
-rw-r--r--test/out/feed.xml25
-rw-r--r--test/out/foo/index.html5
-rw-r--r--test/out/index.html1
20 files changed, 532 insertions, 362 deletions
diff --git a/.repl b/.repl index 229237b..b8f4fc9 100644 --- a/.repl +++ b/.repl
@@ -1,4 +1,5 @@
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"))
diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..bd8289d --- /dev/null +++ b/Makefile
@@ -0,0 +1,18 @@
1# boudin
2
3.PHONY: build
4build:
5 chicken-install -n
6
7.PHONY: install
8install:
9 chicken-install
10
11.PHONY: test
12test: build
13 cd test; ../boudin *.html && (cd out; python -m http.server)
14
15.PHONY: clean
16clean:
17 rm -f boudin
18 rm -f *.build.sh *.install.sh *.import.scm *.link *.so *.o
diff --git a/boudin.egg b/boudin.egg index e9ca2dc..353d1d4 100644 --- a/boudin.egg +++ b/boudin.egg
@@ -1,42 +1,37 @@
1;;; boudin -*- scheme -*- 1;;; boudin
2 2
3((synopsis "A small tasty ssg.") 3((synopsis "a small, tasty ssg.")
4 (author "Case Duckworth") 4 (author "Case Duckworth")
5 (version "0.0.0") 5 (license "God Willing")
6 (license "God Willing License") 6 (version "0.1.1")
7 7 (dependencies atom
8 (dependencies chicanery r7rs utf8
9 html-parser 8 html-parser
10 srfi-152) 9 module-declarations
11 10 schmaltz
11 srfi-1
12 srfi-152
13 sxml-serializer
14 utf8)
12 (component-options 15 (component-options
13 (csc-options "-X" "r7rs" "-R" "r7rs" 16 (csc-options -X module-declarations -X utf8))
14 "-X" "utf8" "-R" "utf8"
15 "-no-warnings"))
16
17 (components 17 (components
18 (program boudin 18 (program boudin
19 (component-dependencies boudin-lib)) 19 (component-dependencies boudin.page
20 20 boudin.page.instances
21 (extension boudin-lib 21 boudin.page.write
22 (source boudin.sld) 22 boudin.site
23 (modules boudin) 23 boudin.util))
24 (install-name boudin) 24 (extension boudin.page
25 (component-dependencies boudin.schmaltz)) 25 (component-dependencies boudin.site
26
27 (extension boudin.config
28 (source lib/config.sld)
29 (component-dependencies boudin.schmaltz))
30
31 (extension boudin.schmaltz
32 (source lib/schmaltz.sld)
33 (source-dependencies lib/schmaltz.sls))
34
35 (extension boudin.types
36 (source lib/types.sld)
37 (source-dependencies lib/types.sls)
38 (component-dependencies boudin.config
39 boudin.util)) 26 boudin.util))
40 27 (extension boudin.page.instances
41 (extension boudin.util 28 (component-dependencies boudin.page
42 (source lib/util.sld)))) 29 boudin.page.write
30 boudin.site
31 boudin.util))
32 (extension boudin.page.write
33 (component-dependencies boudin.page
34 boudin.site))
35 (extension boudin.site
36 (component-dependencies boudin.util))
37 (extension boudin.util)))
diff --git a/boudin.page.instances.scm b/boudin.page.instances.scm new file mode 100644 index 0000000..1a3a12e --- /dev/null +++ b/boudin.page.instances.scm
@@ -0,0 +1,79 @@
1(declare (module (boudin page instances))
2 (export make-feed
3 make-index
4 make-post
5 post-path-transformers
6 post-text-transformers))
7
8(import (boudin page write)
9 (boudin page)
10 (boudin site)
11 (boudin util)
12 (chicken pathname)
13 (html-parser)
14 (except (schmaltz)
15 render-specials
16 render-unprintables)
17 (schmaltz chicken)
18 (srfi 152))
19
20(define (make-post path)
21 (let ((sxml ((apply o (post-text-transformers))
22 (with-input-from-file path slurp))))
23 (make-page sxml
24 ((apply o (post-path-transformers)) path)
25 (post-template)
26 (post-writer)
27 (cons (cons "source" path)
28 (*extract-metadata sxml)))))
29
30(define (*extract-metadata sxml)
31 (let loop ((tree sxml)
32 (acc '()))
33 (cond
34 ((not (pair? tree))
35 (reverse acc))
36 ((and (list? (car tree))
37 (eq? (caar tree) '*COMMENT*))
38 (loop (cdr tree)
39 (map (lambda (ln)
40 (let ((kv (string-split ln ":" 'infix 1)))
41 (cons (string-trim-both (car kv))
42 (string-trim (cdr kv)))))
43 (string-split (cadar tree) "\n"))))
44 ((list? (car tree))
45 (loop (cdr tree)
46 (let ((subtree (loop (car tree) '())))
47 (if (null? subtree)
48 acc
49 (cons subtree acc)))))
50 (else (loop (cdr tree) acc)))))
51
52(define (make-index pgs)
53 (make-page ((index-template) pgs)
54 (make-pathname (site-output) "index.html")
55 page-content
56 (index-writer)
57 `()))
58
59(define (make-feed pgs)
60 (make-page ((feed-template) pgs)
61 (make-pathname (site-output) "feed.xml")
62 page-content
63 (feed-writer)
64 `()))
65
66;; Configurables
67
68(define post-text-transformers
69 (make-parameter
70 (list html->sxml
71 wrap-paragraphs
72 render-string->string)))
73
74(define post-path-transformers
75 (make-parameter
76 (list (lambda (path)
77 (make-pathname (list (site-output)
78 (pathname-strip-extension path))
79 "index.html")))))
diff --git a/boudin.page.scm b/boudin.page.scm new file mode 100644 index 0000000..004e750 --- /dev/null +++ b/boudin.page.scm
@@ -0,0 +1,78 @@
1(declare (module (boudin page))
2 (export make-page
3 page-content
4 page-meta
5 page-meta-set!
6 page-output
7 page-ref
8 page-set!
9 page-slug
10 page-template
11 page-updated
12 page-url
13 page-writer
14 page?)
15 (import (boudin site)
16 (boudin util)
17 (chicken file posix)
18 (chicken file)
19 (chicken pathname)
20 (chicken time posix)
21 (srfi 1)))
22
23(define-record-type page
24 (make-page content output template writer meta)
25 page?
26 (content page-content)
27 (output page-output)
28 (template page-template)
29 (writer page-writer)
30 (meta page-meta page-meta-set!))
31
32(define (page-ref pg k)
33 (assoc-ref k (or (page-meta pg) '())))
34
35(define (page-set! pg k v)
36 (page-meta-set! pg (cons (cons k v)
37 (page-meta pg))))
38
39(define (*urlify path)
40 (normalize-pathname
41 (make-pathname (list (string-append "https://" (site-host))
42 (pathname-strip-extension path))
43 "index.html")))
44
45(define (page-url pg) ; foo.html => http://site.com/foo/index.html
46 (or (page-ref pg "url") ; memoization
47 (let ((url (*urlify (page-ref pg "source"))))
48 (page-set! pg "url" url)
49 url)))
50
51(define (*slugify url) ; I don't love how this is written..
52 (let-values (((_ _ dirs) (decompose-directory url)))
53 (let loop ((this (car dirs))
54 (rest (cdr dirs)))
55 (if (null? (cdr rest))
56 (make-pathname (list "/" this) #f)
57 (loop (car rest)
58 (cdr rest))))))
59
60(define (page-slug pg) ; http://site.com/foo/index.html => /foo/
61 (or (page-ref pg "slug") ; memoization
62 (let ((slug (*slugify (page-url pg))))
63 (page-set! pg "slug" slug)
64 slug)))
65
66(define (*page-mtime pg)
67 (let ((file (page-ref pg "source")))
68 (and file
69 (file-exists? file)
70 (time->string (seconds->utc-time (file-modification-time file))))))
71
72(define (page-updated pg)
73 (let ((meta-date (page-ref pg "date")))
74 (or (and meta-date ; memoization
75 (find (lambda (fmt) (string->time meta-date fmt))
76 (site-date-formats)))
77 (*page-mtime pg)
78 (site-build-time))))
diff --git a/boudin.page.write.scm b/boudin.page.write.scm new file mode 100644 index 0000000..eb719b7 --- /dev/null +++ b/boudin.page.write.scm
@@ -0,0 +1,114 @@
1(declare (module (boudin page write))
2 (export feed-template
3 feed-writer
4 html-head
5 index-template
6 index-writer
7 post-template
8 post-writer
9 write-page))
10
11(import (atom)
12 (boudin page)
13 (boudin site)
14 (chicken file)
15 (chicken pathname)
16 (html-parser)
17 (sxml-serializer))
18
19(define (write-page pg)
20 (let ((outfile (page-output pg)))
21 (create-directory (pathname-directory outfile)
22 'parents)
23 (with-output-to-file outfile
24 (lambda ()
25 ((page-writer pg)
26 ((page-template pg)
27 pg))))))
28
29(define html-head
30 (make-parameter
31 `((meta (@ (charset "utf-8")))
32 (meta (@ (name "viewport")
33 (content "initial-scale=1.0")))
34 (link (@ (href "/style.css")
35 (rel "stylesheet"))))))
36
37(define post-writer
38 (make-parameter
39 sxml-display-as-html))
40
41(define post-template
42 (make-parameter
43 (lambda (pg)
44 (let ((title (page-ref pg "title")))
45 `(html (@ (lang "en-us"))
46 (head ,@(html-head)
47 (title ,(or title "[untitled]")))
48 (body ,(if title `(h1 ,title) "")
49 ,@(cdr (page-content pg))))))))
50
51(define index-writer
52 (make-parameter
53 sxml-display-as-html))
54
55(define index-template
56 (make-parameter
57 (lambda (pgs)
58 `(html (@ (lang "en-us"))
59 (head ,@(html-head)
60 (title ,(site-name)))
61 (body (h1 ,(site-name))
62 (ul ,@(map (lambda (pg)
63 `(li (a (@ (href ,(page-slug pg)))
64 ,(or (page-ref pg "title")
65 (page-slug pg)))))
66 ((site-sort) pgs))))))))
67
68(define feed-writer
69 (make-parameter
70 (lambda (sxml)
71 (serialize-sxml sxml
72 output: (current-output-port)
73 cdata-section-elements: '(atom:content)
74 ns-prefixes:
75 `((*default* . "http://www.w3.org/2005/Atom")
76 (*default* . "http://www.w3.org/1999/xhtml")
77 ,@(atom-ns-prefixes))
78 allow-prefix-redeclarations: #t))))
79
80(define feed-template
81 (make-parameter
82 (lambda (pgs)
83 (make-atom-doc
84 (make-feed
85 title: (make-title (site-name))
86 id: (site-host)
87 updated: (site-build-time)
88 authors: (list (make-author name: (site-author)
89 uri: (site-host)))
90 links: (list (make-link type: 'html
91 uri-language: "en"
92 uri: (site-host))
93 (make-link relation: "self"
94 type: "application/atom+xml"
95 uri: (make-pathname
96 (site-host) "feed" "xml")))
97 rights: (make-rights (force (site-rights)))
98 generator: (make-generator "Boudin"
99 uri: "https://git.acdw.net/boudin"
100 version: "rice")
101 entries: (map (lambda (pg)
102 (make-entry
103 title: (make-title
104 (or (page-ref pg "title") "[untitled]"))
105 links: (list (make-link type: 'html
106 uri: (page-url pg)))
107 id: (page-url pg)
108 updated: (page-updated pg)
109 ;;published:
110 content: (make-content
111 (sxml->html
112 (page-content pg))
113 type: 'html)))
114 ((site-sort) pgs)))))))
diff --git a/boudin.scm b/boudin.scm index 7bd741d..4f6a1b3 100644 --- a/boudin.scm +++ b/boudin.scm
@@ -1,14 +1,69 @@
1;;; (boudin) --- A small tasty ssg 1;;; boudin
2 2
3(import (boudin)) 3(import (boudin page)
4 (boudin page instances)
5 (boudin page write)
6 (boudin site)
7 (boudin util)
8 (chicken file)
9 (chicken pathname)
10 (chicken process-context))
4 11
5(define foo (render-string "#,hello from Boudin!" 12(define site-posts
6 (interaction-environment))) 13 (make-parameter '()))
7 14
8(define (main . args) 15(define site-files
9 (print foo) 16 (make-parameter '()))
10 (for-each print args)) 17
18(define (copy-static file)
19 (copy-file file (pathname-replace-directory file (site-dest))))
20
21(define (with-progress message thunk)
22 (edisplay message)
23 (edisplay "...")
24 (thunk)
25 (eprint "Ok."))
26
27(define (go!)
28 (eprint "Building " (site-name) "...")
29 (when (file-exists? (site-config))
30 (with-progress (string-append "Config found, loading: " (site-config))
31 (lambda () (load (site-config)))))
32 (for-each (lambda (f)
33 (with-progress (string-append "Copying " f " to " (site-output))
34 (lambda () (copy-static f)))) (site-files))
35 (let ((posts (map make-post (site-posts))))
36 (for-each (lambda (pg)
37 (with-progress (string-append "Writing " (page-output pg))
38 (lambda () (write-page pg))))
39 (append posts
40 (list (make-index posts)
41 (make-feed posts)))))
42 (eprint "Done!"))
43
44(define (main args)
45 (define *current #f)
46 (let loop ((args args))
47 (cond
48 ((null? args) (go!))
49 ((equal? (car args) "-c")
50 (site-config (cadr args))
51 (loop (cddr args)))
52 ((not *current) ; add to posts by default
53 (site-posts (cons (car args) (site-posts)))
54 (loop (cdr args)))
55 ((equal? (car args) "-p")
56 (set! *current site-posts)
57 (loop (cdr args)))
58 ((equal? (car args) "-f")
59 (set! *current site-files)
60 (loop (cdr args)))
61 (else
62 (*current (cons (car args) (*current)))
63 (loop (cdr args))))))
11 64
12(cond-expand 65(cond-expand
13 (compiling (apply main (command-line))) 66 ((or chicken-script compiling)
67 (import (chicken process-context))
68 (main (command-line-arguments)))
14 (else)) 69 (else))
diff --git a/boudin.site.scm b/boudin.site.scm new file mode 100644 index 0000000..ee94b9b --- /dev/null +++ b/boudin.site.scm
@@ -0,0 +1,46 @@
1(declare (module (boudin site))
2 (export site-author
3 site-build-time
4 site-config
5 site-host
6 site-name
7 site-date-formats
8 site-output
9 site-rights
10 site-sort)
11 (import (boudin util)
12 (chicken time posix)))
13
14;; Configurables
15
16(define site-sort
17 (make-parameter identity))
18
19(define site-name
20 (make-parameter "a boudin site"))
21
22(define site-host
23 (make-parameter "example.com"))
24
25(define site-author
26 (make-parameter "nobody"))
27
28(define site-rights
29 (make-parameter
30 (delay (string-append "(C) " (site-author)))))
31
32(define site-output
33 (make-parameter "out/"))
34
35(define site-config
36 (make-parameter "config.scm"))
37
38(define site-date-formats
39 (make-parameter '("%Y-%m-%d"
40 "%d/%m/%Y")))
41
42;; State variables
43
44(define site-build-time
45 (make-parameter
46 (time->string (seconds->utc-time) "%FT%TZ")))
diff --git a/boudin.sld b/boudin.sld deleted file mode 100644 index 8129659..0000000 --- a/boudin.sld +++ /dev/null
@@ -1,7 +0,0 @@
1(define-library (boudin)
2 (import (scheme base)
3 (scheme repl)
4 (boudin schmaltz))
5 (export hello)
6 (begin
7 (define hello "Hi")))
diff --git a/boudin.util.scm b/boudin.util.scm new file mode 100644 index 0000000..2683730 --- /dev/null +++ b/boudin.util.scm
@@ -0,0 +1,68 @@
1(declare (module (boudin util))
2 (export assoc-ref
3 slurp
4 wrap-paragraphs
5 edisplay
6 eprint))
7
8(import (srfi 1)
9 (srfi 152))
10
11(define (edisplay x)
12 (parameterize ((current-output-port (current-error-port)))
13 (display x)))
14
15(define (eprint . xs)
16 (parameterize ((current-output-port (current-error-port)))
17 (for-each display xs)
18 (newline)))
19
20(define (assoc-ref k alist)
21 (let ((k/v (and (pair? alist)
22 (assoc k alist))))
23 (if k/v (cdr k/v) #f)))
24
25(define (wrap-paragraphs text)
26 (let loop ((ps (map string-trim (*split-paragraphs text)))
27 (acc '()))
28 (cond
29 ((null? ps)
30 (apply string-append (reverse acc)))
31 ((zero? (string-length (car ps)))
32 (loop (cdr ps) acc))
33 ((eq? #\< (string-ref (car ps) 0))
34 (loop (cdr ps) (cons (car ps) acc)))
35 (else
36 (loop (cdr ps)
37 (cons (string-append "<p>" (car ps) "</p>\n")
38 acc))))))
39
40(define (*split-paragraphs text)
41 (define (*end-buf buf acc)
42 (cons (apply string-append (reverse buf)) acc))
43 (let loop ((ls (string-split text "\n"))
44 (buf '())
45 (acc '()))
46 (cond
47 ((and (null? ls)
48 (null? buf))
49 (reverse acc))
50 ((null? ls)
51 (loop '() '() (*end-buf buf acc)))
52 ((zero? (string-length (car ls)))
53 (loop (cdr ls) '() (*end-buf buf acc)))
54 (else
55 (loop (cdr ls)
56 (cons (string-append (car ls) "\n") buf)
57 acc)))))
58
59(define slurp
60 (case-lambda
61 (() (slurp (current-input-port)))
62 ((port)
63 (let loop ((ch (read-char port))
64 (acc '()))
65 (if (eof-object? ch)
66 (list->string (reverse acc))
67 (loop (read-char port)
68 (cons ch acc)))))))
diff --git a/lib/config.sld b/lib/config.sld deleted file mode 100644 index bdd6ef5..0000000 --- a/lib/config.sld +++ /dev/null
@@ -1,45 +0,0 @@
1;;; (boudin config) --- default values for configuration options
2;;
3;; To change these, make a `config.scm' in your site's root directory and change
4;; these. They're all parameters so .. change em like that.
5
6(define-library (boudin config)
7 (import (scheme base)
8 (boudin schmaltz)
9 ;; not portable
10 (chicken pathname)
11 (html-parser)
12 )
13
14 (export site-url site-dest
15 page-path-transformers page-text-transformers
16 page-template index-template feed-template)
17
18 (begin
19 ;; Site information
20 (define site-url
21 (make-parameter "example.com"))
22 (define site-dest
23 (make-parameter "out/"))
24 ;; Transformers
25 (define page-path-transformers
26 (make-parameter
27 (list (lambda (path) (make-pathname (site-dest) path)))))
28 (define page-text-transformers
29 (make-parameter
30 (list wrap-paragraphs
31 render-string
32 html->sxml)))
33 ;; Templates --- note that we use quote but include unquote forms here.
34 ;; This is to simplify the configuration and to avoid a cyclical dependency
35 ;; with (boudin types).
36 (define page-template
37 (make-parameter
38 '(html (@ (lang "en-us"))
39 (head (title (or (page-ref pg "title") "[untitled]")))
40 (body ,@(page-sxml pg)))))
41 (define index-template
42 (make-parameter 'todo))
43 (define feed-template
44 (make-parameter 'todo))
45 ))
diff --git a/lib/schmaltz.sld b/lib/schmaltz.sld deleted file mode 100644 index d54d53e..0000000 --- a/lib/schmaltz.sld +++ /dev/null
@@ -1,17 +0,0 @@
1(define-library (boudin schmaltz)
2 (export render
3 render-string
4 wrap-paragraphs)
5
6 (import (scheme base)
7 (scheme case-lambda) ; case-lambda
8 (scheme eval) ; eval
9 (scheme read) ; read
10 (scheme repl) ; interaction-environment
11 (scheme write) ; display
12 (only (html-parser)
13 sxml->html)
14 (only (srfi 152)
15 string-split string-trim))
16
17 (include "lib/schmaltz.sls"))
diff --git a/lib/schmaltz.sls b/lib/schmaltz.sls deleted file mode 100644 index 623191f..0000000 --- a/lib/schmaltz.sls +++ /dev/null
@@ -1,103 +0,0 @@
1;;; (boudin schmaltz) --- transform almost-html plus scheme into html
2
3;;; Embedded scheme code
4
5(define (->string x)
6 (call-with-port (open-output-string)
7 (lambda (port)
8 (display x port)
9 (get-output-string port))))
10
11(define render-string
12 (case-lambda
13 ((s) (render-string s (interaction-environment)))
14 ((s env)
15 (call-with-port (open-input-string s)
16 (lambda (port)
17 (render port env))))))
18
19(define (render port env)
20 ;; A few rough edges:
21 ;; #, x will try to render x
22 (define (burn-char)
23 ;; Throw a character away. I've defined this for clarity below.
24 (read-char port))
25
26 (let loop ((ch (read-char port))
27 (acc '()))
28 (define (proceed) (loop (read-char port) (cons ch acc)))
29 (cond
30 ((not ch)
31 (loop (read-char port) acc))
32 ((eof-object? ch)
33 (list->string (reverse acc)))
34 ((eq? ch #\#) ; special processing to come
35 (case (peek-char port)
36 ((#\\) ; inhibit processing of the next char
37 (burn-char)
38 (loop (read-char port) (cons ch acc)))
39 ((#\,) ; scheme eval expansion
40 (burn-char)
41 (loop #f
42 (append (let ((s (->string
43 (eval (read port)
44 env))))
45 (cond
46 ((equal? s "#<unspecified>") ; XXX NOT PORTABLE
47 '())
48 ((equal? s "#!eof") ; XXX NOT PORTABLE
49 '(#\, #\#))
50 (else (reverse (string->list s)))))
51 acc)))
52 ((#\@) ; embedded sxml
53 (burn-char)
54 (loop #f
55 (append (let ((h (eval `(sxml->html ,(list 'quasiquote
56 (read port)))
57 env)))
58 (cond
59 ((equal? h "#!eof") ; XXX NOT PORTABLE
60 '(#\@ #\#))
61 (else (reverse (string->list h)))))
62 acc)))
63 (else (proceed))))
64 (else (proceed)))))
65
66;;; Wrap paragraphs
67
68(define (split-paragraphs str)
69 (let loop ((lines (string-split str "\n"))
70 (par '())
71 (acc '()))
72 (cond
73 ((and (null? lines) ; base case: no more lines
74 (null? par)) ; ... or pending paragraph
75 (reverse acc))
76 ((null? lines) ; add the final paragraph
77 (loop '() '() (cons (apply string-append (reverse par)) acc)))
78 ((equal? (car lines) "") ; paragraph break
79 (loop (cdr lines)
80 '()
81 (cons (apply string-append (reverse par)) acc)))
82 (else ; line break
83 (loop (cdr lines)
84 (cons (string-append (car lines) "\n") par)
85 acc)))))
86
87(define (wrap-paragraphs str)
88 (let loop ((pars (split-paragraphs str))
89 (acc '()))
90 (cond
91 ((null? pars)
92 (apply string-append (reverse acc)))
93 ((zero? (string-length (car pars)))
94 (loop (cdr pars)
95 acc))
96 ((eq? #\< (string-ref (string-trim (car pars)) 0))
97 (loop (cdr pars)
98 (cons (car pars)
99 acc)))
100 (else
101 (loop (cdr pars)
102 (cons (string-append "<p>" (car pars) "</p>\n")
103 acc))))))
diff --git a/lib/types.sld b/lib/types.sld deleted file mode 100644 index 791ff53..0000000 --- a/lib/types.sld +++ /dev/null
@@ -1,24 +0,0 @@
1(define-library (boudin types)
2 (import (scheme base)
3 (scheme case-lambda)
4 (scheme file)
5 (boudin config)
6 (boudin util)
7 ;; non-portable bits
8 (chicken pathname)
9 (html-parser)
10 )
11
12 (export
13 ;; pages
14 make-page page?
15 page-path page-dest page-text page-sxml page-meta
16 set-page-dest! set-page-text! set-page-sxml! set-page-meta!
17 extract-metadata page-ref page-set!
18 page-url page-slug
19 read-page write-page
20 ;; indeces
21 ;; static files
22 )
23
24 (include "lib/types.sls"))
diff --git a/lib/types.sls b/lib/types.sls deleted file mode 100644 index 2b4da5d..0000000 --- a/lib/types.sls +++ /dev/null
@@ -1,72 +0,0 @@
1;;; (boudin types) --- pages, indeces, and static files
2
3;; All paths are relative to the site directory unless otherwise noted
4
5(define-record-type page
6 (make-page path ; Input path
7 dest ; Output path (rel. to output directory)
8 text ; Input text
9 sxml ; Rendered sxml
10 meta ; Metadata (title, etc.)
11 )
12 page?
13 (path page-path)
14 (dest page-dest set-page-dest!)
15 (text page-text set-page-text!)
16 (sxml page-sxml set-page-sxml!)
17 (meta page-meta set-page-meta!))
18
19(define (page-ref pg key)
20 (assoc-ref key (page-meta pg) (identity #f)))
21
22(define (page-set! pg key val)
23 (set-page-meta! pg (cons (cons key val)
24 (page-meta pg))))
25
26(define (extract-metadata sxml)
27 #f)
28
29(define (*urlify path)
30 (normalize-pathname
31 (make-pathname (list (site-url)
32 (pathname-strip-extension path))
33 "index.html")))
34
35(define (page-url pg) ; foo.html => http://site.com/foo/index.html
36 (or (page-ref pg "url") ; memoization
37 (let ((url (*urlify (page-path pg))))
38 (page-set! pg "url" url)
39 url)))
40
41(define (*slugify url) ; I don't love how this is written..
42 (let-values (((_ _ dirs) (decompose-directory url)))
43 (let loop ((this (car dirs))
44 (rest (cdr dirs)))
45 (if (null? (cdr rest))
46 (make-pathname (list "/" this) #f)
47 (loop (car rest)
48 (cdr rest))))))
49
50(define (page-slug pg) ; http://site.com/foo/index.html => /foo/
51 (or (page-ref pg "slug") ; memoization
52 (let ((slug (*slugify (page-url pg))))
53 (page-set! pg "slug" slug)
54 slug)))
55
56(define (read-page path)
57 (let ((pg (make-page path #f #f #f #f)))
58 (set-page-dest! pg ((apply o (page-path-transformers)) path))
59 (set-page-text! pg (with-input-from-file path slurp))
60 (set-page-sxml! pg ((apply o (page-text-transformers)) (page-text pg)))
61 (set-page-meta! pg (extract-metadata (page-sxml pg)))
62 pg))
63
64(define write-page
65 (case-lambda
66 ((pg) (call-with-output-file (page-dest pg)
67 (lambda (port) (write-page pg port))))
68 ((pg port)
69 (sxml-display-as-html ((eval/q (page-template)) pg) port))))
70
71
72
diff --git a/lib/util.sld b/lib/util.sld deleted file mode 100644 index 64c633e..0000000 --- a/lib/util.sld +++ /dev/null
@@ -1,50 +0,0 @@
1;;; (boudin util) --- utility functions
2
3(define-library (boudin util)
4 (import (scheme base)
5 (scheme case-lambda)
6 (scheme eval))
7
8 (export identity
9 o
10 assoc-ref
11 slurp
12 eval/q)
13
14 (begin
15 (define (identity x) x)
16
17 (define (o . procs) ; stole from chicken core
18 (if (null? procs)
19 identity
20 (let loop ((procs procs))
21 (let ((h (car procs))
22 (t (cdr procs)))
23 (if (null? t)
24 h
25 (lambda (x) (h ((loop t) x))))))))
26
27 (define assoc-ref
28 (case-lambda
29 ((key alist)
30 (assoc-ref alist
31 key
32 (lambda () (error "Unrecognized key." key))))
33 ((key alist failure)
34 (cond ((assoc key alist) => cdr)
35 (else (failure))))))
36
37 (define slurp
38 (case-lambda
39 (() (slurp (current-input-port)))
40 ((port)
41 (let loop ((ch (read-char))
42 (acc '()))
43 (if (eof-object? ch)
44 (list->string (reverse acc))
45 (loop (read-char) (cons ch acc)))))))
46
47 (define (eval/q form env) ; this is probably a bad idea
48 (eval (list 'quasiquote form) env))
49
50 ))
diff --git a/test/foo.html b/test/foo.html new file mode 100644 index 0000000..c21e761 --- /dev/null +++ b/test/foo.html
@@ -0,0 +1,3 @@
1a test file
2
3#,(+ 1 2)
diff --git a/test/out/feed.xml b/test/out/feed.xml new file mode 100644 index 0000000..2f1f29f --- /dev/null +++ b/test/out/feed.xml
@@ -0,0 +1,25 @@
1<?xml version="1.0" encoding="utf-8"?>
2<feed xmlns="http://www.w3.org/2005/Atom">
3 <author>
4 <name>nobody</name>
5 <uri>example.com</uri>
6 </author>
7 <generator uri="https://git.acdw.net/boudin" version="rice">Boudin</generator>
8 <id>example.com</id>
9 <link href="example.com" rel="alternate" type="text/html" hreflang="en" />
10 <link href="example.com/feed.xml" rel="self" type="application/atom+xml" />
11 <rights type="text">(C) nobody</rights>
12 <title type="text">a boudin site</title>
13 <updated>2023-09-07T03:42:00Z</updated>
14 <entry>
15 <content type="html"><![CDATA[<p>a test file
16</p>
17<p>3
18</p>
19]]></content>
20 <id>https:/example.com/foo/index.html</id>
21 <title type="text">[untitled]</title>
22 <updated>Wed Sep 6 04:59:10 2023</updated>
23 <link href="https:/example.com/foo/index.html" rel="alternate" type="text/html" />
24 </entry>
25</feed> \ No newline at end of file
diff --git a/test/out/foo/index.html b/test/out/foo/index.html new file mode 100644 index 0000000..7d408f6 --- /dev/null +++ b/test/out/foo/index.html
@@ -0,0 +1,5 @@
1<html lang="en-us"><head><meta charset="utf-8"></meta><meta name="viewport" content="initial-scale=1.0"></meta><link href="/style.css" rel="stylesheet"></link><title>[untitled]</title></head><body><p>a test file
2</p>
3<p>3
4</p>
5</body></html> \ No newline at end of file
diff --git a/test/out/index.html b/test/out/index.html new file mode 100644 index 0000000..2267cf0 --- /dev/null +++ b/test/out/index.html
@@ -0,0 +1 @@
<html lang="en-us"><head><meta charset="utf-8"></meta><meta name="viewport" content="initial-scale=1.0"></meta><link href="/style.css" rel="stylesheet"></link><title>a boudin site</title></head><body><h1>a boudin site</h1><ul><li><a href="/foo/">/foo/</a></li></ul></body></html> \ No newline at end of file