path: root/wikme.ss

;;; Wikme --- convert a directory of markdown files into a static wiki

;;; 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]].
  ;; XXX
  '(: "[["
      (=> pname (*? (~ "|")))
      (? ($ "|" (=> ptitle
                    (*? (~ "]")))))
      "]]"))

(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)))))

;;; TODO: merge linkify and indexify ... they're almost the same thing.
(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 #\/))))))

(define (wiki-page-origin-path page #!optional wiki)
  ;;; Return PAGE's origin path in WIKI.
  (path-relativize (page-origin page)
                   (wiki-origin-dir (or wiki
                                        (page-wiki page)))))

(define (wiki-page-destination-path page #!optional wiki)
  ;;; Return PAGE's destination path in WIKI.
  (path-relativize (page-destination page)
                   (wiki-destination-dir (or wiki
                                             (page-wiki page)))))

;;; 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 (wiki-page-origin-path 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))))))

(define (eprintf . args)
  (apply fprintf (current-error-port) args))

(define (build-wiki origin
                    #!key
                    (destination (make-pathname origin "out"))
                    (base-url "")
                    (base-template (make-pathname origin "template.html"))
                    (source-transformers (list page-cmark->html wikify-links))
                    (path-transformers (list indexify))
                    (source-extension "md"))
  (define w (make-wiki
             base-url
             origin
             destination
             '()
             `((template . ,base-template)
               (source-transformers . ,source-transformers)
               (path-transformers . ,path-transformers)
               (source-extension . ,source-extension))))

  (eprintf "\nBuilding pages...\n")
  (for-each (lambda (f)
              (let ((p (file->page f w)))
                (eprintf "~a -> ~a\n" f (page-meta-ref p 'title))))
            (glob (make-pathname origin
                                 "*"
                                 (wiki-default-ref w 'source-extension))))

  (let ((dd (wiki-destination-dir w)))
    (eprintf "\nCreating destination directory: ~a\n" dd)
    (create-directory dd 'parents))

  (eprintf "\nWriting pages...\n")
  (for-each (lambda (p)
              (eprintf "~a -> ~a\n"
                       (page-meta-ref p 'title)
                       (wiki-page-destination-path p))
              (page->file p))
            (wiki-pages w)))