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,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)
|
||||
|
|
|
|||
16
scripts/init
16
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)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue