diff options
| -rw-r--r-- | formlets.rkt | 49 | ||||
| -rw-r--r-- | handlers.rkt | 65 | ||||
| -rw-r--r-- | views.rkt | 39 |
3 files changed, 127 insertions, 26 deletions
diff --git a/formlets.rkt b/formlets.rkt index 406a54a..d0067e3 100644 --- a/formlets.rkt +++ b/formlets.rkt @@ -1,11 +1,14 @@ #lang racket -(provide measurements-formlet) +(provide measurements-formlet + targets-formlet) (require gregor web-server/http web-server/formlets - "models/nutrient.rkt") + "models/nutrient.rkt" + "models/crop.rkt" + "models/crop-requirement.rkt") (define date-formlet @@ -26,7 +29,7 @@ [id ,(number->string id)] [step "0.1"] [placeholder ,(nutrient-name nutrient)]))) - (define input-label `(label ((for ,(number->string id))) ,(nutrient-name nutrient))) + (define input-label `(label ([for ,(number->string id)]) ,(nutrient-name nutrient))) (formlet (#%# (div ([class "form-floating mb-3"]) @@ -51,3 +54,43 @@ (let ([measured-on (first measured-on*)] [measurements (filter pair? measurements*)]) ; drop #f’s from empty values (values measured-on measurements)))) + +(define (crop-requirement-formlet requirement) + (define id (crop-requirement-id requirement)) + (define profile (crop-requirement-profile requirement)) + (define maybe-crop (crop-requirement-crop-id requirement)) + (define crop (if maybe-crop (crop-name (get-crop #:id maybe-crop)) #f)) + (define number-input + (input #:type "number" + #:attributes `([class "form-control"] + [id ,(number->string id)] + [step "1"] + [placeholder ,profile]))) + (define input-label `(label ([for ,(number->string id)]) + ,(if crop + (format "~a (~a)" crop profile) + (format "~a" profile)))) + (formlet + (#%# + (div ([class "form-floating mb-3"]) + ,{=> number-input requirement-proportion-b} + ,input-label)) + (let ([requirement-proportion (string->number + (bytes->string/utf-8 + (binding:form-value requirement-proportion-b)))]) + (and requirement-proportion (cons requirement requirement-proportion))))) + +(define (targets-formlet) + (formlet* + (#%# + `(div ([class "mb-3"]) + (h5 "Date ciblée") + ,{=>* date-formlet effective-on*}) + `(div ([class "mb-3"]) + (h5 "Valeurs cibles") + ,@(for/list ([requirement (get-crop-requirements)]) + {=>* (crop-requirement-formlet requirement) requirements*})) + {=>* (submit "Enregistrer la cible" #:attributes '([class "btn btn-primary"])) _}) + (let ([effective-on (first effective-on*)] + [requirements (filter pair? requirements*)]) ; drop #f’s from empty values + (values effective-on requirements)))) diff --git a/handlers.rkt b/handlers.rkt index 42e4a76..aa380aa 100644 --- a/handlers.rkt +++ b/handlers.rkt @@ -8,8 +8,22 @@ "views.rkt" "formlets.rkt" "models/nutrient.rkt" - "models/nutrient-measurement.rkt") + "models/nutrient-measurement.rkt" + "models/nutrient-target.rkt" + "models/crop-requirement.rkt") +(define-values (app-dispatch _) + (dispatch-rules + ;; Nutrient measurements + [("measurement" "new") #:method "get" new-measurement] + [("measurement" "create") #:method "post" create-measurement] + [("measurement" "destroy") #:method "post" destroy-measurement] + ;; Nutrient targets + [("target" "new") #:method "get" new-target] + [("target" "create") #:method "post" create-target] + ;; Index + [("") #:method "get" index] + [else fallback])) (define (index _) (define measurements (get-nutrient-measurements)) @@ -17,6 +31,9 @@ #:preamble #"<!DOCTYPE html>" (index-page measurements))) + +;; Nutrient measurements + (define (new-measurement _) (response/xexpr #:preamble #"<!DOCTYPE html>" @@ -29,20 +46,42 @@ (redirect-to "/")) (define (destroy-measurement req) - (define-values (measured-on measurements) - (formlet-process (measurements-formlet) req)) - (create-nutrient-measurement! measured-on measurements) + (delete-nutrient-measurement! req) (redirect-to "/")) -(define (fallback req) + +;; Nutrient targets + +(define (new-target _) (response/xexpr #:preamble #"<!DOCTYPE html>" - (fallback-page 404))) + (new-target-page))) -(define-values (app-dispatch app-url) - (dispatch-rules - [("measurement" "new") #:method "get" new-measurement] - [("measurement" "create") #:method "post" create-measurement] - [("measurement" "destroy") #:method "post" destroy-measurement] - [("") #:method "get" index] - [else fallback])) +(define (create-target req) + (define-values (effective-on crop-requirement-mix) + (formlet-process (targets-formlet) req)) + + (define (average-nutrient-values mix) + (define totals + (for/fold ([acc (hash)]) ([pair (in-list mix)]) + (define crop-requirement (car pair)) + (define percentage (/ (cdr pair) 100)) + (for/fold ([acc acc]) + ([nv (in-list (get-crop-requirement-values crop-requirement))]) + (define n (car nv)) + (define v (cdr nv)) + (hash-update acc n + (λ (old) (+ old (* v percentage))) + (λ () (* v percentage)))))) + (for/list ([(k v) (in-hash totals)]) + (cons k v))) + + (define target-nutrient-values (average-nutrient-values crop-requirement-mix)) + (pretty-display target-nutrient-values) + (create-nutrient-target! effective-on target-nutrient-values) + (redirect-to "/")) + +(define (fallback _) + (response/xexpr + #:preamble #"<!DOCTYPE html>" + (fallback-page 404))) @@ -2,12 +2,14 @@ (provide index-page new-measurement-page + new-target-page fallback-page) (require web-server/formlets "formlets.rkt" "models/nutrient.rkt" - "models/nutrient-measurement.rkt") + "models/nutrient-measurement.rkt" + "models/nutrient-target.rkt") (define (page-template title body-xexpr) @@ -77,19 +79,26 @@ (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"]) "Dernière Cible") (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))) + (define latest-target (get-latest-nutrient-target-value n)) + (define latest-measurement (get-latest-nutrient-measurement-value n)) + (define delta-percentage (cond + [(zero? latest-target) + -100] + [(zero? latest-measurement) + 100] + [(number? latest-target) + (* 100 + (/ (- latest-target latest-measurement) + latest-measurement))] + [else #f])) `(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))))) + (td ([class "text-end"]) ,(if latest-measurement (round 2 latest-measurement) "—")) + (td ([class "text-end"]) ,(if latest-target (round 2 latest-target) "—")) + (td ([class "text-end"]) ,(if delta-percentage (round 1 delta-percentage) "—"))))) (a ([class "btn btn-primary mb-3"] [href "/measurement/new"]) "Ajouter un relevé") (table ([class "table table-striped"]) @@ -122,6 +131,16 @@ [method "POST"]) ,@(formlet-display (measurements-formlet))))))) +(define (new-target-page) + (page-template + "Nouvelle cible" + `((h1 ([class "display-1 mb-3"]) "Nouvelle cible") + (div ([class "mb-3"] [style "max-width: 30em"]) + (form + ([action "/target/create"] + [method "POST"]) + ,@(formlet-display (targets-formlet))))))) + (define (fallback-page request-code) (page-template (format "Réponse: ~a" request-code) |