Absorb existing domain data.

1 files changed, 152 insertions, 0 deletions

diff --git a/views.rkt b/views.rkt
new file mode 100644
index 0000000..d78c370
--- /dev/null
+++ b/views.rkt
@@ -0,0 +1,152 @@
+#lang racket
+
+(provide index-page
+         new-measurement-page
+         fallback-page)
+
+(require web-server/formlets
+         "formlets.rkt"
+         "models/nutrient.rkt"
+         "models/nutrient-measurement.rkt")
+
+
+(define (page-template title body-xexpr)
+  `(html
+    (head
+     (meta ([charset "utf-8"]))
+     (meta ([name "viewport"] [content "width=device-width, initial-scale=1"]))
+     (title ,title)
+     ;; Bootstrap CSS
+     (link ([href "https://cdn.jsdelivr.net/npm/bootstrap@5.3.3/dist/css/bootstrap.min.css"]
+            [rel "stylesheet"]
+            [integrity "sha384-QWTKZyjpPEjISv5WaRU9OFeRpok6YctnYmDr5pNlyT2bRjXh0JMhjY6hW+ALEwIH"]
+            [crossorigin "anonymous"])))
+    (body
+     ,navbar
+     (div ([class "container"])
+          ,@body-xexpr)
+     ;; Bootstrap JS bundle
+     (script ([src "https://cdn.jsdelivr.net/npm/bootstrap@5.3.3/dist/js/bootstrap.bundle.min.js"]
+              [integrity "sha384-YvpcrYf0tY3lHB60NNkmXc5s9fDVZLESaAA55NDzOxhy9GkcIdslK1eN7N6jIeHz"]
+              [crossorigin "anonymous"])))))
+
+
+;; Page components
+
+(define navbar
+  '(nav ([class "navbar"])
+        (div ([class "container-fluid"])
+             (a ([class "navbar-brand"] [href "/"]) "FAPG")
+             (button ([class "navbar-toggler"]
+                      [type "button"]
+                      [data-bs-toggle "collapse"]
+                      [data-bs-target "#navbarNav"]
+                      [aria-controls "navbarNav"]
+                      [aria-expanded "false"]
+                      [aria-label "Toggle navigation"])
+                     (span ([class "navbar-toggler-icon"])))
+             (div ([class "collapse navbar-collapse"] [id "navbarNav"])
+                  (ul ([class "navbar-nav"])
+                      (li ([class "nav-item"])
+                          (a ([class "nav-link active"]
+                              [aria-current "page"]
+                              [href "/"])
+                             "Home"))
+                      (li ([class "nav-item"])
+                          (a ([class "nav-link"]
+                              [href "/about"])
+                             "About"))
+                      (li ([class "nav-item"])
+                          (a ([class "nav-link"]
+                              [href "/contact"])
+                             "Contact")))))))
+
+
+;; Page helpers
+
+(define (round n number)
+  (~r number #:precision n))
+
+
+;; Pages
+
+(define (index-page measurements)
+  (page-template
+   "Ferti"
+   `((h1 ([class "display-1 mb-3"]) "Ferti")
+     (a ([class "btn btn-primary mb-3"] [href "/target/new"]) "Créer une cible")
+     (table ([class "table"])
+            (tr (th "Nutriment")
+                (th ([class "text-end"]) "Dernière Cible")
+                (th ([class "text-end"]) "Dernier Relevé")
+                (th ([class "text-end"]) "Delta (%)"))
+            ,@(for/list ([n (get-nutrients)])
+                (define latest-target (+ (get-latest-nutrient-measurement-value n) 1))
+                (define latest-value (get-latest-nutrient-measurement-value n))
+                (define delta (* 100
+                                 (/ (- latest-target latest-value)
+                                    latest-target)))
+                `(tr (td ,(nutrient-name n))
+                     (td ([class "text-end"]) ,(round 2 latest-target))
+                     (td ([class "text-end"]) ,(round 2 latest-value))
+                     (td ([class "text-end"]) ,(round 1 delta)))))
+
+     (a ([class "btn btn-primary mb-3"] [href "/measurement/new"]) "Ajouter un relevé")
+     (table ([class "table table-striped"])
+            (tr (th "Date")
+                (th ([class "text-end"]) "N")
+                (th ([class "text-end"]) "P")
+                (th ([class "text-end"]) "K"))
+            ,@(for/list ([m measurements])
+                (define measured-on (nutrient-measurement-measured-on m))
+                (define-values (n p k)
+                  (apply values
+                         (for/list ([nutrient '("Nitrate Nitrogen" "Phosphorus" "Potassium")])
+                           (define n (get-nutrient #:name nutrient))
+                           (define mnv (get-nutrient-measurement-value m n))
+                           (if (real? mnv)
+                               (round 2 mnv)
+                               "—"))))
+                `(tr (td ,measured-on)
+                     (td ([class "text-end font-monospace"]) ,n)
+                     (td ([class "text-end font-monospace"]) ,p)
+                     (td ([class "text-end font-monospace"]) ,k)))))))
+
+(define (new-measurement-page)
+  (page-template
+   "Nouveau relevé"
+   `((h1 ([class "display-1 mb-3"]) "Nouveau relevé")
+     (div ([class "mb-3"] [style "max-width: 30em"])
+          (form
+           ([action "/measurement/create"]
+            [method "POST"])
+           ,@(formlet-display (measurements-formlet)))))))
+
+(define (fallback-page request-code)
+  (page-template
+   (format "Réponse: ~a" request-code)
+   `((h1 ([class "display-1 text-danger"]) ,(number->string request-code))
+     (p ,(fallback-message request-code))
+     (a ([href "/"]) "Revenir à la page d'accueil"))))
+
+(define (fallback-message request-code)
+  (string-join
+   `("Bonjour, je suis votre serveur."
+     ,(format "J'ai répondu '~a'" request-code)
+     "et"
+     ,(case (string-ref (number->string request-code) 0)
+        [(#\4) "c'est de votre faute, malheureusement."]
+        [(#\5) "c'est de ma faute, pardonnez-moi."]
+        [else "je ne sais pas qui est en tort."])
+     ,(case request-code
+        ;; Client errors
+        [(400) "Votre requête ne fait pas sens."]
+        [(401) "Vous n'avez pas vérifié votre identité."]
+        [(403) "Vous n'avez pas le droit de consulter cette page."]
+        [(404) "Vous avez demandé de consulter une page qui n'existe pas."]
+        ;; Server errors
+        [(500) "Je suis dans une situation que je ne sais pas gérer, et ne peux vous en dire davantage."]
+        [(502) "Un tiers ne m'a pas transmis les informations nécessaires pour répondre à votre requête."]
+        [(503) "Je ne peux pas vous aider, il se peut que je sois momentanément surchargé. Revenez plus tard."]
+        ;; Fallback message
+        [else (format "Je ne sais pas encore interpréter le code ~a." request-code)]))))