Add fertilizer product updating logic.

5 files changed, 135 insertions, 49 deletions

diff --git a/formlets.rkt b/formlets.rkt
index 3408278..cb4601f 100644
--- a/formlets.rkt
+++ b/formlets.rkt
@@ -8,6 +8,7 @@
          web-server/formlets
          "models/nutrient.rkt"
          "models/nutrient-measurement.rkt"
+         "models/fertilizer-product.rkt"
          "models/crop.rkt"
          "models/crop-requirement.rkt")
 
@@ -38,20 +39,42 @@
                                              (values req proportion))])
               (values rotation-date requirement-proportions))))
 
-(define (fertilizer-formlet)
-  (formlet*
-   (#%# `(div ((class "mb-3")) (h5 "Nom de référence") ,{=>* required-string-input canonical-name*})
-        `(div ((class "mb-3")) (h5 "Nom de marque") ,{=>* required-string-input brand-name*})
-        `(div ((class "mb-3"))
-              (h5 "Valeurs de l'intrant")
-              ,@(for/list ([nutrient (get-nutrients)])
-                  {=>* (nutrient-value-formlet nutrient) nutrient-values*}))
-        {=>* (submit "Enregistrer l'intrant" #:attributes '((class "btn btn-primary"))) _})
-   (let ([canonical-name (first canonical-name*)]
-         [nutrient-values (for/hash ([nv nutrient-values*])
-                            (values (car nv) (cdr nv)))]
-         [brand-name (first brand-name*)])
-     (values canonical-name brand-name nutrient-values))))
+(define (fertilizer-formlet #:value [fp #f])
+  (formlet* (#%# (=>* (to-string (required (hidden (if fp
+                                                       (number->string (fertilizer-product-id fp))
+                                                       ""))))
+                      id*)
+                 `(div ((class "mb-3"))
+                       (h5 "Nom de référence")
+                       ,{=>*
+                         (required-string-input #:value (if fp
+                                                            (fertilizer-product-name fp)
+                                                            ""))
+                         canonical-name*})
+                 `(div ((class "mb-3"))
+                       (h5 "Nom de marque")
+                       ,{=>*
+                         (required-string-input #:value (if fp
+                                                            (fertilizer-brand-name fp)
+                                                            ""))
+                         brand-name*})
+                 `(div ((class "mb-3"))
+                       (h5 "Valeurs de l'intrant")
+                       ,@(for/list ([n (get-nutrients)])
+                           (define v
+                             (if fp
+                                 (fertilizer-product-value fp n)
+                                 0))
+                           (=>* (nutrient-value-formlet n v) nutrient-values*)))
+                 (=>* (submit (string-join (list (if fp "Modifier" "Enregistrer") "l'intrant"))
+                              #:attributes '((class "btn btn-primary")))
+                      _))
+            (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)))])
+              (fertilizer-product id canonical-name brand-name nutrient-values))))
 
 (define (crop-requirement-formlet requirement)
   (define id (number->string (crop-requirement-id requirement)))
@@ -86,7 +109,7 @@
                               #:value (or date-string (date->iso8601 (today)))
                               #:attributes '((class "form-control") [required "required"])))))
 
-(define (nutrient-value-formlet nutrient)
+(define (nutrient-value-formlet nutrient value)
   (define id (number->string (nutrient-id nutrient)))
   (define number-input
     (to-number (to-string (required (input #:type "number"
@@ -95,6 +118,7 @@
                                              [required "required"]
                                              [id ,id]
                                              [name ,id]
+                                             [value ,(number->string value)]
                                              [step "0.1"]
                                              [placeholder ,(nutrient-french-name nutrient)]))))))
   (define input-label
@@ -104,5 +128,6 @@
   (formlet (div ((class "form-floating mb-3")) ,{=> number-input nutrient-value} ,input-label)
            (cons nutrient nutrient-value)))
 
-(define required-string-input
-  (to-string (required (text-input #:attributes '((class "form-control") [required "required"])))))
+(define (required-string-input #:value [str #f])
+  (to-string (required (text-input #:attributes `((class "form-control") [required "required"]
+                                                                         [value ,(or str "")])))))
diff --git a/handlers.rkt b/handlers.rkt
index 010fe8e..759dbfe 100644
--- a/handlers.rkt
+++ b/handlers.rkt
@@ -43,7 +43,9 @@
    [("ferti" "fertilizers" "new") #:method "get" new-fertilizer]
    [("ferti" "fertilizers" "create") #:method "post" create-fertilizer]
    [("ferti" "fertilizers" (integer-arg)) #:method "get" show-fertilizer]
-   [("ferti" "fertilizers" "destroy" (integer-arg)) #:method "get" destroy-fertilizer]
+   [("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]
    ;; Default
    [("") #:method "get" index]
    [else fallback]))
@@ -122,15 +124,23 @@
   (render-page (new-fertilizer-page)))
 
 (define (create-fertilizer req)
-  (define-values (canonical-name brand-name nutrient-values)
-    (formlet-process (fertilizer-formlet) req))
-  (create-fertilizer-product! canonical-name brand-name nutrient-values)
+  (define new-fertilizer-product (formlet-process (fertilizer-formlet) req))
+  (create-fertilizer-product! new-fertilizer-product)
   (redirect-to "/ferti/fertilizers"))
 
 (define (show-fertilizer _ id)
   (define fp (get-fertilizer-product #:id id))
   (render-page (show-fertilizer-page fp)))
 
+(define (edit-fertilizer _ id)
+  (define fp (get-fertilizer-product #:id id))
+  (render-page (edit-fertilizer-page fp)))
+
+(define (update-fertilizer req)
+  (define edited-fertilizer-product (formlet-process (fertilizer-formlet) req))
+  (update-fertilizer-product! edited-fertilizer-product)
+  (redirect-to "/ferti/fertilizers"))
+
 (define (destroy-fertilizer _ id)
   (delete-fertilizer-product! id)
   (redirect-to "/ferti/fertilizers"))
diff --git a/models/fertilizer-product.rkt b/models/fertilizer-product.rkt
index 152b72a..c579354 100644
--- a/models/fertilizer-product.rkt
+++ b/models/fertilizer-product.rkt
@@ -3,18 +3,20 @@
 (provide fertilizer-product
          fertilizer-product?
          fertilizer-product-id
+         fertilizer-product-value
          (rename-out [fertilizer-product-canonical-name fertilizer-product-name]
                      [fertilizer-product-nutrient-values fertilizer-product-values]
                      [fertilizer-product-brand-name fertilizer-brand-name])
-         (contract-out
-          [create-fertilizer-product! (-> string? string? nutrient-value-hash/c fertilizer-product?)]
-          [get-fertilizer-products (-> (listof fertilizer-product?))]
-          [get-fertilizer-product
-           (->* () (#:id db-id? #:canonical-name string?) (or/c fertilizer-product? #f))]
-          [get-fertilizer-product-values (-> fertilizer-product-or-id/c nutrient-value-hash/c)]
-          [get-fertilizer-product-value
-           (-> fertilizer-product-or-id/c nutrient? maybe-nutrient-value?)]
-          [delete-fertilizer-product! (-> fertilizer-product-or-id/c void?)]))
+         (contract-out [create-fertilizer-product! (-> fertilizer-product? fertilizer-product?)]
+                       [get-fertilizer-products (-> (listof fertilizer-product?))]
+                       [get-fertilizer-product
+                        (->* () (#:id db-id? #:canonical-name string?) (or/c fertilizer-product? #f))]
+                       [get-fertilizer-product-values
+                        (-> fertilizer-product-or-id/c nutrient-value-hash/c)]
+                       [get-fertilizer-product-value
+                        (-> fertilizer-product-or-id/c nutrient? maybe-nutrient-value?)]
+                       [update-fertilizer-product! (-> fertilizer-product? void?)]
+                       [delete-fertilizer-product! (-> fertilizer-product-or-id/c void?)]))
 
 (require racket/contract
          db
@@ -46,6 +48,9 @@
                (~a (nutrient-canonical-name n) #:min-width 14)
                (~a v #:max-width 6 #:align 'right)))))
 
+(define (fertilizer-product-value fp nutrient)
+  (hash-ref (fertilizer-product-nutrient-values fp) nutrient #f))
+
 (define fertilizer-product-or-id/c (or/c fertilizer-product? db-id?))
 
 (define (->fp-id fp-or-id)
@@ -55,7 +60,10 @@
 
 ;; CREATE
 
-(define (create-fertilizer-product! canonical-name brand-name nutrient-values)
+(define (create-fertilizer-product! fp)
+  (define canonical-name (fertilizer-product-canonical-name fp))
+  (define brand-name (fertilizer-product-brand-name fp))
+  (define nutrient-values (fertilizer-product-nutrient-values fp))
   (with-tx (define fp-id
              (insert-id (query (current-conn)
                                (insert #:into fertilizer_products
@@ -66,7 +74,7 @@
                                (insert #:into nutrient_value_sets
                                        #:set [fertilizer_product_id ,fp-id]))))
            (insert-nutrient-values (current-conn) nvs-id nutrient-values)
-           (fertilizer-product nvs-id canonical-name brand-name nutrient-values)))
+           (fertilizer-product fp-id canonical-name brand-name nutrient-values)))
 
 ;; READ
 
@@ -149,6 +157,21 @@
 
 ;; UPDATE
 
+(define (update-fertilizer-product! fp)
+  (define id
+    (or (fertilizer-product-id fp)
+        (raise-argument-error 'update-fertilizer-product! "db-id?" (fertilizer-product-id fp))))
+  (with-tx
+   (query-exec (current-conn)
+               (update fertilizer_products
+                       #:set [canonical_name ,(fertilizer-product-canonical-name fp)]
+                       [brand_name ,(fertilizer-product-brand-name fp)]
+                       #:where [= id ,id]))
+   (define nvs-id
+     (query-value (current-conn)
+                  (select id #:from nutrient_value_sets #:where [= fertilizer_product_id ,id])))
+   (update-nutrient-values! (current-conn) nvs-id (fertilizer-product-nutrient-values fp))))
+
 ;; DELETE
 
 (define (delete-fertilizer-product! fp-or-id)
@@ -177,9 +200,10 @@
        (define nitrogen (get-nutrient #:name "Nitrogen"))
        (define phosphorus (get-nutrient #:name "Phosphorus"))
 
-       (create-fertilizer-product! canonical-product-name
-                                   "MasterBlend"
-                                   (hash nitrogen 40 phosphorus 200))
+       (create-fertilizer-product! (fertilizer-product #f
+                                                       canonical-product-name
+                                                       "MasterBlend"
+                                                       (hash nitrogen 40 phosphorus 200)))
 
        (check-equal? (length (get-fertilizer-products)) 1)
 
@@ -188,13 +212,6 @@
        (check-equal? (fertilizer-product-canonical-name fp) canonical-product-name)
        (check-equal? (fertilizer-product-brand-name fp) "MasterBlend"))
 
-     (test-case "Create product without brand name"
-       (define nitrogen (get-nutrient #:name "Nitrogen"))
-
-       (define fp (create-fertilizer-product! "Generic N" "" (hash nitrogen 100)))
-
-       (check-false (fertilizer-product-brand-name fp)))
-
      (test-case "Check all product values"
        (define nitrogen (get-nutrient #:name "Nitrogen"))
        (define phosphorus (get-nutrient #:name "Phosphorus"))
@@ -225,7 +242,9 @@
 
      (test-case "Custom write property formatting"
        (define nitrogen (get-nutrient #:name "Nitrogen"))
-       (define fp (create-fertilizer-product! "Test Fertilizer" "TestBrand" (hash nitrogen 50)))
+       (define fp
+         (create-fertilizer-product!
+          (fertilizer-product #f "Test Fertilizer" "TestBrand" (hash nitrogen 50))))
 
        (define output (open-output-string))
        (write fp output)
@@ -240,6 +259,6 @@
        (delete-fertilizer-product! fp)
        (check-false (get-fertilizer-product #:id (fertilizer-product-id fp)))
        (check-equal? (length (get-fertilizer-products))
-                     2
+                     1
                      "wrong number of fertilizer products were deleted")
        (check-true (hash-empty? (get-fertilizer-product-values fp)))))))
diff --git a/models/nutrient-value.rkt b/models/nutrient-value.rkt
index b5798db..08bcfad 100644
--- a/models/nutrient-value.rkt
+++ b/models/nutrient-value.rkt
@@ -5,6 +5,7 @@
          nutrient-value-hash/c
          (contract-out [insert-nutrient-values
                         (-> connection? db-id? nutrient-value-hash/c (listof (cons/c symbol? any/c)))]
+                       [update-nutrient-values! (-> connection? db-id? nutrient-value-hash/c void?)]
                        [residuals->nutrient-value-hash
                         (-> (listof residual-vector/c) nutrient-value-hash/c)]))
 
@@ -33,6 +34,13 @@
                    #:from (TableExpr:AST ,(make-values*-table-expr-ast nv-rows)))))
   (simple-result-info result))
 
+(define (update-nutrient-values! conn nvs-id nutrient-values)
+  (for ([(n v) (in-hash nutrient-values)])
+    (query-exec conn
+                (update nutrient_values
+                        #:set [value_ppm ,v]
+                        #:where (and (= value_set_id ,nvs-id) (= nutrient_id ,(nutrient-id n)))))))
+
 (define (residuals->nutrient-value-hash residuals)
   (for/hash ([r (in-list residuals)])
     (match-define (vector n-id n-canonical-name n-french-name n-formula value-ppm) r)
diff --git a/views.rkt b/views.rkt
index 75018a4..0695079 100644
--- a/views.rkt
+++ b/views.rkt
@@ -9,6 +9,7 @@
          new-measurement-page
          new-rotation-page
          new-fertilizer-page
+         edit-fertilizer-page
          show-measurement-page
          show-rotation-page
          show-fertilizer-page
@@ -16,6 +17,7 @@
 
 (require gregor
          web-server/formlets
+         racket/hash
          "formlets.rkt"
          "models/user.rkt"
          "models/nutrient.rkt"
@@ -187,9 +189,14 @@
 (define (new-measurement-page)
   (page-template "Nouveau relevé"
                  `((h1 ((class "display-1 mb-3")) "Nouveau relevé")
+;; 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 "/ferti/measurements/create"] [method "POST"])
-                              ,@(formlet-display (measurements-formlet)))))))
+                        (form ([action ,action] [method "POST"]) ,@(formlet-display formlet))))))
+
 
 (define (new-rotation-page #:date [date-string #f])
   (page-template "Nouvel assolement"
@@ -204,6 +211,17 @@
                    (div ((class "mb-3") [style "max-width: 30em"])
                         (form ([action "/ferti/fertilizers/create"] [method "POST"])
                               ,@(formlet-display (fertilizer-formlet)))))))
+;; Edit
+
+(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 (show-measurement-page nm)
   (define title (format "Relevé du ~a" (normal-date (nutrient-measurement-date nm))))
@@ -251,12 +269,18 @@
                        (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"))
+          (a ((class "btn btn-primary")
+              [href ,(format "/ferti/fertilizers/~a/edit" (fertilizer-product-id fp))])
+             "Modifier")
+          (a ((class "btn btn-danger")
+              [href ,(format "/ferti/fertilizers/~a/destroy" (fertilizer-product-id fp))])
+             "Supprimer")))
   (page-template product-name
                  `((h1 ((class "display-1 mb-3")) ,(or brand-name "Intrant générique"))
                    (h5 ((class "display-5 mb-3")) ,product-name)
-                   (a ((class "btn btn-danger")
-                       [href ,(format "/ferti/fertilizers/destroy/~a" (fertilizer-product-id fp))])
-                      "Supprimer")
+                   ,button-group
                    ,table)))
 
 (define (index-page user)