From f68515ddb9bc6b6de4b4dc60b112b2a538b65887 Mon Sep 17 00:00:00 2001 From: haskal Date: Mon, 4 May 2020 01:54:07 -0400 Subject: [PATCH] Formalize preferences --- private/prefs.rkt | 69 +++++++++++++++++++++++++++++++++++++++++++++ private/rules.rkt | 72 +++++++++++++++++++++++++++++------------------ scripts/init | 16 ++++------- 3 files changed, 120 insertions(+), 37 deletions(-) create mode 100644 private/prefs.rkt diff --git a/private/prefs.rkt b/private/prefs.rkt new file mode 100644 index 0000000..055e783 --- /dev/null +++ b/private/prefs.rkt @@ -0,0 +1,69 @@ +#lang racket + +(require net/url-string) + +(provide prefs-save prefs-load prefs-get prefs-update DEFAULT-PREFS) + +(define (instance-url? x) + (and (string? x) + (with-handlers ([exn? (lambda (e) #f)]) + (let ([u (string->url x)]) + (string=? "https" (url-scheme u)))))) + +(define (id-string? x) + (and (string? x) (regexp-match-exact? #px"^[a-zA-Z0-9_]+$" x))) + +(define (pronoun-list? x) + (and (list? x) (= 5 (length x)))) + +(define SCHEMA + (hash 'instance-url instance-url? + 'display-name string? + 'name id-string? + 'make-discoverable boolean? + 'is-cat boolean? + 'pronouns pronoun-list?)) + +(define DEFAULT-PREFS + '((instance-url "https://myinstance.tld/") + (display-name "Display Name(tm)") + (name "username") + (make-discoverable #t) + (is-cat #t) + (pronouns ("they" "them" "their" "theirs" "themselves")))) + +(define (prefs-save prefs [port (current-output-port)]) + (pretty-write prefs port)) + +(define (validate-one k v) + (unless (hash-has-key? SCHEMA k) + (error "unknown preference name" k)) + (unless (apply (hash-ref SCHEMA k) (list v)) + (error "invalid preference value" v (hash-ref SCHEMA k)))) + +(define (validate x) + (unless (list? x) + (error "preferences must be list")) + (for ([kv (in-list x)]) + (match kv + [(list k v) (validate-one k v)] + [_ (error "invalid preference")])) + x) +(void (validate DEFAULT-PREFS)) + +(define (prefs-load [port (current-input-port)]) + (validate (read port))) + +(define (prefs-get prefs what) + (match prefs + [(list _ ... (list (? (curry symbol=? what)) value) _ ...) value] + [_ (error "no such pref" prefs what)])) + +(define (prefs-update prefs key value) + (validate-one key value) + (define (upd p) + (match p + ['() (list (list key value))] + [(list (list (? (curry symbol=? key)) _) rst ...) (cons (list key value) rst)] + [x (cons (first x) (upd (rest x)))])) + (upd prefs)) diff --git a/private/rules.rkt b/private/rules.rkt index 3d713b3..e69eceb 100644 --- a/private/rules.rkt +++ b/private/rules.rkt @@ -4,55 +4,73 @@ (require json net/url-string - "compile.rkt") - -(define (get-pref prefs what) - (match prefs - [(list _ ... (list (? (curry symbol=? what)) value) _ ...) value] - [_ (error "no such pref" prefs what)])) + "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 "as:movedTo" + '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 "toot:featured"))) + '@id "toot:focalPoint") + 'featured (hash '@id "toot:featured" + '@type "@id") + 'schema "http://schema.org#" + 'PropertyValue "schema:PropertyValue" + 'value "schema:value" + 'discoverable "toot:discoverable" + ;; todo put an actual ns here + '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"))) (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 (read (hash-ref in "src/instance.rktd"))) - (define instance-url (get-pref prefs 'shonks:instance-url)) - (define display-name (get-pref prefs 'shonks:display-name)) - (define name (get-pref prefs 'shonks:name)) + (define prefs (prefs-load (hash-ref in "src/instance.rktd"))) (define bio (port->string (hash-ref in "src/bio.md"))) + (define (render-pronouns) + (define p (prefs-get prefs 'pronouns)) + (match p + [(list a b _ ...) (format "~a/~a" a b)] + [_ "any"])) + (define instance-url (prefs-get prefs 'instance-url)) (define actor (hash '@context ACTOR-CONTEXT 'Type "Person" 'id instance-url - 'name display-name - 'preferredUsername name + '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) + 'url "something" + 'sensitive #f) 'image (hash 'type "Image" 'url "something" 'sensitive #f) 'tag (list (hash 'type "Hashtag" - 'href (string-append instance-url "tags/blahaj") - 'name "#blahaj")) + 'href (string-append instance-url "tags/blahaj") + 'name "#blahaj")) 'manuallyApprovesFollowers #f 'summary bio 'attachment (list (hash 'type "PropertyValue" - 'name "pronouns" - 'value "they/them")) + 'name "pronouns" + 'value (render-pronouns))) 'url instance-url 'inbox (string-append instance-url "inbox") 'sharedInbox (string-append instance-url "inbox") @@ -62,18 +80,18 @@ 'followers (string-append instance-url "followers") 'liked 'null 'publicKey (hash 'id (string-append instance-url "#main-key") - 'type "Key" - 'owner instance-url - 'publicKeyPem 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 (read (hash-ref in "src/instance.rktd"))) - (define instance-url (get-pref prefs 'shonks:instance-url)) + (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 (get-pref prefs 'shonks:name)) + (define name (prefs-get prefs 'name)) (define webfinger (hash 'subject (format "acct:~a@~a" name host) diff --git a/scripts/init b/scripts/init index b2146da..2c2d2e8 100755 --- a/scripts/init +++ b/scripts/init @@ -5,7 +5,9 @@ (require db crypto crypto/libcrypto - net/base64) + net/base64 + "../private/prefs.rkt" + "../private/taskq.rkt") (when (file-exists? "version") (displayln "current directory contains data") @@ -43,14 +45,9 @@ ; src and public (make-directory "src") -;; TODO -;; don't rly like preferences, so this is custom because i said so :P -(define DEFAULT-PREFS - '((shonks:instance-url "https://myinstance.tld/") - (shonks:display-name "Display Name(tm)") - (shonks:name "username"))) + (with-output-to-file "src/instance.rktd" - (lambda () (pretty-write DEFAULT-PREFS) (void))) + (lambda () (prefs-save DEFAULT-PREFS) (void))) (with-output-to-file "src/bio.md" (lambda () (write-string "this section left intentionally blank") @@ -64,8 +61,7 @@ (make-directory "nginx") ; task queue -(require "../private/taskq.rkt") -(taskq-close (make-taskq "taskq.sqlite3" #t)) +(taskq-shutdown (make-taskq "taskq.sqlite3" #t)) (with-output-to-file "version" (lambda () (write-string "1.0") (void)))