220 lines
9.9 KiB
Racket
220 lines
9.9 KiB
Racket
#lang racket
|
|
|
|
;; rules:
|
|
;; the actual rules that generate the blog contents
|
|
|
|
(require json
|
|
net/url-string
|
|
markdown
|
|
markdown/toc
|
|
racket/fasl
|
|
(only-in sass [compile/string sass-compile/string])
|
|
"compile.rkt"
|
|
"prefs.rkt")
|
|
|
|
;; actor context object
|
|
(define ACTOR-CONTEXT
|
|
(list "https://www.w3.org/ns/activitystreams"
|
|
"https://w3id.org/security/v1"
|
|
(hash 'manuallyApprovesFollowers "as:manuallyApprovesFollowers"
|
|
'sensitive "as:sensitive"
|
|
'movedTo (hash '@id "as:movedTo"
|
|
'@type "@id")
|
|
'alsoKnownAs (hash '@id "as:alsoKnownAs"
|
|
'@type "@id")
|
|
'Hashtag "as:Hashtag"
|
|
;; i like how there's actually nothing in this ns
|
|
;; thanks eugen lmao
|
|
'toot "http://joinmastodon.org/ns#"
|
|
'Emoji "toot:Emoji"
|
|
'focalPoint (hash '@container "@list"
|
|
'@id "toot:focalPoint")
|
|
'featured (hash '@id "toot:featured"
|
|
'@type "@id")
|
|
'schema "http://schema.org#"
|
|
'PropertyValue "schema:PropertyValue"
|
|
'value "schema:value"
|
|
'discoverable "toot:discoverable"
|
|
;; welcome to the awoo zone
|
|
'awoo "https://awoo.systems/ns#"
|
|
;; misskey has no ns for this so i'm stealing it
|
|
'isCat "awoo:isCat"
|
|
;; yeah ok why not lol
|
|
'pronouns "awoo:pronouns")))
|
|
|
|
;; transforms the xexpr into an xexpr that includes links to hashtags
|
|
(define (process-hashtags! xexpr instance-url hashtags)
|
|
(define (process+ xexpr)
|
|
(match xexpr
|
|
[(list tag attrs children ...)
|
|
(list (cons tag (cons attrs
|
|
(apply append
|
|
(map (lambda (child) (process+ child)) children)))))]
|
|
[(? string? str)
|
|
(define posns (regexp-match-positions* #px"#(\\p{L}|\\p{N})+" str))
|
|
(define-values [items last-pos]
|
|
(for/fold ([items '()] [last-pos 0]) ([pos (in-list posns)])
|
|
(define hashtag (substring str (car pos) (cdr pos)))
|
|
(set-add! hashtags hashtag)
|
|
(values (cons `(a ((href ,(string-append
|
|
instance-url
|
|
"tags/"
|
|
(substring hashtag 1))))
|
|
,hashtag)
|
|
(cons (substring str last-pos (car pos)) items))
|
|
(cdr pos))))
|
|
(reverse (cons (substring str last-pos) items))]))
|
|
(first (process+ xexpr)))
|
|
|
|
;; creates the index.json file (an actor object for this blog)
|
|
(define compile-index-json
|
|
(rule '("db/actorkey.pub" "src/instance.rktd" "src/bio.md") "public/index.json"
|
|
(lambda (in out)
|
|
(define key (port->string (hash-ref in "db/actorkey.pub")))
|
|
(define prefs (prefs-load (hash-ref in "src/instance.rktd")))
|
|
(define instance-url (prefs-get prefs 'instance-url))
|
|
(define bio-md (port->string (hash-ref in "src/bio.md")))
|
|
|
|
(define bio-hashtags (mutable-set))
|
|
(define bio-xs (map (lambda (b) (process-hashtags! b instance-url bio-hashtags))
|
|
(parse-markdown bio-md)))
|
|
(define bio (apply string-append (map xexpr->string bio-xs)))
|
|
|
|
(define (render-pronouns)
|
|
(define p (prefs-get prefs 'pronouns))
|
|
(match p
|
|
[(list a b _ ...) (format "~a/~a" a b)]
|
|
[_ "any"]))
|
|
|
|
(define actor (hash
|
|
'@context ACTOR-CONTEXT
|
|
'Type "Person"
|
|
'id instance-url
|
|
'name (prefs-get prefs 'display-name)
|
|
'preferredUsername (prefs-get prefs 'name)
|
|
'discoverable (prefs-get prefs 'make-discoverable)
|
|
'isCat (prefs-get prefs 'is-cat)
|
|
'pronouns (hash 'en (prefs-get prefs 'pronouns))
|
|
'icon (hash 'type "Image"
|
|
'url "something" ;; TODO
|
|
'sensitive #f)
|
|
'image (hash 'type "Image"
|
|
'url "something" ;; TODO
|
|
'sensitive #f)
|
|
'tag (for/list ([hashtag (in-set bio-hashtags)])
|
|
(hash 'type "Hashtag"
|
|
'href (string-append instance-url "tags/"
|
|
(substring hashtag 1))
|
|
'name hashtag))
|
|
'manuallyApprovesFollowers #f ;; TODO
|
|
'summary bio
|
|
'attachment (list (hash 'type "PropertyValue" ;; TODO
|
|
'name "pronouns"
|
|
'value (render-pronouns)))
|
|
'url instance-url
|
|
'inbox (string-append instance-url "inbox")
|
|
'sharedInbox (string-append instance-url "inbox")
|
|
;; there's only one inbox
|
|
'endpoints (hash 'sharedInbox (string-append instance-url "inbox"))
|
|
'outbox (string-append instance-url "outbox")
|
|
;; currently we don't support actually following anyone
|
|
'following 'null
|
|
'followers (string-append instance-url "followers")
|
|
;; liking posts is similarly not supported
|
|
'liked 'null
|
|
;; TODO key rotation or something idk
|
|
'publicKey (hash 'id (string-append instance-url "#main-key")
|
|
'type "Key"
|
|
'owner instance-url
|
|
'publicKeyPem key)))
|
|
(write-json actor out))))
|
|
|
|
;; builds the webfinger endpoint for the instance actor
|
|
(define compile-webfinger
|
|
(rule '("src/instance.rktd") "public/webfinger.json"
|
|
(lambda (in out)
|
|
(define prefs (prefs-load (hash-ref in "src/instance.rktd")))
|
|
(define instance-url (prefs-get prefs 'instance-url))
|
|
(define host (url-host (string->url instance-url)))
|
|
(define name (prefs-get prefs 'name))
|
|
(define webfinger
|
|
(hash
|
|
'subject (format "acct:~a@~a" name host)
|
|
'links (list (hash
|
|
'rel "self"
|
|
'type "application/activity+json"
|
|
'href instance-url))))
|
|
(write-json webfinger out))))
|
|
|
|
;; generates render rules for each post that is present
|
|
(define (generate-post-render-rules)
|
|
;; creates a rule that builds common post info into cache
|
|
(define (make-post-cache-rule post-src post-dst)
|
|
(rule `("src/instance.rktd" ,post-src) post-dst
|
|
(lambda (in out)
|
|
(define prefs (prefs-load (hash-ref in "src/instance.rktd")))
|
|
(define instance-url (prefs-get prefs 'instance-url))
|
|
(define src-meta-raw (read (hash-ref in post-src)))
|
|
(define src-meta
|
|
(for/hash ([x (in-list src-meta-raw)])
|
|
(values (first x) (second x))))
|
|
(define post-content (port->string (hash-ref in post-src)))
|
|
(define hashtags (mutable-set))
|
|
(define post-htmls (map (lambda (b)
|
|
(process-hashtags! b instance-url hashtags))
|
|
(parse-markdown post-content)))
|
|
(write-bytes
|
|
(s-exp->fasl
|
|
(hash 'is-meow (hash-ref src-meta 'is-meow #t)
|
|
'title (hash-ref src-meta 'title "unknown")
|
|
'summary (hash-ref src-meta 'summary "unknown")
|
|
'date (hash-ref src-meta 'date '(0 0 0))
|
|
'hashtags (set->list hashtags)
|
|
'toc (toc post-htmls)
|
|
'content post-htmls))
|
|
out))))
|
|
|
|
;; add all cache rules
|
|
(define-values [posts-set cache-set]
|
|
(for/fold ([posts (set)] [caches (set)]) ([post-name (in-list (directory-list "src/posts"))]
|
|
#:when (regexp-match? #px"\\.md$" post-name))
|
|
(define post-src (build-path "src/posts" post-name))
|
|
(define cache-dst (build-path "cache/posts"
|
|
(path-replace-extension post-name ".rktb")))
|
|
(define json-dst (build-path "public/posts/"))
|
|
(values
|
|
(set-add posts (make-post-cache-rule post-src cache-dst))
|
|
(set-add caches cache-dst))))
|
|
;; use the cache set to make a tags rule
|
|
(set-add
|
|
posts-set
|
|
(rule (set->list cache-set) "cache/tagindex.rktb"
|
|
(lambda (in out)
|
|
(define index (make-hash))
|
|
(for ([(fname port) (in-hash in)])
|
|
(define meta (fasl->s-exp (port->bytes port)))
|
|
(for ([tag (in-list (hash-ref meta 'hashtags))])
|
|
(hash-update! index tag (lambda (s) (set-add s fname)) set)))
|
|
(write-bytes (s-exp->fasl (for/hash ([(k v) (in-hash index)])
|
|
(values k (set->list v)))) out)))))
|
|
|
|
;; build the main blog css
|
|
(define compile-css
|
|
(rule '("src/style.sass") "public/style.css"
|
|
(lambda (in out)
|
|
(define str (port->string (hash-ref in "src/style.sass")))
|
|
(write-string (sass-compile/string str #t) out))))
|
|
|
|
;; collect all compiler rules
|
|
(define compiler-rules
|
|
(set-union
|
|
(generate-post-render-rules)
|
|
(set compile-css
|
|
compile-index-json
|
|
compile-webfinger)))
|
|
|
|
(define ops (generate-operations compiler-rules))
|
|
(for ([op (in-list ops)])
|
|
(printf "executing ~s\n" op)
|
|
(execute-rule op))
|