Add crop new/show/edit logic.

4 files changed, 111 insertions, 13 deletions

diff --git a/formlets.rkt b/formlets.rkt
index c2923ad..17b9448 100644
--- a/formlets.rkt
+++ b/formlets.rkt
@@ -3,6 +3,7 @@
 (provide measurements-formlet
          rotation-formlet
          fertilizer-formlet
+         crop-formlet
          crop-requirements-formlet)
 
 (require gregor
@@ -86,6 +87,24 @@
                   [nutrient-values (make-immutable-hash nutrient-values*)])
               (fertilizer-product id canonical-name brand-name nutrient-values))))
 
+(define (crop-formlet #:value [c #f])
+  (formlet* (#%# (=>* (to-string (required (hidden (if c
+                                                       (number->string (crop-id c))
+                                                       ""))))
+                      id*)
+                 `(div ((class "mb-3"))
+                       (h5 "Culture")
+                       ,(=>* (required-string-input #:value (if c
+                                                                (crop-name c)
+                                                                ""))
+                             crop-name*))
+                 (=>* (submit (string-join (list (if c "Modifier" "Enregistrer") "la culture"))
+                              #:attributes '((class "btn btn-primary")))
+                      _))
+            (let ([id (string->number (first id*))]
+                  [crop-name (first crop-name*)])
+              (crop id crop-name))))
+
 (define (crop-requirements-formlet #:value [cr #f])
   (formlet* (#%# (=>* (to-string (required (hidden (if cr
                                                        (number->string (crop-requirement-id cr))
diff --git a/handlers.rkt b/handlers.rkt
index e38ece8..d61e942 100644
--- a/handlers.rkt
+++ b/handlers.rkt
@@ -11,6 +11,7 @@
          "formlets.rkt"
          "models/user.rkt"
          "models/nutrient-measurement.rkt"
+         "models/crop.rkt"
          "models/crop-requirement.rkt"
          "models/crop-rotation.rkt"
          "models/fertilizer-product.rkt"
@@ -35,6 +36,13 @@
    [("ferti" "measurements" (integer-arg) "edit") #:method "get" edit-measurement]
    [("ferti" "measurements" "update") #:method "post" update-measurement]
    [("ferti" "measurements" (integer-arg) "destroy") #:method "get" destroy-measurement]
+   ;; Crops
+   [("ferti" "crops" "new") #:method "get" new-crop]
+   [("ferti" "crops" "create") #:method "post" create-crop]
+   [("ferti" "crops" (integer-arg)) #:method "get" show-crop]
+   [("ferti" "crops" (integer-arg) "edit") #:method "get" edit-crop]
+   [("ferti" "crops" "update") #:method "post" update-crop]
+   [("ferti" "crops" (integer-arg) "destroy") #:method "get" destroy-crop]
    ;; Crop rotations
    [("ferti" "rotations" "new") #:method "get" new-rotation]
    [("ferti" "rotations" "new" (string-arg)) #:method "get" new-rotation-for-date]
@@ -117,6 +125,35 @@
   (delete-nutrient-measurement! id)
   (redirect-to "/ferti/measurements-and-rotations"))
 
+;; Crops
+
+(define (new-crop _)
+  (render-page (new-crop-page)))
+
+(define (create-crop req)
+  (define new-crop (formlet-process (crop-formlet) req))
+  (if (get-crop #:name (crop-name new-crop))
+      (update-crop! new-crop)
+      (create-crop! new-crop))
+  (redirect-to "/ferti/crop-requirements"))
+
+(define (show-crop _ id)
+  (define crop (get-crop #:id id))
+  (render-page (show-crop-page crop)))
+
+(define (edit-crop _ id)
+  (define crop (get-crop #:id id))
+  (render-page (edit-crop-page crop)))
+
+(define (update-crop req)
+  (define edited-crop (formlet-process (crop-formlet) req))
+  (update-crop! edited-crop)
+  (redirect-to "/ferti/crop-requirements"))
+
+(define (destroy-crop _ id)
+  (delete-crop! id)
+  (redirect-to "/ferti/crop-requirements"))
+
 ;; Crop rotations
 
 (define (new-rotation _)
diff --git a/models/crop.rkt b/models/crop.rkt
index b37ec47..135de7d 100644
--- a/models/crop.rkt
+++ b/models/crop.rkt
@@ -4,7 +4,7 @@
          crop?
          crop-id
          crop-name
-         (contract-out [create-crop! (-> string? crop?)]
+         (contract-out [create-crop! (-> crop? crop?)]
                        [get-crops (-> (listof crop?))]
                        [get-crop (->* () (#:id db-id? #:name string?) (or/c crop? #f))]
                        [update-crop! (->* (db-id?) (#:name string?) (or/c crop? #f))]
@@ -19,7 +19,8 @@
 
 ;; CREATE
 
-(define (create-crop! name)
+(define (create-crop! c)
+  (define name (crop-name c))
   (or (get-crop #:name name)
       (with-tx (query-exec (current-conn) (insert #:into crops #:set [canonical_name ,name]))
                (get-crop #:name name))))
diff --git a/views.rkt b/views.rkt
index b988fef..adcf59b 100644
--- a/views.rkt
+++ b/views.rkt
@@ -9,14 +9,17 @@
          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
-         new-crop-requirement-page
-         edit-crop-requirement-page
          fallback-page)
 
 (require gregor
@@ -167,17 +170,19 @@
     `(table ((class "table table-striped"))
             (tr (th "Profil") (th "Culture"))
             ,@(for/list ([cr crop-requirements])
-                (define crop-id (crop-requirement-crop-id cr))
+                (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 crop-id
-                              (string-titlecase (crop-name (get-crop #:id crop-id)))
+                     (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/crop/new"]) "Ajouter une culture")))
-  (ferti-template "Cultures" `(,button-group ,table)))
+          (a ((class "btn btn-secondary") [href "/ferti/crops/new"]) "Ajouter une culture")))
+  (ferti-template "Cultures" (list button-group accordion)))
 
 ;; TODO: add bar chart for comparing to target concentrations
 (define (ferti-recipe-page recipe-date fertilizer-recipe)
@@ -218,6 +223,9 @@
 (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)))
 
@@ -229,7 +237,12 @@
                       (measurements-formlet #:value nm)))
 
 (define (edit-fertilizer-page fp)
-  (form-page-template "Modifier intrant" "/ferti/fertilizers/update" (fertilizer-formlet #:value 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"
@@ -285,7 +298,7 @@
 
 (define (show-fertilizer-page fp)
   (define id (fertilizer-product-id fp))
-  (define product-name (fertilizer-product-name 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
@@ -307,9 +320,33 @@
                    ,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 title (string-titlecase (crop-requirement-profile 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)")))
@@ -323,7 +360,11 @@
              "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)))
+  (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