capybara/render.rkt

#lang racket/base

(require racket/class racket/draw racket/fasl racket/list racket/match racket/port racket/path
         racket/set racket/string racket/runtime-path net/url-string pict
         markdown markdown/display-xexpr markdown/toc
         "compiler.rkt" "defs.rkt" "fetch.rkt"
         threading
         (prefix-in sass: sass)
         (prefix-in mathml: "ext-mathml/main.rkt")
         (prefix-in syntax: "ext-syntax/main.rkt")
         (prefix-in page: "templates/page.html.rkt"))

(struct input-doc [metadata xref-name text] #:transparent)
(struct ir-doc [metadata xref-name html] #:prefab)

(define-runtime-path *render.scss* "render.scss")

(define *index.md* (build-path "index.md"))
(define *config.rktd* (build-path "config.rktd"))

(define *reserved-slugs* (set (build-path "hashtag") (build-path "user") (build-path "tech")))

(define (read-input-doc xref-name [port (current-input-port)])
  (define metadata (read port))
  (unless (metadata? metadata)
    (error "post front matter is not valid metadata!"))
  (define text (port->string port))
  (input-doc metadata xref-name text))

(define *xref-char* "^")
(define *user-char* "@")
(define *hashtag-char* "#")

;; transforms the xexpr into an xexpr that includes links to entities
(define (extract-text-starting-with xexpr start-char tag-name)
  (define re (pregexp (string-append start-char "(\\p{L}|\\p{N})+")))
  (define (process+ xexpr)
    (match xexpr
      ;; do not descend into other special tags
      [(list (or 'code 'math 'tech 'deftech 'masto 'user 'xref) attrs children ...) (list xexpr)]
      ;; recursive
      [(list tag attrs children ...)
       (list (cons tag (cons attrs
                       (apply append
                              (map (lambda (child) (process+ child)) children)))))]
      ;; extract and transform the prefixed text
      [(? string? str)
       (define posns (regexp-match-positions* re str))
       (define-values [items last-pos]
         (for/fold ([items '()] [last-pos 0]) ([pos (in-list posns)])
           (define value (substring str (car pos) (cdr pos)))
           (values (cons `(,tag-name ([target ,(substring value 1)]) ,value)
                         (cons (substring str last-pos (car pos)) items))
                   (cdr pos))))
       (reverse (cons (substring str last-pos) items))]))
  (first (process+ xexpr)))
(define (extract-text-starting-with/many xexprs start-char tag-name)
  (map (λ (xexpr) (extract-text-starting-with xexpr start-char tag-name)) xexprs))

;; extracts prefixed links and converts them into the <xref> pseudo-tag
(define (extract-prefixed-links xexpr start-char tag-name)
  (define (pred? s)
    (and (string? s) (> (string-length s) 1) (string=? start-char (substring s 0 1))))
  (define (extract-prefixed-links+ xexpr)
    (match xexpr
      [(list 'a attrs body ...)
       (match (assoc 'href attrs)
         [(list _ (? pred? value))
          (define target (substring value 1))
          `(,tag-name ([target ,target]) ,@(map extract-prefixed-links+ body))]
         [_ (apply list 'a attrs (map extract-prefixed-links+ body))])]
      [(list tag attrs children ...)
       (apply list tag attrs (map extract-prefixed-links+ children))]
      [(? string? str) str]))
  (extract-prefixed-links+ xexpr))

(define (extract-prefixed-links/many xexprs start-char tag-name)
  (map (λ (xexpr) (extract-prefixed-links xexpr start-char tag-name)) xexprs))

(define (check-xrefs xexprs xrefs-repo base-xref)
  (define (check-xrefs-help xexpr)
    (match xexpr
      [(list 'xref (list (list 'target target)) body ...)
       (define abs-target
         (simplify-path
           (url->path
             (combine-url/relative
               (path->url base-xref)
               target))
           #f))
       (unless (set-member? xrefs-repo (explode-path abs-target))
         (error "invalid xref!" target))
       (apply list 'xref (list (list 'target (path->string abs-target)))
              (map check-xrefs-help body))]
      [(list tag attrs body ...)
       (cons tag (cons attrs (map check-xrefs-help body)))]
      [(? string?) xexpr]))
  (map check-xrefs-help xexprs))

(define (input-doc->ir-doc doc xrefs-repo)
  (match-define (input-doc md xref-name text) doc)
  (define output-raw (parse-markdown text))
  (define output-cooked
    (~> output-raw syntax:transform-xexprs mathml:transform-xexprs
        (extract-text-starting-with/many *hashtag-char* 'hashtag)
        (extract-text-starting-with/many *user-char* 'user)
        (extract-prefixed-links/many *xref-char* 'xref)
        (extract-prefixed-links/many *user-char* 'user)
        (check-xrefs xrefs-repo xref-name)))
  (ir-doc md xref-name output-cooked))

;; lowers pseudo-tags into their final form
(define (lower-specials xexpr base-url)
  (define (lower-specials* xexpr)
    (match xexpr
      ;; hashtags
      [(list 'hashtag (list (list 'target target)) body ...)
       `(a ([class "hashtag"] [href ,(format "~a/hashtag/~a" base-url target)])
           ,@(map lower-specials* body))]
      ;; xrefs
      [(list 'xref (list (list 'target target)) body ...)
       `(a ([class "xref"] [href ,(format "~a~a" base-url target)])
           ,@(map lower-specials* body))]
      ;; users
      [(list 'user (list (list 'target target)) body ...)
       `(a ([class "user"] [href ,(format "~a/user/~a" base-url target)])
           ,@(map lower-specials* body))]
      ;; deftech and tech
      [(list 'deftech (list (list 'key key)) (? string? body))
       `(em ([class "deftech"] [id ,(format "tech-~a" key)]) ,body)]
      [(list 'tech (list (list 'key key)) (? string? body))
       `(a ([class "tech"] [href ,(format "~a/tech/~a" base-url key)]) ,body)]
      ;; masto
      ;; TODO make this not janky
      [(list 'p _ (list 'masto _ (? string? url)))
       (masto-fetch-embed url)]
      ;; everything else
      [(list tag attrs children ...)
       (apply list tag attrs (map lower-specials* children))]
      [(? string? str) str]))
  (lower-specials* xexpr))

(define (ir-doc->page doc site-config)
  (match-define (ir-doc md xref-name content) doc)
  (define base-url (assoc-ref+ site-config 'base))
  (let ([content (lower-specials content base-url)])
    (define content-toc (toc content))

    (define document
      (page:execute
        (hash 'metadata md
              'site-config site-config
              'xref-name xref-name
              'base-url base-url
              'content-toc content-toc
              'content content)))

    (with-output-to-string (λ () (display "<!doctype html>") (display-xexpr document)))))

(define (compile-index-scss index.scss)
  (define scss-files (cons *render.scss* (append mathml:scss-files syntax:scss-files)))
  (define top-level-style
    (string-join
      (cons index.scss (map (λ (x) (format "@import \"~a\";" (path->string x))) scss-files))
      "\n"))
  (sass:compile/string top-level-style #t))

(define (scan-for-rules [output-dir (build-path "target")]
                        [build-dir (build-path "build")]
                        [src-dir (build-path "src")])
  (define-rule (scss [out (build-path output-dir "index.css")]
                     [in (build-path src-dir "index.scss")])
    (~> (compile-index-scss (port->string in)) (write-string out)))

  (define favicon.rkt (build-path src-dir "favicon.rkt"))
  (define-rule (favicon [out (build-path output-dir "favicon.png")]
                        [in favicon.rkt])
    (define icon-pict (dynamic-require favicon.rkt 'icon-pict))
    (define icon-bitmap (pict->bitmap icon-pict))
    (send icon-bitmap save-file out 'png))

  (struct rule-spec [src intermediate output xref-name] #:transparent)

  (define rule-specs
    (parameterize ([current-directory src-dir])
      (for/list ([md-file (in-directory #f)]
                 #:when (equal? (path-get-extension md-file) #".md"))
        (define fasl-file (path-replace-extension md-file #".fasl"))
        (define out-file (path-replace-extension md-file #".html"))
        (define xref-name
          (let-values ([(base name dir?) (split-path md-file)])
            (if (equal? *index.md* name)
              (if (eq? 'relative base)
                (build-path "/")
                (build-path "/" base))
              (build-path "/" (path-replace-extension md-file #"")))))
        (rule-spec (build-path src-dir md-file)
                   (build-path build-dir fasl-file)
                   (build-path output-dir out-file)
                   xref-name))))
  (define config.rktd (build-path src-dir *config.rktd*))

  (define xrefs-repo
    (for/set ([spec (in-list rule-specs)])
      (define exploded (explode-path (rule-spec-xref-name spec)))
      (when (and (> (length exploded) 1)
                 (set-member? *reserved-slugs* (second exploded)))
        (error "file is using a reserved slug" (rule-spec-src spec)))
      exploded))

  (define intermediate-rules
    (for/list ([spec (in-list rule-specs)])
      (define-rule (intermediate-rule [out (rule-spec-intermediate spec)]
                                      [in (rule-spec-src spec)])
        (~> (read-input-doc (rule-spec-xref-name spec) in)
            (input-doc->ir-doc xrefs-repo)
            s-exp->fasl (write-bytes out)))
      intermediate-rule))

  (define output-rules
    (for/list ([spec (in-list rule-specs)])
      (define-rule (output-rule [out (rule-spec-output spec)]
                                [in (rule-spec-intermediate spec)]
                                [config-in config.rktd])
        (define config (read config-in))
        (unless (config? config)
          (error "invalid config in config.rktd!"))
        (~> (port->bytes in) fasl->s-exp (ir-doc->page config) (write-string out)))
      output-rule))
  (append intermediate-rules output-rules (list scss favicon)))

(module+ main
  (require racket/cmdline)
  (command-line
    #:program "capybara-render"
    #:args ()
    (generate/execute (scan-for-rules))))