commit 310521c415f9e8b758933fbcb09ec836482879ec
parent e17d1e847a955dbfce44d4cee8621d222974bfc6
Author: Luke Willis <lukejw@loquat.dev>
Date: Sat, 5 Jul 2025 02:21:40 -0400
Tie a lot of things together
Diffstat:
7 files changed, 208 insertions(+), 88 deletions(-)
diff --git a/example/grug.scm b/example/grug.scm
@@ -0,0 +1,7 @@
+(use-modules (grug site)
+ (grug builders))
+
+(site #:metadata `((title . "Example Site"))
+ #:builders (list (simple-pages "pages")
+ (copy-directory "css")
+ (blog "posts" #:prefix "/blog")))
diff --git a/example/pages/about.md b/example/pages/about.md
@@ -1,2 +1,7 @@
`((title . "About Me"))
This is some information about me.
+
+- I am `N/A` years old
+- I am a test website
+
+Isn't that cool?
diff --git a/example/pages/index.md b/example/pages/index.md
@@ -0,0 +1,8 @@
+`((title . "Welcome"))
+This is the homepage for this example site.
+
+Feel free to visit these pages:
+- [About Me](about.html)
+- [Blog](blog/index.html)
+
+Everything should work!
diff --git a/grug/builders.scm b/grug/builders.scm
@@ -5,6 +5,7 @@
#:use-module (htmlprag)
#:use-module (grug utils)
#:use-module (grug readers)
+ #:use-module (grug site)
#:export (copy-directory
simple-pages
blog))
@@ -16,25 +17,25 @@
;; This is good for things like CSS folders.
(define* (copy-directory directory
#:key
- (prefix "site"))
- (display "copy-directory\n")
+ (prefix ""))
+ (lambda (site)
+ (display "copy-directory\n")
+ (for-each
+ (lambda (path)
+ (let* ((output-path (string-append (site-build-directory site) prefix "/" path))
+ (output-dir (dirname output-path)))
+ (format #t "\t~A -> ~A\n" path output-path)
+ (mkdir-p output-dir)
+ (copy-file path output-path)))
+ (reverse (ls-recursive directory)))))
- (for-each
- (lambda (path)
- (let* ((output-path (string-append prefix "/" path))
- (output-dir (dirname output-path)))
- (format #t "\t~A -> ~A\n" path output-path)
- (unless (file-exists? output-dir) (mkdir output-dir))
- (copy-file path output-path)))
- (reverse (ls-recursive directory))))
-
-;; metadata should be an a-list
-(define (basic-template body metadata)
+;; Metadata should be an a-list
+(define (basic-template site-metadata metadata body)
`(*TOP* (*DECL* DOCTYPE html)
(html
(head
(meta (@ (charset "utf-8")))
- (title ,(assoc-ref metadata 'title)))
+ (title ,(assoc-ref metadata 'title) " - " ,(assoc-ref site-metadata 'title)))
(body
(h1 ,(assoc-ref metadata 'title))
,@body))))
@@ -43,31 +44,30 @@
;; This is good for things like 'About' or 'Contact' pages.
(define* (simple-pages directory
#:key
- (prefix "site")
+ (prefix "")
(reader cmark)
(template basic-template))
- (display "simple-pages\n")
-
- ;; Iterate through files in directory
- (for-each
- (lambda (path)
- (let* ((output-dir
- (string-append prefix
- (substring (dirname path)
- (string-length directory))))
- (output-path
- (string-append output-dir "/"
- (strip-extension path)
- ".html")))
- (unless (file-exists? output-dir) (mkdir output-dir))
- (format #t "\t~A -> ~A\n" path output-path)
- (receive (metadata contents)
- (load-string-with-metadata path)
- (let* ((base-shtml (reader contents))
- (built-shtml (template base-shtml metadata))
- (output (shtml->html built-shtml)))
- (write-string-to-path output output-path)))))
- (reverse (ls-recursive directory))))
+ (lambda (site)
+ (display "simple-pages\n")
+ (for-each
+ (lambda (path)
+ (let* ((output-dir
+ (string-append (site-build-directory site) prefix
+ (substring (dirname path)
+ (string-length directory))))
+ (output-path
+ (string-append output-dir "/"
+ (strip-extension path)
+ ".html")))
+ (mkdir-p output-dir)
+ (format #t "\t~A -> ~A\n" path output-path)
+ (receive (metadata contents)
+ (load-string-with-metadata path)
+ (let* ((base-shtml (reader contents))
+ (built-shtml (template (site-metadata site) metadata base-shtml))
+ (output (shtml->html built-shtml)))
+ (write-string-to-path output output-path)))))
+ (reverse (ls-recursive directory)))))
;; `posts` should be a list of a-lists containing post metadata
(define (basic-collection-template posts)
@@ -76,18 +76,16 @@
(lambda (a b)
(string>? (assoc-ref a 'date)
(assoc-ref b 'date))))
- ;; Return shtml for all the posts posts
`((h1 "Posts")
- ,@(map (lambda (post)
- `(article (h2 (a (@ (href ,(assoc-ref post 'uri)))
- ,(assoc-ref post 'title)))
- ;; Parse ISO 8601 date from 'date and reformat it to look nice
- (h3 ,(date->string
- (string->date (assoc-ref post 'date)
- "~Y~m~d")
- "~B ~d, ~Y"))
- (p ,(assoc-ref post 'description))))
- posts)))
+ ,@(map
+ (lambda (post)
+ `(article (h2 (a (@ (href ,(assoc-ref post 'uri)))
+ ,(assoc-ref post 'title)))
+ ;; Parse ISO 8601 date from 'date and reformat it to look nice
+ (h3 ,(date->string
+ (string->date (assoc-ref post 'date) "~Y~m~d") "~B ~d, ~Y"))
+ (p ,(assoc-ref post 'description))))
+ posts)))
;; Build a blog using the posts in the given directory.
;;
@@ -95,43 +93,43 @@
;; Posts have 'uri added to their metadata.
(define* (blog directory
#:key
- (prefix "site")
+ (prefix "")
(post-prefix "posts")
(metadata `((title . "Recent Posts")))
(reader cmark)
(template basic-template)
(collection-template basic-collection-template))
- (display "blog\n")
-
- (let ((posts (map
- (lambda (path)
- (let* ((output-name
- (string-append (strip-extension path)
- ".html"))
- (relative-output-dir
- (string-append post-prefix
- (substring (dirname path)
- (string-length directory))))
- (relative-output-path
- (string-append relative-output-dir "/"
- output-name))
- (output-dir
- (string-append prefix "/" relative-output-dir))
- (output-path
- (string-append output-dir "/"
- output-name)))
- (unless (file-exists? output-dir) (mkdir output-dir))
- (format #t "\t~A -> ~A\n" path output-path)
- (receive (metadata contents)
- (load-string-with-metadata path)
- (let* ((base-shtml (cmark contents))
- (built-shtml (template base-shtml metadata))
- (output (shtml->html built-shtml)))
- (write-string-to-path output output-path))
- (acons 'uri relative-output-path metadata))))
- (reverse (ls-recursive directory)))))
- ;; Build index.html
- (let ((output (shtml->html (template (collection-template posts) metadata)))
- (output-path (string-append prefix "/index.html")))
- (format #t "\t~A\n" output-path)
- (write-string-to-path output output-path))))
+ (lambda (site)
+ (display "blog\n")
+ (let ((posts (map
+ (lambda (path)
+ (let* ((output-name
+ (string-append (strip-extension path)
+ ".html"))
+ (relative-output-dir
+ (string-append post-prefix
+ (substring (dirname path)
+ (string-length directory))))
+ (relative-output-path
+ (string-append relative-output-dir "/"
+ output-name))
+ (output-dir
+ (string-append (site-build-directory site) prefix "/" relative-output-dir))
+ (output-path
+ (string-append output-dir "/"
+ output-name)))
+ (format #t "\t~A -> ~A\n" path output-path)
+ (mkdir-p output-dir)
+ (receive (metadata contents)
+ (load-string-with-metadata path)
+ (let* ((base-shtml (cmark contents))
+ (built-shtml (template (site-metadata site) metadata base-shtml))
+ (output (shtml->html built-shtml)))
+ (write-string-to-path output output-path))
+ (acons 'uri relative-output-path metadata))))
+ (reverse (ls-recursive directory)))))
+ ;; Build index.html
+ (let ((output (shtml->html (template (site-metadata site) metadata (collection-template posts))))
+ (output-path (string-append (site-build-directory site) prefix "/index.html")))
+ (format #t "\t~A\n" output-path)
+ (write-string-to-path output output-path)))))
diff --git a/grug/site.scm b/grug/site.scm
@@ -0,0 +1,32 @@
+(define-module (grug site)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (grug readers)
+ #:use-module (grug utils)
+ #:export (site
+ site?
+ site-build-directory
+ site-metadata
+ site-reader
+ site-builders
+ build-site))
+
+(define-record-type <site>
+ (make-site build-directory metadata reader builders)
+ site?
+ (build-directory site-build-directory)
+ (metadata site-metadata)
+ (reader site-reader)
+ (builders site-builders))
+
+(define* (site #:key
+ (build-directory "site")
+ (metadata `((title . "Grug Site")))
+ (reader cmark)
+ (builders '()))
+ (make-site build-directory metadata reader builders))
+
+(define (build-site site)
+ (delete-file-recursively (site-build-directory site))
+ (mkdir (site-build-directory site))
+ (for-each (cut <> site) (site-builders site)))
diff --git a/grug/ui.scm b/grug/ui.scm
@@ -1,12 +1,27 @@
;;; Grug user interface.
(define-module (grug ui)
+ #:declarative? #f
#:use-module (ice-9 pretty-print)
- #:use-module (grug builders)
+ #:use-module (grug site)
#:export (main))
+(define (absolute-file-name file-name)
+ "Return a an absolute file name string relative to the current
+working directory for FILE-NAME, a relative file name string. If
+FILE-NAME happens to already be absolute, FILE-NAME is returned
+as-is."
+ (if (absolute-file-name? file-name)
+ file-name
+ (string-append (getcwd) "/" file-name)))
+
+(define* (load-config filename)
+ (if (file-exists? filename)
+ (let ((obj (load (absolute-file-name filename))))
+ (if (site? obj)
+ obj
+ (error "Configuration does not return site")))
+ (error "Configuration not found")))
+
(define* (main prog . args)
- (pretty-print args)
- (simple-pages "pages")
- (copy-directory "css")
- (blog "posts"))
+ (build-site (load-config "grug.scm")))
diff --git a/grug/utils.scm b/grug/utils.scm
@@ -4,9 +4,12 @@
#:use-module (ice-9 eval-string)
#:use-module (ice-9 ftw)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:export (strip-extension
ls-recursive
+ delete-file-recursively
+ mkdir-p
load-string-with-metadata
write-string-to-path))
@@ -25,6 +28,58 @@
(noop (lambda (path stat result) result)))
(file-system-fold enter? leaf noop noop noop err '() directory)))
+;; Written by Ludovic Courtès for GNU Guix.
+(define* (delete-file-recursively dir
+ #:key follow-mounts?)
+ "Delete DIR recursively, like `rm -rf', without following symlinks. Don't
+follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
+errors."
+ (let ((dev (stat:dev (lstat dir))))
+ (file-system-fold (lambda (dir stat result) ; enter?
+ (or follow-mounts?
+ (= dev (stat:dev stat))))
+ (lambda (file stat result) ; leaf
+ (delete-file file))
+ (const #t) ; down
+ (lambda (dir stat result) ; up
+ (rmdir dir))
+ (const #t) ; skip
+ (lambda (file stat errno result)
+ (format (current-error-port)
+ "warning: failed to delete ~a: ~a~%"
+ file (strerror errno)))
+ #t
+ dir
+
+ ;; Don't follow symlinks.
+ lstat)))
+
+;; Written by Ludovic Courtès for GNU Guix.
+(define (mkdir-p dir)
+ "Create directory DIR and all its ancestors."
+ (define absolute?
+ (string-prefix? "/" dir))
+
+ (define not-slash
+ (char-set-complement (char-set #\/)))
+
+ (let loop ((components (string-tokenize dir not-slash))
+ (root (if absolute?
+ ""
+ ".")))
+ (match components
+ ((head tail ...)
+ (let ((path (string-append root "/" head)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir path)
+ (loop tail path))
+ (lambda args
+ (if (= EEXIST (system-error-errno args))
+ (loop tail path)
+ (apply throw args))))))
+ (() #t))))
+
;; Load a file, parse metadata from the top of the file and return the rest as a string.
;; Using eval-string might be overkill. Perhaps a custom parser should be written?
;; TODO: Allow for multi-line metadata
