refactoring of cmaps, widgets, etc.
This commit is contained in:
@@ -1,7 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Wiki-wide CMap appearance styles stored in wiki_settings.
|
||||
;; Wiki-wide CMap appearance stored in wiki_settings.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require db
|
||||
@@ -10,10 +10,11 @@
|
||||
racket/string
|
||||
"database.rkt")
|
||||
|
||||
(provide read-cmap-styles
|
||||
save-cmap-styles!)
|
||||
(provide read-cmap-appearance
|
||||
save-cmap-appearance!)
|
||||
|
||||
(define setting-key "cmap.styles.v1")
|
||||
(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
|
||||
@@ -50,6 +51,10 @@
|
||||
(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) ""))
|
||||
@@ -130,49 +135,73 @@
|
||||
(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 shared CMap appearance styles.
|
||||
; goal : Read the complete shared CMap appearance.
|
||||
; pre : The wiki database is configured and its schema is initialized.
|
||||
; post : Default styles are inserted when no style setting exists yet.
|
||||
; result : A validated, normalized non-empty list of style hashes.
|
||||
; post : The database is not changed; absent settings use model defaults.
|
||||
; result : A hash containing validated styles and colour palette.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (read-cmap-styles config)
|
||||
(define (read-cmap-appearance config)
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((stored
|
||||
(query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key)))
|
||||
(if stored
|
||||
(normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles)
|
||||
(let ((encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))))
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING"
|
||||
setting-key encoded (current-seconds))
|
||||
(normalize-cmap-styles
|
||||
(string->jsexpr
|
||||
(query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
|
||||
'read-cmap-styles)))))))
|
||||
(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 shared CMap appearance styles.
|
||||
; pre : styles is a non-empty list containing the required default style.
|
||||
; post : The normalized style setting is stored atomically in the database.
|
||||
; result : The normalized list of stored style hashes.
|
||||
; 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-styles! config styles)
|
||||
(let* ((normalized (normalize-cmap-styles styles 'save-cmap-styles!))
|
||||
(encoded (jsexpr->string normalized)))
|
||||
(when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024))
|
||||
(error 'save-cmap-styles! "style data is too large"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (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"
|
||||
setting-key encoded (current-seconds))))
|
||||
normalized))
|
||||
(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)
|
||||
@@ -187,6 +216,7 @@
|
||||
(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?
|
||||
(λ ()
|
||||
@@ -0,0 +1,132 @@
|
||||
#lang racket/base
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Wiki and user settings for the browser-side CMap workspace.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require db
|
||||
racket/string
|
||||
"database.rkt")
|
||||
|
||||
(provide read-cmap-settings
|
||||
save-start-cmap!
|
||||
save-cmap-page-guides!
|
||||
save-cmap-zoom!)
|
||||
|
||||
(define start-cmap-setting-key "cmap.start.v1")
|
||||
|
||||
(define (clean-context-key who context-key)
|
||||
(unless (and (string? context-key)
|
||||
(not (string=? (string-trim context-key) ""))
|
||||
(<= (string-length context-key) 200))
|
||||
(error who "invalid CMap context"))
|
||||
context-key)
|
||||
|
||||
(define (clean-zoom who zoom)
|
||||
(unless (and (exact-integer? zoom) (<= 25 zoom 300))
|
||||
(error who "zoom must be an integer between 25 and 300"))
|
||||
zoom)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the wiki start CMap and one user's CMap view preferences.
|
||||
; pre : user-id identifies an authenticated wiki user.
|
||||
; post : The database is unchanged; missing preferences receive defaults.
|
||||
; result : A JSON-compatible settings hash.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (read-cmap-settings config user-id)
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(define start-slug
|
||||
(or (query-maybe-value
|
||||
db
|
||||
"SELECT value FROM wiki_settings WHERE key = $1"
|
||||
start-cmap-setting-key)
|
||||
""))
|
||||
(define page-guide-row
|
||||
(query-maybe-row
|
||||
db
|
||||
"SELECT page_guides_visible FROM user_cmap_preferences WHERE user_id = $1"
|
||||
user-id))
|
||||
(define page-guides-visible
|
||||
(if page-guide-row (vector-ref page-guide-row 0) #t))
|
||||
(define zoom-rows
|
||||
(query-rows
|
||||
db
|
||||
"SELECT cmap_slug, context_key, zoom_percent FROM user_cmap_zoom_levels WHERE user_id = $1 ORDER BY cmap_slug, context_key"
|
||||
user-id))
|
||||
(define zooms
|
||||
(for/list ((row (in-list zoom-rows)))
|
||||
(hash 'cmapSlug (vector-ref row 0)
|
||||
'contextKey (vector-ref row 1)
|
||||
'zoomPercent (vector-ref row 2))))
|
||||
(hash 'startCmapSlug start-slug
|
||||
'pageGuidesVisible page-guides-visible
|
||||
'zooms zooms))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Select the wiki-wide start CMap.
|
||||
; pre : slug is empty, or identifies a current non-archived CMap.
|
||||
; post : The start setting is removed or updated atomically.
|
||||
; result : The stored slug, or the empty string when cleared.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-start-cmap! config slug)
|
||||
(define clean-slug (if (string? slug) (string-trim slug) ""))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(cond
|
||||
((string=? clean-slug "")
|
||||
(query-exec db "DELETE FROM wiki_settings WHERE key = $1" start-cmap-setting-key))
|
||||
((query-maybe-value
|
||||
db
|
||||
"SELECT 1 FROM concept_maps WHERE slug = $1 AND archived = FALSE"
|
||||
clean-slug)
|
||||
(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"
|
||||
start-cmap-setting-key clean-slug (current-seconds)))
|
||||
(else
|
||||
(error 'save-start-cmap! "the selected start CMap does not exist")))))
|
||||
clean-slug)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store one user's wiki-wide A4 page-guide preference.
|
||||
; pre : visible is a boolean and user-id identifies an authenticated user.
|
||||
; post : The user's preference is inserted or updated atomically.
|
||||
; result : The stored boolean.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-cmap-page-guides! config user-id visible)
|
||||
(unless (boolean? visible)
|
||||
(error 'save-cmap-page-guides! "pageGuidesVisible must be a boolean"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO user_cmap_preferences(user_id, page_guides_visible, updated_at) VALUES ($1, $2, $3) ON CONFLICT(user_id) DO UPDATE SET page_guides_visible = excluded.page_guides_visible, updated_at = excluded.updated_at"
|
||||
user-id visible (current-seconds))))
|
||||
visible)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store one user's zoom for one CMap context.
|
||||
; pre : The CMap exists, context-key is non-empty and zoom is 25 through 300.
|
||||
; post : This single context preference is inserted or updated atomically.
|
||||
; result : The normalized zoom percentage.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-cmap-zoom! config user-id cmap-slug context-key zoom)
|
||||
(define clean-context (clean-context-key 'save-cmap-zoom! context-key))
|
||||
(define clean-zoom-percent (clean-zoom 'save-cmap-zoom! zoom))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(unless (query-maybe-value
|
||||
db
|
||||
"SELECT 1 FROM concept_maps WHERE slug = $1 AND archived = FALSE"
|
||||
cmap-slug)
|
||||
(error 'save-cmap-zoom! "the selected CMap does not exist"))
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO user_cmap_zoom_levels(user_id, cmap_slug, context_key, zoom_percent, updated_at) VALUES ($1, $2, $3, $4, $5) ON CONFLICT(user_id, cmap_slug, context_key) DO UPDATE SET zoom_percent = excluded.zoom_percent, updated_at = excluded.updated_at"
|
||||
user-id cmap-slug clean-context clean-zoom-percent (current-seconds))))
|
||||
clean-zoom-percent)
|
||||
+28
-1
@@ -21,7 +21,7 @@
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define current-schema-version 21)
|
||||
(define current-schema-version 22)
|
||||
|
||||
(define schema-1-statements
|
||||
(list
|
||||
@@ -1214,6 +1214,32 @@ SQL
|
||||
)
|
||||
(record-schema-version! db 21)))
|
||||
|
||||
(define (migrate-21->22! db)
|
||||
(query-exec
|
||||
db
|
||||
#<<SQL
|
||||
CREATE TABLE IF NOT EXISTS user_cmap_preferences (
|
||||
user_id BIGINT PRIMARY KEY REFERENCES users(id) ON DELETE CASCADE,
|
||||
page_guides_visible BOOLEAN NOT NULL DEFAULT TRUE,
|
||||
updated_at BIGINT NOT NULL
|
||||
)
|
||||
SQL
|
||||
)
|
||||
(query-exec
|
||||
db
|
||||
#<<SQL
|
||||
CREATE TABLE IF NOT EXISTS user_cmap_zoom_levels (
|
||||
user_id BIGINT NOT NULL REFERENCES users(id) ON DELETE CASCADE,
|
||||
cmap_slug TEXT NOT NULL REFERENCES concept_maps(slug) ON DELETE CASCADE,
|
||||
context_key TEXT NOT NULL,
|
||||
zoom_percent INTEGER NOT NULL CHECK(zoom_percent BETWEEN 25 AND 300),
|
||||
updated_at BIGINT NOT NULL,
|
||||
PRIMARY KEY(user_id, cmap_slug, context_key)
|
||||
)
|
||||
SQL
|
||||
)
|
||||
(record-schema-version! db 22))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Bring a racket-wiki PostgreSQL database to the current schema.
|
||||
; pre : db is a writable PostgreSQL connection and config identifies the
|
||||
@@ -1250,6 +1276,7 @@ SQL
|
||||
((= version 18) (migrate-18->19! db) (loop (database-schema-version db)))
|
||||
((= version 19) (migrate-19->20! db) (loop (database-schema-version db)))
|
||||
((= version 20) (migrate-20->21! db) (loop (database-schema-version db)))
|
||||
((= version 21) (migrate-21->22! db) (loop (database-schema-version db)))
|
||||
((> version current-schema-version)
|
||||
(error 'migrate-database!
|
||||
"database schema ~a is newer than this racket-wiki supports (~a)"
|
||||
|
||||
Reference in New Issue
Block a user