cmap functions, email, architecture documentation.

2026-08-18 03:33:10 +02:00
parent 12f1ed2764
commit 63b7ca0853
33 changed files with 3974 additions and 80 deletions
@@ -18,6 +18,7 @@
         "private/cmap-storage.rkt"
         "private/config.rkt"
         "private/http-util.rkt"
+         "private/mail.rkt"
         "private/setup.rkt"
         "private/storage.rkt"
         "private/version.rkt"
@@ -33,6 +34,7 @@
  (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)))

@@ -97,6 +99,9 @@ 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
  )

@@ -139,7 +144,9 @@ CSS
                  (type "password")
                  (autocomplete "current-password")
                  (required "required"))))
-         (button ((type "submit")) ,(tr config 'sign-in)))))))
+         (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
@@ -168,6 +175,116 @@ CSS
    (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
@@ -179,6 +296,39 @@ CSS
      (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
@@ -234,6 +384,22 @@ CSS
         (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
@@ -247,13 +413,22 @@ CSS
       (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))))))
+                             base-version
+                             summary
+                             (if snapshot? "snapshot" "edit")))))))

 (define (concept-map-rename-handler config req slug)
  (require-write-role
@@ -580,6 +755,82 @@ CSS
   (λ (_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
@@ -617,6 +868,7 @@ CSS
       (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))
@@ -624,7 +876,9 @@ CSS
         (error 'admin-create-user-handler "Invalid role"))
       (when (or (string=? username "") (string=? password ""))
         (error 'admin-create-user-handler "Username and password are required"))
-       (create-user! config username display-name password role status)
+       (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)
@@ -634,12 +888,15 @@ CSS
     (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"))
-       (update-user! config id display-name role status password)
+       (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)
@@ -717,6 +974,8 @@ CSS
      (λ (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"
@@ -741,6 +1000,10 @@ CSS
      (λ (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"
@@ -767,6 +1030,12 @@ CSS
      (λ (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"
@@ -801,6 +1070,10 @@ CSS
       (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)