Add crop requirement new/show/edit logic.

5 files changed, 156 insertions, 33 deletions

diff --git a/db/seed.rkt b/db/seed.rkt
index 2ff8277..eea1359 100644
--- a/db/seed.rkt
+++ b/db/seed.rkt
@@ -86,11 +86,9 @@
         (define v (string->number (cdr crop-requirement)))
         (values n v)))
     (unless (get-crop-requirement #:profile profile)
-      (cond
-        [(non-empty-string? crop-name)
-         (define crop (get-crop #:name crop-name))
-         (create-crop-requirement! profile nutrient-values crop)]
-        [else (create-crop-requirement! profile nutrient-values)])))
+      (if (non-empty-string? crop-name)
+          (create-crop-requirement! profile nutrient-values (get-crop #:name crop-name))
+          (create-crop-requirement! profile nutrient-values))))
   (with-tx (csv-for-each row->seed! next-row)))
 
 (define (seed-initial-crop-rotation!)
diff --git a/formlets.rkt b/formlets.rkt
index c35e882..c2923ad 100644
--- a/formlets.rkt
+++ b/formlets.rkt
@@ -2,7 +2,8 @@
 
 (provide measurements-formlet
          rotation-formlet
-         fertilizer-formlet)
+         fertilizer-formlet
+         crop-requirements-formlet)
 
 (require gregor
          web-server/formlets
@@ -82,10 +83,43 @@
             (let ([id (string->number (first id*))]
                   [canonical-name (first canonical-name*)]
                   [brand-name (first brand-name*)]
-                  [nutrient-values (for/hash ([nv nutrient-values*])
-                                     (values (car nv) (cdr nv)))])
+                  [nutrient-values (make-immutable-hash nutrient-values*)])
               (fertilizer-product id canonical-name brand-name nutrient-values))))
 
