1 files changed, 290 insertions, 0 deletions

@@ -0,0 +1,290 @@
+;;; Wikme --- convert a directory of markdown files into a static wiki
+
+(import (chicken file)
+        (chicken file posix)
+        (chicken format)
+        (chicken io)
+        (chicken irregex)
+        (chicken pathname)
+        (chicken port)
+        (chicken process)
+        (chicken process-context)
+        (chicken string)
+        (chicken time posix)
+        (cmark)
+        (regex)                         ; XXX: deprecated upstream
+        (srfi-13))
+
+;;; Records
+
+(define-record-type <wiki>
+  ;;; A wiki is a collection of pages and assorted metadata.
+  (make-wiki base-url                   ; base URL for links
+             origin-dir                 ; origin directory
+             destination-dir            ; destination directory
+             pages                      ; list of <page>s
+             defaults                   ; alist of default properties for pages
+             )
+  wiki?
+  (base-url wiki-base-url (setter wiki-base-url))
+  (origin-dir wiki-origin-dir (setter wiki-origin-dir))
+  (destination-dir wiki-destination-dir (setter wiki-destination-dir))
+  (pages wiki-pages (setter wiki-pages))
+  (defaults wiki-defaults (setter wiki-defaults)))
+
+(define (wiki-default-ref wiki key)
+  (alist-ref key (wiki-defaults wiki)))
+
+(define (wiki-default-set! wiki key value)
+  (set! (wiki-defaults wiki) (cons (cons key value)
+                                   (wiki-defaults wiki))))
+
+(define-record-type <page>
+  ;;; A wiki page is a mapping between source and body content, and between the
+  ;;; page's origin and its destination files, wrapped together with some
+  ;;; metadata.
+  (make-page source                     ; source markup
+             body                       ; rendered page body
+             origin                     ; source filename (relative to wiki)
+             destination                ; destination file (relative to wiki)
+             template                   ; this page's template
+             source-transformers        ; list of source transformer functions
+             path-transformers          ; list of path transformers
+             wiki                       ; the <wiki> this page is a part of
+             meta                       ; alist of metadata tags
+             )
+  page?
+  (source page-source (setter page-source))
+  (body page-body (setter page-body))
+  (origin page-origin (setter page-origin))
+  (destination page-destination (setter page-destination))
+  (template page-template (setter page-template))
+  (source-transformers page-source-transformers (setter page-source-transformers))
+  (path-transformers page-path-transformers (setter page-path-transformers))
+  (wiki page-wiki (setter page-wiki))
+  (meta page-meta (setter page-meta)))
+
+(define (page-meta-ref page key)
+  ;;; Get metadata KEY from PAGE.
+  (alist-ref key (page-meta page)))
+
+(define (page-meta-set! page key value)
+  ;;; Set KEY in PAGE's metadata to VALUE.
+  (set! (page-meta page) (cons (cons key value)
+                               (page-meta page))))
+
+;;; Transformers
+
+(define (transform page input transformers)
+  (let loop ((ts transformers)
+             (it input))
+    (if (null? ts)
+        it
+        (loop (cdr ts)
+              ;; This is ugly but I need it for some things (namely, `indexify').
+              ;; Transformers can add an #!optional _ parameter to ignore it.
+              ((car ts) it page)))))
+
+(define (transform-source! page)
+  ;;; Transform PAGE's source to html.
+  ;; Passes page-source through each of page-transformers in order and sets
+  ;; page-body to the result.
+  (set! (page-body page)
+    (transform page (page-source page) (page-source-transformers page))))
+
+(define (transform-path! page)
+  ;;; Transform PAGE's path from input directory to output directory.
+  ;; This will take the page-origin  and transform it using
+  ;; page-path-transformers.  It will then set page-destination to the result.
+  (set! (page-destination page)
+    (transform page (page-origin page) (page-path-transformers page))))
+
+;; Cmark wrapper
+(define (page-cmark->html input #!optional page)
+  (cmark->html input (page-meta-ref page 'safe)))
+
+;;; Templates
+
+(define (render-template template env)
+  ;;; Render TEMPLATE using ENV.
+  ;; TEMPLATE is a string with {{placeholders}}; ENV is an alist of key-value
+  ;; pairs to insert into the TEMPLATE's placeholders.
+  ;; XXX: Depends on the deprecated library (regex) which is just glue around
+  ;; irregex (apparently).
+  (string-substitute* template (env->replacements env)))
+
+(define (env->replacements env)
+  ;;; Convert an ENV alist of the form `((X . Y) ...) to '(("{{X}}" . "Y") ...).
+  ;; X's are template variables and Y's are the values of those variables.  In
+  ;; the template, both "{{X}}" and "{{ X }}" will be replaced.
+  ;; If Y is a thunk, call it.
+  (let loop ((env env)
+             (res '()))
+    (if (null? env)
+        res
+        (let* ((this (car env))
+               (rest (cdr env))
+               (key (->string (car this)))
+               (val (if (procedure? (cdr this))
+                        ((cdr this))
+                        (->string (cdr this)))))
+          (loop (cdr env)
+                (append (list (cons (sprintf "{{~a}}" key) val)
+                              (cons (sprintf "{{ ~a }}" key) val))
+                        res))))))
+
+(define (render page)
+  (render-template (page-template page)
+                   (append `((source . ,(page-source page))
+                             (body . ,(page-body page))
+                             (origin . ,(page-origin page))
+                             (destination . ,(page-destination page)))
+                           (page-meta page))))
+
+;;; Links
+
+(define wiki-link-sre
+  ;;; An SRE for [[wiki-style links|with optional titles]].
+  '(: "[["
+      (submatch-named pname (+ (~ "|")))
+      (? (submatch "|" (submatch-named ptitle (*? nonl))))
+      "]]"))
+
+(define (wikify-links text #!optional page)
+  ;;; Convert [[Wiki-style links]] to <a> tags in TEXT.
+  ;; The base url of PAGE's wiki is prepended to the generated links.
+  (irregex-replace/all wiki-link-sre
+                       text
+                       (lambda (m)
+                         (let* ((pname (irregex-match-substring m 'pname))
+                                (ptitle (or (irregex-match-substring m 'ptitle)
+                                            pname)))
+                           (sprintf "<a href=\"~a\">~a</a>"
+                                    (linkify pname
+                                             (if page
+                                                 (wiki-base-url
+                                                  (page-wiki page))
+                                                 ""))
+                                    ptitle)))))
+
+(define (linkify pagename base-url)
+  ;;; Turn a page name into a link suitable for an <a> tag.
+  (make-pathname (list base-url (slugify pagename))
+                 "index"
+                 "html"))
+
+(define (slugify str)
+  ;;;  Convert STR to a 'slug', that is, another string suitable for linking.
+  ;; This function will return the input string, in sentence case, and with all
+  ;; punctuation and spaces converted to a hypen.
+  (string-capitalize
+   (string-trim-both (irregex-replace/all '(+ (~ alnum)) str "-")
+                     (lambda (c)
+                       (char=? c #\-)))))
+
+(define (string-capitalize str)
+  ;;; Capitalize the first word in STR, and ensure the rest of it is lowercase.
+  ;; Returns the new string.
+  (let loop ((cs (string->list str))
+             (it #f))
+    (if (null? cs)
+        (reverse-list->string it)
+        (loop (cdr cs)
+              (if it
+                  (cons (char-downcase (car cs)) it)
+                  (list (char-upcase (car cs))))))))
+
+(define (unslugify str)
+  ;;; Convert a SLUG back into a normal string as best as possible.
+  ;; Because information is lost in slugification, it's impossible to be sure
+  ;; that the result of this procedure is totally accurate.  That is,
+  ;; slugification is not round-trippable.
+  (irregex-replace/all "-" str " "))
+
+(define (path-relativize path dir)
+  ;;; Return PATH relative to DIR.
+  ;; Currently, this doesn't do anything special if PATH begins with / or ~ ...
+  ;; it probably should.
+  (let ((path (normalize-pathname path))
+        (dir (normalize-pathname dir)))
+    (make-pathname
+     dir
+     (string-trim (string-drop path (string-prefix-length path dir))
+                  (lambda (c) (char=? c #\/))))))
+
+;;; Build a page
+
+(define (file->page file wiki
+                    #!key
+                    (source
+                     (with-input-from-file file read-string))
+                    (template
+                     (wiki-default-ref wiki 'template))
+                    (source-transformers
+                     (wiki-default-ref wiki 'source-transformers))
+                    (path-transformers
+                     (wiki-default-ref wiki 'path-transformers)))
+  (let ((page (make-page source
+                         #f
+                         (path-relativize file (wiki-origin-dir wiki))
+                         #f
+                         (with-input-from-file template read-string)
+                         source-transformers
+                         path-transformers
+                         wiki
+                         '())))
+    (transform-source! page)
+    (page-meta-set! page 'title (guess-title page))
+    (page-meta-set! page 'last-updated (guess-last-updated page))
+    (transform-path! page)
+    (set! (wiki-pages wiki) (cons page (wiki-pages wiki)))
+    page))
+
+(define (guess-title page)
+  ;;; Guess the title from PAGE.
+  ;; If the first line is a Markdown H1 ("# ..."), use that as the title.
+  ;; Otherwise, unslugify the basename of the PAGE file to use as the title.
+  (let* ((str (page-body page))
+         (m (irregex-match '(: "#" (* whitespace) ($ (* nonl)) (* any))
+                           str)))
+    (if (irregex-match-data? m)
+        (irregex-match-substring m 1)
+        (unslugify (basename (page-origin page))))))
+
+(define (basename file)
+  (receive (_ base _) (decompose-pathname file)
+    base))
+
+(define (indexify _origin page)
+  ;;; Transform a PAGE's filename from a markdown source to an html destination.
+  (make-pathname (slugify (page-meta-ref page 'title))
+                 "index"
+                 "html"))
+
+(define (guess-last-updated page)
+  ;;; Guess when PAGE was last edited.
+  ;; Tries to use git, but falls back to mtime.
+  (let ((f (path-relativize (page-origin page)
+                            (wiki-origin-dir (page-wiki page)))))
+    (time->string
+     (seconds->local-time
+      (or #;
+       (string->number
+       (string-trim-both
+       (with-input-from-pipe
+       (sprintf "git log -1 --format=%ct --date=unix -C ~s ~s"
+       (wiki-origin-dir (page-wiki page))
+       f)
+       read-string)))
+       (file-modification-time f))))))
+
+(define (page->file page)
+  ;;; Write PAGE to its destination file.
+  (let ((dest (make-pathname (wiki-destination-dir (page-wiki page))
+                             (page-destination page))))
+    (receive (dir _ _) (decompose-pathname dest)
+      (create-directory dir 'parents))
+    (with-output-to-file dest
+      (lambda ()
+        (write-string (render page))))))
+