70 lines
1.9 KiB
Racket
70 lines
1.9 KiB
Racket
|
#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))
|