From 76b7e6eeaf99e5aeac3d9f651bc548f2c537ce85 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Thu, 24 Aug 2023 12:42:22 -0500 Subject: bleh --- lib/config.sld | 16 +++++++++-- lib/types.sld | 17 ++++++++++- lib/types.sls | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- lib/util.sld | 38 +++++++++++++++++++++++- 4 files changed, 155 insertions(+), 7 deletions(-) (limited to 'lib') 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 @@ (boudin schmaltz) ;; not portable (chicken pathname) + (chicken time posix) (html-parser) ) (export site-url site-dest page-path-transformers page-text-transformers - page-template index-template feed-template) + page-date-formats + page-template index-template feed-template + build-time) (begin ;; Site information @@ -42,4 +45,13 @@ (make-parameter 'todo)) (define feed-template (make-parameter 'todo)) - )) + ;; Miscellaneous + (define page-date-formats + (make-parameter (list "%Y-%m-%d" + "%Y-%m-%d%n%H:%M" + "%Y-%m-%d%n%I:%M%n%p"))) + ;; Not actually configuration, but state ... meh + (define build-time + (make-parameter + (time->string (seconds->utc-time) "%FT%TZ")))) + ) 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 @@ (define-library (boudin types) (import (scheme base) (scheme case-lambda) + (scheme cxr) (scheme file) + (scheme write) (boudin config) (boudin util) + (srfi 1) + (srfi 152) ;; non-portable bits + (chicken file) + (chicken file posix) (chicken pathname) + (chicken time posix) (html-parser) ) @@ -15,10 +22,18 @@ page-path page-dest page-text page-sxml page-meta set-page-dest! set-page-text! set-page-sxml! set-page-meta! extract-metadata page-ref page-set! - page-url page-slug + page-url page-slug page-updated read-page write-page ;; indeces + make-index index? + index-dest index-template index-writer index-pages index-meta + set-index-dest! set-index-template! set-index-writer! set-index-pages! + set-index-meta! + index-ref index-set! index-push! + index-for-each + write-index ;; static files + static-copy ) (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 @@ ;;; (boudin types) --- pages, indeces, and static files - +;; ;; All paths are relative to the site directory unless otherwise noted +;;; Pages + (define-record-type page (make-page path ; Input path dest ; Output path (rel. to output directory) @@ -17,14 +19,33 @@ (meta page-meta set-page-meta!)) (define (page-ref pg key) - (assoc-ref key (page-meta pg) (identity #f))) + (assoc-ref key (page-meta pg) (lambda _ #f))) (define (page-set! pg key val) (set-page-meta! pg (cons (cons key val) (page-meta pg)))) (define (extract-metadata sxml) - #f) + (let loop ((tree sxml) + (acc '())) + (cond + ((not (pair? tree)) + (reverse acc)) + ((and (list? (car tree)) + (eq? (caar tree) '*COMMENT*)) + (loop (cdr tree) + (map (lambda (ln) + (let ((kv (string-split ln ":" 'infix 1))) + (cons (string-trim-both (car kv)) + (string-trim (cdr kv))))) + (string-split (cadar tree) "\n")))) + ((list? (car tree)) + (loop (cdr tree) + (let ((subtree (loop (car tree) '()))) + (if (null? subtree) + acc + (cons subtree acc))))) + (else (loop (cdr tree) acc))))) (define (*urlify path) (normalize-pathname @@ -53,6 +74,20 @@ (page-set! pg "slug" slug) slug))) +(define (*page-mtime pg) + (let ((file (page-path pg))) + (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 + (find (lambda (fmt) (string->time meta-date fmt)) + (page-date-formats))) + (*page-mtime pg) + (build-time)))) + (define (read-page path) (let ((pg (make-page path #f #f #f #f))) (set-page-dest! pg ((apply o (page-path-transformers)) path)) @@ -69,4 +104,54 @@ (sxml-display-as-html ((eval/q (page-template)) pg) port)))) +;;; Indeces +;; These are generated pages from collections of other pages. Think index.html, +;; feed.xml, possibly tag indeces and the like. These pages don't have a source +;; file, but they have a destination and a template. Because there are +;; different file formats here and ... stuff, there's also a slot for the index +;; writer function. Finally, pages and meta are the pages and various other +;; metadata of the index. + +(define-record-type index + (make-index dest ; Relative to (site-dest) + template ; Template to put pages in + writer ; Proc to write sxml out to a file + pages ; Input pages + meta ; Various other metadata + ) + index? + (dest index-dest set-index-dest!) + (template index-template set-index-template!) + (writer index-writer set-index-writer!) + (pages index-pages set-index-pages!) + (meta index-meta set-index-meta!)) + +(define (index-ref idx key) + (assoc-ref key (index-meta idx) (lambda _ #f))) + +(define (index-set! idx key val) + (set-index-meta! idx (cons (cons key val) + (index-meta idx)))) + +(define (index-push! idx pg) + (set-index-pages! idx (cons pg (index-pages idx)))) + +(define (index-for-each idx proc) + (for-each proc (index-pages idx))) + +(define write-index + (case-lambda + ((idx) (call-with-output-file (index-dest idx) + (lambda (port) (write-index idx (current-output-port))))) + ((idx port) + ((index-writer idx) ((index-template idx) (index-pages idx)) port)))) + + +;;; Static files +;; These are simply copied from the input to the output, possibly with a changed +;; path. Because these are just files, we don't need a record type. +(define (static-copy path) + (copy-file path + (make-pathname (site-dest) path) + '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 @@ (export identity o + constantly assoc-ref slurp - eval/q) + eval/q + intersperse + string-intersperse) (begin (define (identity x) x) @@ -24,6 +27,9 @@ h (lambda (x) (h ((loop t) x)))))))) + (define (constantly x) + (lambda _ x)) + (define assoc-ref (case-lambda ((key alist) @@ -47,4 +53,34 @@ (define (eval/q form env) ; this is probably a bad idea (eval (list 'quasiquote form) env)) + (define (intersperse xs delim) + (if (null? xs) + '() + (let loop ((acc (list (car xs))) + (rest (cdr xs))) + (if (null? rest) + (reverse acc) + (loop (cons (car rest) (cons delim acc)) + (cdr rest)))))) + + (define (string-intersperse ss delim) + (apply string-append (intersperse ss delim))) + + (define index + (case-lambda + ((xs needle) + (index xs needle eq? (constantly #f))) + ((xs needle comparator) + (index xs needle comparator (constantly #f))) + ((xs needle comparator fail) + (let loop ((i 0) + (xs xs)) + (cond + ((null? xs) (fail)) + ((comparator (car xs) needle) i) + (else (loop (+ i 1) (cdr xs)))))))) + + (define (string-index str ch) + (index (string->list str) ch)) + )) -- cgit 1.4.1-21-gabe81