path: root/views.rkt

#lang racket

(provide index-page
         ferti-index-page
         ferti-measurements-and-rotations-page
         ferti-recipe-page
         ferti-fertilizers-page
         ferti-crop-requirements-page
         new-measurement-page
         new-rotation-page
         new-fertilizer-page
         new-crop-page
         new-crop-requirement-page
         edit-measurement-page
         edit-fertilizer-page
         edit-crop-page
         edit-crop-requirement-page
         show-measurement-page
         show-rotation-page
         show-fertilizer-page
         show-crop-page
         show-crop-requirement-page
         fallback-page)

(require gregor
         web-server/formlets
         "formlets.rkt"
         "models/user.rkt"
         "models/nutrient.rkt"
         "models/nutrient-value.rkt"
         "models/nutrient-measurement.rkt"
         "models/crop.rkt"
         "models/crop-rotation.rkt"
         "models/crop-requirement.rkt"
         "models/fertilizer-product.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 navbar-expand-lg navbar-light bg-light"))
    (div
     ((class "container-fluid"))
     (a ((class "navbar-brand") [href "/"]) "FAPG")
     (button ((class "navbar-toggler") [type "button"]
                                       [data-bs-toggle "collapse"]
                                       [data-bs-target "#navbarSupportedContent"]
                                       [aria-controls "navbarSupportedContent"]
                                       [aria-expanded "false"]
                                       [aria-label "Toggle navigation"])
             (span ((class "navbar-toggler-icon"))))
     (div ((class "collapse navbar-collapse") [id "navbarSupportedContent"])
          (ul ((class "navbar-nav me-auto mb-2 mb-lg-0"))
              (li ((class "nav-item"))
                  (a ((class "nav-link disabled") [href "#"] [tabindex "-1"] [aria-disabled "true"])
                     "Facturation Pro"))
              (li ((class "nav-item"))
                  (a ((class "nav-link active") [aria-current "page"] [href "/ferti/index"]) "Ferti"))
              (li ((class "nav-item"))
                  (a ((class "nav-link disabled") [href "#"] [tabindex "-1"] [aria-disabled "true"])
                     "Inventaire"))
              (li ((class "nav-item")) (a ((class "nav-link") [href "/contact"]) "Contact")))))))

;; Page helpers

(define (round n number)
  (~r number #:precision `(= ,n)))

(define (normal-date date-string)
  (~t (iso8601->date date-string) "dd/MM/yyyy"))

;; Ferti

(define (ferti-template active-tab body-xexpr)
  (page-template (format "Ferti — ~a" active-tab) `(,(ferti-tabs-bar active-tab) ,@body-xexpr)))

(define (ferti-tabs-bar active-tab)
  `(ul ((class "nav nav-tabs my-3"))
       ,@
       (for/list ([tab ferti-tabs])
         (match-define (cons tab-title tab-action) tab)
         `(li ((class "nav-item"))
              (a ((class ,(string-append "nav-link" (if (equal? tab-title active-tab) " active" "")))
                  (aria-current "page")
                  (href ,tab-action))
                 ,tab-title)))))

(define ferti-tabs
  '(("Accueil" . "/ferti/index") ("Relevés et Assolements" . "/ferti/measurements-and-rotations")
                                 ("Intrants" . "/ferti/fertilizers")
                                 ("Cultures" . "/ferti/crop-requirements")))

(define (ferti-index-page)
  (ferti-template
   "Accueil"
   `((p "La recette Ferti© est calculée en fonction d'un relevé de nutriments et d'un assolement.")
     (div
      ((class "btn-group-vertical"))
      (a ((class "btn btn-outline-primary") [href "/ferti/measurements/new"]) "Ajouter un relevé")
      (a ((class "btn btn-outline-primary") [href "/ferti/rotations/new"]) "Ajouter un assolement")
      (a ((class "btn btn-outline-primary") [href "/ferti/fertilizers/new"]) "Ajouter un intrant")))))

(define (ferti-measurements-and-rotations-page measurements rotations)
  (define (maybe-rotation-for-measurement m)
    (findf (λ (r) (equal? (crop-rotation-date r) (nutrient-measurement-date m))) rotations))
  (define table
    `(table
      ((class "table"))
      (thead (tr (th "Date du relevé") (th "Relevé") (th "Assolement") (th "Recette")))
      (tbody
       ,@(for/list ([m measurements])
           (define maybe-rotation (maybe-rotation-for-measurement m))
           `(tr
             (td ((class "font-monospace align-middle")) ,(normal-date (nutrient-measurement-date m)))
             (td (a ((class "btn btn-outline-secondary btn-sm")
                     (href ,(format "/ferti/measurements/~a" (nutrient-measurement-id m))))
                    "Consulter"))
             (td ,(if maybe-rotation
                      `(a ((class "btn btn-outline-secondary btn-sm")
                           (href ,(format "/ferti/rotations/~a" (crop-rotation-id maybe-rotation))))
                          "Consulter")
                      `(a ((class "btn btn-outline-primary btn-sm")
                           (href ,(format "/ferti/rotations/new/~a" (nutrient-measurement-date m))))
                          "Ajouter")))
             (td ,(if maybe-rotation
                      `(a ((class "btn btn-outline-secondary btn-sm")
                           (href ,(format "/ferti/recipes/~a" (crop-rotation-date maybe-rotation))))
                          "Consulter")
                      "—")))))))
  (ferti-template "Relevés et Assolements"
                  `((div ((class "btn-group mb-3"))
                         (a ((class "btn btn-primary") [href "/ferti/measurements/new"])
                            "Ajouter un relevé"))
                    (div ((class "overflow-auto")) ,table))))

(define (ferti-fertilizers-page fertilizers)
  (define table
    `(table ((class "table table-striped"))
            (tr (th () "Nom de référence") (th () "Nom de marque"))
            ,@(for/list ([fp fertilizers])
                (define brand-name (fertilizer-brand-name fp))
                `(tr (td (a ([href ,(format "/ferti/fertilizers/~a" (fertilizer-product-id fp))])
                            ,(fertilizer-product-name fp)))
                     (td ,(if (and brand-name (non-empty-string? brand-name)) brand-name "—"))))))
  (ferti-template "Intrants"
                  `((a ((class "btn btn-primary mb-3") [href "/ferti/fertilizers/new"])
                       "Ajouter un intrant")
                    ,table)))

(define (ferti-crop-requirements-page crop-requirements)
  (define table
    `(table ((class "table table-striped"))
            (tr (th "Profil") (th "Culture"))
            ,@(for/list ([cr crop-requirements])
                (define cid (crop-requirement-crop-id cr))
                `(tr (td (a ((href ,(format "/ferti/crop-requirements/~a" (crop-requirement-id cr))))
                            ,(string-titlecase (crop-requirement-profile cr))))
                     (td ,(if cid
                              (let ([crop (get-crop #:id cid)])
                                `(a ((href ,(format "/ferti/crops/~a" cid)))
                                    ,(string-titlecase (crop-name crop))))
                              "—"))))))
  (define button-group
    '(div ((class "btn-group mb-3"))
          (a ((class "btn btn-primary") [href "/ferti/crop-requirements/new"]) "Ajouter un profil")
          (a ((class "btn btn-secondary") [href "/ferti/crops/new"]) "Ajouter une culture")))
  (ferti-template "Cultures" (list button-group table)))

;; TODO: add bar chart for comparing to target concentrations
(define (ferti-recipe-page recipe-date fertilizer-recipe)
  (define normal-recipe-date (normal-date recipe-date))
  (define title (format "Recette du ~a" normal-recipe-date))
  (define table
    `(table ((class "table"))
            (thead (tr (th "Intrant") (th "Marque") (th ((class "text-end")) "Quantité (g)")))
            (tbody ,@(for/list ([(fertilizer quantity) (in-hash fertilizer-recipe)]
                                #:when (not (zero? quantity)))
                       (define canonical-name (fertilizer-product-name fertilizer))
                       (define brand-name (fertilizer-brand-name fertilizer))
                       `(tr (td ,canonical-name)
                            (td ,(if (non-empty-string? brand-name) brand-name "—"))
                            (td ((class "text-end font-monospace")) ,(round 2 (* 100 quantity))))))))
  (page-template title
                 `((h1 ((class "display-1 mb-3")) "Recette Ferti")
                   (h5 ((class "display-5 mb-3")) ,normal-recipe-date)
                   (p "Quantités calculées pour 100'000 L.")
                   ,table)))

;; New

(define (form-page-template title action formlet)
  (page-template title
                 `((h1 ((class "display-1 mb-3")) ,title)
                   (div ((class "mb-3") [style "max-width: 30em"])
                        (form ([action ,action] [method "POST"]) ,@(formlet-display formlet))))))

(define (new-measurement-page)
  (form-page-template "Nouveau relevé" "/ferti/measurements/create" (measurements-formlet)))

(define (new-rotation-page #:date [date-string #f])
  (form-page-template "Nouvel assolement"
                      "/ferti/rotations/create"
                      (rotation-formlet #:date date-string)))

(define (new-fertilizer-page)
  (form-page-template "Nouvel intrant" "/ferti/fertilizers/create" (fertilizer-formlet)))

(define (new-crop-page)
  (form-page-template "Nouvelle culture" "/ferti/crops/create" (crop-formlet)))

(define (new-crop-requirement-page)
  (form-page-template "Nouveau profil" "/ferti/crop-requirements/create" (crop-requirements-formlet)))

;; Edit

(define (edit-measurement-page nm)
  (form-page-template "Modifier le relevé"
                      "/ferti/measurements/update"
                      (measurements-formlet #:value nm)))

(define (edit-fertilizer-page fp)
  (form-page-template "Modifier l'intrant"
                      "/ferti/fertilizers/update"
                      (fertilizer-formlet #:value fp)))

(define (edit-crop-page crop)
  (form-page-template "Modifier la culture" "/ferti/crops/update" (crop-formlet #:value crop)))

(define (edit-crop-requirement-page cr)
  (form-page-template "Modifier profil"
                      "/ferti/crop-requirements/update"
                      (crop-requirements-formlet #:value cr)))

;; Show

(define (show-measurement-page nm)
  (define id (nutrient-measurement-id nm))
  (define measurement-date (normal-date (nutrient-measurement-date nm)))
  (define table
    `(table ((class "table") (style "max-width: 30em"))
            (thead (tr (th "Nutriment") (th ((class "text-end")) "Concentration (mg/L)")))
            (tbody ,@(for/list ([n (get-nutrients)])
                       (define nutrient-value (hash-ref (nutrient-measurement-values nm) n 0))
                       `(tr (td ,(nutrient-french-name n))
                            (td ((class "text-end font-monospace")) ,(round 2 nutrient-value)))))))
  (define button-group
    `(div ((class "btn-group mb-3"))
          (a ((class "btn btn-primary") [href ,(format "/ferti/measurements/~a/edit" id)]) "Modifier")
          (a ((class "btn btn-danger") [href ,(format "/ferti/measurements/~a/destroy" id)])
             "Supprimer")))
  (page-template (format "Relevé du ~a" measurement-date)
                 `((h1 ((class "display-1 mb-3")) "Relevé") (h5 ((class "display-5 mb-3"))
                                                                ,measurement-date)
                                                            ,button-group
                                                            ,table)))

(define (show-rotation-page cr)
  (define id (crop-rotation-id cr))
  (define rotation-date (normal-date (crop-rotation-date cr)))
  (define table
    `(table ((class "table") (style "max-width: 30em"))
            (thead (tr (th "Type de culture") (th ((class "text-end")) "Proportion (%)")))
            (tbody ,@(for/list ([requirement (get-crop-requirements)])
                       (define requirement-proportion
                         (hash-ref (crop-rotation-requirements cr) requirement 0))
                       `(tr (td ,(crop-requirement-profile requirement))
                            (td ((class "text-end font-monospace"))
                                ,(round 2 requirement-proportion)))))))
  (define button-group
    `(div ((class "btn-group mb-3"))
          (a ((class "btn btn-primary") [href ,(format "/ferti/rotations/~a/edit" id)]) "Modifier")
          (a ((class "btn btn-danger")
              [href ,(format "/ferti/rotations/~a/destroy" (crop-rotation-id cr))])
             "Supprimer")))
  (page-template (format "Assolement du ~a" rotation-date)
                 `((h1 ((class "display-1 mb-3")) ,"Assolement") (h5 ((class "display-5 mb-3"))
                                                                     ,rotation-date)
                                                                 ,button-group
                                                                 ,table)))

(define (show-fertilizer-page fp)
  (define id (fertilizer-product-id fp))
  (define product-name (string-titlecase (fertilizer-product-name fp)))
  (define brand-name (fertilizer-brand-name fp))
  (define sorted-nutrient-values (get-sorted-nutrient-values (fertilizer-product-values fp)))
  (define table
    `(table ((class "table") (style "max-width: 30em"))
            (thead (tr (th "Nutriment") (th ((class "text-end")) "Concentration (mg/L)")))
            (tbody ,@(for/list ([nv-pair sorted-nutrient-values])
                       (match-define (cons n v) nv-pair)
                       `(tr (td ,(nutrient-french-name n))
                            (td ((class "text-end font-monospace")) ,(round 2 v)))))))
  (define button-group
    `(div ((class "btn-group mb-3"))
          (a ((class "btn btn-primary") [href ,(format "/ferti/fertilizers/~a/edit" id)]) "Modifier")
          (a ((class "btn btn-danger") [href ,(format "/ferti/fertilizers/~a/destroy" id)])
             "Supprimer")))
  (page-template product-name
                 `((h1 ((class "display-1 mb-3")) ,product-name)
                   (h5 ((class "display-5 mb-3"))
                       ,(if (non-empty-string? brand-name) brand-name "Intrant générique"))
                   ,button-group
                   ,table)))

(define (show-crop-page crop)
  (define id (crop-id crop))
  (define name (string-titlecase (crop-name crop)))
  (define crop-requirements-for-crop
    (filter (λ (cr) (equal? (crop-requirement-crop-id cr) (crop-id crop))) (get-crop-requirements)))
  (define profile-list
    `(ul ,@(for/list ([cr crop-requirements-for-crop])
             `(li (a ([href ,(format "/ferti/crop-requirements/~a" (crop-requirement-id cr))])
                     ,(string-titlecase (crop-requirement-profile cr)))))))
  (define button-group
    `(div ((class "btn-group mb-3"))
          (a ((class "btn btn-primary") [href ,(format "/ferti/crops/~a/edit" id)]) "Modifier")
          (a ((class "btn btn-danger") [href ,(format "/ferti/crops/~a/destroy" id)]) "Supprimer")))
  (page-template name `((h1 ((class "display-1 mb-3")) ,name) ,button-group ,profile-list)))

(define (show-crop-requirement-page cr)
  (define id (crop-requirement-id cr))
  (define cid (crop-requirement-crop-id cr))
  (define crop
    (if cid
        (string-titlecase (crop-name (get-crop #:id cid)))
        #f))
  (define profile (string-titlecase (crop-requirement-profile cr)))
  (define title
    (if crop
        (format "~a — ~a" crop profile)
        profile))
  (define table
    `(table ((class "table") (style "max-width: 30em"))
            (thead (tr (th "Nutriment") (th ((class "text-end")) "Concentration (mg/L)")))
            (tbody ,@(for/list ([n (get-nutrients)])
                       (define nutrient-value (hash-ref (crop-requirement-values cr) n 0))
                       `(tr (td ,(nutrient-french-name n))
                            (td ((class "text-end font-monospace")) ,(round 2 nutrient-value)))))))
  (define button-group
    `(div ((class "btn-group"))
          (a ((class "btn btn-primary") [href ,(format "/ferti/crop-requirements/~a/edit" id)])
             "Modifier")
          (a ((class "btn btn-danger") [href ,(format "/ferti/crop-requirements/~a/destroy" id)])
             "Supprimer")))
  (page-template title
                 `((h1 ((class "display-1 mb-3")) ,profile) (h5 ((class "display-5 mb-3"))
                                                                ,(or crop "Profil générique"))
                                                            ,button-group
                                                            ,table)))

(define (index-page user)
  (page-template
   "Bienvenue à la FAPG"
   `((div ((class "jumbotron"))
          (h1 ((class "display-1 mb-3"))
              ,(string-join (list (if (<= (->hours (current-time)) 17) "Bonjour" "Bonsoir")
                                  (if user
                                      (user-name user)
                                      "et bienvenue"))))
          (hr ((class "my-3")))
          (p ((class "lead")) ,(~t (now) "'Dernière connexion à' HH:mm, 'le' EEEE d MMMM yyyy"))
          (p ((class "lead"))
             (a ((class "btn btn-primary mb-3") [href "/ferti/index"]) "Accéder à Ferti"))))))

(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."]
        [(#\5) "c'est de ma faute."]
        [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)]))))