Formalize preferences

This commit is contained in:
xenia 2020-05-04 01:54:07 -04:00
parent e1d9ec6fc5
commit f68515ddb9
3 changed files with 120 additions and 37 deletions

69
private/prefs.rkt Normal file
View File

@ -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))

View File

@ -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)

View File

@ -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)))