#lang racket/base

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP routing and server-rendered setup/login handling.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require net/url
         net/uri-codec
         racket/file
         racket/list
         racket/string
         (prefix-in cookie: net/cookies/server)
         web-server/dispatch
         web-server/dispatchers/dispatch
         web-server/http
         web-server/servlet-env
         "private/auth.rkt"
         "private/cmap-storage.rkt"
         "private/config.rkt"
         "private/http-util.rkt"
         "private/mail.rkt"
         "private/setup.rkt"
         "private/storage.rkt"
         "private/version.rkt"
         "translate.rkt")

(provide start-wiki-server)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (user->jsexpr user)
  (hash 'id (wiki-user-id user)
        'username (wiki-user-username user)
        'displayName (wiki-user-display-name user)
        'email (or (wiki-user-email user) "")
        'role (symbol->string (wiki-user-role user))
        'enabled (wiki-user-enabled? user)))

(define (session->jsexpr session)
  (if session
      (hash 'authenticated #t
            'user (user->jsexpr (wiki-session-user session))
            'csrfToken (wiki-session-csrf-token session))
      (hash 'authenticated #f)))

(define (require-role config req role proc)
  (define session (session-from-request config req))
  (cond
    ((not session) (json-error 401 "Authentication required"))
    ((not (role-at-least? (wiki-session-user session) role))
     (json-error 403 "Insufficient permissions"))
    (else (proc session))))

(define (require-write-role config req role proc)
  (require-role
   config req role
   (λ (session)
     (define csrf (request-header/string req "X-CSRF-Token"))
     (if (csrf-valid? session csrf)
         (proc session)
         (json-error 403 "Invalid CSRF token")))))

(define (session-cookie-header config session)
  (define cookie
    (cookie:make-cookie "racket-wiki-session"
                        (wiki-session-token session)
                        #:path "/"
                        #:max-age (wiki-config-session-seconds config)
                        #:http-only? #t
                        #:secure? (wiki-config-secure-cookie? config)
                        #:extension "SameSite=Strict"))
  (make-header #"Set-Cookie"
               (cookie:cookie->set-cookie-header cookie)))

(define (login-handler config req)
  (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
    (define body (request-json req))
    (define username (hash-ref body 'username ""))
    (define password (hash-ref body 'password ""))
    (define user (authenticate-user config username password))
    (cond
      ((not user) (json-error 401 "Invalid username or password"))
      (else
       (define session (create-session! config user))
       (json-response
        (session->jsexpr session)
        #:headers (list (session-cookie-header config session)))))))

(define login-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; }
.login { width: min(440px, 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 24px; font-size: 2rem; }
label { display: block; margin: 16px 0; font-weight: 600; }
input { display: block; width: 100%; margin-top: 6px; padding: 10px 12px; font: inherit; border: 1px solid #aeb7c4; border-radius: 6px; }
button { margin-top: 2px; padding: 9px 14px; font: inherit; cursor: pointer; }
.error { margin: 0 0 18px; padding: 12px 14px; background: #fff1f1; border: 1px solid #e8b7b7; border-radius: 6px; color: #8b1f1f; }
.message { margin: 0 0 18px; padding: 12px 14px; background: #eef7ee; border: 1px solid #bad7ba; border-radius: 6px; }
.login-links { margin: 18px 0 0; }
.login-links a { color: #315f91; }
CSS
  )

(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 (login-page config [message #f] [username ""])
  `(html
    (head
     (meta ((charset "utf-8")))
     (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
     (title ,(string-append (tr config 'sign-in) " - " (wiki-config-site-title config)))
     (style ,login-style))
    (body
     (main ((class "login"))
       (h1 ,(tr config 'sign-in))
       ,@(if message
             `((div ((class "error")) ,message))
             '())
       (form ((method "post") (action "/login"))
         (label
          ,(tr config 'username)
          (input ((name "username")
                  (value ,username)
                  (autocomplete "username")
                  (required "required")
                  (autofocus "autofocus"))))
         (label
          ,(tr config 'password)
          (input ((name "password")
                  (type "password")
                  (autocomplete "current-password")
                  (required "required"))))
         (button ((type "submit")) ,(tr config 'sign-in)))
       (p ((class "login-links"))
          (a ((href "/forgot-password")) ,(tr config 'forgot-password)))))))

(define (login-page-response config [message #f] [username ""])
  (html-response
   (login-page config message username)
   #:code (if message 401 200)
   #:headers (list (make-header #"Cache-Control" #"no-store"))))

(define (browser-login-handler config req)
  (define session (session-from-request config req))
  (cond
    (session
     (redirect-response "/"))
    ((string-ci=? (bytes->string/latin-1 (request-method req)) "POST")
     (define form (request-form req))
     (define username (string-trim (form-value form 'username)))
     (define password (form-value form 'password))
     (define user (authenticate-user config username password))
     (cond
       ((not user)
        (login-page-response config "Invalid username or password" username))
       (else
        (define new-session (create-session! config user))
        (redirect-response
         "/"
         #:headers (list (session-cookie-header config new-session))))))
    (else
     (login-page-response config))))

(define (password-page config title body-elements)
  `(html
    (head
     (meta ((charset "utf-8")))
     (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
     (title ,(string-append title " - " (wiki-config-site-title config)))
     (style ,login-style))
    (body
     (main ((class "login"))
       (h1 ,title)
       ,@body-elements))))

(define (password-page-response config title body-elements [code 200])
  (html-response (password-page config title body-elements)
                 #:code code
                 #:headers (list (make-header #"Cache-Control" #"no-store"))))

(define (forgot-password-handler config req)
  (define post? (string-ci=? (bytes->string/latin-1 (request-method req)) "POST"))
  (if post?
      (let* ((form (request-form req))
             (identity (string-trim (form-value form 'identity)))
             (settings (password-reset-mail-settings config))
             (mail-configured? (password-reset-mail-configured? config))
             (configured-limit (string->number (hash-ref settings "reset-limit")))
             (limit (if (and (exact-integer? configured-limit) (<= 1 configured-limit 20)) configured-limit 2))
             (reset (and mail-configured?
                         (not (string=? identity ""))
                         (request-password-reset! config identity 3600 limit))))
        (unless mail-configured?
          (eprintf "Password-reset email was not sent: SMTP is not configured.\n"))
        (when reset
          (thread
           (λ ()
             (with-handlers ((exn:fail?
                              (λ (e)
                                (cancel-password-reset! config (car reset))
                                (eprintf "Password-reset email could not be sent: ~a\n" (exn-message e)))))
               (send-password-reset-mail! config (cdr reset) (car reset))))))
        (password-page-response
         config
         (tr config 'forgot-password)
         `((div ((class "message")) ,(tr config 'reset-request-result))
           (p ,(tr config 'reset-request-next-step))
           (p (a ((href "/login")) ,(tr config 'back-to-login))))))
      (password-page-response
       config
       (tr config 'forgot-password)
       `((p ,(tr config 'reset-request-help))
         (form ((method "post") (action "/forgot-password"))
           (label
            ,(tr config 'username-or-email)
            (input ((name "identity") (autocomplete "username") (required "required") (autofocus "autofocus"))))
           (button ((type "submit")) ,(tr config 'send-reset-link)))
         (p ((class "login-links"))
            (a ((href "/login")) ,(tr config 'back-to-login)))))))

(define (query-parameter req name)
  (for/or ((entry (in-list (url-query (request-uri req)))))
    (and (string=? (format "~a" (car entry)) name)
         (cdr entry))))

(define (reset-password-handler config req)
  (define post? (string-ci=? (bytes->string/latin-1 (request-method req)) "POST"))
  (define form (if post? (request-form req) '()))
  (define token (if post? (form-value form 'token) (or (query-parameter req "token") "")))
  (cond
    ((string=? token "")
     (password-page-response config (tr config 'reset-password)
                             `((div ((class "error")) ,(tr config 'invalid-reset-link))
                               (p (a ((href "/forgot-password")) ,(tr config 'request-new-reset-link))))
                             400))
    (post?
     (define password (form-value form 'password))
     (define repeated (form-value form 'repeat-password))
     (cond
       ((or (< (string-length password) 8) (> (string-length password) 1024))
        (password-page-response config (tr config 'reset-password)
                                `((div ((class "error")) ,(tr config 'password-minimum))
                                  ,(reset-password-form config token))
                                400))
       ((not (string=? password repeated))
        (password-page-response config (tr config 'reset-password)
                                `((div ((class "error")) ,(tr config 'passwords-do-not-match))
                                  ,(reset-password-form config token))
                                400))
       ((reset-password! config token password)
        (password-page-response config (tr config 'reset-password)
                                `((div ((class "message")) ,(tr config 'password-reset-complete))
                                  (p (a ((href "/login")) ,(tr config 'sign-in))))))
       (else
        (password-page-response config (tr config 'reset-password)
                                `((div ((class "error")) ,(tr config 'invalid-reset-link))
                                  (p (a ((href "/forgot-password")) ,(tr config 'request-new-reset-link))))
                                400))))
    (else
     (password-page-response config (tr config 'reset-password)
                             (list (reset-password-form config token))))))

(define (reset-password-form config token)
  `(form ((method "post") (action "/reset-password"))
     (input ((type "hidden") (name "token") (value ,token)))
     (label
      ,(tr config 'new-password)
      (input ((type "password") (name "password") (autocomplete "new-password") (minlength "8") (maxlength "1024") (required "required") (autofocus "autofocus"))))
     (label
      ,(tr config 'repeat-password)
      (input ((type "password") (name "repeat-password") (autocomplete "new-password") (minlength "8") (maxlength "1024") (required "required"))))
     (button ((type "submit")) ,(tr config 'save-new-password))))

(define (logout-handler config req)
  (require-write-role
   config req 'reader
   (λ (session)
     (delete-session! config (wiki-session-token session))
     (json-response
      (hash 'ok #t)
      #:headers
      (list (make-header #"Set-Cookie"
                         (cookie:clear-cookie-header "racket-wiki-session" #:path "/")))))))

(define (valid-email? email)
  (or (string=? email "")
      (regexp-match? #px"^[^[:space:]@]+@[^[:space:]@]+[.][^[:space:]@]+$" email)))

(define (profile-update-handler config req)
  (require-write-role
   config req 'reader
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define display-name (string-trim (hash-ref body 'displayName "")))
       (define email (string-downcase (string-trim (hash-ref body 'email ""))))
       (define current-password (hash-ref body 'currentPassword ""))
       (define new-password (hash-ref body 'newPassword ""))
       (when (string=? display-name "")
         (error 'profile-update-handler "Display name is required"))
       (when (> (string-length display-name) 200)
         (error 'profile-update-handler "Display name is too long"))
       (unless (valid-email? email)
         (error 'profile-update-handler "Invalid email address"))
       (when (> (string-length email) 320)
         (error 'profile-update-handler "Email address is too long"))
       (when (and (not (string=? new-password ""))
                  (or (< (string-length new-password) 8) (> (string-length new-password) 1024)))
         (error 'profile-update-handler "The new password must contain between 8 and 1024 characters"))
       (update-own-profile! config
                            (wiki-user-id (wiki-session-user session))
                            (wiki-session-token session)
                            display-name email current-password new-password)
       (json-response
        (hash 'ok #t
              'session (session->jsexpr (session-from-request config req))))))))

(define (page-list-handler config req)
  (require-role
   config req 'reader
   (λ (_session)
     (json-response (hash 'pages (list-pages config)
                          'aliases (list-page-aliases config))))))

(define (concept-map-list-handler config req)
  (require-role
   config req 'reader
   (λ (_session)
     (json-response (hash 'conceptMaps (list-concept-maps config))))))

(define (request-concept-map-document body)
  (define document (hash-ref body 'document #f))
  (unless (hash? document)
    (raise-argument-error 'request-concept-map-document "hash?" document))
  document)

(define (concept-map-create-handler config req)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define title (string-trim (hash-ref body 'title "")))
       (define requested-slug (string-trim (hash-ref body 'slug "")))
       (define slug
         (if (string=? requested-slug "")
             (title->slug title)
             requested-slug))
       (define document (request-concept-map-document body))
       (cond
         ((string=? title "") (json-error 400 "Title is required"))
         ((string=? slug "") (json-error 400 "The title cannot be converted to a concept map address"))
         ((read-concept-map config slug)
          (json-error 409 "A concept map with this address already exists"))
         (else
          (json-response
           (create-concept-map! config
                                slug
                                title
                                document
                                (wiki-user-username (wiki-session-user session)))
           #:code 201)))))))

(define (concept-map-get-handler config req slug)
  (require-role
   config req 'reader
   (λ (_session)
     (define concept-map (read-concept-map config slug))
     (if concept-map
         (json-response concept-map)
         (json-error 404 "Concept map not found")))))

(define (concept-map-history-handler config req slug)
  (require-role
   config req 'reader
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 404 (exn-message e)))))
       (json-response (hash 'versions (concept-map-history config slug)))))))

(define (concept-map-version-handler config req slug version)
  (require-role
   config req 'reader
   (λ (_session)
     (define result (read-concept-map-version config slug version))
     (if result
         (json-response result)
         (json-error 404 "Concept map version not found")))))

(define (concept-map-update-handler config req slug)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail?
                      (λ (e)
                        (if (string=? (exn-message e) "update-concept-map!: version-conflict")
                            (json-error 409 "Concept map changed since it was opened")
                            (json-error 400 (exn-message e))))))
       (define body (request-json req))
       (define title (string-trim (hash-ref body 'title "")))
       (define document (request-concept-map-document body))
       (define base-version (hash-ref body 'baseVersion ""))
       (define snapshot? (eq? (hash-ref body 'snapshot #f) #t))
       (define supplied-summary (hash-ref body 'summary "Edited CMap"))
       (define summary
         (if (and (string? supplied-summary)
                  (not (string=? (string-trim supplied-summary) "")))
             (substring supplied-summary 0 (min 500 (string-length supplied-summary)))
             "Edited CMap"))
       (json-response
        (update-concept-map! config
                             slug
                             title
                             document
                             (wiki-user-username (wiki-session-user session))
                             base-version
                             summary
                             (if snapshot? "snapshot" "edit")))))))

(define (concept-map-rename-handler config req slug)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail?
                      (λ (e)
                        (if (string=? (exn-message e) "rename-concept-map!: version-conflict")
                            (json-error 409 "Concept map changed since it was opened")
                            (json-error 400 (exn-message e))))))
       (define body (request-json req))
       (define title (string-trim (hash-ref body 'title "")))
       (define base-version (hash-ref body 'baseVersion ""))
       (json-response
        (rename-concept-map! config
                             slug
                             title
                             (wiki-user-username (wiki-session-user session))
                             base-version))))))

(define (concept-map-delete-handler config req slug)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (archive-concept-map! config
                             slug
                             (wiki-user-username (wiki-session-user session)))
       (json-response (hash 'ok #t))))))

(define (request-query-value req key [default ""])
  (define found (assoc key (url-query (request-uri req))))
  (if found (cdr found) default))

(define (search-result-before? first-result second-result)
  (define first-rank (hash-ref first-result 'rank 0))
  (define second-rank (hash-ref second-result 'rank 0))
  (if (= first-rank second-rank)
      (string-ci<? (hash-ref first-result 'title "")
                   (hash-ref second-result 'title ""))
      (> first-rank second-rank)))

(define (recent-result-before? first-result second-result)
  (define first-updated-at (hash-ref first-result 'updatedAt 0))
  (define second-updated-at (hash-ref second-result 'updatedAt 0))
  (if (= first-updated-at second-updated-at)
      (string-ci<? (hash-ref first-result 'title "")
                   (hash-ref second-result 'title ""))
      (> first-updated-at second-updated-at)))

(define (search-handler config req)
  (require-role
   config req 'reader
   (λ (_session)
     (define query-text (request-query-value req 'q))
     (define page-results (search-pages config query-text))
     (define concept-map-results (search-concept-maps config query-text))
     (define sorted-results
       (sort (append page-results concept-map-results)
             search-result-before?))
     (define result-count (min 50 (length sorted-results)))
     (json-response
      (hash 'results (take sorted-results result-count))))))

(define (todo-list-handler config req)
  (require-role
   config req 'reader
   (λ (_session)
     (json-response (hash 'items (list-todos config))))))


(define (recent-list-handler config req)
  (require-role
   config req 'reader
   (λ (_session)
     (define page-results
       (map (λ (page) (hash-set page 'type "page"))
            (list-recent-pages config)))
     (define concept-map-results
       (map (λ (concept-map) (hash-set concept-map 'type "cmap"))
            (list-recent-concept-maps config)))
     (define sorted-results
       (sort (append page-results concept-map-results)
             recent-result-before?))
     (define result-count (min 50 (length sorted-results)))
     (json-response (hash 'items (take sorted-results result-count))))))

(define (bookmark-list-handler config req)
  (require-role
   config req 'reader
   (λ (session)
     (define user-id (wiki-user-id (wiki-session-user session)))
     (json-response (hash 'bookmarks (list-bookmarks config user-id))))))

(define (bookmark-save-handler config req)
  (require-write-role
   config req 'reader
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define slug (hash-ref body 'slug ""))
       (define section (hash-ref body 'section ""))
       (unless (string? slug)
         (raise-argument-error 'bookmark-save-handler "string?" slug))
       (unless (string? section)
         (raise-argument-error 'bookmark-save-handler "string?" section))
       (define user-id (wiki-user-id (wiki-session-user session)))
       (set-bookmark! config user-id slug section)
       (json-response (hash 'ok #t))))))

(define (bookmark-delete-handler config req slug)
  (require-write-role
   config req 'reader
   (λ (session)
     (define user-id (wiki-user-id (wiki-session-user session)))
     (delete-bookmark! config user-id slug)
     (json-response (hash 'ok #t)))))

(define (translations-handler config req)
  (require-role
   config req 'reader
   (λ (_session)
     (json-response
      (hash 'language (current-language config)
            'page (translation-page-slug)
            'template (translation-page-template)
            'translations (translations-for config))))))

(define (page-get-handler config req slug)
  (require-role
   config req 'reader
   (λ (_session)
     (define page (and (valid-page-reference? slug) (read-page config slug)))
     (if page
         (json-response page)
         (json-error 404 "Page not found")))))

(define (request-tags body)
  (define value (hash-ref body 'tags '()))
  (if (and (list? value)
           (for/and ((tag (in-list value)))
             (string? tag)))
      value
      (raise-argument-error 'request-tags "list of strings" value)))

(define (page-create-handler config req)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define requested-slug (hash-ref body 'slug #f))
       (define namespace (string-trim (hash-ref body 'namespace "")))
       (define title (hash-ref body 'title ""))
       (define markdown (hash-ref body 'markdown ""))
       (define tags (request-tags body))
       (define summary (hash-ref body 'summary "Created page"))
       (define slug
         (cond
           (requested-slug requested-slug)
           ((string=? namespace "") (title->slug title))
           (else (page-reference namespace (title->slug title)))))
       (cond
         ((string=? (string-trim title) "")
          (json-error 400 "Title is required"))
         ((string=? slug "")
          (json-error 400 "The title cannot be converted to a page slug"))
         ((not (valid-page-reference? slug))
          (json-error 400 "Invalid page address"))
         ((read-page config slug)
          (json-error 409 "A page with this address already exists"))
         (else
          (json-response
           (create-page! config
                         slug
                         title
                         markdown
                         (wiki-user-username (wiki-session-user session))
                         summary
                         tags)
           #:code 201)))))))

(define (page-update-handler config req slug)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail?
                      (λ (e)
                        (if (string=? (exn-message e) "update-page!: version-conflict")
                            (json-error 409 "Page changed since it was opened")
                            (json-error 400 (exn-message e))))))
       (define body (request-json req))
       (define title (hash-ref body 'title ""))
       (define markdown (hash-ref body 'markdown ""))
       (define tags (request-tags body))
       (define base-version (hash-ref body 'baseVersion ""))
       (define summary (hash-ref body 'summary "Edited page"))
       (json-response
        (update-page! config
                      slug
                      title
                      markdown
                      (wiki-user-username (wiki-session-user session))
                      base-version
                      summary
                      tags
                      #f))))))

(define (page-rename-handler config req reference)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (when (string=? reference (translation-page-slug))
         (error 'page-rename-handler "the translations system page cannot be renamed"))
       (define body (request-json req))
       (define title (string-trim (hash-ref body 'title "")))
       (define namespace (string-trim (hash-ref body 'namespace "")))
       (define slug (string-trim (hash-ref body 'slug "")))
       (define summary (hash-ref body 'summary "Renamed page"))
       (json-response
        (rename-page! config
                      reference
                      title
                      namespace
                      slug
                      (wiki-user-username (wiki-session-user session))
                      summary))))))

(define (page-delete-handler config req slug)
  (require-write-role
   config req 'editor
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (archive-page! config
                      slug
                      (wiki-user-username (wiki-session-user session)))
       (json-response (hash 'ok #t))))))

(define (history-handler config req slug)
  (require-role
   config req 'reader
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 404 (exn-message e)))))
       (json-response (hash 'versions (page-history config slug)))))))

(define (version-handler config req slug version)
  (require-role
   config req 'reader
   (λ (_session)
     (define result (read-version config slug version))
     (if result
         (json-response result)
         (json-error 404 "Version not found")))))

(define (upload-handler config req slug)
  (require-write-role
   config req 'editor
   (λ (session)
     (define name (or (request-header/string req "X-File-Name") "upload.bin"))
     (define content (or (request-post-data/raw req) #""))
     (cond
       ((> (bytes-length content) (* 50 1024 1024))
        (json-error 413 "Upload exceeds 50 MiB"))
       (else
        (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
          (json-response (save-upload! config
                                      slug
                                      name
                                      content
                                      (wiki-user-username (wiki-session-user session)))
                         #:code 201)))))))

(define (inline-image-mime? mime)
  (if (member mime
              '(#"image/png"
                #"image/jpeg"
                #"image/gif"
                #"image/webp"))
      #t
      #f))

(define (upload-file-response attachment)
  (define mime (string->bytes/utf-8 (hash-ref attachment 'mimeType)))
  (define stored-name (hash-ref attachment 'storedName))
  (define original-name (hash-ref attachment 'originalName))
  (define disposition
    (if (inline-image-mime? mime)
        #"inline"
        (string->bytes/utf-8
         (format "attachment; filename=\"~a\"" original-name))))
  (bytes-response
   (hash-ref attachment 'content)
   mime
   #:headers
   (list (make-header #"Content-Disposition" disposition))))

(define (upload-get-handler config req slug stored-name)
  (require-role
   config req 'reader
   (λ (_session)
     (define attachment (uploaded-file config slug stored-name))
     (if attachment
         (upload-file-response attachment)
         (json-error 404 "File not found")))))

(define (admin-orphaned-uploads-handler config req)
  (require-role
   config req 'admin
   (λ (_session)
     (json-response (hash 'uploads (list-orphaned-uploads config))))))

(define (admin-delete-orphaned-upload-handler config req id)
  (require-write-role
   config req 'admin
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (delete-orphaned-upload! config id)
       (json-response (hash 'ok #t))))))

(define (admin-info-handler config req)
  (require-role
   config req 'admin
   (λ (_session)
     (json-response (hash 'softwareVersion racket-wiki-version)))))

(define (mail-settings->jsexpr settings)
  (hash 'publicUrl (hash-ref settings "public-url")
        'smtpHost (hash-ref settings "smtp-host")
        'smtpPort (hash-ref settings "smtp-port")
        'smtpFrom (hash-ref settings "smtp-from")
        'smtpUser (hash-ref settings "smtp-user")
        'smtpTls (string-ci=? (hash-ref settings "smtp-tls") "true")
        'smtpAcceptUntrustedCertificates
        (string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates") "true")
        'resetLimit (hash-ref settings "reset-limit")
        'hasPassword (not (string=? (hash-ref settings "smtp-password") ""))))

(define (mail-settings-from-request body)
  (define port (string-trim (hash-ref body 'smtpPort "587")))
  (define reset-limit (string-trim (hash-ref body 'resetLimit "2")))
  (define public-url (string-trim (hash-ref body 'publicUrl "")))
  (define sender (string-trim (hash-ref body 'smtpFrom "")))
  (define smtp-host (string-trim (hash-ref body 'smtpHost "")))
  (define smtp-user (string-trim (hash-ref body 'smtpUser "")))
  (define smtp-password (hash-ref body 'smtpPassword ""))
  (unless (and (exact-integer? (string->number port))
               (<= 1 (string->number port) 65535))
    (error 'mail-settings-from-request "Invalid SMTP port"))
  (unless (and (exact-integer? (string->number reset-limit))
               (<= 1 (string->number reset-limit) 20))
    (error 'mail-settings-from-request "The reset limit must be between 1 and 20"))
  (unless (or (string=? public-url "")
              (regexp-match? #px"^https?://[^[:space:]]+$" public-url))
    (error 'mail-settings-from-request "Invalid public wiki URL"))
  (unless (valid-email? sender)
    (error 'mail-settings-from-request "Invalid sender address"))
  (hash "public-url" public-url
        "smtp-host" smtp-host
        "smtp-port" port
        "smtp-from" sender
        "smtp-user" smtp-user
        "smtp-password" smtp-password
        "smtp-tls" (if (hash-ref body 'smtpTls #t) "true" "false")
        "smtp-accept-untrusted-certificates"
        (if (hash-ref body 'smtpAcceptUntrustedCertificates #f) "true" "false")
        "reset-limit" reset-limit))

(define (admin-mail-settings-handler config req)
  (if (string-ci=? (bytes->string/latin-1 (request-method req)) "GET")
      (require-role
       config req 'admin
       (λ (_session)
         (json-response (mail-settings->jsexpr (password-reset-mail-settings config)))))
      (require-write-role
       config req 'admin
       (λ (_session)
         (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
           (define body (request-json req))
           (define settings (mail-settings-from-request body))
           (save-password-reset-mail-settings! config settings)
           (json-response (hash 'ok #t)))))))

(define (admin-test-mail-handler config req)
  (require-write-role
   config req 'admin
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define recipient (string-downcase (string-trim (hash-ref body 'recipient ""))))
       (when (string=? recipient "")
         (error 'admin-test-mail-handler "Test recipient is required"))
       (unless (valid-email? recipient)
         (error 'admin-test-mail-handler "Invalid test recipient"))
       (define settings (mail-settings-from-request body))
       (when (string=? (hash-ref settings "smtp-host") "")
         (error 'admin-test-mail-handler "SMTP server is required"))
       (when (string=? (hash-ref settings "smtp-from") "")
         (error 'admin-test-mail-handler "Sender address is required"))
       (send-test-mail! config settings recipient)
       (json-response (hash 'ok #t))))))

(define (admin-page-aliases-handler config req)
  (require-role
   config req 'admin
   (λ (_session)
     (json-response (hash 'aliases (list-page-alias-details config))))))


(define (admin-cleanup-page-alias-handler config req id)
  (require-write-role
   config req 'admin
   (λ (session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define author (wiki-user-username (wiki-session-user session)))
       (json-response (cleanup-page-alias! config id author))))))

(define (admin-delete-page-alias-handler config req id)
  (require-write-role
   config req 'admin
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (delete-page-alias! config id)
       (json-response (hash 'ok #t))))))

(define (admin-users-handler config req)
  (require-role
   config req 'admin
   (λ (_session)
     (json-response (hash 'users (map user->jsexpr (list-users config)))))))

(define (admin-create-user-handler config req)
  (require-write-role
   config req 'admin
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define username (hash-ref body 'username ""))
       (define display-name (hash-ref body 'displayName username))
       (define email (string-trim (hash-ref body 'email "")))
       (define password (hash-ref body 'password ""))
       (define role (string->symbol (hash-ref body 'role "reader")))
       (define status (if (hash-ref body 'enabled #t) 'enabled 'disabled))
       (unless (member role '(reader editor admin))
         (error 'admin-create-user-handler "Invalid role"))
       (when (or (string=? username "") (string=? password ""))
         (error 'admin-create-user-handler "Username and password are required"))
       (unless (valid-email? email)
         (error 'admin-create-user-handler "Invalid email address"))
       (create-user! config username display-name password role status email)
       (json-response (hash 'ok #t) #:code 201)))))

(define (admin-update-user-handler config req id)
  (require-write-role
   config req 'admin
   (λ (_session)
     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
       (define body (request-json req))
       (define display-name (hash-ref body 'displayName ""))
       (define email (string-trim (hash-ref body 'email "")))
       (define role (string->symbol (hash-ref body 'role "reader")))
       (define status (if (hash-ref body 'enabled #t) 'enabled 'disabled))
       (define password (hash-ref body 'password #f))
       (unless (member role '(reader editor admin))
         (error 'admin-update-user-handler "Invalid role"))
       (unless (valid-email? email)
         (error 'admin-update-user-handler "Invalid email address"))
       (update-user! config id display-name role status password email)
       (json-response (hash 'ok #t))))))

(define (admin-delete-user-handler config req id)
  (require-write-role
   config req 'admin
   (λ (session)
     (if (= id (wiki-user-id (wiki-session-user session)))
         (json-error 400 "You cannot delete your own account")
         (begin
           (delete-user! config id)
           (json-response (hash 'ok #t)))))))

(define (request-path-string req)
  (define segments
    (for/list ([segment (in-list (url-path (request-uri req)))])
      (path/param-path segment)))
  (string-append "/" (string-join segments "/")))

(define (index-response)
  (define cmap-cache-id (number->string (random 1000000000)))
  (define index-html
    (file->string (build-path static-directory "index.html")))
  (define cache-busted-index-html
    (string-replace index-html "__CMAP_CACHE_ID__" cmap-cache-id))
  (bytes-response
   (string->bytes/utf-8 cache-busted-index-html)
   #"text/html; charset=utf-8"
   #:headers (list (make-header #"Cache-Control" #"no-cache"))))

(define (static-request-path? path)
  (or (regexp-match? #px"^/(vendor|cmap|css|js)/" path)
      (string=? path "/favicon.ico")))

(define (application-api-path? path)
  (or (regexp-match? #px"^/api(/|$)" path)
      (regexp-match? #px"^/uploads(/|$)" path)))

(define (request-page-slug path)
  (define match (regexp-match #px"^/([^/]+)/?$" path))
  (if match
      (list-ref match 1)
      #f))

(define (page-location slug)
  (string-append "/#/" (uri-path-segment-unreserved-encode slug)))

(define (not-found-response config)
  (html-response
   `(html
     (head
      (meta ((charset "utf-8")))
      (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
      (title ,(string-append "Not found - " (wiki-config-site-title config))))
     (body
      (h1 "Page not found")))
   #:code 404
   #:headers (list (make-header #"Cache-Control" #"no-store"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Start the HTTP server for the wiki.
; pre    : config is initialized and its static and data paths are available.
; post   : The server is listening until the servlet environment stops. When
;          initial setup is incomplete, normal application requests redirect
;          to /setup.
; result : The result returned by serve/servlet.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (start-wiki-server config)
  (define-values (application-dispatch _url)
    (dispatch-rules
     [("api" "session") #:method "get"
      (λ (req)
        (json-response
         (session->jsexpr (session-from-request config req))))]
     [("api" "login") #:method "post"
      (λ (req) (login-handler config req))]
     [("api" "logout") #:method "post"
      (λ (req) (logout-handler config req))]
     [("api" "profile") #:method "put"
      (λ (req) (profile-update-handler config req))]
     [("api" "ping") #:method "get"
      (λ (_req) (json-response (hash 'ok #t 'time (current-seconds))))]
     [("api" "translations") #:method "get"
      (λ (req) (translations-handler config req))]
     [("api" "todos") #:method "get"
      (λ (req) (todo-list-handler config req))]
     [("api" "recent") #:method "get"
      (λ (req) (recent-list-handler config req))]
     [("api" "bookmarks") #:method "get"
      (λ (req) (bookmark-list-handler config req))]
     [("api" "bookmarks") #:method "post"
      (λ (req) (bookmark-save-handler config req))]
     [("api" "bookmarks" (string-arg)) #:method "delete"
      (λ (req slug) (bookmark-delete-handler config req slug))]
     [("api" "search") #:method "get"
      (λ (req) (search-handler config req))]
     [("api" "pages") #:method "get"
      (λ (req) (page-list-handler config req))]
     [("api" "cmaps") #:method "get"
      (λ (req) (concept-map-list-handler config req))]
     [("api" "cmaps") #:method "post"
      (λ (req) (concept-map-create-handler config req))]
     [("api" "cmaps" (string-arg)) #:method "get"
      (λ (req slug) (concept-map-get-handler config req slug))]
     [("api" "cmaps" (string-arg) "history") #:method "get"
      (λ (req slug) (concept-map-history-handler config req slug))]
     [("api" "cmaps" (string-arg) "versions" (string-arg)) #:method "get"
      (λ (req slug version) (concept-map-version-handler config req slug version))]
     [("api" "cmaps" (string-arg)) #:method "put"
      (λ (req slug) (concept-map-update-handler config req slug))]
     [("api" "cmaps" (string-arg) "rename") #:method "post"
      (λ (req slug) (concept-map-rename-handler config req slug))]
     [("api" "cmaps" (string-arg)) #:method "delete"
      (λ (req slug) (concept-map-delete-handler config req slug))]
     [("api" "pages") #:method "post"
      (λ (req) (page-create-handler config req))]
     [("api" "pages" (string-arg)) #:method "get"
      (λ (req slug) (page-get-handler config req slug))]
     [("api" "pages" (string-arg)) #:method "put"
      (λ (req slug) (page-update-handler config req slug))]
     [("api" "pages" (string-arg) "rename") #:method "post"
      (λ (req slug) (page-rename-handler config req slug))]
     [("api" "pages" (string-arg)) #:method "delete"
      (λ (req slug) (page-delete-handler config req slug))]
     [("api" "pages" (string-arg) "history") #:method "get"
      (λ (req slug) (history-handler config req slug))]
     [("api" "pages" (string-arg) "versions" (string-arg)) #:method "get"
      (λ (req slug version) (version-handler config req slug version))]
     [("api" "pages" (string-arg) "upload") #:method "post"
      (λ (req slug) (upload-handler config req slug))]
     [("uploads" (string-arg) (string-arg)) #:method "get"
      (λ (req slug stored-name) (upload-get-handler config req slug stored-name))]
     [("api" "admin" "info") #:method "get"
      (λ (req) (admin-info-handler config req))]
     [("api" "admin" "mail-settings") #:method "get"
      (λ (req) (admin-mail-settings-handler config req))]
     [("api" "admin" "mail-settings") #:method "put"
      (λ (req) (admin-mail-settings-handler config req))]
     [("api" "admin" "mail-settings" "test") #:method "post"
      (λ (req) (admin-test-mail-handler config req))]
     [("api" "admin" "aliases") #:method "get"
      (λ (req) (admin-page-aliases-handler config req))]
     [("api" "admin" "aliases" (integer-arg) "cleanup") #:method "post"
      (λ (req id) (admin-cleanup-page-alias-handler config req id))]
     [("api" "admin" "aliases" (integer-arg)) #:method "delete"
      (λ (req id) (admin-delete-page-alias-handler config req id))]
     [("api" "admin" "uploads" "orphaned") #:method "get"
      (λ (req) (admin-orphaned-uploads-handler config req))]
     [("api" "admin" "uploads" "orphaned" (integer-arg)) #:method "delete"
      (λ (req id) (admin-delete-orphaned-upload-handler config req id))]
     [("api" "admin" "users") #:method "get"
      (λ (req) (admin-users-handler config req))]
     [("api" "admin" "users") #:method "post"
      (λ (req) (admin-create-user-handler config req))]
     [("api" "admin" "users" (integer-arg)) #:method "put"
      (λ (req id) (admin-update-user-handler config req id))]
     [("api" "admin" "users" (integer-arg)) #:method "delete"
      (λ (req id) (admin-delete-user-handler config req id))]
     [else (λ (_req) (json-error 404 "API endpoint not found"))]))

  (define setup-ready? (box (setup-complete? config)))

  (define (dispatch req)
    (define path (request-path-string req))
    (cond
      ((regexp-match? #px"^/setup/?$" path)
       (define response (setup-handler config req))
       (when (setup-complete? config)
         (set-box! setup-ready? #t))
       response)
      ((not (unbox setup-ready?))
       (redirect-response "/setup"))
      ((regexp-match? #px"^/login/?$" path)
       (browser-login-handler config req))
      ((regexp-match? #px"^/forgot-password/?$" path)
       (forgot-password-handler config req))
      ((regexp-match? #px"^/reset-password/?$" path)
       (reset-password-handler config req))
      ((static-request-path? path)
       (next-dispatcher))
      ((application-api-path? path)
       (application-dispatch req))
      ((or (string=? path "/")
           (string=? path "/index.html"))
       (if (session-from-request config req)
           (index-response)
           (redirect-response "/login")))
      (else
       (define session (session-from-request config req))
       (define slug (request-page-slug path))
       (cond
         ((not session)
          (redirect-response "/login"))
         ((and slug (valid-page-reference? slug))
          (let ((page (read-page config slug)))
            (cond
              (page
               (redirect-response (page-location slug)))
              ((role-at-least? (wiki-session-user session) 'editor)
               (redirect-response (page-location slug)))
              (else
               (not-found-response config)))))
         (else
          (not-found-response config))))))

  (displayln
   (format "~a listening on http://~a:~a/"
           (wiki-config-site-title config)
           (or (wiki-config-listen-ip config) "0.0.0.0")
           (wiki-config-port config)))

  (when (not (unbox setup-ready?))
    (displayln "Initial setup is required. Open /setup in a browser."))

  (serve/servlet dispatch
                 #:launch-browser? #f
                 #:quit? #f
                 #:banner? #f
                 #:listen-ip (wiki-config-listen-ip config)
                 #:port (wiki-config-port config)
                 #:servlet-regexp #rx""
                 #:extra-files-paths (list (data-static-directory config)
                                           static-directory)))