Formalize preferences
This commit is contained in:
parent
e1d9ec6fc5
commit
f68515ddb9
|
@ -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))
|
|
@ -4,41 +4,59 @@
|
||||||
|
|
||||||
(require json
|
(require json
|
||||||
net/url-string
|
net/url-string
|
||||||
"compile.rkt")
|
"compile.rkt"
|
||||||
|
"prefs.rkt")
|
||||||
(define (get-pref prefs what)
|
|
||||||
(match prefs
|
|
||||||
[(list _ ... (list (? (curry symbol=? what)) value) _ ...) value]
|
|
||||||
[_ (error "no such pref" prefs what)]))
|
|
||||||
|
|
||||||
(define ACTOR-CONTEXT
|
(define ACTOR-CONTEXT
|
||||||
(list "https://www.w3.org/ns/activitystreams"
|
(list "https://www.w3.org/ns/activitystreams"
|
||||||
"https://w3id.org/security/v1"
|
"https://w3id.org/security/v1"
|
||||||
(hash 'manuallyApprovesFollowers "as:manuallyApprovesFollowers"
|
(hash 'manuallyApprovesFollowers "as:manuallyApprovesFollowers"
|
||||||
'sensitive "as:sensitive"
|
'sensitive "as:sensitive"
|
||||||
'movedTo "as:movedTo"
|
'movedTo (hash '@id "as:movedTo"
|
||||||
|
'@type "@id")
|
||||||
|
'alsoKnownAs (hash '@id "as:alsoKnownAs"
|
||||||
|
'@type "@id")
|
||||||
'Hashtag "as:Hashtag"
|
'Hashtag "as:Hashtag"
|
||||||
|
;; i like how there's actually nothing in this ns
|
||||||
|
;; thanks eugen lmao
|
||||||
'toot "http://joinmastodon.org/ns#"
|
'toot "http://joinmastodon.org/ns#"
|
||||||
'Emoji "toot:Emoji"
|
'Emoji "toot:Emoji"
|
||||||
'focalPoint (hash '@container "@list"
|
'focalPoint (hash '@container "@list"
|
||||||
'@id "toot:focalPoint")
|
'@id "toot:focalPoint")
|
||||||
'featured "toot:featured")))
|
'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
|
(define compile-index-json
|
||||||
(rule '("db/actorkey.pub" "src/instance.rktd" "src/bio.md") "public/index.json"
|
(rule '("db/actorkey.pub" "src/instance.rktd" "src/bio.md") "public/index.json"
|
||||||
(lambda (in out)
|
(lambda (in out)
|
||||||
(define key (port->string (hash-ref in "db/actorkey.pub")))
|
(define key (port->string (hash-ref in "db/actorkey.pub")))
|
||||||
(define prefs (read (hash-ref in "src/instance.rktd")))
|
(define prefs (prefs-load (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 bio (port->string (hash-ref in "src/bio.md")))
|
(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
|
(define actor (hash
|
||||||
'@context ACTOR-CONTEXT
|
'@context ACTOR-CONTEXT
|
||||||
'Type "Person"
|
'Type "Person"
|
||||||
'id instance-url
|
'id instance-url
|
||||||
'name display-name
|
'name (prefs-get prefs 'display-name)
|
||||||
'preferredUsername 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"
|
'icon (hash 'type "Image"
|
||||||
'url "something"
|
'url "something"
|
||||||
'sensitive #f)
|
'sensitive #f)
|
||||||
|
@ -52,7 +70,7 @@
|
||||||
'summary bio
|
'summary bio
|
||||||
'attachment (list (hash 'type "PropertyValue"
|
'attachment (list (hash 'type "PropertyValue"
|
||||||
'name "pronouns"
|
'name "pronouns"
|
||||||
'value "they/them"))
|
'value (render-pronouns)))
|
||||||
'url instance-url
|
'url instance-url
|
||||||
'inbox (string-append instance-url "inbox")
|
'inbox (string-append instance-url "inbox")
|
||||||
'sharedInbox (string-append instance-url "inbox")
|
'sharedInbox (string-append instance-url "inbox")
|
||||||
|
@ -70,10 +88,10 @@
|
||||||
(define compile-webfinger
|
(define compile-webfinger
|
||||||
(rule '("src/instance.rktd") "public/webfinger.json"
|
(rule '("src/instance.rktd") "public/webfinger.json"
|
||||||
(lambda (in out)
|
(lambda (in out)
|
||||||
(define prefs (read (hash-ref in "src/instance.rktd")))
|
(define prefs (prefs-load (hash-ref in "src/instance.rktd")))
|
||||||
(define instance-url (get-pref prefs 'shonks:instance-url))
|
(define instance-url (prefs-get prefs 'instance-url))
|
||||||
(define host (url-host (string->url 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
|
(define webfinger
|
||||||
(hash
|
(hash
|
||||||
'subject (format "acct:~a@~a" name host)
|
'subject (format "acct:~a@~a" name host)
|
||||||
|
|
16
scripts/init
16
scripts/init
|
@ -5,7 +5,9 @@
|
||||||
(require db
|
(require db
|
||||||
crypto
|
crypto
|
||||||
crypto/libcrypto
|
crypto/libcrypto
|
||||||
net/base64)
|
net/base64
|
||||||
|
"../private/prefs.rkt"
|
||||||
|
"../private/taskq.rkt")
|
||||||
|
|
||||||
(when (file-exists? "version")
|
(when (file-exists? "version")
|
||||||
(displayln "current directory contains data")
|
(displayln "current directory contains data")
|
||||||
|
@ -43,14 +45,9 @@
|
||||||
|
|
||||||
; src and public
|
; src and public
|
||||||
(make-directory "src")
|
(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"
|
(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"
|
(with-output-to-file "src/bio.md"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(write-string "this section left intentionally blank")
|
(write-string "this section left intentionally blank")
|
||||||
|
@ -64,8 +61,7 @@
|
||||||
(make-directory "nginx")
|
(make-directory "nginx")
|
||||||
|
|
||||||
; task queue
|
; task queue
|
||||||
(require "../private/taskq.rkt")
|
(taskq-shutdown (make-taskq "taskq.sqlite3" #t))
|
||||||
(taskq-close (make-taskq "taskq.sqlite3" #t))
|
|
||||||
|
|
||||||
(with-output-to-file "version" (lambda () (write-string "1.0") (void)))
|
(with-output-to-file "version" (lambda () (write-string "1.0") (void)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue