#lang racket ;; static generation rules (require json net/url-string markdown markdown/toc racket/fasl "compile.rkt" "prefs.rkt") (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))) (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" 'sensitive #f) 'image (hash 'type "Image" 'url "something" '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 'summary bio 'attachment (list (hash 'type "PropertyValue" 'name "pronouns" 'value (render-pronouns))) 'url instance-url 'inbox (string-append instance-url "inbox") 'sharedInbox (string-append instance-url "inbox") 'endpoints (hash 'sharedInbox (string-append instance-url "inbox")) 'outbox (string-append instance-url "outbox") 'following 'null 'followers (string-append instance-url "followers") 'liked 'null 'publicKey (hash 'id (string-append instance-url "#main-key") 'type "Key" 'owner instance-url 'publicKeyPem key))) (write-json actor out)))) (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)))) (define (generate-post-render-rules) (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") 'date (hash-ref src-meta 'date '(0 0 0)) 'hashtags (set->list hashtags) 'toc (toc post-htmls) 'content post-htmls)) out)))) (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))))) (define compiler-rules (set-union (generate-post-render-rules) (set compile-index-json compile-webfinger))) (define ops (generate-operations compiler-rules)) (for ([op (in-list ops)]) (printf "executing ~s\n" op) (execute-rule op))