refactoring by skill

2026-08-29 22:22:49 +02:00
parent 67fce7a330
commit 649ff0d7c5
22 changed files with 1598 additions and 1644 deletions
@@ -24,10 +24,10 @@
 (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))))
+           (let ((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)))
@@ -49,16 +49,16 @@
       (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))
-      '()))
+  (let ((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))
+  (let ((found (assoc key form)))
+    (if (and found (cdr found))
+        (cdr found)
+        default)))

 (define setup-style
  #<<CSS
@@ -96,21 +96,21 @@ CSS


 (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))))))
+  (let ((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))
+  (let* ((settings (read-database-settings config))
+         (ssl-text
+          (form-value form
+                      'db-ssl
+                      (symbol->string (setting-value settings database-settings-ssl 'no))))
+         (ssl (string->symbol ssl-text)))
+    `((h2 ,(tr config 'postgresql))
    (div ((class "fields"))
      (label
       ,(tr config 'server)
@@ -147,7 +147,7 @@ CSS
       (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)))))))
+         (option ((value "yes") ,@(if (eq? ssl 'yes) '((selected "selected")) '())) ,(tr config 'ssl-required))))))))

 (define (admin-fields config [form '()])
  `((h2 ,(tr config 'administrator))
@@ -177,10 +177,10 @@ CSS
             (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
+  (let ((db-ready? (database-ready? config))
+        (administrator-ready? (admin-ready? config))
+        (vendor-ready? (vendor-files-ready? config)))
+    `(html
    (head
     (meta ((charset "utf-8")))
     (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
@@ -210,7 +210,7 @@ CSS
       (p ((class "note"))
          "Frontend libraries are stored below "
          (code ,(path->string (vendor-directory config)))
-          " and are served locally after setup.")))))
+          " and are served locally after setup."))))))

 (define (setup-page-response config [message #f] [form '()])
  (html-response
@@ -218,85 +218,85 @@ CSS
   #: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))))
+  (let ((username (string-trim (form-value form 'username)))
+        (display-name (string-trim (form-value form 'display-name)))
+        (password (form-value form 'password))
+        (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
+  (let* ((port (string->number (form-value form 'db-port "5432")))
+         (ssl-text (form-value form 'db-ssl "no"))
+         (ssl
+          (cond
+            ((string=? ssl-text "yes") 'yes)
+            ((string=? ssl-text "optional") 'optional)
+            (else 'no))))
    (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))))
+      ((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))
+  (let ((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)))
+    (let ((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)))
+    (let ((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))
+  (let ((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