#lang racket/base

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Wiki-wide CMap appearance styles stored in wiki_settings.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require db
         json
         racket/list
         racket/string
         "database.rkt")

(provide read-cmap-styles
         save-cmap-styles!)

(define setting-key "cmap.styles.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 (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))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read the shared CMap appearance styles.
; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-cmap-styles 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)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))

(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-exn exn:fail? (λ () (normalize-cmap-styles '())))
  (check-exn exn:fail?
             (λ ()
               (normalize-cmap-styles
                (list (hash 'id "custom" 'name "Custom" 'values values))))))