359 lines
15 KiB
Racket
359 lines
15 KiB
Racket
#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))))
|