chomp/private/prefs.rkt

#lang racket

;; prefs:
;; utilities for reading and writing preferences

(require net/url-string)

(provide prefs-save prefs-load prefs-get prefs-update DEFAULT-PREFS)

(define (instance-url? x)
  (and (string? x)
       (char=? (last (string->list 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))))

;; a preferences schema with validation functions
(define SCHEMA
  (hash 'instance-url instance-url?
        'display-name string?
        'name id-string?
        'title string?
        'make-discoverable boolean?
        'is-cat boolean?
        'lang string?
        'pronouns pronoun-list?))

(define DEFAULT-PREFS
  '((instance-url "https://myinstance.tld/")
    (display-name "Display Name(tm)")
    (name "username")
    (title "My Shiny New Blog")
    (lang "en")
    (make-discoverable #t)
    (is-cat #t)
    (pronouns ("they" "them" "their" "theirs" "themselves"))))

;; saves preferences to the given port (or current out)
(define (prefs-save prefs [port (current-output-port)])
  (pretty-write prefs port))

;; validates a preference entry against the schema
(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))))

;; validates a whole prefs object
(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)
;; check the defaults
(void (validate DEFAULT-PREFS))

;; reads and validates preferences from the given port (or current in)
(define (prefs-load [port (current-input-port)])
  (validate (read port)))

;; finds a preference by name
(define (prefs-get prefs what)
  (match prefs
    [(list _ ... (list (? (curry symbol=? what)) value) _ ...) value]
    [_ (error "no such pref" prefs what)]))

;; updates one key/value pair in the preferences list
(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))