+(define (crop-requirements-formlet #:value [cr #f])
+  (formlet* (#%# (=>* (to-string (required (hidden (if cr
+                                                       (number->string (crop-requirement-id cr))
+                                                       ""))))
+                      id*)
+                 `(div ((class "mb-3"))
+                       (h5 "Profil de culture")
+                       ,(=>* (required-string-input #:value (if cr
+                                                                (crop-requirement-profile cr)
+                                                                ""))
+                             profile*))
+                 `(div ((class "mb-3"))
+                       (h5 "Culture associée")
+                       ,(=>* (select-input (cons (crop #f "<aucune>") (get-crops))
+                                           #:attributes '((class "form-select"))
+                                           #:display crop-name)
+                             crop*))
+                 `(div ((class "mb-3"))
+                       (h5 "Valeurs du profil")
+                       ,@(for/list ([n (get-nutrients)])
+                           (define v
+                             (if cr
+                                 (crop-requirement-value cr n)
+                                 0))
+                           (=>* (nutrient-value-formlet n v) nutrient-values*)))
+                 (=>* (submit (string-join (list (if cr "Modifier" "Enregistrer") "l'intrant"))
+                              #:attributes '((class "btn btn-primary")))
+                      _))
+            (let ([id (string->number (first id*))]
+                  [profile (first profile*)]
+                  [crop-id (crop-id (first crop*))]
+                  [nutrient-values (make-immutable-hash nutrient-values*)])
+              (crop-requirement id profile crop-id nutrient-values))))
+
 (define (crop-requirement-formlet requirement)
   (define id (number->string (crop-requirement-id requirement)))
   (define profile (crop-requirement-profile requirement))
diff --git a/handlers.rkt b/handlers.rkt
index 49e27d9..e38ece8 100644
--- a/handlers.rkt
+++ b/handlers.rkt
@@ -48,6 +48,13 @@
    [("ferti" "fertilizers" (integer-arg) "edit") #:method "get" edit-fertilizer]
    [("ferti" "fertilizers" "update") #:method "post" update-fertilizer]
    [("ferti" "fertilizers" (integer-arg) "destroy") #:method "get" destroy-fertilizer]
+   ;; Crop requirements
+   [("ferti" "crop-requirements" "new") #:method "get" new-requirement]
+   [("ferti" "crop-requirements" "create") #:method "post" create-requirement]
+   [("ferti" "crop-requirements" (integer-arg)) #:method "get" show-requirement]
+   [("ferti" "crop-requirements" (integer-arg) "edit") #:method "get" edit-requirement]
+   [("ferti" "crop-requirements" "update") #:method "post" update-requirement]
+   [("ferti" "crop-requirements" (integer-arg) "destroy") #:method "get" destroy-requirement]
    ;; Default
    [("") #:method "get" index]
    [else fallback]))
@@ -158,6 +165,35 @@
   (delete-fertilizer-product! id)
   (redirect-to "/ferti/fertilizers"))
 
+;; Crop requirements
+
+(define (new-requirement _)
+  (render-page (new-crop-requirement-page)))
+
+(define (create-requirement req)
+  (define new-requirement (formlet-process (crop-requirements-formlet) req))
+  (if (get-crop-requirement #:profile (crop-requirement-profile new-requirement))
+      (update-crop-requirement! new-requirement)
+      (create-crop-requirement! new-requirement))
+  (redirect-to "/ferti/crop-requirements"))
+
+(define (show-requirement _ id)
+  (define cr (get-crop-requirement #:id id))
+  (render-page (show-crop-requirement-page cr)))
+
+(define (edit-requirement _ id)
+  (define cr (get-crop-requirement #:id id))
+  (render-page (edit-crop-requirement-page cr)))
+
+(define (update-requirement req)
+  (define edited-nutrient-requirement (formlet-process (crop-requirements-formlet) req))
+  (update-crop-requirement! edited-nutrient-requirement)
+  (redirect-to "/ferti/crop-requirements"))
+
+(define (destroy-requirement _ id)
+  (delete-crop-requirement! id)
+  (redirect-to "/ferti/crop-requirements"))
+
 ;; Fallback
 
 (define (fallback _)
diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt
index 803578c..2dd8071 100644
--- a/models/crop-requirement.rkt
+++ b/models/crop-requirement.rkt
@@ -5,13 +5,18 @@
          crop-requirement-id
          crop-requirement-profile
          crop-requirement-crop-id
+         crop-requirement-value
          (rename-out [crop-requirement-nutrient-values crop-requirement-values])
          (contract-out
-          [create-crop-requirement! (->* (string? nutrient-value-hash/c) (crop?) crop-requirement?)]
+          [create-crop-requirement!
+           (case-> (-> crop-requirement? crop-requirement?)
+                   (-> string? nutrient-value-hash/c crop-requirement?)
+                   (-> string? nutrient-value-hash/c crop? crop-requirement?))]
           [get-crop-requirements (-> (listof crop-requirement?))]
           [get-crop-requirement (->* () (#:id db-id? #:profile string?) (or/c crop-requirement? #f))]
           [get-crop-requirement-values (-> crop-requirement-or-id/c nutrient-value-hash/c)]
           [get-crop-requirement-value (-> crop-requirement-or-id/c nutrient? maybe-nutrient-value?)]
+          [update-crop-requirement! (-> crop-requirement? void?)]
           [delete-crop-requirement! (-> crop-requirement-or-id/c void?)]
           [average-crop-requirement-nutrient-values
            (-> (hash/c crop-requirement? (between/c 0 100)) nutrient-value-hash/c)]))
@@ -29,6 +34,9 @@
   #:guard (λ (id profile crop-id nutrient-values _)
             (values id profile (if (sql-null? crop-id) #f crop-id) nutrient-values)))
 
+(define (crop-requirement-value cr nutrient)
+  (hash-ref (crop-requirement-nutrient-values cr) nutrient #f))
+
 (define crop-requirement-or-id/c (or/c crop-requirement? db-id?))
 
 (define (->cr-id cr-or-id)
@@ -38,24 +46,30 @@
 
 ;; CREATE
 
-(define (create-crop-requirement! profile nutrient-values [crop #f])
-  (with-tx
-   (define cr-id
-     (insert-id
-      (query (current-conn)
-             (if crop
-                 (insert #:into crop_requirements #:set [crop_id ,(crop-id crop)] [profile ,profile])
-                 (insert #:into crop_requirements #:set [profile ,profile])))))
-   (define nvs-id
-     (insert-id (query (current-conn)
-                       (insert #:into nutrient_value_sets #:set [crop_requirement_id ,cr-id]))))
-   (insert-nutrient-values (current-conn) nvs-id nutrient-values)
-   (crop-requirement cr-id
-                     profile
-                     (if crop
-                         (crop-id crop)
-                         #f)
-                     nutrient-values)))
+(define create-crop-requirement!
+  (case-lambda
+    [(cr) (create-crop-requirement!/cr cr)]
+    [(profile nutrient-values)
+     (create-crop-requirement!/cr (crop-requirement #f profile #f nutrient-values))]
+    [(profile nutrient-values crop)
+     (create-crop-requirement!/cr (crop-requirement #f profile (crop-id crop) nutrient-values))]))
+
+(define (create-crop-requirement!/cr cr)
+  (define profile (crop-requirement-profile cr))
+  (define nutrient-values (crop-requirement-nutrient-values cr))
+  (define crop-id (crop-requirement-crop-id cr))
+  (with-tx (define cr-id
+             (insert-id
+              (query (current-conn)
+                     (if crop-id
+                         (insert #:into crop_requirements #:set [crop_id ,crop-id] [profile ,profile])
+                         (insert #:into crop_requirements #:set [profile ,profile])))))
+           (define nvs-id
+             (insert-id (query (current-conn)
+                               (insert #:into nutrient_value_sets
+                                       #:set [crop_requirement_id ,cr-id]))))
+           (insert-nutrient-values (current-conn) nvs-id nutrient-values)
+           (crop-requirement cr-id profile crop-id nutrient-values)))
 
 ;; READ
 
@@ -135,6 +149,23 @@
 
 ;; UPDATE
 
+(define (update-crop-requirement! cr)
+  (define id
+    (or (crop-requirement-id cr)
+        (raise-argument-error 'update-crop-requirement! "db-id?" (crop-requirement-id cr))))
+  (define profile (crop-requirement-profile cr))
+  (define crop-id (crop-requirement-crop-id cr))
+  (with-tx
+   (query-exec
+    (current-conn)
+    (if crop-id
+        (update crop_requirements #:set [profile ,profile] [crop_id ,crop-id] #:where [= id ,id])
+        (update crop_requirements #:set [profile ,profile] #:where [= id ,id])))
+   (define nvs-id
+     (query-value (current-conn)
+                  (select id #:from nutrient_value_sets #:where [= crop_requirement_id ,id])))
+   (update-nutrient-values! (current-conn) nvs-id (crop-requirement-nutrient-values cr))))
+
 ;; DELETE
 
 (define (delete-crop-requirement! cr-or-id)
diff --git a/views.rkt b/views.rkt
index 2ffce4c..e46843f 100644
--- a/views.rkt
+++ b/views.rkt
@@ -14,6 +14,9 @@
          show-measurement-page
          show-rotation-page
          show-fertilizer-page
+         show-crop-requirement-page
+         new-crop-requirement-page
+         edit-crop-requirement-page
          fallback-page)
 
 (require gregor
@@ -206,6 +209,9 @@
 (define (new-fertilizer-page)
   (form-page-template "Nouvel intrant" "/ferti/fertilizers/create" (fertilizer-formlet)))
 
+(define (new-crop-requirement-page)
+  (form-page-template "Nouveau profil" "/ferti/crop-requirements/create" (crop-requirements-formlet)))
+
 ;; Edit
 
 (define (edit-measurement-page nm)
@@ -216,12 +222,12 @@
 (define (edit-fertilizer-page fp)
   (form-page-template "Modifier intrant" "/ferti/fertilizers/update" (fertilizer-formlet #:value fp)))
 
-;; (define (new-crop-requirement-page)
-;;   (page-template "Nouveau profil"
-;;                  `((h1 ((class "display-1 mb-3")) "Nouveau profil")
-;;                    (div ((class "mb-3") [style "max-width: 30em"])
-;;                         (form ([action "/ferti/crop-requirements/create"] [method "POST"])
-;;                               ,@(formlet-display (crop-requirement-formlet)))))))
+(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 title (format "Relevé du ~a" (normal-date (nutrient-measurement-date nm))))
@@ -285,6 +291,24 @@
                    ,button-group
                    ,table)))
 
+(define (show-crop-requirement-page cr)
+  (define id (crop-requirement-id cr))
+  (define title (string-titlecase (crop-requirement-profile cr)))
+  (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")) ,title) ,button-group ,table)))
+
 (define (index-page user)
   (page-template
    "Bienvenue à la FAPG"