refactoring of cmaps, widgets, etc.
This commit is contained in:
@@ -0,0 +1,224 @@
|
||||
#lang racket/base
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Wiki-wide CMap appearance stored in wiki_settings.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require db
|
||||
json
|
||||
racket/list
|
||||
racket/string
|
||||
"database.rkt")
|
||||
|
||||
(provide read-cmap-appearance
|
||||
save-cmap-appearance!)
|
||||
|
||||
(define styles-setting-key "cmap.styles.v1")
|
||||
(define palette-setting-key "cmap.palette.v1")
|
||||
(define maximum-style-count 100)
|
||||
(define maximum-style-name-length 80)
|
||||
(define permitted-name-keys
|
||||
'(style-default style-subtle style-emphasis style-warning style-success))
|
||||
(define value-keys
|
||||
'(backgroundColor textColor fontFamily fontSize fontWeight fontStyle
|
||||
synopsisTextColor synopsisFontFamily synopsisFontSize synopsisFontWeight
|
||||
synopsisFontStyle submapBackgroundColor submapBorderColor))
|
||||
|
||||
(define (seeded-style id name-key background text font size bold? italic? [synopsis-text #f])
|
||||
(hash 'id id
|
||||
'nameKey name-key
|
||||
'protected (string=? id "default")
|
||||
'values
|
||||
(hash 'backgroundColor background
|
||||
'textColor text
|
||||
'fontFamily font
|
||||
'fontSize size
|
||||
'fontWeight (if bold? "700" "400")
|
||||
'fontStyle (if italic? "italic" "normal")
|
||||
'synopsisTextColor (or synopsis-text text)
|
||||
'synopsisFontFamily font
|
||||
'synopsisFontSize (max 6 (- size 2))
|
||||
'synopsisFontWeight "400"
|
||||
'synopsisFontStyle (if italic? "italic" "normal")
|
||||
'submapBackgroundColor "#edf7e8"
|
||||
'submapBorderColor "#57834a")))
|
||||
|
||||
(define initial-cmap-styles
|
||||
(list
|
||||
(seeded-style "default" "style-default" "#fff4cf" "#222222" "Arial, Helvetica, sans-serif" 11 #t #f "#4d4d4d")
|
||||
(seeded-style "subtle" "style-subtle" "#f1f3f5" "#56616b" "system-ui, sans-serif" 10 #f #f)
|
||||
(seeded-style "emphasis" "style-emphasis" "#e7f2fb" "#173b57" "Georgia, Times New Roman, serif" 12 #t #f)
|
||||
(seeded-style "warning" "style-warning" "#fff0d5" "#713b00" "Arial, Helvetica, sans-serif" 11 #t #t)
|
||||
(seeded-style "success" "style-success" "#e6f4e2" "#285b27" "Arial, Helvetica, sans-serif" 11 #f #t)))
|
||||
|
||||
(define initial-cmap-palette
|
||||
'("#ffffff" "#f1f3f5" "#e7f2fb" "#e6f4e2" "#fff4cf" "#fff0d5"
|
||||
"#f7dede" "#dcd8f7" "#222222" "#4479a1" "#57834a" "#a97c00"))
|
||||
|
||||
(define (required-string who value description [maximum-length #f])
|
||||
(unless (and (string? value)
|
||||
(not (string=? (string-trim value) ""))
|
||||
(or (not maximum-length) (<= (string-length (string-trim value)) maximum-length)))
|
||||
(error who "invalid ~a" description))
|
||||
(string-trim value))
|
||||
|
||||
(define (style-color who value key)
|
||||
(unless (and (string? value) (regexp-match? #px"(?i:^#[0-9a-f]{6}$)" value))
|
||||
(error who "invalid colour for ~a" key))
|
||||
(string-downcase value))
|
||||
|
||||
(define (style-size who value key)
|
||||
(unless (and (real? value) (<= 6 value 54))
|
||||
(error who "invalid font size for ~a" key))
|
||||
value)
|
||||
|
||||
(define (normalize-style-values who values)
|
||||
(unless (hash? values) (error who "style values must be an object"))
|
||||
(for ([key (in-list value-keys)])
|
||||
(unless (hash-has-key? values key) (error who "missing style value: ~a" key)))
|
||||
(hash
|
||||
'backgroundColor (style-color who (hash-ref values 'backgroundColor) 'backgroundColor)
|
||||
'textColor (style-color who (hash-ref values 'textColor) 'textColor)
|
||||
'fontFamily (required-string who (hash-ref values 'fontFamily) "font family" 200)
|
||||
'fontSize (style-size who (hash-ref values 'fontSize) 'fontSize)
|
||||
'fontWeight (let ([value (hash-ref values 'fontWeight)])
|
||||
(unless (member value '("400" "700")) (error who "invalid font weight"))
|
||||
value)
|
||||
'fontStyle (let ([value (hash-ref values 'fontStyle)])
|
||||
(unless (member value '("normal" "italic")) (error who "invalid font style"))
|
||||
value)
|
||||
'synopsisTextColor (style-color who (hash-ref values 'synopsisTextColor) 'synopsisTextColor)
|
||||
'synopsisFontFamily (required-string who (hash-ref values 'synopsisFontFamily) "synopsis font family" 200)
|
||||
'synopsisFontSize (style-size who (hash-ref values 'synopsisFontSize) 'synopsisFontSize)
|
||||
'synopsisFontWeight (let ([value (hash-ref values 'synopsisFontWeight)])
|
||||
(unless (member value '("400" "700")) (error who "invalid synopsis font weight"))
|
||||
value)
|
||||
'synopsisFontStyle (let ([value (hash-ref values 'synopsisFontStyle)])
|
||||
(unless (member value '("normal" "italic")) (error who "invalid synopsis font style"))
|
||||
value)
|
||||
'submapBackgroundColor (style-color who (hash-ref values 'submapBackgroundColor) 'submapBackgroundColor)
|
||||
'submapBorderColor (style-color who (hash-ref values 'submapBorderColor) 'submapBorderColor)))
|
||||
|
||||
(define (normalize-cmap-styles styles [who 'cmap-styles])
|
||||
(unless (and (list? styles) (<= 1 (length styles) maximum-style-count))
|
||||
(error who "styles must contain between 1 and ~a entries" maximum-style-count))
|
||||
(let* ((seen (make-hash))
|
||||
(normalized
|
||||
(for/list ([style (in-list styles)])
|
||||
(unless (hash? style) (error who "each style must be an object"))
|
||||
(let* ((id (required-string who (hash-ref style 'id #f) "style id" 120))
|
||||
(name (and (string? (hash-ref style 'name #f))
|
||||
(required-string who
|
||||
(hash-ref style 'name)
|
||||
"style name"
|
||||
maximum-style-name-length)))
|
||||
(name-key
|
||||
(and (string? (hash-ref style 'nameKey #f))
|
||||
(string->symbol
|
||||
(required-string who
|
||||
(hash-ref style 'nameKey)
|
||||
"style name key"
|
||||
40)))))
|
||||
(unless (regexp-match? #px"^[A-Za-z0-9_-]+$" id)
|
||||
(error who "invalid style id"))
|
||||
(when (hash-ref seen id #f)
|
||||
(error who "duplicate style id: ~a" id))
|
||||
(hash-set! seen id #t)
|
||||
(unless (or name (member name-key permitted-name-keys))
|
||||
(error who "a style needs a name"))
|
||||
(hash 'id id
|
||||
(if (member name-key permitted-name-keys) 'nameKey 'name)
|
||||
(if (member name-key permitted-name-keys) (symbol->string name-key) name)
|
||||
'protected (string=? id "default")
|
||||
'values (normalize-style-values who (hash-ref style 'values #f)))))))
|
||||
(unless (hash-ref seen "default" #f)
|
||||
(error who "the default style is required"))
|
||||
normalized))
|
||||
|
||||
(define (normalize-cmap-palette palette [who 'cmap-palette])
|
||||
(unless (and (list? palette) (= (length palette) (length initial-cmap-palette)))
|
||||
(error who "the colour palette must contain ~a colours" (length initial-cmap-palette)))
|
||||
(for/list ((color (in-list palette)))
|
||||
(style-color who color 'palette)))
|
||||
|
||||
(define (read-setting db key fallback normalize who)
|
||||
(define stored (query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" key))
|
||||
(if stored
|
||||
(normalize (string->jsexpr stored) who)
|
||||
(normalize fallback who)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the complete shared CMap appearance.
|
||||
; pre : The wiki database is configured and its schema is initialized.
|
||||
; post : The database is not changed; absent settings use model defaults.
|
||||
; result : A hash containing validated styles and colour palette.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (read-cmap-appearance config)
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(hash 'styles
|
||||
(read-setting db
|
||||
styles-setting-key
|
||||
initial-cmap-styles
|
||||
normalize-cmap-styles
|
||||
'read-cmap-appearance)
|
||||
'palette
|
||||
(read-setting db
|
||||
palette-setting-key
|
||||
initial-cmap-palette
|
||||
normalize-cmap-palette
|
||||
'read-cmap-appearance)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Validate and store the complete shared CMap appearance.
|
||||
; pre : appearance contains styles and palette values accepted by this module.
|
||||
; post : Both normalized settings are stored in one database transaction.
|
||||
; result : The normalized appearance hash.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-cmap-appearance! config appearance)
|
||||
(unless (hash? appearance)
|
||||
(error 'save-cmap-appearance! "appearance must be an object"))
|
||||
(define styles
|
||||
(normalize-cmap-styles (hash-ref appearance 'styles #f) 'save-cmap-appearance!))
|
||||
(define palette
|
||||
(normalize-cmap-palette (hash-ref appearance 'palette #f) 'save-cmap-appearance!))
|
||||
(define encoded-styles (jsexpr->string styles))
|
||||
(define encoded-palette (jsexpr->string palette))
|
||||
(when (> (bytes-length (string->bytes/utf-8 encoded-styles)) (* 128 1024))
|
||||
(error 'save-cmap-appearance! "style data is too large"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
|
||||
styles-setting-key encoded-styles (current-seconds))
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
|
||||
palette-setting-key encoded-palette (current-seconds))))))
|
||||
(hash 'styles styles 'palette palette))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define values
|
||||
(hash 'backgroundColor "#FFF4CF" 'textColor "#222222"
|
||||
'fontFamily "Arial" 'fontSize 11 'fontWeight "700" 'fontStyle "normal"
|
||||
'synopsisTextColor "#4d4d4d" 'synopsisFontFamily "Arial"
|
||||
'synopsisFontSize 9 'synopsisFontWeight "400" 'synopsisFontStyle "normal"
|
||||
'submapBackgroundColor "#edf7e8" 'submapBorderColor "#57834a"))
|
||||
(define normalized
|
||||
(normalize-cmap-styles
|
||||
(list (hash 'id "default" 'nameKey "style-default" 'values values))))
|
||||
(check-equal? (hash-ref (hash-ref (first normalized) 'values) 'backgroundColor) "#fff4cf")
|
||||
(check-equal? (length (normalize-cmap-styles initial-cmap-styles)) 5)
|
||||
(check-equal? (normalize-cmap-palette initial-cmap-palette) initial-cmap-palette)
|
||||
(check-exn exn:fail? (λ () (normalize-cmap-styles '())))
|
||||
(check-exn exn:fail?
|
||||
(λ ()
|
||||
(normalize-cmap-styles
|
||||
(list (hash 'id "custom" 'name "Custom" 'values values))))))
|
||||
Reference in New Issue
Block a user