#lang racket/base

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; First-run setup state and web setup processing.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require crypto
         net/uri-codec
         racket/path
         racket/string
         web-server/http
         "auth.rkt"
         "config.rkt"
         "database.rkt"
         "http-util.rkt"
         "vendor.rkt"
         "../translate.rkt")

(provide setup-complete?
         setup-handler)

(define setup-lock (make-semaphore 1))

(define (bytes->hex value)
  (apply string-append
         (for/list ((byte (in-bytes value)))
           (define hex (number->string byte 16))
           (if (= (string-length hex) 1)
               (string-append "0" hex)
               hex))))

(define setup-form-token
  (bytes->hex (crypto-random-bytes 32)))

(define (admin-ready? config)
  (and (database-ready? config)
       (with-handlers ((exn:fail? (λ (_e) #f)))
         (administrator-exists? config))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Check whether the wiki has everything required for normal use.
; pre    : The data directory is accessible.
; post   : PostgreSQL configuration/schema and vendor files have only been inspected.
; result : #t when PostgreSQL, an administrator and browser libraries are ready.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (setup-complete? config)
  (and (database-ready? config)
       (admin-ready? config)
       (vendor-files-ready? config)))

(define (request-form req)
  (define body (request-post-data/raw req))
  (if body
      (form-urlencoded->alist (bytes->string/utf-8 body))
      '()))

(define (form-value form key [default ""])
  (define found (assoc key form))
  (if (and found (cdr found))
      (cdr found)
      default))

(define setup-style
  #<<CSS
html { box-sizing: border-box; font-family: system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", sans-serif; color: #172033; background: #f4f6f8; }
*, *::before, *::after { box-sizing: inherit; }
body { margin: 0; min-height: 100vh; display: grid; place-items: center; padding: 32px; }
.setup { width: min(700px, 100%); background: white; border: 1px solid #d7dde5; border-radius: 14px; padding: 34px; box-shadow: 0 12px 40px rgba(22, 32, 51, 0.08); }
h1 { margin: 0 0 10px; font-size: 2rem; }
h2 { margin: 28px 0 8px; font-size: 1.15rem; }
p { line-height: 1.55; }
.status { margin: 24px 0; padding: 0; list-style: none; border-top: 1px solid #e3e7ed; }
.status li { display: flex; justify-content: space-between; gap: 20px; padding: 12px 0; border-bottom: 1px solid #e3e7ed; }
.ready { color: #286b3d; font-weight: 600; }
.pending { color: #8b5d00; font-weight: 600; }
.fields { display: grid; grid-template-columns: 1fr 140px; gap: 0 14px; }
.fields .wide { grid-column: 1 / -1; }
label { display: block; margin: 12px 0; font-weight: 600; }
input, select { display: block; width: 100%; margin-top: 6px; padding: 10px 12px; font: inherit; border: 1px solid #aeb7c4; border-radius: 6px; background: white; }
button { margin-top: 18px; padding: 10px 18px; font: inherit; font-weight: 600; cursor: pointer; }
.error { margin: 18px 0; padding: 12px 14px; background: #fff1f1; border: 1px solid #e8b7b7; border-radius: 6px; color: #8b1f1f; white-space: pre-wrap; }
.note { color: #5b6472; font-size: 0.94rem; }
code { background: #f2f4f7; padding: 2px 5px; border-radius: 4px; }
@media (max-width: 620px) { .fields { grid-template-columns: 1fr; } .fields .wide { grid-column: auto; } }
CSS
  )

(define (status-row label ready? ready-text pending-text)
  `(li
    (span ,label)
    (span ((class ,(if ready? "ready" "pending")))
          ,(if ready? ready-text pending-text))))

(define (setting-value settings getter default)
  (if settings (getter settings) default))


(define (language-field config [form '()])
  (define language (form-value form 'language (current-language config)))
  `((label
     ,(tr config 'language)
     (select ((name "language"))
       (option ((value "en") ,@(if (string-ci=? language "en") '((selected "selected")) '())) ,(tr config 'language-en))
       (option ((value "nl") ,@(if (string-ci=? language "nl") '((selected "selected")) '())) ,(tr config 'language-nl))))))

(define (database-fields config [form '()])
  (define settings (read-database-settings config))
  (define ssl-text
    (form-value form
                'db-ssl
                (symbol->string (setting-value settings database-settings-ssl 'no))))
  (define ssl (string->symbol ssl-text))
  `((h2 ,(tr config 'postgresql))
    (div ((class "fields"))
      (label
       ,(tr config 'server)
       (input ((name "db-server")
               (value ,(form-value form 'db-server (setting-value settings database-settings-server "localhost")))
               (required "required"))))
      (label
       ,(tr config 'port)
       (input ((name "db-port")
               (type "number")
               (min "1")
               (max "65535")
               (value ,(form-value form 'db-port (number->string (setting-value settings database-settings-port 5432))))
               (required "required"))))
      (label ((class "wide"))
       ,(tr config 'database)
       (input ((name "db-database")
               (value ,(form-value form 'db-database (setting-value settings database-settings-database "racket_wiki")))
               (required "required"))))
      (label ((class "wide"))
       ,(tr config 'user)
       (input ((name "db-user")
               (autocomplete "username")
               (value ,(form-value form 'db-user (setting-value settings database-settings-user "")))
               (required "required"))))
      (label ((class "wide"))
       ,(tr config 'password)
       (input ((name "db-password")
               (type "password")
               (autocomplete "current-password")
               (value ""))))
      (label ((class "wide"))
       ,(tr config 'tls-ssl)
       (select ((name "db-ssl"))
         (option ((value "no") ,@(if (eq? ssl 'no) '((selected "selected")) '())) ,(tr config 'ssl-no))
         (option ((value "optional") ,@(if (eq? ssl 'optional) '((selected "selected")) '())) ,(tr config 'ssl-optional))
         (option ((value "yes") ,@(if (eq? ssl 'yes) '((selected "selected")) '())) ,(tr config 'ssl-required)))))))

(define (admin-fields config [form '()])
  `((h2 ,(tr config 'administrator))
    (label
     ,(tr config 'administrator-username)
     (input ((name "username")
             (autocomplete "username")
             (value ,(form-value form 'username ""))
             (required "required"))))
    (label
     ,(tr config 'display-name)
     (input ((name "display-name")
             (autocomplete "name")
             (value ,(form-value form 'display-name ""))
             (placeholder "Optional; defaults to username"))))
    (label
     ,(tr config 'administrator-password)
     (input ((name "password")
             (type "password")
             (autocomplete "new-password")
             (required "required"))))
    (label
     ,(tr config 'repeat-password)
     (input ((name "password-confirm")
             (type "password")
             (autocomplete "new-password")
             (required "required"))))))

(define (setup-page config [message #f] [form '()])
  (define db-ready? (database-ready? config))
  (define administrator-ready? (admin-ready? config))
  (define vendor-ready? (vendor-files-ready? config))
  `(html
    (head
     (meta ((charset "utf-8")))
     (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
     (title ,(string-append "Setup - " (wiki-config-site-title config)))
     (style ,setup-style))
    (body
     (main ((class "setup"))
       (h1 ,(tr config 'setup-title))
       (p ,(tr config 'setup-description))
       (ul ((class "status"))
         ,(status-row (tr config 'postgresql) db-ready? (tr config 'ready) (tr config 'required))
         ,(status-row (tr config 'administrator-account) administrator-ready? (tr config 'ready) (tr config 'required))
         ,(status-row (tr config 'frontend-libraries) vendor-ready? (tr config 'ready) (tr config 'will-download)))
       ,@(if message
             `((div ((class "error")) ,message))
             '())
       (form ((method "post") (action "/setup"))
         (input ((type "hidden") (name "setup-token") (value ,setup-form-token)))
         ,@(language-field config form)
         ,@(if db-ready? '() (database-fields config form))
         ,@(if administrator-ready? '() (admin-fields config form))
         (button ((type "submit")) ,(tr config 'complete-setup)))
       (p ((class "note"))
          "PostgreSQL connection settings are stored in "
          (code ,(path->string (database-config-path config)))
          ". Protect the wiki data directory as you would any other file containing database credentials.")
       (p ((class "note"))
          "Frontend libraries are stored below "
          (code ,(path->string (vendor-directory config)))
          " and are served locally after setup.")))))

(define (setup-page-response config [message #f] [form '()])
  (html-response
   (setup-page config message form)
   #:headers (list (make-header #"Cache-Control" #"no-store"))))

(define (validate-admin-form form)
  (define username (string-trim (form-value form 'username)))
  (define display-name (string-trim (form-value form 'display-name)))
  (define password (form-value form 'password))
  (define password-confirm (form-value form 'password-confirm))
  (cond
    ((string=? username "") "Administrator username is required.")
    ((string=? password "") "Administrator password is required.")
    ((< (string-length password) 8) "Administrator password must contain at least 8 characters.")
    ((not (string=? password password-confirm)) "The two passwords do not match.")
    (else
     (list username
           (if (string=? display-name "") username display-name)
           password))))

(define (form->database-settings form)
  (define port (string->number (form-value form 'db-port "5432")))
  (define ssl-text (form-value form 'db-ssl "no"))
  (define ssl
    (cond
      ((string=? ssl-text "yes") 'yes)
      ((string=? ssl-text "optional") 'optional)
      (else 'no)))
  (cond
    ((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.")
    ((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.")
    ((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.")
    ((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.")
    (else
     (database-settings (string-trim (form-value form 'db-server))
                        port
                        (string-trim (form-value form 'db-database))
                        (string-trim (form-value form 'db-user))
                        (form-value form 'db-password)
                        ssl))))


(define (configure-language! config form)
  (define language (string-downcase (form-value form 'language (current-language config))))
  (unless (member language '("en" "nl"))
    (error 'setup "Unsupported UI language: ~a" language))
  (write-language! config language))

(define (configure-database! config form)
  (unless (database-ready? config)
    (define settings (form->database-settings form))
    (when (string? settings)
      (error 'setup settings))
    (test-database-settings! settings)
    (initialize-database-with-settings! settings config)
    (write-database-settings! config settings)))

(define (configure-administrator! config form)
  (unless (admin-ready? config)
    (define admin-values (validate-admin-form form))
    (when (string? admin-values)
      (error 'setup admin-values))
    (create-user! config
                  (list-ref admin-values 0)
                  (list-ref admin-values 1)
                  (list-ref admin-values 2)
                  'admin
                  'enabled)))

(define (cleartext-password-error? message)
  (and (string? message)
       (regexp-match? #rx"refusing to send cleartext password" message)))

(define (setup-error-message e)
  (define message (exn-message e))
  (if (cleartext-password-error? message)
      (string-append
       "PostgreSQL requests cleartext password authentication. "
       "Configure the matching pg_hba.conf rule for this database/user to use "
       "scram-sha-256 (recommended), then reload PostgreSQL and try again. "
       "If more than one pg_hba.conf rule could match, remember that PostgreSQL "
       "uses the first matching rule. "
       "The entered non-password fields have been preserved below.\n\n"
       "Technical detail: " message)
      message))

(define (complete-setup! config req)
  (call-with-semaphore
   setup-lock
   (λ ()
     (if (setup-complete? config)
         (redirect-response "/login")
         (let ((form (request-form req)))
           (cond
             ((not (string=? (form-value form 'setup-token) setup-form-token))
              (setup-page-response
               config
               "Invalid setup form token. Reload the setup page and try again."
               form))
             (else
              (with-handlers ((exn:fail?
                               (λ (e)
                                 (setup-page-response
                                  config
                                  (setup-error-message e)
                                  form))))
                (configure-language! config form)
                (configure-database! config form)
                (configure-administrator! config form)
                (download-vendor-files! config)
                (redirect-response "/login")))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Handle the web-based initial setup page.
; pre    : req is a GET or POST request for /setup.
; post   : POST can configure PostgreSQL, create the first administrator and
;          download frontend libraries.
; result : An HTML setup response or a redirect to /login.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (setup-handler config req)
  (cond
    ((setup-complete? config)
     (redirect-response "/login"))
    ((string-ci=? (bytes->string/latin-1 (request-method req)) "POST")
     (complete-setup! config req))
    (else
     (setup-page-response config))))