Handle videos and source code highlighting in Markdown posts.

1 files changed, 141 insertions, 18 deletions

diff --git a/haunt.scm b/haunt.scm
index 2a089a5..447f36a 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -31,12 +31,16 @@
              (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)
@@ -163,28 +167,54 @@ free culture works available under the " ,%cc-by-sa-link " license.")
       (let ((line (read-line port)))
         (match:substring (regexp-exec rx line) 1)))))
 
-(define (maybe-highlight-code source)
-  (call-with-input-string source
-    (lambda (port)
-      (let ((lang (string->symbol (parse-lang port))))
-        (if lang
-            (highlights->sxml
-             (highlight (match lang
-                          ('scheme lex-scheme)
-                          ('xml    lex-xml))
-                        port))
-            source)))))
+(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
-    ((pre (@ . ,attrs) ,source)
-     `(pre (@ ,@attrs)
-           ,(maybe-highlight-code source)))))
+    ((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 ,(highlights->sxml (highlight lex-scheme code))))
+  `(pre (code ,(highlights->sxml (highlight lex-scheme code)))))
+
+(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)
@@ -242,7 +272,7 @@ system. The official repository is hosted at "
             (h3 "Anonymous clone")
             (pre "git clone " ,url)))
       (h2 "Community")
-      (p "Real-time discussion for Guile-SDL2 can be found on the "
+      (p "Real-time discussion for " ,name " can be found on the "
          (code "#guile")
          " channel on the Freenode IRC network.")
       (h2 "Contributing")
@@ -278,7 +308,7 @@ at "
    `((h1 "Projects")
      (p ,(anchor "Guile-SDL2" "projects/guile-sdl2.html")
         " — SDL2 bindings for Guile Scheme")
-     (p ,(anchor "Haunt" "projects/haunt.html")
+     (p ,(anchor "Haunt" "https://haunt.dthompson.us")
         " — Functional, hackable static site generator")
      (p ,(anchor "Shroud" "projects/shroud.html")
         " — GPG-based password manager")
@@ -380,12 +410,102 @@ following modules:")
      ("0.1.1" ,(date 2016 01 01))
      ("0.1.0" ,(date 2015 12 22)))))
 
+(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
       '((author . "David Thompson")
         (email  . "davet@gnu.org"))
-      #:readers (list commonmark-reader)
+      #:readers (list commonmark-reader*)
       #:builders (list (blog #:theme dthompson-theme #:collections %collections)
                        (atom-feed)
                        (atom-feeds-by-tag)
@@ -393,8 +513,11 @@ following modules:")
                        projects-page
                        sly-page
                        guile-sdl2-page
+                       shroud-page
+                       srt2vtt-page
                        (static-directory "css")
                        (static-directory "fonts")
                        (static-directory "images")
+                       (static-directory "videos")
                        (static-directory "src")
                        (static-directory "manuals")))