#!/usr/bin/env chicken-scheme
;; An opinionated static file generator for authoring simple websites.
;; Copyright (C) 2026 Diego A. Mundo
;; This program is free software: you can redistribute it and/or modify it
;; under the terms of version 3 of the GNU Affero General Public License as
;; published by the Free Software Foundation.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(module pebble ()
(import (except (scheme base) raise)
(scheme file)
(scheme process-context)
(except (chicken base) exit)
(chicken port)
(except (chicken file) file-exists?)
(chicken file posix)
(chicken pathname)
(chicken io)
(chicken string)
(chicken process-context)
lowdown
sxml-transforms
getopt-long
(srfi 18)
(srfi 1))
(cond-expand
((library inotify)
(import inotify))
(else))
(cond-expand
((library spiffy)
(import (prefix spiffy spiffy:)))
(else
(define spiffy:start-server void)))
(define pebble-source
(make-parameter
"./source/"
(lambda (dir)
(if (string? dir)
(normalize-pathname dir)
(error "Bad pebble-source" dir)))))
(define pebble-root
(make-parameter
"./site/"
(lambda (s)
(cond ((string? s)
(let ((normalized (normalize-pathname s)))
(cond-expand
((library spiffy)
(spiffy:root-path normalized))
(else))
normalized))
(else (error "Bad pebble-root" s))))))
(define pebble-quiet
(make-parameter #f))
(define (pre-file)
(make-pathname (pebble-source) "static/pebble-pre.md"))
(define (post-file)
(make-pathname (pebble-source) "static/pebble-post.md"))
(define (pebble-log . rest)
(unless (pebble-quiet)
(apply print rest)
(flush-output-port)))
(define copy-function
(make-parameter
"link"
(lambda (m)
(cond ((string=? m "copy")
(lambda (old new)
(copy-file old new 'clobber)))
((string=? m "link")
(lambda (old new)
(when (file-exists? new)
(delete-file new))
(file-link old new)))
((string=? m "symlink")
(lambda (old new)
(when (file-exists? new)
(delete-file new))
(create-symbolic-link old new)))))))
(define (sxml->html sxml out)
(parameterize ((current-output-port out))
(SRV:send-reply
(pre-post-order*
sxml
;; LITERAL tag contents are used as raw HTML.
`((literal *preorder* . ,(lambda (tag body) (map ->string body)))
,@universal-conversion-rules*)))))
(define (->html body-proc)
(lambda (input output)
(cond-expand
(chicken-5 (write-string "" #f output))
(else (write-string "" output)))
(sxml->html
`(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(lang "en"))
(head
(meta (@ (charset "utf-8")))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1.0, user-scalable=yes" )))
;; (title ,title)
((link (@ (rel "stylesheet") (type "text/css")
(href "/static/pebble.css"))))
((script (@ (src "/static/pebble.js")))))
(body
,@(if (file-exists? (pre-file))
(call-with-input-file (pre-file) markdown->sxml)
'())
(article
,(body-proc input))
,@(if (file-exists? (post-file))
(call-with-input-file (post-file) markdown->sxml)
'())))
output)))
(define markdown-source->html-root (->html markdown->sxml))
(define sxml-source->html-root (->html read-list))
(define html-source->html-root (->html
(lambda (input)
`(literal
,(read-string #f input)))))
(define file-translators
`(("md" . ,markdown-source->html-root)
("sxml" . ,sxml-source->html-root)
("html" . ,html-source->html-root)))
(define raw-file-translators
`(("md" . ,(lambda (in out)
(parameterize ((current-output-port out))
(markdown->html in))))
("sxml" . ,sxml->html)))
(define (enough-namestring pathname #!optional (defaults (current-directory)))
(receive (origin1 base1 default-elements) (decompose-directory defaults)
(receive (origin2 base2 elements) (decompose-directory (pathname-directory pathname))
(cond ((not (equal? base1 base2))
pathname)
(else
(let loop ((elems1 default-elements)
(elems2 elements))
(cond ((null? elems1)
(make-pathname (foldr make-pathname "" elems2)
(pathname-strip-directory pathname)))
((or (null? elems2)
(not (string=? (car elems1) (car elems2))))
pathname)
(else
(loop (cdr elems1) (cdr elems2))))))))))
(define (source-path->root-path source-path)
(let* ((filename (pathname-file source-path))
(extension (pathname-extension source-path))
(source-path (if (and filename
(equal? #\_ (string-ref filename 0))
(member extension '("md" "sxml" "html") equal?))
(pathname-replace-file source-path (substring filename 1))
source-path))
(base-root-path (make-pathname
(pebble-root)
(enough-namestring source-path (pebble-source)))))
(cond ((member extension '("md" "sxml") equal?)
(pathname-replace-extension base-root-path "html"))
(else base-root-path))))
(define (source-file->root-file source-path #!optional force)
(let* ((extension (pathname-extension source-path))
(name (pathname-file source-path))
(root-path (source-path->root-path source-path))
(exists (file-exists? source-path))
(source-modified (and exists (file-modification-time source-path)))
(root-exists (file-exists? root-path))
(root-modified (and root-exists (file-modification-time root-path)))
(translate (or (and (not (equal? #\_ (string-ref name 0)))
(alist-ref extension file-translators equal?))
(alist-ref extension raw-file-translators equal?))))
(when (and exists
(or force
(not root-exists)
(> source-modified root-modified)
(and translate
(or (and (file-exists? (pre-file))
(> (file-modification-time (pre-file)) root-modified))
(and (file-exists? (post-file))
(> (file-modification-time (post-file)) root-modified))))))
;; This create-diretory was in the watch! function, but it makes more
;; sense to create dirs as needed. Plus I think this fixes the
;; non-watch case where a dir doesn't yet exist?
(create-directory (if (directory? source-path)
root-path
(pathname-directory root-path))
'parents)
(cond (translate
(pebble-log "Writing " source-path " to " root-path)
(call-with-input-file source-path
(lambda (in)
(call-with-output-file root-path
(lambda (out)
(translate in out))))))
((and (not (eqv? force #:pre-post))
(not (directory? source-path)))
(pebble-log "Copying or linking " source-path " to " root-path)
((copy-function) source-path root-path))))))
(cond-expand
((library inotify)
(define (watch!)
(init!)
(add-watch-recursively! (pebble-source) '(create delete modify move))
(let loop ((events (next-events!)))
;; (print events)
(let ((event (car events)))
(let* ((flags (event-flags event))
(name (event-name event))
(wd (event-wd event))
(cookie (event-cookie event))
(event-path (make-pathname (wd->path wd) name))
(normalized-path (normalize-pathname event-path))
(root-path (source-path->root-path event-path)))
(define (delete-it file)
(when (file-exists? file)
(pebble-log "Deleting " file)
(if (member 'isdir flags)
(delete-directory file)
(delete-file file))))
(define (create-it source-path)
(cond ((member 'isdir flags)
;; make sure to watch new dirs for changes!
(pebble-log "Watching directory " source-path)
(generate-site! #:dir source-path)
(add-watch-recursively! source-path '(create delete modify move)))
(else
(source-file->root-file source-path))))
;; (pebble-log flags " " event-path " " root-path)
(cond ((and (or (equal? normalized-path (pre-file))
(equal? normalized-path (post-file))))
(generate-site! #:force #:pre-post)
(loop (if (null? (cdr events)) (next-events!) (cdr events))))
((member 'create flags)
(create-it event-path)
(loop (if (null? (cdr events)) (next-events!) (cdr events))))
((member 'modify flags)
;; dir modification shouldn't do anything, otherwise handle
;; file modification
(unless (member 'isdir flags)
(source-file->root-file event-path))
(loop (if (null? (cdr events)) (next-events!) (cdr events))))
;; uhhhhh this is kinda complicated to do in the general
;; case? this assumes we will get both a moved-from and a
;; moved-to in the same next-events!, which is not always
;; the case, but should be fine for simple renames (e.g.
;; not bulk or concurrent)
((member 'moved-from flags)
(let ((moved-to (find
(lambda (e)
(and (= cookie (event-cookie e))
(member 'moved-to (event-flags e))))
events)))
(cond (moved-to
(let* ((wd (event-wd moved-to))
(event-path (make-pathname (wd->path wd) (event-name moved-to)))
(moved-to-root-path (source-path->root-path event-path)))
(pebble-log "Renaming " root-path " to " moved-to-root-path)
(rename-file root-path moved-to-root-path))
(loop
(if (null? (cddr events)) ;; only moved-from and moved-to
(next-events!)
(delete moved-to (cdr events)))))
;; otherwise, treat this like a delete
(else
(delete-it root-path)
(loop (if (null? (cdr events)) (next-events!) (cdr events)))))))
;; under the assumption above, this is just a create
((member 'moved-to flags)
(create-it event-path)
(loop (if (null? (cdr events)) (next-events!) (cdr events))))
((member 'delete flags)
(delete-it root-path)
(loop (if (null? (cdr events)) (next-events!) (cdr events))))
(else ;; catch other flags(?) like ignore
(loop (if (null? (cdr events)) (next-events!) (cdr events))))))))))
(else (define watch! void)))
(define pebble-args
`((help "print usage" (single-char #\h))
(source "specify source directory (default ./source)"
(value (required "SOURCE-DIR")
(transformer ,pebble-source)))
(root "specify site root directory (defoult ./site)"
(value (required "ROOT-DIR")
(transformer ,pebble-root)))
(copy "how to copy files to ROOT-DIR (link, copy, symlink)"
(value (required "METHOD")
(transformer ,copy-function)))
(force "force re-write unmodified files"
(single-char #\f))
(quiet "suppress output" (single-char #\q))
,@(cond-expand
((library inotify)
'((watch "watch SOURCE-DIR for changes and update ROOT-DIR"
(single-char #\w))))
(else '()))
,@(cond-expand
((library spiffy)
`((server "start a spiffy server with ROOT-DIR as root-path"
(single-char #\s))
(port "port for spiffy server"
(single-char #\p)
(value (required "PORT")
(transformer
,(lambda (p)
(spiffy:server-port (string->number p))))))
(user "user for spiffy server"
(single-char #\u)
(value (required "USER")
(transformer spiffy:spiffy-user)))
(group "group for spiffy server"
(single-char #\g)
(value (required "GROUP")
(transformer spiffy:spiffy-group)))))
(else '()))))
(define (pebble-usage status)
(print "Usage: pebble [OPTION]...
version 0.1.4
An opinionated static file generator for authoring simple websites. This
software is licensed AGPL-3.0-only.
Pebble converts a source directory SOURCE-DIR into a website root directory
ROOT-DIR. Source Markdown, SXML, and HTML files are wrapped with and
converted to site root HTML files with reasonable meta information. All other
files are copied or linked as-is.
Pebble sites can be customized using four optional files:
SOURCE-DIR/static/pebble.css
stylesheet included in
SOURCE-DIR/static/pebble.js
javascript included in
SOURCE-DIR/static/pebble-pre.md
markdown (including literal HTML) to insert before content (e.g. site
header). Not copied to ROOT-DIR.
SOURCE-DIR/static/pebble-post.md
markdown (including literal HTML) to insert after content (e.g. site
footer). Not copied to ROOT-DIR.
Bare files without meta info or pre/post content can be generated by prefixing
Markdown, SXML, or HTML filenames in SOURCE-DIR with an underscore, which is
stripped in ROOT-DIR.
A static pebble executable can be generated as follows (ideally with musl libc):
chicken-install pebble -D pebble-static
OPTIONS:")
(print (usage pebble-args))
(print "Note that some options are only available if the spiffy or inotify eggs were
installed at pebble build time, and are not shown otherwise.
Source code and bug reports at https://sr.ht/~dieggsy/pebble/")
(exit status))
(define (generate-site! #!key force (dir (pebble-source)))
(find-files
dir
#:test (lambda (file)
(not (or (equal? (normalize-pathname file) (pre-file))
(equal? (normalize-pathname file) (post-file)))))
#:action (lambda (file _)
(source-file->root-file file force))))
(define (main args)
(let* ((options (getopt-long args pebble-args
#:unknown-option-handler (lambda (c) (pebble-usage 1))))
(watch (alist-ref 'watch options))
(force (alist-ref 'force options)))
(pebble-quiet (alist-ref 'quiet options))
(when (alist-ref 'help options)
(pebble-usage 0))
(create-directory (pebble-source) 'parents)
(create-directory (pebble-root) 'parents)
(generate-site! #:force force)
(let ((server-thread (make-thread spiffy:start-server))
(watch-thread (make-thread watch!)))
(when watch
(thread-start! watch-thread))
(when (alist-ref 'server options)
(thread-start! server-thread)
(thread-join! server-thread))
(when watch
(thread-join! watch-thread)))))
(main (command-line-arguments)))