diff options
Diffstat (limited to 'haunt.scm')
-rw-r--r-- | haunt.scm | 625 |
1 files changed, 6 insertions, 619 deletions
@@ -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 |