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 ext: "ext/main.rkt")
         (prefix-in page: "templates/page.html.rkt")
         (prefix-in hashtag: "templates/hashtag.html.rkt"))

(provide scan-for-rules)

(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*
  (apply set (map build-path '("hashtag" "user" "tech" "capybara" "dynamic" "robots.txt"
                               "sitemap.xml" "feeds" "unsupported-browser"))))

(define *special-slugs*
  (apply set (map build-path '("/40x" "/50x"))))

(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 (? symbol? 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 (? symbol? 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 (? symbol? 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 ext: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 (? symbol? tag) attrs children ...)
       (apply list tag attrs (map lower-specials* children))]
      [(? string? str) str]))
  (map lower-specials* xexpr))

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

(define (ir-doc->page doc xrefs-repo site-config)
  (match-define (ir-doc md xref-name content) doc)
  (define base-url (assoc-ref+ site-config 'base))

  (define exploded (explode-path xref-name))
  (define exploded-length (length exploded))

  (define (neighbor/immediate-child? p)
    (or (= exploded-length (length p))
        (and (= (add1 exploded-length) (length p))
             (equal? (list-ref p (sub1 exploded-length))
                     (last exploded)))))

  (define site-toc-defs
    (for/list ([p (in-set xrefs-repo)] #:when (neighbor/immediate-child? p))
      (define target (apply build-path p))
      (define link (format "~a~a" base-url (path->string target)))
      (define name (path->string (apply build-path (list-tail p (sub1 exploded-length)))))
      (list
        name
        `(li () (a ([href ,link])
                   ,(if (equal? p exploded) `(strong () ,name) name))))))
  (define parent-name (simplify-path (build-path xref-name 'up) #f))

  (define site-toc
    `(ol ()
         ,@(if (equal? (build-path "/") xref-name)
             '()
             `((li () (a ([href ,(format "~a~a" base-url (path->string parent-name))]) "<up>"))))
         ,@(for/list ([def (in-list (sort site-toc-defs string<? #:key first))])
             (second def))))

  (let ([content (lower-specials content base-url)])
    (define content-toc (toc content))

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

    (capy-xexp->string document)))

(define (make-hashtag-page hashtags-map site-config)
  (define base-url (assoc-ref+ site-config 'base))
  (define content
    (hashtag:execute
      (hash 'site-config site-config
            'base-url base-url
            'hashtags-map hashtags-map)))
  (define site-toc
    `(ol ()
         (li () (a ([href ,(format "~a~a" base-url "/")]) "/"))))
  (define document
    (page:execute
      (hash 'metadata `((lang "en")
                        (title "All pages by tag")
                        (summary "List of all pages on this site by tags"))
            'site-config site-config
            'base-url base-url
            'site-toc site-toc
            'content-toc #f
            'content content)))
  (capy-xexp->string document))

(define (compile-index-scss index.scss)
  (define scss-files (list *render.scss*))
  (define top-level-style
    (string-join
      (apply list index.scss (ext:get-scss-include)
             (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 img-rules
    (parameterize ([current-directory src-dir])
      (for/list ([rkt-file (in-directory #f)]
                 #:when (regexp-match? #px"\\.(png|jpg|jpeg|svg)\\.rkt$" rkt-file))
        (define out-file (path-replace-extension rkt-file #""))
        (define filetype
          (match (path-get-extension out-file)
            [#".png" 'png]
            [(or #".jpg" #".jpeg") 'jpeg]
            [#".svg" 'svg]))
        (define-rule (render-1-image [out (build-path output-dir out-file)]
                                     [in (build-path src-dir rkt-file)])
          (define icon-pict (dynamic-require (build-path src-dir rkt-file) 'icon-pict))
          (cond
            [(eq? 'svg filetype)
             (define dc (new svg-dc%
                             [width (pict-width icon-pict)]
                             [height (pict-height icon-pict)]
                             [output out]))
             (send dc start-doc "meow")
             (send dc start-page)
             (draw-pict icon-pict dc 0 0)
             (send dc end-page)
             (send dc end-doc)]
            [else
             (define icon-bitmap (pict->bitmap icon-pict))
             (send icon-bitmap save-file out filetype)]))
        render-1-image)))

  (define static-rules
    (parameterize ([current-directory src-dir])
      (for/list ([static-file (in-directory #f)]
                 #:when (regexp-match? #px"\\.(png|jpg|jpeg|svg)$" static-file))
        (define-rule (copy-static [out (build-path output-dir static-file)]
                                  [in (build-path src-dir static-file)])
          (copy-port in out))
        copy-static)))

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

  ;; TODO : this sucks
  ;; we should have a radix tree
  (define xrefs-repo
    (for/set ([spec (in-list rule-specs)]
              #:unless (set-member? *special-slugs* (rule-spec-xref-name spec)))
      (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-rule* (hashtag-page [out (build-path output-dir "hashtag.html")]
                              [ins (cons config.rktd (map rule-spec-intermediate rule-specs))])
    (define config (read (first ins)))
    (unless (config? config)
      (error "invalid config in config.rktd!"))
    (define hashtag-map (make-hash))
    (for ([ir-in (in-list (rest ins))] [xref-name (in-list (map rule-spec-xref-name rule-specs))])
      (define md (~> (port->bytes ir-in) fasl->s-exp ir-doc-metadata))
      (define title (assoc-ref+ md 'title "<untitled page>"))
      (for ([tag (in-list (assoc-ref md 'tags '()))])
        (hash-set! (hash-ref! hashtag-map tag make-hash) xref-name title)))
    (~> (make-hashtag-page hashtag-map config) (write-string out)))

  (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 xrefs-repo config)
            (write-string out)))
      output-rule))
  (define all-rules (append intermediate-rules output-rules img-rules static-rules (list scss hashtag-page)))
  (define existing-output-files
    (parameterize ([current-directory output-dir])
      (for/set ([file (in-directory #f)] #:when (file-exists? file))
        (build-path output-dir file))))
  (define accounted-output-files
    (for/set ([rule (in-list all-rules)]) (rule-output rule)))
  (define unknown-output-files (set-subtract existing-output-files accounted-output-files))
  (for ([f (in-set unknown-output-files)])
    (printf "WARN: unknown file in output dir: ~a\n" f))
  all-rules)

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