#!/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)))
(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 (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 watch-loop ()
(let ((events (next-events!)))
;; (print events)
(for-each
(lambda (event)
(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)))
;; (print flags " " event-path " " root-path)
(cond ((and (or (equal? normalized-path (pre-file))
(equal? normalized-path (post-file))))
(generate-site! #:pre-post))
((member 'create flags)
(cond ((member 'isdir flags)
;; make sure to watch new dirs for changes!
(add-watch-recursively! event-path '(create delete modify move)))
(else
(source-file->root-file event-path))))
((member 'modify flags)
;; dir modification shouldn't do anything, otherwise handle
;; file modification
(unless (member 'isdir flags)
(source-file->root-file event-path)))
;; 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! Not sure we can always
;; make that assumption.
((member 'moved-from flags)
(let* ((moved-to (find
(lambda (e)
(and (= cookie (event-cookie e))
(member 'moved-to (event-flags e))))
events))
(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)))
((member 'delete flags)
(when (file-exists? root-path)
(pebble-log "Deleting " root-path)
(if (member 'isdir flags)
(delete-directory root-path)
(delete-file root-path)))))))
events))
(watch-loop))))
(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! #!optional force)
(find-files
(pebble-source)
#: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)
(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)))