summaryrefslogtreecommitdiff
path: root/haunt.scm
diff options
context:
space:
mode:
Diffstat (limited to 'haunt.scm')
-rw-r--r--haunt.scm625
1 files changed, 6 insertions, 619 deletions
diff --git a/haunt.scm b/haunt.scm
index 807d652..ed7358f 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -1,4 +1,4 @@
-;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;; Copyright © 2018-2021 David Thompson <davet@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
@@ -18,288 +18,16 @@
(haunt builder blog)
(haunt builder atom)
(haunt builder assets)
- (haunt html)
- (haunt page)
(haunt post)
- (haunt reader)
- (haunt reader commonmark)
(haunt site)
- (haunt utils)
- (commonmark)
- (syntax-highlight)
- (syntax-highlight scheme)
- (syntax-highlight xml)
- (syntax-highlight c)
- (sxml match)
- (sxml transform)
- (texinfo)
- (texinfo html)
- (srfi srfi-1)
- (srfi srfi-19)
- (ice-9 rdelim)
- (ice-9 regex)
- (ice-9 match)
- (web uri))
-
-(define (date year month day)
- "Create a SRFI-19 date for the given YEAR, MONTH, DAY"
- (let ((tzoffset (tm:gmtoff (localtime (time-second (current-time))))))
- (make-date 0 0 0 0 day month year tzoffset)))
-
-(define (stylesheet name)
- `(link (@ (rel "stylesheet")
- (href ,(string-append "/css/" name ".css")))))
-
-(define* (anchor content #:optional (uri content))
- `(a (@ (href ,uri)) ,content))
-
-(define %cc-by-sa-link
- '(a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
- "Creative Commons Attribution Share-Alike 4.0 International"))
-
-(define %cc-by-sa-button
- '(a (@ (class "cc-button")
- (href "https://creativecommons.org/licenses/by-sa/4.0/"))
- (img (@ (src "https://licensebuttons.net/l/by-sa/4.0/80x15.png")))))
-
-(define %piwik-code
- '((script (@ (type "text/javascript") (src "/js/piwik.js")))
- (noscript
- (p (img (@ (src "//stats.dthompson.us/piwik.php?idsite=1")
- (style "border:0;")
- (alt "")))))))
-
-(define (link name uri)
- `(a (@ (href ,uri)) ,name))
-
-(define* (centered-image url #:optional alt)
- `(img (@ (class "centered-image")
- (src ,url)
- ,@(if alt
- `((alt ,alt))
- '()))))
-
-(define (first-paragraph post)
- (let loop ((sxml (post-sxml post))
- (result '()))
- (match sxml
- (() (reverse result))
- ((or (('p ...) _ ...) (paragraph _ ...))
- (reverse (cons paragraph result)))
- ((head . tail)
- (loop tail (cons head result))))))
-
-(define dthompson-theme
- (theme #:name "dthompson"
- #:layout
- (lambda (site title body)
- `((doctype "html")
- (head
- (meta (@ (charset "utf-8")))
- (title ,(string-append title " — " (site-title site)))
- ,(stylesheet "reset")
- ,(stylesheet "fonts")
- ,(stylesheet "dthompson"))
- (body
- (div (@ (class "container"))
- (div (@ (class "nav"))
- (ul (li ,(link "David Thompson" "/"))
- (li (@ (class "fade-text")) " ")
- (li ,(link "About" "/about.html"))
- (li ,(link "Blog" "/index.html"))
- (li ,(link "Projects" "/projects.html"))))
- ,body
- (footer (@ (class "text-center"))
- (p (@ (class "copyright"))
- "© 2020 David Thompson"
- ,%cc-by-sa-button)
- (p "The text and images on this site are
-free culture works available under the " ,%cc-by-sa-link " license.")
- (p "This website is built with "
- (a (@ (href "https://dthompson.us/projects/haunt.html"))
- "Haunt")
- ", a static site generator written in "
- (a (@ (href "https://gnu.org/software/guile"))
- "Guile Scheme")
- ".")))
- ,%piwik-code)))
- #:post-template
- (lambda (post)
- `((h1 (@ (class "title")),(post-ref post 'title))
- (div (@ (class "date"))
- ,(date->string (post-date post)
- "~B ~d, ~Y"))
- (div (@ (class "post"))
- ,(post-sxml post))))
- #:collection-template
- (lambda (site title posts prefix)
- (define (post-uri post)
- (string-append "/" (or prefix "")
- (site-post-slug site post) ".html"))
-
- `((h1 ,title
- (a (@ (href "/feed.xml"))
- (img (@ (src "images/feed.png")))))
- ,(map (lambda (post)
- (let ((uri (string-append "/"
- (site-post-slug site post)
- ".html")))
- `(div (@ (class "summary"))
- (h2 (a (@ (href ,uri))
- ,(post-ref post 'title)))
- (div (@ (class "date"))
- ,(date->string (post-date post)
- "~B ~d, ~Y"))
- (div (@ (class "post"))
- ,(first-paragraph post))
- (a (@ (href ,uri)) "read more ➔"))))
- posts)))))
+ (markdown)
+ (projects)
+ (theme)
+ (utils))
(define %collections
`(("Recent Blog Posts" "index.html" ,posts/reverse-chronological)))
-(define parse-lang
- (let ((rx (make-regexp "-*-[ ]+([a-z]*)[ ]+-*-")))
- (lambda (port)
- (let ((line (read-line port)))
- (match:substring (regexp-exec rx line) 1)))))
-
-(define (maybe-highlight-code lang source)
- (let ((lexer (match lang
- ('scheme lex-scheme)
- ('xml lex-xml)
- ('c lex-c)
- (_ #f))))
- (if lexer
- (highlights->sxml (highlight lexer source))
- source)))
-
-(define (sxml-identity . args) args)
-
-(define (highlight-code . tree)
- (sxml-match tree
- ((code (@ (class ,class) . ,attrs) ,source)
- (let ((lang (string->symbol
- (string-drop class (string-length "language-")))))
- `(code (@ ,@attrs)
- ,(maybe-highlight-code lang source))))
- (,other other)))
-
-(define (highlight-scheme code)
- `(pre (code ,(highlights->sxml (highlight lex-scheme code)))))
-
-(define (raw-snippet code)
- `(pre (code ,(if (string? code) code (read-string code)))))
-
-;; Markdown doesn't support video, so let's hack around that! Find
-;; <img> tags with a ".webm" source and substitute a <video> tag.
-(define (media-hackery . tree)
- (sxml-match tree
- ((img (@ (src ,src) . ,attrs) . ,body)
- (if (string-suffix? ".webm" src)
- `(video (@ (src ,src) (controls "true"),@attrs) ,@body)
- tree))))
-
-(define %commonmark-rules
- `((code . ,highlight-code)
- (img . ,media-hackery)
- (*text* . ,(lambda (tag str) str))
- (*default* . ,sxml-identity)))
-
-(define (post-process-commonmark sxml)
- (pre-post-order sxml %commonmark-rules))
-
-(define commonmark-reader*
- (make-reader (make-file-extension-matcher "md")
- (lambda (file)
- (call-with-input-file file
- (lambda (port)
- (values (read-metadata-headers port)
- (post-process-commonmark
- (commonmark->sxml port))))))))
-
-(define (static-page title file-name body)
- (lambda (site posts)
- (make-page file-name
- (with-layout dthompson-theme site title body)
- sxml->html)))
-
-(define* (project-page #:key name file-name description usage requirements
- installation manual? license repo releases guix-package)
- (define (tarball-url version)
- (string-append "https://files.dthompson.us/"
- repo "/" repo "-" version
- ".tar.gz"))
- (define body
- `((h1 ,name)
- ,description
- ,@(if usage
- `((h2 "Usage")
- ,usage)
- '())
- ,@(if manual?
- `((h2 "Documentation")
- (p ,(anchor "View the reference manual"
- (string-append "/manuals/" repo "/index.html"))))
- '())
- (h2 "Releases")
- (ul ,(map (match-lambda
- ((version date)
- (let ((url (tarball-url version)))
- `(li ,(date->string date "~Y-~m-~d")
- " — " ,version " — "
- ,(anchor (string-append repo "-" version ".tar.gz")
- url)
- " — "
- ,(anchor "GPG signature"
- (string-append url ".asc"))))))
- releases))
- (h2 "Requirements")
- (ul ,(map (lambda (requirement)
- `(li ,requirement))
- requirements))
- (h2 "Installation")
- ,@(if installation
- (list installation)
- (match (car releases)
- ((version _)
- `(,@(if guix-package
- `((p "To install " ,name " with the GNU Guix package manager, run:")
- (pre "guix install " ,guix-package))
- '())
- (p "To build and install " ,name " from source, run:")
- (pre "wget "
- ,(tarball-url version)
- "
-tar xf "
- ,repo "-" ,version ".tar.gz"
- "
-cd "
- ,repo "-" ,version
- "
-./configure
-make
-make install")))))
- (h2 "License")
- (p ,license)
- (h2 "Git Repository")
- ,@(let ((url (string-append "https://git.dthompson.us/" repo ".git")))
- `((p ,name " is developed using the Git version control
-system. The official repository is hosted at "
- ,(anchor url url) ".")
- (p "To clone the repository, run:")
- (pre "git clone " ,url)))
- (h2 "Community")
- (p "Real-time discussion for " ,name " can be found on the "
- (code "#guile")
- " channel on the Freenode IRC network.")
- (h2 "Contributing")
- (p "Send patches and bug reports to "
- ,(anchor "davet@gnu.org" "mailto:davet@gnu.org")
- ".")))
-
- (static-page name (string-append "projects/" file-name) body))
-
(define about-page
(static-page
"About Me"
@@ -307,7 +35,7 @@ system. The official repository is hosted at "
`((h2 "Hi.")
(p "I am a professional software developer, hobbyist gardener,
woodworker, and drummer from Worcester, Massachusetts.")
- (p "I am currently a DevOps engineer at " ,(anchor "Vista Higher
+ (p "I am currently a Senior DevOps engineer at " ,(anchor "Vista Higher
Learning" "http://vistahigherlearning.com")
", and formerly a web developer at the "
,(anchor "Free Software Foundation." "https://fsf.org"))
@@ -336,347 +64,6 @@ Learning" "http://vistahigherlearning.com")
(p ,(anchor "srt2vtt" "projects/srt2vtt.html")
" — SRT to WebVTT subtitle converter"))))
-(define sly-page
- (project-page
- #:name "Sly"
- #:file-name "sly.html"
- #:description
- `((p (strong "note: this project is no longer being developed!"))
- (p "Sly is a fun, free software 2D/3D game engine written in "
- ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
- ,(centered-image "/images/sly/logo.png" "Sly fox mascot")
- (p "Sly differentiates itself from most other game engines by encouraging
-and enabling the use of "
- ,(anchor "live coding"
- "http://toplap.org/about/")
- " and "
- ,(anchor "functional reactive programming"
- "https://en.wikipedia.org/wiki/Functional_reactive_programming")
- " techniques. Sly provides a dynamic live coding environment
-that allows games to be built interactively and iteratively without
-ever stopping the running program. A data structure called a “signal”
-provides a method of modeling time-varying state that is declarative,
-functional, and reactive.")
- (p ,(centered-image "/images/sly/2048.png"))
- (p ,(centered-image "/images/sly/mines.png")))
- #:requirements '("GNU Guile >= 2.0.11"
- "guile-opengl_ >= 0.1.0"
- "guile-sdl_ >= 0.5.0"
- "SDL 1.2.x"
- "FreeImage >= 3.0"
- "GNU Scientific Library (GSL)")
- #:license "GNU GPLv3+"
- #:repo "sly"
- #:manual? #t
- #:releases
- `(("0.1" ,(date 2015 11 12)))))
-
-(define guile-sdl2-page
- (project-page
- #:name "Guile-SDL2"
- #:file-name "guile-sdl2.html"
- #:repo "guile-sdl2"
- #:guix-package "guile-sdl2"
- #:description
- `((p "Guile-SDL2 provides "
- ,(anchor "Guile Scheme" "https://gnu.org/s/guile")
- " bindings for the "
- ,(anchor "SDL2" "http://libsdl.org")
- " C shared library. The bindings are written in pure Scheme
-using Guile's foreign function interface."))
- #:usage
- `((p "Guile-SDL2 provides modules in the "
- (code "(sdl2 ...)")
- " namespace, roughly organized how the SDL2 C header files are
-organized. Low-level bindings are available in the"
- (code "(sdl2 bindings ...)")
- " namespace, but these are not recommended for normal usage.")
- (p "Additionally, SDL2 extension library bindings are available in the
-following modules:")
- (ul (li "SDL2_image: " (code "(sdl2 image)"))
- (li "SDL2_mixer: " (code "(sdl2 mixer)"))
- (li "SDL2_ttf: " (code "(sdl2 ttf)")))
- (p "Here is a short “hello, world” example program:")
- ,(highlight-scheme
- "(use-modules (sdl2)
- (sdl2 render)
- (sdl2 surface)
- (sdl2 video))
-
-(define (draw ren)
- (let* ((surface (load-bmp \"hello.bmp\"))
- (texture (surface->texture ren surface)))
- (clear-renderer ren)
- (render-copy ren texture)
- (present-renderer ren)
- (sleep 2)))
-
-(sdl-init)
-
-(call-with-window (make-window)
- (lambda (window)
- (call-with-renderer (make-renderer window) draw)))
-
-(sdl-quit)"))
- #:requirements '("GNU Guile >= 2.0.9"
- "SDL2 >= 2.0.0"
- "SDL2_image >= 2.0.0"
- "SDL2_mixer >= 2.0.0"
- "SDL2_ttf >= 2.0.0"
- "GNU Make"
- "GNU pkg-config")
- #:license "GNU LGPLv3+"
- #:manual? #t
- #:releases
- `(("0.5.0" ,(date 2020 04 07))
- ("0.4.0" ,(date 2019 06 02))
- ("0.3.1" ,(date 2018 10 16))
- ("0.3.0" ,(date 2018 07 10))
- ("0.2.0" ,(date 2017 01 20))
- ("0.1.2" ,(date 2016 08 10))
- ("0.1.1" ,(date 2016 01 01))
- ("0.1.0" ,(date 2015 12 22)))))
-
-(define guile-syntax-highlight-page
- (project-page
- #:name "guile-syntax-highlight"
- #:file-name "guile-syntax-highlight.html"
- #:repo "guile-syntax-highlight"
- #:description
- `((p "guile-syntax-highlight is a general-purpose syntax
-highlighting library for GNU Guile. It can parse code written in
-various programming languages into a simple s-expression that can be
-easily converted to HTML (via SXML) or any other format for
-rendering."))
- #:usage
- (highlight-scheme
- "(use-modules (syntax-highlight)
- (syntax-highlight scheme)
- (sxml simple))
-
-(define code
- \"(define (square x) \\\"Return the square of X.\\\" (* x x))\")
-
-;; Get raw highlights list.
-(define highlighted-code
- (highlight scheme-highlighter code))
-
-;; Convert to SXML.
-(define highlighted-sxml
- (highlights->sxml highlighted-code))
-
-;; Write HTML to stdout.
-(display (sxml->xml highlighted-sxml))
-(newline)
-")
- #:requirements '("GNU Guile >= 2.0"
- "GNU Make"
- "GNU pkg-config")
- #:license "GNU LGPLv3+"
- #:releases
- `(("0.1" ,(date 2018 03 10)))))
-
-(define haunt-page
- (project-page
- #:name "Haunt"
- #:file-name "haunt.html"
- #:repo "haunt"
- #:guix-package "haunt"
- #:manual? #t
- #:description
- `((p "Haunt is a simple, functional, hackable static site generator
-that gives authors the ability to treat websites as Scheme programs.")
- ,(centered-image "/images/haunt/logo.png" "crudely drawn ghost")
- (p "By giving authors the full expressive power of Scheme, they
-are able to control every aspect of the site generation process.
-Haunt provides a simple, functional build system that can be easily
-extended for this purpose.")
- (p "Haunt has no opinion about what markup language authors
-should use to write posts, though it comes with support for the
-popular Markdown format. Likewise, Haunt has no opinion about how
-authors structure their sites. Though it comes with support for
-building simple blogs or Atom feeds, authors should feel empowered to
-tweak, replace, or create builders to do things that aren't provided
-out-of-the-box."))
- #:usage
- `((p "Here's what a simple Haunt configuration looks like:")
- ,(call-with-input-file "snippets/haunt.scm" highlight-scheme)
- (p "In a new directory, save the above to a file named "
- (code "haunt.scm") ".")
- (p "Create a subdirectory named " (code "posts") ".")
- (p "Add the following to a new file named " (code "posts/hello.md") ":")
- ,(call-with-input-file "snippets/haunt-hello.md" raw-snippet)
- (p "Run " (code "haunt build") " to build the site.")
- (p "Run " (code "haunt serve") " to a launch a web server to
-preview your work.")
- (p "Open " ,(anchor "http://localhost:8080") " in your web browser
-and smile, because you've just generated your first Haunt site!"))
- #:requirements
- '("GNU Guile >= 2.0"
- "guile-commonmark (for Markdown support, optional)"
- "guile-reader (for Skribe support, optional)")
- #:license "GNU GPLv3+"
- #:releases
- `(("0.2.4" ,(date 2018 11 29))
- ("0.2.3" ,(date 2018 11 25))
- ("0.2.2" ,(date 2018 03 10))
- ("0.2.1" ,(date 2017 01 23))
- ("0.2" ,(date 2016 04 24))
- ("0.1" ,(date 2015 08 08)))))
-
-(define chickadee-page
- (project-page
- #:name "Chickadee"
- #:file-name "chickadee.html"
- #:repo "chickadee"
- #:guix-package "guile-chickadee"
- #:manual? #t
- #:description
- `((p "Chickadee is a game development toolkit for "
- ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
- ,(centered-image "/images/chickadee/logo.png" "Chickadee logo")
- (p "Chickadee provides all the essential tools that
-parenthetically inclined game developers need to make games in
-Scheme.")
- (p "Here is the obligatory “Hello, world” program:")
- ,(highlight-scheme
- "(use-modules (chickadee)
- (chickadee math vector)
- (chickadee graphics font))
-
-(define (draw alpha)
- (draw-text \"Hello, world!\" (vec2 260.0 240.0)))
-
-(run-game #:draw draw)
-")
- (p "And here's how to draw a sprite:")
- ,(highlight-scheme
- "(use-modules (chickadee)
- (chickadee math vector)
- (chickadee graphics sprite)
- (chickadee graphics texture))
-
-(define sprite #f)
-
-(define (load)
- (set! sprite (load-image \"images/chickadee.png\")))
-
-(define (draw alpha)
- (draw-sprite sprite (vec2 256.0 176.0)))
-
-(run-game #:load load #:draw draw)
-")
- (p "Features include:")
- (ul
- (li "extensible, fixed-timestep game loop")
- (li "OpenGL-based rendering engine")
- (li "keyboard, mouse, controller input events")
- (li "vectors, matrices, bounding boxes, easing functions, etc.")
- (li "asynchronous scripting"))
- (p (small ,(anchor "chickadee sprite by Refuzzle, CC0"
- "http://opengameart.org/content/winter-birds"))))
- #:requirements '("GNU Guile >= 2.1.4"
- "Guile-SDL2 >= 0.2.0"
- "Guile-OpenGL >= 0.1.0")
- #:license "GNU GPLv3+"
- #:releases
- `(("0.6.0" ,(date 2020 11 19))
- ("0.5.0" ,(date 2020 04 08))
- ("0.4.0" ,(date 2019 06 04))
- ("0.3.0" ,(date 2018 10 03))
- ("0.2.0" ,(date 2017 01 26))
- ("0.1.0" ,(date 2017 01 23)))))
-
-(define shroud-page
- (project-page
- #:name "Shroud"
- #:file-name "shroud.html"
- #:repo "shroud"
- #:description
- `((p "Shroud is a simple secret manager with a command line interface.")
- (p "The password database is stored as a Scheme s-expression
-and encrypted with a "
- ,(anchor "GnuPG" "https://gnupg.org")
- " key. Secrets consist of an arbitrary number of key/value
-pairs, making Shroud suitable for more than just password storage.
-For copying and pasting secrets into web browsers and other graphical
-applications, there is xclip integration."))
- #:requirements '("GNU Guile >= 2.0.9"
- "GnuPG >= 1.4"
- "GNU Make"
- "GNU pkg-config"
- ("optional: xclip is needed for the "
- (code "-c")
- " flag of "
- (code "shroud show")
- " to work"))
- #:usage
- `((p "First, create a " (code ".shroud")
- " file in your home directory to hold your
-configuration settings. All you really need to set here is your GPG
-user ID i.e. your email address:")
- ,(highlight-scheme
- "'((user-id . \"foo@example.com\"))")
- (p "The "
- (code ".shroud")
- " file is Scheme source code, so any expression that evaluates
-to an alist of valid configuration settings is usable by Shroud.")
- (p "Once Shroud is configured, try out the following commands to
-get a feel for how things work:")
- (pre
- "# Add a new secret:
-shroud hide bank-account username=foobar password=hackme
-
-# Edit an existing secret:
-shroud hide --edit bank-account password=hackmepls
-
-# List all secrets:
-shroud list
-
-# Show all key/value pairs for a saved secret:
-shroud show bank-account
-
-# Show a single value in a secret:
-shroud show bank-account password
-
-# Copy a password directly to X clipboard:
-shroud show -c bank-account password
-
-# Delete a secret:
-shroud remove bank-account")
- (p "Happy shrouding!"))
- #:license "GNU GPLv3+"
- #:releases
- `(("0.1.1" ,(date 2015 10 01))
- ("0.1.0" ,(date 2015 09 29)))))
-
-(define srt2vtt-page
- (project-page
- #:name "srt2vtt"
- #:file-name "srt2vtt.html"
- #:repo "srt2vtt"
- #:description
- `((p "Convert SRT formatted subtitles to WebVTT format for use with
-the HTML5 "
- (code "<track>") " tag."))
- #:requirements '("GNU Guile >= 2.0.5")
- #:usage
- `((pre
- "$ srt2vtt --help
-Usage: srt2vtt [OPTIONS]
-Convert SubRip formatted subtitles to WebVTT format.
-
- -h, --help display this help and exit
- -v, --version display version and exit
- -i, --input=FILE-NAME read input from FILE-NAME
- -o, --output=FILE-NAME write output to FILE-NAME")
- (p "If " (code "--input")
- " or " (code "--output")
- " is ommitted, read from stdin or stdout, respectively."))
- #:license "GNU GPLv3+"
- #:releases
- `(("0.1" ,(date 2015 02 7)))))
-
(site #:title "dthompson"
#:domain "dthompson.us"
#:default-metadata
generated by cgit v1.2.3 (git 2.25.4) at 2024-07-01 19:01:18 +0000