summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--db/conn.rkt17
-rw-r--r--db/migrations.rkt268
-rw-r--r--db/seed.rkt73
-rw-r--r--formlets.rkt116
-rw-r--r--handlers.rkt58
-rw-r--r--main.rkt3
-rw-r--r--models/crop-requirement.rkt121
-rw-r--r--models/crop.rkt91
-rw-r--r--models/fertilizer-product.rkt224
-rw-r--r--models/nutrient-measurement.rkt86
-rw-r--r--models/nutrient-target.rkt152
-rw-r--r--models/nutrient.rkt109
-rw-r--r--models/user.rkt24
-rw-r--r--tests/models/nutrient-measurement.rkt95
-rw-r--r--tests/models/nutrient.rkt112
-rw-r--r--views.rkt223
16 files changed, 763 insertions, 1009 deletions
diff --git a/db/conn.rkt b/db/conn.rkt
index e083d94..793cf03 100644
--- a/db/conn.rkt
+++ b/db/conn.rkt
@@ -12,11 +12,9 @@
(define (connect! #:path [path 'memory])
(cond
- [(connection? (current-conn))
- (printf "Database connection already exists: ~e\n" (current-conn))]
+ [(connection? (current-conn)) (printf "Database connection already exists: ~e\n" (current-conn))]
[else
- (current-conn (sqlite3-connect #:database path
- #:mode 'create))
+ (current-conn (sqlite3-connect #:database path #:mode 'create))
(printf "Created database connection at path: ~a\n" path)]))
(define (disconnect!)
@@ -25,10 +23,14 @@
(current-conn #f))
(define-syntax-rule (with-db body ...)
- (begin (connect!) body ...))
+ (begin
+ (connect!)
+ body ...))
(define-syntax-rule (with-tx body ...)
- (call-with-transaction (current-conn) (λ () body ...)))
+ (call-with-transaction (current-conn)
+ (λ ()
+ body ...)))
(module+ test
(require rackunit)
@@ -37,5 +39,4 @@
(check-true (connection? (current-conn)))
(disconnect!)
(check-equal? (current-conn) #f)
- (with-db
- (check-true (connection? (current-conn)))))
+ (with-db (check-true (connection? (current-conn)))))
diff --git a/db/migrations.rkt b/db/migrations.rkt
index fb8ab80..4007db4 100644
--- a/db/migrations.rkt
+++ b/db/migrations.rkt
@@ -14,203 +14,149 @@
(for ([pair (in-list (unbox migrations-box))])
(match pair
[(cons migration-name stmts)
- (with-tx
- (for ([stmt (in-list stmts)])
- (query-exec (current-conn) stmt)))
+ (with-tx (for ([stmt (in-list stmts)])
+ (query-exec (current-conn) stmt)))
(printf "Applied migration: ~a\n" migration-name)])))
(define-syntax-rule (define-migration migration-name sql)
- (let ((migrations (unbox migrations-box))
- (name-symbol (string->symbol migration-name)))
+ (let ([migrations (unbox migrations-box)]
+ [name-symbol (string->symbol migration-name)])
(if (assoc name-symbol migrations)
(error 'define-migration "migration '~a' declared more than once" migration-name)
(set-box! migrations-box (append migrations (list (cons name-symbol sql)))))))
-
;;;;;;;;
;; USERS
;;;;;;;;
(define-migration "create table users"
- (list
- (create-table #:if-not-exists
- users
- #:columns
- [id integer #:not-null]
- [name text #:not-null]
- [role_id integer]
- #:constraints
- (primary-key id)
- (unique name)
- (foreign-key role_id
- #:references (user_roles id)))))
+ (list (create-table #:if-not-exists users
+ #:columns [id integer #:not-null]
+ [name text #:not-null]
+ [role_id integer]
+ #:constraints (primary-key id)
+ (unique name)
+ (foreign-key role_id #:references (user_roles id)))))
(define-migration "create table user_roles"
- (list
- (create-table #:if-not-exists
- user_roles
- #:columns
- [id integer #:not-null]
- [name text #:not-null]
- #:constraints
- (primary-key id)
- (unique name))))
-
+ (list (create-table #:if-not-exists user_roles
+ #:columns [id integer #:not-null]
+ [name text #:not-null]
+ #:constraints (primary-key id)
+ (unique name))))
;;;;;;;;;;;;
;; NUTRIENTS
;;;;;;;;;;;;
(define-migration "create table nutrients"
- (list
- (create-table #:if-not-exists
- nutrients
- #:columns
- [id integer #:not-null]
- [canonical_name text #:not-null]
- [formula text #:not-null]
- #:constraints
- (primary-key id)
- (unique canonical_name)
- (unique formula))))
-
-(define-migration "create table nutrient_value_sets"
- (list
- (create-table #:if-not-exists
- nutrient_value_sets
- #:columns
- [id integer #:not-null]
- [nutrient_measurement_id integer]
- [nutrient_target_id integer]
- [crop_requirement_id integer]
- [fertilizer_product_id integer]
- #:constraints
- (primary-key id)
- (foreign-key nutrient_measurement_id
- #:references (nutrient_measurements id)
- #:on-delete #:cascade)
- (foreign-key nutrient_target_id
- #:references (nutrient_targets id)
- #:on-delete #:cascade)
- (foreign-key crop_requirement_id
- #:references (crop_requirements id)
- #:on-delete #:cascade)
- (foreign-key fertilizer_product_id
- #:references (fertilizer_products id)
- #:on-delete #:cascade)
- (unique nutrient_measurement_id)
- (unique nutrient_target_id)
- (unique crop_requirement_id)
- (unique fertilizer_product_id)
- (check (or (and (is-not-null nutrient_measurement_id)
- (is-null nutrient_target_id)
- (is-null crop_requirement_id)
- (is-null fertilizer_product_id))
- (and (is-null nutrient_measurement_id)
- (is-not-null nutrient_target_id)
- (is-null crop_requirement_id)
- (is-null fertilizer_product_id))
- (and (is-null nutrient_measurement_id)
- (is-null nutrient_target_id)
- (is-not-null crop_requirement_id)
- (is-null fertilizer_product_id))
- (and (is-null nutrient_measurement_id)
- (is-null nutrient_target_id)
- (is-null crop_requirement_id)
- (is-not-null fertilizer_product_id)))))
- "CREATE INDEX IF NOT EXISTS idx_nvs_meas ON nutrient_value_sets(nutrient_measurement_id)"
- "CREATE INDEX IF NOT EXISTS idx_nvs_targ ON nutrient_value_sets(nutrient_target_id)"
- "CREATE INDEX IF NOT EXISTS idx_nvs_crop ON nutrient_value_sets(crop_requirement_id)"
- "CREATE INDEX IF NOT EXISTS idx_nvs_prod ON nutrient_value_sets(fertilizer_product_id)"))
-
-(define-migration "create table nutrient_values"
- (list
- (create-table #:if-not-exists
- nutrient_values
- #:columns
- [value_set_id integer #:not-null]
- [nutrient_id integer #:not-null]
- [value_ppm real #:not-null]
- #:constraints
- (primary-key value_set_id nutrient_id)
- (foreign-key value_set_id
- #:references (nutrient_value_sets id)
- #:on-delete #:cascade)
- (foreign-key nutrient_id
- #:references (nutrients id)
- #:on-delete #:cascade))
- "CREATE INDEX IF NOT EXISTS idx_nv_set_nutrient ON nutrient_values(value_set_id, nutrient_id)"))
+ (list (create-table #:if-not-exists nutrients
+ #:columns [id integer #:not-null]
+ [canonical_name text #:not-null]
+ [formula text #:not-null]
+ #:constraints (primary-key id)
+ (unique canonical_name)
+ (unique formula))))
+
+(define-migration
+ "create table nutrient_value_sets"
+ (list
+ (create-table
+ #:if-not-exists nutrient_value_sets
+ #:columns [id integer #:not-null]
+ [nutrient_measurement_id integer]
+ [nutrient_target_id integer]
+ [crop_requirement_id integer]
+ [fertilizer_product_id integer]
+ #:constraints (primary-key id)
+ (foreign-key nutrient_measurement_id #:references (nutrient_measurements id) #:on-delete #:cascade)
+ (foreign-key nutrient_target_id #:references (nutrient_targets id) #:on-delete #:cascade)
+ (foreign-key crop_requirement_id #:references (crop_requirements id) #:on-delete #:cascade)
+ (foreign-key fertilizer_product_id #:references (fertilizer_products id) #:on-delete #:cascade)
+ (unique nutrient_measurement_id)
+ (unique nutrient_target_id)
+ (unique crop_requirement_id)
+ (unique fertilizer_product_id)
+ (check (or (and (is-not-null nutrient_measurement_id)
+ (is-null nutrient_target_id)
+ (is-null crop_requirement_id)
+ (is-null fertilizer_product_id))
+ (and (is-null nutrient_measurement_id)
+ (is-not-null nutrient_target_id)
+ (is-null crop_requirement_id)
+ (is-null fertilizer_product_id))
+ (and (is-null nutrient_measurement_id)
+ (is-null nutrient_target_id)
+ (is-not-null crop_requirement_id)
+ (is-null fertilizer_product_id))
+ (and (is-null nutrient_measurement_id)
+ (is-null nutrient_target_id)
+ (is-null crop_requirement_id)
+ (is-not-null fertilizer_product_id)))))
+ "CREATE INDEX IF NOT EXISTS idx_nvs_meas ON nutrient_value_sets(nutrient_measurement_id)"
+ "CREATE INDEX IF NOT EXISTS idx_nvs_targ ON nutrient_value_sets(nutrient_target_id)"
+ "CREATE INDEX IF NOT EXISTS idx_nvs_crop ON nutrient_value_sets(crop_requirement_id)"
+ "CREATE INDEX IF NOT EXISTS idx_nvs_prod ON nutrient_value_sets(fertilizer_product_id)"))
+
+(define-migration
+ "create table nutrient_values"
+ (list
+ (create-table #:if-not-exists nutrient_values
+ #:columns [value_set_id integer #:not-null]
+ [nutrient_id integer #:not-null]
+ [value_ppm real #:not-null]
+ #:constraints (primary-key value_set_id nutrient_id)
+ (foreign-key value_set_id #:references (nutrient_value_sets id) #:on-delete #:cascade)
+ (foreign-key nutrient_id #:references (nutrients id) #:on-delete #:cascade))
+ "CREATE INDEX IF NOT EXISTS idx_nv_set_nutrient ON nutrient_values(value_set_id, nutrient_id)"))
(define-migration "create table nutrient_measurements"
- (list
- (create-table #:if-not-exists
- nutrient_measurements
- #:columns
- [id integer #:not-null]
- ;; ISO8601 date
- [measured_on text #:not-null]
- #:constraints
- (primary-key id)
- (unique measured_on))))
+ (list (create-table #:if-not-exists nutrient_measurements
+ #:columns [id integer #:not-null]
+ ;; ISO8601 date
+ [measured_on text #:not-null]
+ #:constraints (primary-key id)
+ (unique measured_on))))
(define-migration "create table nutrient_targets"
- (list
- (create-table #:if-not-exists
- nutrient_targets
- #:columns
- [id integer #:not-null]
- ;; ISO8601 date
- [effective_on text #:not-null]
- #:constraints
- (primary-key id)
- (unique effective_on))))
-
+ (list (create-table #:if-not-exists nutrient_targets
+ #:columns [id integer #:not-null]
+ ;; ISO8601 date
+ [effective_on text #:not-null]
+ #:constraints (primary-key id)
+ (unique effective_on))))
;;;;;;;;
;; CROPS
;;;;;;;;
(define-migration "create table crops"
- (list
- (create-table #:if-not-exists
- crops
- #:columns
- [id integer #:not-null]
- [canonical_name integer #:not-null]
- #:constraints
- (primary-key id)
- (unique canonical_name))))
-
-(define-migration "create table crop_requirements"
- (list
- (create-table #:if-not-exists
- crop_requirements
- #:columns
- [id integer #:not-null]
- [crop_id integer]
- [profile text #:not-null]
- #:constraints
- (primary-key id)
- (foreign-key crop_id
- #:references (crops id)
- #:on-delete #:cascade))))
-
+ (list (create-table #:if-not-exists crops
+ #:columns [id integer #:not-null]
+ [canonical_name integer #:not-null]
+ #:constraints (primary-key id)
+ (unique canonical_name))))
+
+(define-migration
+ "create table crop_requirements"
+ (list (create-table #:if-not-exists crop_requirements
+ #:columns [id integer #:not-null]
+ [crop_id integer]
+ [profile text #:not-null]
+ #:constraints (primary-key id)
+ (foreign-key crop_id #:references (crops id) #:on-delete #:cascade))))
;;;;;;;;;;;;;;
;; FERTILIZERS
;;;;;;;;;;;;;;
(define-migration "create table fertilizer_products"
- (list
- (create-table #:if-not-exists
- fertilizer_products
- #:columns
- [id integer #:not-null]
- [canonical_name text #:not-null]
- [brand_name text]
- #:constraints
- (primary-key id)
- (unique canonical_name))))
+ (list (create-table #:if-not-exists fertilizer_products
+ #:columns [id integer #:not-null]
+ [canonical_name text #:not-null]
+ [brand_name text]
+ #:constraints (primary-key id)
+ (unique canonical_name))))
(module+ test
(connect!)
diff --git a/db/seed.rkt b/db/seed.rkt
index 4a765f6..881b9ef 100644
--- a/db/seed.rkt
+++ b/db/seed.rkt
@@ -20,29 +20,27 @@
(define (seed-nutrients!)
(define nutrient-names (map nutrient-name (get-nutrients)))
(define default-nutrients
- '(("Nitrate Nitrogen" "NNO3")
- ("Phosphorus" "P")
- ("Potassium" "K")
- ("Calcium" "Ca")
- ("Magnesium" "Mg")
- ("Sulfur" "S")
- ("Sodium" "Na")
- ("Chloride" "Cl")
- ("Silicon" "Si")
- ("Iron" "Fe")
- ("Zinc" "Zn")
- ("Boron" "B")
- ("Manganese" "Mn")
- ("Copper" "Cu")
- ("Molybdenum" "Mo")
- ("Ammonium Nitrogen" "NNH4")))
- (with-tx
- (for ([pair (in-list default-nutrients)])
- (define name (first pair))
- (define formula (second pair))
- ;; Ensure idempotence
- (unless (member name nutrient-names)
- (create-nutrient! name formula)))))
+ '(("Nitrate Nitrogen" "NNO3") ("Phosphorus" "P")
+ ("Potassium" "K")
+ ("Calcium" "Ca")
+ ("Magnesium" "Mg")
+ ("Sulfur" "S")
+ ("Sodium" "Na")
+ ("Chloride" "Cl")
+ ("Silicon" "Si")
+ ("Iron" "Fe")
+ ("Zinc" "Zn")
+ ("Boron" "B")
+ ("Manganese" "Mn")
+ ("Copper" "Cu")
+ ("Molybdenum" "Mo")
+ ("Ammonium Nitrogen" "NNH4")))
+ (with-tx (for ([pair (in-list default-nutrients)])
+ (define name (first pair))
+ (define formula (second pair))
+ ;; Ensure idempotence
+ (unless (member name nutrient-names)
+ (create-nutrient! name formula)))))
(define-runtime-path measurement-csv "data/dolibarr_nutrient_measurements_ppm.csv")
(define (seed-historical-nutrient-measurements!)
@@ -58,20 +56,15 @@
(define v (string->number (cdr nm)))
(cons n v)))
(create-nutrient-measurement! measured-on nutrient-values))
- (with-tx
- (csv-for-each row->seed! next-row)))
+ (with-tx (csv-for-each row->seed! next-row)))
(define (seed-crops!)
(define crop-names (map crop-name (get-crops)))
- (define default-crops '("salade"
- "laitue"
- "tomate"
- "framboise"))
- (with-tx
- (for ([name (in-list default-crops)])
- ;; Ensure idempotence
- (unless (member name crop-names)
- (create-crop! name)))))
+ (define default-crops '("salade" "laitue" "tomate" "framboise"))
+ (with-tx (for ([name (in-list default-crops)])
+ ;; Ensure idempotence
+ (unless (member name crop-names)
+ (create-crop! name)))))
(define-runtime-path requirements-csv "data/dolibarr_crop_requirements_ppm.csv")
(define (seed-crop-requirements!)
@@ -91,10 +84,8 @@
[(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)]))
- (with-tx
- (csv-for-each row->seed! next-row)))
+ [else (create-crop-requirement! profile nutrient-values)]))
+ (with-tx (csv-for-each row->seed! next-row)))
(define-runtime-path fertilizer-csv "data/dolibarr_fertilizer_compositions_percentage.csv")
(define (seed-existing-fertilizer-products!)
@@ -113,10 +104,8 @@
(cond
[(non-empty-string? brand-name)
(create-fertilizer-product! canonical-name nutrient-values brand-name)]
- [else
- (create-fertilizer-product! canonical-name nutrient-values)]))
- (with-tx
- (csv-for-each row->seed! next-row)))
+ [else (create-fertilizer-product! canonical-name nutrient-values)]))
+ (with-tx (csv-for-each row->seed! next-row)))
(define seed-sequence
(list (cons "nutrients" seed-nutrients!)
diff --git a/formlets.rkt b/formlets.rkt
index d0067e3..20a84d8 100644
--- a/formlets.rkt
+++ b/formlets.rkt
@@ -10,87 +10,73 @@
"models/crop.rkt"
"models/crop-requirement.rkt")
-
(define date-formlet
- (formlet
- ,{=> (to-string
- (required
- (input #:type "date"
- #:value (date->iso8601 (today))
- #:attributes '([class "form-control"] [required "required"]))))
- date-b}
- date-b))
+ (formlet ,{=>
+ (to-string (required (input #:type "date"
+ #:value (date->iso8601 (today))
+ #:attributes
+ '((class "form-control") [required "required"]))))
+ date-b}
+ date-b))
(define (measurement-formlet nutrient)
(define id (nutrient-id nutrient))
(define number-input
(input #:type "number"
- #:attributes `([class "form-control"]
- [id ,(number->string id)]
- [step "0.1"]
- [placeholder ,(nutrient-name nutrient)])))
- (define input-label `(label ([for ,(number->string id)]) ,(nutrient-name nutrient)))
- (formlet
- (#%#
- (div ([class "form-floating mb-3"])
- ,{=> number-input nutrient-value-b}
- ,input-label))
- (let ([nutrient-value (string->number
- (bytes->string/utf-8
- (binding:form-value nutrient-value-b)))])
- (and nutrient-value (cons id nutrient-value)))))
+ #:attributes `((class "form-control") [id ,(number->string id)]
+ [step "0.1"]
+ [placeholder ,(nutrient-name nutrient)])))
+ (define input-label
+ `(label ((for ,(number->string id)
+ ))
+ ,(nutrient-name nutrient)))
+ (formlet (#%# (div ((class "form-floating mb-3")) ,{=> number-input nutrient-value-b} ,input-label))
+ (let ([nutrient-value (string->number (bytes->string/utf-8
+ (binding:form-value nutrient-value-b)))])
+ (and nutrient-value (cons id nutrient-value)))))
(define (measurements-formlet)
- (formlet*
- (#%#
- `(div ([class "mb-3"])
- (h5 "Date du relevé")
- ,{=>* date-formlet measured-on*})
- `(div ([class "mb-3"])
- (h5 "Valeurs du relevé")
- ,@(for/list ([nutrient (get-nutrients)])
- {=>* (measurement-formlet nutrient) measurements*}))
- {=>* (submit "Enregistrer le relevé" #:attributes '([class "btn btn-primary"])) _})
- (let ([measured-on (first measured-on*)]
- [measurements (filter pair? measurements*)]) ; drop #f’s from empty values
- (values measured-on measurements))))
+ (formlet* (#%# `(div ((class "mb-3")) (h5 "Date du relevé") ,{=>* date-formlet measured-on*})
+ `(div ((class "mb-3"))
+ (h5 "Valeurs du relevé")
+ ,@(for/list ([nutrient (get-nutrients)])
+ {=>* (measurement-formlet nutrient) measurements*}))
+ {=>* (submit "Enregistrer le relevé" #:attributes '((class "btn btn-primary"))) _})
+ (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 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))))
+ #: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)))])
+ (#%# (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))))
+ (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 a4de123..7fcd004 100644
--- a/handlers.rkt
+++ b/handlers.rkt
@@ -14,44 +14,39 @@
"services/nnls.rkt")
(define-values (app-dispatch _)
- (dispatch-rules
- ;; Ferti dashboard
- [("ferti") #:method "get" ferti]
- ;; 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]))
+ ;; Ferti dashboard
+ (dispatch-rules [("ferti") #:method "get" ferti]
+ ;; 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 (ferti _)
- (define measurements (get-nutrient-measurements))
(define ferti-recipe (find-ferti-recipe))
+ (define latest-measurement-hash (get-latest-nutrient-measurement-hash))
+ (define latest-target-hash (get-latest-nutrient-target-hash))
+ (define latest-measurements (take* (get-nutrient-measurements) 10))
(response/xexpr
#:preamble #"<!DOCTYPE html>"
- (ferti-page measurements ferti-recipe)))
+ (ferti-page ferti-recipe latest-measurement-hash latest-target-hash latest-measurements)))
(define (index _)
(define user (get-current-user))
- (response/xexpr
- #:preamble #"<!DOCTYPE html>"
- (index-page user)))
-
+ (response/xexpr #:preamble #"<!DOCTYPE html>" (index-page user)))
;; Nutrient measurements
(define (new-measurement _)
- (response/xexpr
- #:preamble #"<!DOCTYPE html>"
- (new-measurement-page)))
+ (response/xexpr #:preamble #"<!DOCTYPE html>" (new-measurement-page)))
(define (create-measurement req)
- (define-values (measured-on measurements)
- (formlet-process (measurements-formlet) req))
+ (define-values (measured-on measurements) (formlet-process (measurements-formlet) req))
(create-nutrient-measurement! measured-on measurements)
(redirect-to "/"))
@@ -59,23 +54,16 @@
(delete-nutrient-measurement! req)
(redirect-to "/"))
-
;; Nutrient targets
(define (new-target _)
- (response/xexpr
- #:preamble #"<!DOCTYPE html>"
- (new-target-page)))
+ (response/xexpr #:preamble #"<!DOCTYPE html>" (new-target-page)))
(define (create-target req)
- (define-values (effective-on crop-requirement-mix)
- (formlet-process (targets-formlet) req))
- (define target-nutrient-values
- (average-crop-requirement-nutrient-values crop-requirement-mix))
+ (define-values (effective-on crop-requirement-mix) (formlet-process (targets-formlet) req))
+ (define target-nutrient-values (average-crop-requirement-nutrient-values crop-requirement-mix))
(create-nutrient-target! effective-on target-nutrient-values)
(redirect-to "/"))
(define (fallback _)
- (response/xexpr
- #:preamble #"<!DOCTYPE html>"
- (fallback-page 404)))
+ (response/xexpr #:preamble #"<!DOCTYPE html>" (fallback-page 404)))
diff --git a/main.rkt b/main.rkt
index 7b6c25e..647f43d 100644
--- a/main.rkt
+++ b/main.rkt
@@ -10,5 +10,4 @@
(connect! #:path "storage/development.sqlite3")
(migrate-all!)
(seed-database!)
- (serve/dispatch
- app-dispatch))
+ (serve/dispatch app-dispatch))
diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt
index e5f8ae6..8d99434 100644
--- a/models/crop-requirement.rkt
+++ b/models/crop-requirement.rkt
@@ -1,29 +1,29 @@
#lang racket
-(provide
- ;; Model struct
- crop-requirement
- crop-requirement?
- crop-requirement-id crop-requirement-profile crop-requirement-crop-id
- (contract-out
- ;; SQL CRUD
- [create-crop-requirement! (->* (string?
- (listof nutrient-value-pair/c))
- ((or/c #f crop?))
- crop-requirement?)]
- [get-crop-requirements (-> (listof crop-requirement?))]
- [get-crop-requirement (->* ()
- (#:id (or/c #f exact-nonnegative-integer?)
- #:profile (or/c #f string?))
- (or/c crop-requirement? #f))]
- [get-crop-requirement-values (-> crop-requirement? (listof nutrient-value-pair/c))]
- [get-crop-requirement-value (-> crop-requirement? nutrient? number?)]
- [get-latest-crop-requirement-value (-> nutrient? number?)]
- [delete-crop-requirement! (-> crop-requirement? void?)]
- ;; Helpers
- [average-crop-requirement-nutrient-values (-> (listof (cons/c crop-requirement?
- (and/c real? (>=/c 0) (<=/c 100))))
- (listof nutrient-value-pair/c))]))
+;; Model struct
+(provide crop-requirement
+ crop-requirement?
+ crop-requirement-id
+ crop-requirement-profile
+ crop-requirement-crop-id
+ (rename-out [crop-requirement-nutrient-values crop-requirement-values])
+ (contract-out
+ ;; SQL CRUD
+ [create-crop-requirement!
+ (->* (string? (listof nutrient-value-pair/c)) ((or/c #f crop?)) crop-requirement?)]
+ [get-crop-requirements (-> (listof crop-requirement?))]
+ [get-crop-requirement
+ (->* ()
+ (#:id (or/c #f exact-nonnegative-integer?) #:profile (or/c #f string?))
+ (or/c crop-requirement? #f))]
+ [get-crop-requirement-values (-> crop-requirement? (listof nutrient-value-pair/c))]
+ [get-crop-requirement-value (-> crop-requirement? nutrient? number?)]
+ [get-latest-crop-requirement-value (-> nutrient? number?)]
+ [delete-crop-requirement! (-> crop-requirement? void?)]
+ ;; Helpers
+ [average-crop-requirement-nutrient-values
+ (-> (listof (cons/c crop-requirement? (and/c real? (>=/c 0) (<=/c 100))))
+ (listof nutrient-value-pair/c))]))
(require racket/contract
db
@@ -41,30 +41,25 @@
(define (create-crop-requirement! profile nutrient-values [crop #f])
(or (get-crop-requirement #:profile profile)
(with-tx
- (query-exec (current-conn)
- (if crop
- (insert #:into crop_requirements
- #:set [crop_id ,(crop-id crop)] [profile ,profile])
- (insert #:into crop_requirements
- #:set [profile ,profile])))
- (define cr-id (crop-requirement-id (get-crop-requirement #:profile profile)))
- (query-exec (current-conn)
- (insert #:into nutrient_value_sets
- #:set [crop_requirement_id ,cr-id]))
- (define nvs-id (query-value (current-conn)
- (select id
- #:from nutrient_value_sets
- #:where (= crop_requirement_id ,cr-id))))
- (for ([nv nutrient-values])
- (match-define (cons n v) nv)
- (query-exec (current-conn)
- (insert #:into nutrient_values
- #:set
- [value_set_id ,nvs-id]
- [nutrient_id ,(nutrient-id n)]
- [value_ppm ,v])))
- (get-crop-requirement #:profile profile))))
-
+ (query-exec
+ (current-conn)
+ (if crop
+ (insert #:into crop_requirements #:set [crop_id ,(crop-id crop)] [profile ,profile])
+ (insert #:into crop_requirements #:set [profile ,profile])))
+ (define cr-id (crop-requirement-id (get-crop-requirement #:profile profile)))
+ (query-exec (current-conn)
+ (insert #:into nutrient_value_sets #:set [crop_requirement_id ,cr-id]))
+ (define nvs-id
+ (query-value (current-conn)
+ (select id #:from nutrient_value_sets #:where (= crop_requirement_id ,cr-id))))
+ (for ([nv nutrient-values])
+ (match-define (cons n v) nv)
+ (query-exec (current-conn)
+ (insert #:into nutrient_values
+ #:set [value_set_id ,nvs-id]
+ [nutrient_id ,(nutrient-id n)]
+ [value_ppm ,v])))
+ (get-crop-requirement #:profile profile))))
;; READ
@@ -103,13 +98,12 @@
(define (get-crop-requirement-values crop-requirement)
(for/list ([(nutrient-id name formula value_ppm)
(in-query (current-conn)
- (string-join
- '("SELECT n.id, n.canonical_name, n.formula, nv.value_ppm"
- "FROM nutrient_values nv"
- "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id"
- "JOIN crop_requirements cr ON cr.id = nvs.crop_requirement_id"
- "JOIN nutrients n ON n.id = nv.nutrient_id"
- "WHERE cr.id = $1"))
+ (string-join '("SELECT n.id, n.canonical_name, n.formula, nv.value_ppm"
+ "FROM nutrient_values nv"
+ "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id"
+ "JOIN crop_requirements cr ON cr.id = nvs.crop_requirement_id"
+ "JOIN nutrients n ON n.id = nv.nutrient_id"
+ "WHERE cr.id = $1"))
(crop-requirement-id crop-requirement))])
(cons (nutrient nutrient-id name formula) value_ppm)))
@@ -139,28 +133,21 @@
;; UPDATE
-
;; DELETE
(define (delete-crop-requirement! crop-requirement)
(define id (crop-requirement-id crop-requirement))
- (query-exec (current-conn)
- (delete #:from crop_requirements
- #:where (= id ,id))))
-
+ (query-exec (current-conn) (delete #:from crop_requirements #:where (= id ,id))))
;; Helpers
(define (average-crop-requirement-nutrient-values mix)
(define average-values
(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))])
+ (match-define (cons crop-requirement percentage) pair)
+ (for/fold ([acc acc]) ([nv (in-list (get-crop-requirement-values crop-requirement))])
(match-define (cons n v) nv)
- (hash-update acc n
- (λ (old) (+ old (* v percentage)))
- (λ () (* v percentage))))))
+ (define nutrient-contribution (* v (/ percentage 100)))
+ (hash-update acc n (λ (old) (+ old nutrient-contribution)) (λ () nutrient-contribution)))))
(for/list ([(n v) (in-hash average-values)])
(cons n v)))
diff --git a/models/crop.rkt b/models/crop.rkt
index 51b332d..edbb7a3 100644
--- a/models/crop.rkt
+++ b/models/crop.rkt
@@ -1,22 +1,20 @@
#lang racket
-(provide
- ;; Model struct
- crop
- crop?
- crop-id crop-name
- (contract-out
- ;; SQL CRUD
- [create-crop! (-> string? crop?)]
- [get-crops (-> (listof crop?))]
- [get-crop (->* ()
- (#:id (or/c #f exact-nonnegative-integer?)
- #:name (or/c #f string?))
- (or/c crop? #f))]
- [update-crop! (->* (exact-nonnegative-integer?)
- (#:name (or/c #f string?))
- (or/c crop? #f))]
- [delete-crop! (-> exact-nonnegative-integer? void?)]))
+;; Model struct
+(provide crop
+ crop?
+ crop-id
+ crop-name
+ ;; SQL CRUD
+ (contract-out [create-crop! (-> string? crop?)]
+ [get-crops (-> (listof crop?))]
+ [get-crop
+ (->* ()
+ (#:id (or/c #f exact-nonnegative-integer?) #:name (or/c #f string?))
+ (or/c crop? #f))]
+ [update-crop!
+ (->* (exact-nonnegative-integer?) (#:name (or/c #f string?)) (or/c crop? #f))]
+ [delete-crop! (-> exact-nonnegative-integer? void?)]))
(require racket/contract
db
@@ -25,67 +23,48 @@
(struct crop (id name) #:transparent)
-
;; CREATE
(define (create-crop! name)
(or (get-crop #:name name)
(begin
- (query-exec (current-conn)
- (insert #:into crops
- #:set [canonical_name ,name]))
+ (query-exec (current-conn) (insert #:into crops #:set [canonical_name ,name]))
(get-crop #:name name))))
-
;; READ
(define (get-crops)
- (for/list ([(id* name*)
- (in-query (current-conn)
- (select id canonical_name
- #:from crops
- #:order-by id #:asc))])
+ (for/list ([(id* name*) (in-query (current-conn)
+ (select id canonical_name #:from crops #:order-by id #:asc))])
(crop id* name*)))
-(define (get-crop #:id [id #f]
- #:name [name #f])
+(define (get-crop #:id [id #f] #:name [name #f])
(define where
(cond
- [(and id name)
- (scalar-expr-qq (and (= id ,id)
- (= canonical_name ,name)))]
- [id
- (scalar-expr-qq (= id ,id))]
- [name
- (scalar-expr-qq (= canonical_name ,name))]))
- (define query (select id canonical_name
- #:from crops
- #:where (ScalarExpr:AST ,where)
- #:order-by id #:asc
- #:limit 1))
+ [(and id name) (scalar-expr-qq (and (= id ,id) (= canonical_name ,name)))]
+ [id (scalar-expr-qq (= id ,id))]
+ [name (scalar-expr-qq (= canonical_name ,name))]))
+ (define query
+ (select id
+ canonical_name
+ #:from crops
+ #:where (ScalarExpr:AST ,where)
+ #:order-by id
+ #:asc
+ #:limit 1))
(match (query-maybe-row (current-conn) query)
- [(vector id* name*)
- (crop id* name*)]
+ [(vector id* name*) (crop id* name*)]
[#f #f]))
-
;; UPDATE
-(define (update-crop! id
- #:name [name #f])
+(define (update-crop! id #:name [name #f])
(cond
- [name
- (query-exec (current-conn)
- (update crops
- #:set [canonical_name ,name]
- #:where (= id ,id)))]
+ [name (query-exec (current-conn) (update crops #:set [canonical_name ,name] #:where (= id ,id)))]
[else (void)])
- (or (get-crop #:id id)
- (error 'update-crop! "No crop with id ~a" id)))
-
+ (or (get-crop #:id id) (error 'update-crop! "No crop with id ~a" id)))
;; DELETE
(define (delete-crop! id)
- (query-exec (current-conn)
- (delete #:from crops #:where (= id ,id))))
+ (query-exec (current-conn) (delete #:from crops #:where (= id ,id))))
diff --git a/models/fertilizer-product.rkt b/models/fertilizer-product.rkt
index 0809f73..225af10 100644
--- a/models/fertilizer-product.rkt
+++ b/models/fertilizer-product.rkt
@@ -1,29 +1,24 @@
#lang racket
-(provide
- ;; Model struct
- fertilizer-product
- fertilizer-product?
- fertilizer-product-id
- (rename-out
- [fertilizer-product-canonical-name fertilizer-name]
- [fertilizer-product-nutrient-values fertilizer-product-values]
- [fertilizer-product-brand-name fertilizer-brand-name])
- (contract-out
- ;; SQL CRUD
- [create-fertilizer-product! (->* (string?
- (listof nutrient-value-pair/c))
- (string?)
- fertilizer-product?)]
- [get-fertilizer-products (-> (listof fertilizer-product?))]
- [get-fertilizer-product (->* ()
- (#:id (or/c #f exact-nonnegative-integer?)
- #:canonical-name (or/c #f string?))
- (or/c fertilizer-product? #f))]
- [get-fertilizer-product-values (-> fertilizer-product?
- (listof nutrient-value-pair/c))]
- [get-fertilizer-product-value (-> fertilizer-product? nutrient? number?)]
- [delete-fertilizer-product! (-> fertilizer-product? void?)]))
+;; Model struct
+(provide fertilizer-product
+ fertilizer-product?
+ fertilizer-product-id
+ (rename-out [fertilizer-product-canonical-name fertilizer-name]
+ [fertilizer-product-nutrient-values fertilizer-product-values]
+ [fertilizer-product-brand-name fertilizer-brand-name])
+ (contract-out
+ ;; SQL CRUD
+ [create-fertilizer-product!
+ (->* (string? (listof nutrient-value-pair/c)) (string?) fertilizer-product?)]
+ [get-fertilizer-products (-> (listof fertilizer-product?))]
+ [get-fertilizer-product
+ (->* ()
+ (#:id (or/c #f exact-nonnegative-integer?) #:canonical-name (or/c #f string?))
+ (or/c fertilizer-product? #f))]
+ [get-fertilizer-product-values (-> fertilizer-product? (listof nutrient-value-pair/c))]
+ [get-fertilizer-product-value (-> fertilizer-product? nutrient? number?)]
+ [delete-fertilizer-product! (-> fertilizer-product? void?)]))
(require racket/contract
db
@@ -34,123 +29,112 @@
;; Instances of this struct are persisted in the fertilizer_products table.
(struct fertilizer-product (id canonical-name nutrient-values brand-name)
#:transparent
- #:guard
- (λ (id canonical-name nutrient-values brand-name _)
- (values id
- canonical-name
- nutrient-values
- (if (sql-null? brand-name) #f brand-name)))
+ #:guard (λ (id canonical-name nutrient-values brand-name _)
+ (values id canonical-name nutrient-values (if (sql-null? brand-name) #f brand-name)))
#:property prop:custom-write
(λ (v out _mode)
(fprintf out "Fertilizer #~a\n" (fertilizer-product-id v))
(if (fertilizer-product-brand-name v)
- (fprintf out "~a (~a)\n"
+ (fprintf out
+ "~a (~a)\n"
(fertilizer-product-canonical-name v)
(fertilizer-product-brand-name v))
- (fprintf out "~a\n"
- (fertilizer-product-canonical-name v)))
+ (fprintf out "~a\n" (fertilizer-product-canonical-name v)))
(for ([nv (in-list (fertilizer-product-nutrient-values v))])
(match-define (cons n v) nv)
- (fprintf out "~a ~a\n"
+ (fprintf out
+ "~a ~a\n"
(~a (nutrient-name n) #:min-width 14)
(~a v #:max-width 6 #:align 'right)))))
-
;; CREATE
(define (create-fertilizer-product! canonical-name nutrient-values [brand-name #f])
- (or (get-fertilizer-product #:canonical-name canonical-name)
- (with-tx
- (query-exec (current-conn)
- (cond
- [brand-name
- (insert #:into fertilizer_products
- #:set [canonical_name ,canonical-name] [brand_name ,brand-name])]
- [else
- (insert #:into fertilizer_products
- #:set [canonical_name ,canonical-name])]))
- (define fp-id (query-value (current-conn)
- (select id
- #:from fertilizer_products
- #:where (= canonical_name ,canonical-name))))
- (query-exec (current-conn)
- (insert #:into nutrient_value_sets
- #:set [fertilizer_product_id ,fp-id]))
- (define nvs-id (query-value (current-conn)
- (select id
- #:from nutrient_value_sets
- #:where (= fertilizer_product_id ,fp-id))))
- (for ([nv nutrient-values])
- (match-define (cons n v) nv)
- (query-exec (current-conn)
- (insert #:into nutrient_values
- #:set
- [value_set_id ,nvs-id]
- [nutrient_id ,(nutrient-id n)]
- [value_ppm ,v])))
- (get-fertilizer-product #:canonical-name canonical-name))))
-
+ (or
+ (get-fertilizer-product #:canonical-name canonical-name)
+ (with-tx
+ (query-exec (current-conn)
+ (cond
+ [brand-name
+ (insert #:into fertilizer_products
+ #:set [canonical_name ,canonical-name]
+ [brand_name ,brand-name])]
+ [else (insert #:into fertilizer_products #:set [canonical_name ,canonical-name])]))
+ (define fp-id
+ (query-value (current-conn)
+ (select id #:from fertilizer_products #:where (= canonical_name ,canonical-name))))
+ (query-exec (current-conn)
+ (insert #:into nutrient_value_sets #:set [fertilizer_product_id ,fp-id]))
+ (define nvs-id
+ (query-value (current-conn)
+ (select id #:from nutrient_value_sets #:where (= fertilizer_product_id ,fp-id))))
+ (for ([nv nutrient-values])
+ (match-define (cons n v) nv)
+ (query-exec (current-conn)
+ (insert #:into nutrient_values
+ #:set [value_set_id ,nvs-id]
+ [nutrient_id ,(nutrient-id n)]
+ [value_ppm ,v])))
+ (get-fertilizer-product #:canonical-name canonical-name))))
;; READ
(struct acc (canonical-name brand-name pairs) #:transparent)
(define joined
- (table-expr-qq
- (inner-join
- (inner-join
- (inner-join
- (as fertilizer_products fp)
- (as nutrient_value_sets nvs)
- #:on (= nvs.fertilizer_product_id fp.id))
- (as nutrient_values nv)
- #:on (= nv.value_set_id nvs.id))
- (as nutrients n)
- #:on (= n.id nv.nutrient_id))))
+ (table-expr-qq (inner-join (inner-join (inner-join (as fertilizer_products fp)
+ (as nutrient_value_sets nvs)
+ #:on (= nvs.fertilizer_product_id fp.id))
+ (as nutrient_values nv)
+ #:on (= nv.value_set_id nvs.id))
+ (as nutrients n)
+ #:on (= n.id nv.nutrient_id))))
(define (get-fertilizer-products)
- (define query (select fp.id fp.canonical_name fp.brand_name
- n.id n.canonical_name n.formula
- nv.value_ppm
- #:from (TableExpr:AST ,joined)
- #:order-by fp.canonical_name #:asc))
+ (define query
+ (select fp.id
+ fp.canonical_name
+ fp.brand_name
+ n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
+ #:from (TableExpr:AST ,joined)
+ #:order-by fp.canonical_name
+ #:asc))
(define rows (query-rows (current-conn) query))
(define by-id
(for/fold ([h (hash)]) ([row (in-list rows)])
(match-define (vector fp-id canonical-name brand-name n-id n-name n-formula value-ppm) row)
(define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm))
- (hash-update h fp-id
+ (hash-update h
+ fp-id
(λ (old-acc)
(acc (acc-canonical-name old-acc)
(acc-brand-name old-acc)
(cons nv-pair (acc-pairs old-acc))))
- (λ ()
- (acc canonical-name
- brand-name
- (list nv-pair))))))
+ (λ () (acc canonical-name brand-name (list nv-pair))))))
(for/list ([(id a) (in-hash by-id)])
- (fertilizer-product id
- (acc-canonical-name a)
- (reverse (acc-pairs a))
- (acc-brand-name a))))
+ (fertilizer-product id (acc-canonical-name a) (reverse (acc-pairs a)) (acc-brand-name a))))
-(define (get-fertilizer-product #:id [fp-id #f]
- #:canonical-name [canonical-name #f])
+(define (get-fertilizer-product #:id [fp-id #f] #:canonical-name [canonical-name #f])
(define where
(cond
[(and fp-id canonical-name)
- (scalar-expr-qq (and (= fp.id ,fp-id)
- (= fp.canonical_name ,canonical-name)))]
- [fp-id
- (scalar-expr-qq (= fp.id ,fp-id))]
- [canonical-name
- (scalar-expr-qq (= fp.canonical_name ,canonical-name))]))
- (define query (select fp.id fp.canonical_name fp.brand_name
- n.id n.canonical_name n.formula
- nv.value_ppm
- #:from (TableExpr:AST ,joined)
- #:where (ScalarExpr:AST ,where)
- #:limit 1))
+ (scalar-expr-qq (and (= fp.id ,fp-id) (= fp.canonical_name ,canonical-name)))]
+ [fp-id (scalar-expr-qq (= fp.id ,fp-id))]
+ [canonical-name (scalar-expr-qq (= fp.canonical_name ,canonical-name))]))
+ (define query
+ (select fp.id
+ fp.canonical_name
+ fp.brand_name
+ n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
+ #:from (TableExpr:AST ,joined)
+ #:where (ScalarExpr:AST ,where)
+ #:limit 1))
(define rows (query-rows (current-conn) query))
(cond
[(null? rows) #f]
@@ -160,24 +144,22 @@
(define A #f)
(for ([row (in-list rows)])
(match-define (vector fp-id canonical-name brand-name n-id n-name n-formula value-ppm) row)
- (unless the-id (set! the-id fp-id))
+ (unless the-id
+ (set! the-id fp-id))
(define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm))
- (set! A (if A
- (acc (acc-canonical-name A)
- (acc-brand-name A)
- (cons nv-pair (acc-pairs A)))
- (acc canonical-name
- brand-name
- (list nv-pair)))))
- (fertilizer-product the-id
- (acc-canonical-name A)
- (reverse (acc-pairs A))
- (acc-brand-name A))]))
+ (set! A
+ (if A
+ (acc (acc-canonical-name A) (acc-brand-name A) (cons nv-pair (acc-pairs A)))
+ (acc canonical-name brand-name (list nv-pair)))))
+ (fertilizer-product the-id (acc-canonical-name A) (reverse (acc-pairs A)) (acc-brand-name A))]))
(define (get-fertilizer-product-values fertilizer-product)
(for/list ([(nutrient-id name formula value_ppm)
(in-query (current-conn)
- (select n.id n.canonical_name n.formula nv.value_ppm
+ (select n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
#:from (TableExpr:AST ,joined)
#:where (= nm.id ,(fertilizer-product-id fertilizer-product))))])
(cons (nutrient nutrient-id name formula) value_ppm)))
@@ -189,14 +171,10 @@
#:where (and (= nm.id ,(fertilizer-product-id fertilizer-product))
(= nv.nutrient_id ,(nutrient-id nutrient))))))
-
;; UPDATE
-
;; DELETE
(define (delete-fertilizer-product! fertilizer-product)
(define id (fertilizer-product-id fertilizer-product))
- (query-exec (current-conn)
- (delete #:from fertilizer_products
- #:where (= id ,id))))
+ (query-exec (current-conn) (delete #:from fertilizer_products #:where (= id ,id))))
diff --git a/models/nutrient-measurement.rkt b/models/nutrient-measurement.rkt
index ee336fe..5b999d8 100644
--- a/models/nutrient-measurement.rkt
+++ b/models/nutrient-measurement.rkt
@@ -35,62 +35,53 @@
#:transparent
#:property prop:custom-write
(λ (v out _)
- (fprintf out "Measurement #~a on ~a\n"
+ (fprintf out
+ "Measurement #~a on ~a\n"
(nutrient-measurement-id v)
(nutrient-measurement-measured-on v))
(for ([nv (nutrient-measurement-nutrient-values v)])
(match-define (cons n v) nv)
- (fprintf out "~a ~a\n"
+ (fprintf out
+ "~a ~a\n"
(~a (nutrient-name n) #:min-width 14)
(~a v #:max-width 6 #:align 'right)))))
-
;; CREATE
(define (create-nutrient-measurement! measured-on nutrient-values)
- (or (get-nutrient-measurement #:measured-on measured-on)
- (with-tx
- (query-exec (current-conn)
- (insert #:into nutrient_measurements
- #:set [measured_on ,measured-on]))
- (define nm-id (query-value (current-conn)
- (select id
- #:from nutrient_measurements
- #:where (= measured_on ,measured-on))))
- (query-exec (current-conn)
- (insert #:into nutrient_value_sets
- #:set [nutrient_measurement_id ,nm-id]))
- (define nvs-id (query-value (current-conn)
- (select id
- #:from nutrient_value_sets
- #:where (= nutrient_measurement_id ,nm-id))))
- (for ([nv nutrient-values])
- (match-define (cons n v) nv)
- (query-exec (current-conn)
- (insert #:into nutrient_values
- #:set
- [value_set_id ,nvs-id]
- [nutrient_id ,(nutrient-id n)]
- [value_ppm ,v])))
- (get-nutrient-measurement #:measured-on measured-on))))
-
+ (or
+ (get-nutrient-measurement #:measured-on measured-on)
+ (with-tx
+ (query-exec (current-conn) (insert #:into nutrient_measurements #:set [measured_on ,measured-on]))
+ (define nm-id
+ (query-value (current-conn)
+ (select id #:from nutrient_measurements #:where (= measured_on ,measured-on))))
+ (query-exec (current-conn)
+ (insert #:into nutrient_value_sets #:set [nutrient_measurement_id ,nm-id]))
+ (define nvs-id
+ (query-value (current-conn)
+ (select id #:from nutrient_value_sets #:where (= nutrient_measurement_id ,nm-id))))
+ (for ([nv nutrient-values])
+ (match-define (cons n v) nv)
+ (query-exec (current-conn)
+ (insert #:into nutrient_values
+ #:set [value_set_id ,nvs-id]
+ [nutrient_id ,(nutrient-id n)]
+ [value_ppm ,v])))
+ (get-nutrient-measurement #:measured-on measured-on))))
;; READ
(struct acc (measured-on pairs) #:transparent)
-
(define joined
- (table-expr-qq
- (inner-join
- (inner-join
- (inner-join
- (as nutrient_measurements nm)
- (as nutrient_value_sets nvs)
- #:on (= nvs.nutrient_measurement_id nm.id))
- (as nutrient_values nv)
- #:on (= nv.value_set_id nvs.id))
- (as nutrients n)
- #:on (= n.id nv.nutrient_id))))
+ (table-expr-qq (inner-join (inner-join (inner-join (as nutrient_measurements nm)
+ (as nutrient_value_sets nvs)
+ #:on (= nvs.nutrient_measurement_id nm.id))
+ (as nutrient_values nv)
+ #:on (= nv.value_set_id nvs.id))
+ (as nutrients n)
+ #:on (= n.id nv.nutrient_id))))
+
(define (get-nutrient-measurements)
(define query (select nm.id nm.measured_on
@@ -155,7 +146,10 @@
(define (get-nutrient-measurement-values nutrient-measurement)
(for/list ([(nutrient-id name formula value_ppm)
(in-query (current-conn)
- (select n.id n.canonical_name n.formula nv.value_ppm
+ (select n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
#:from (TableExpr:AST ,joined)
#:where (= nm.id ,(nutrient-measurement-id nutrient-measurement))))])
(cons (nutrient nutrient-id name formula) value_ppm)))
@@ -172,17 +166,15 @@
(select value_ppm
#:from (TableExpr:AST ,joined)
#:where (= nv.nutrient_id ,(nutrient-id nutrient))
- #:order-by nm.measured_on #:desc
+ #:order-by nm.measured_on
+ #:desc
#:limit 1)))
;; UPDATE
-
;; DELETE
(define (delete-nutrient-measurement! nutrient-measurement)
(define id (nutrient-measurement-id nutrient-measurement))
- (query-exec (current-conn)
- (delete #:from nutrient_measurements
- #:where (= id ,id))))
+ (query-exec (current-conn) (delete #:from nutrient_measurements #:where (= id ,id))))
diff --git a/models/nutrient-target.rkt b/models/nutrient-target.rkt
index c2f9c2e..922dba7 100644
--- a/models/nutrient-target.rkt
+++ b/models/nutrient-target.rkt
@@ -34,102 +34,89 @@
#:transparent
#:property prop:custom-write
(λ (v out _)
- (fprintf out "Target #~a on ~a\n"
- (nutrient-target-id v)
- (nutrient-target-effective-on v))
+ (fprintf out "Target #~a on ~a\n" (nutrient-target-id v) (nutrient-target-effective-on v))
(for ([nv (nutrient-target-nutrient-values v)])
(match-define (cons n v) nv)
- (fprintf out "~a ~a\n"
+ (fprintf out
+ "~a ~a\n"
(~a (nutrient-name n) #:min-width 14)
(~a v #:max-width 6 #:align 'right)))))
-
;; CREATE
(define (create-nutrient-target! effective-on nutrient-values)
(or (get-nutrient-target #:effective-on effective-on)
(with-tx
- (query-exec (current-conn)
- (insert #:into nutrient_targets
- #:set [effective_on ,effective-on]))
- (define nt-id (query-value (current-conn)
- (select id
- #:from nutrient_targets
- #:where (= effective_on ,effective-on))))
- (query-exec (current-conn)
- (insert #:into nutrient_value_sets
- #:set [nutrient_target_id ,nt-id]))
- (define nvs-id (query-value (current-conn)
- (select id
- #:from nutrient_value_sets
- #:where (= nutrient_target_id ,nt-id))))
- (for ([nv nutrient-values])
- (match-define (cons n v) nv)
- (query-exec (current-conn)
- (insert #:into nutrient_values
- #:set
- [value_set_id ,nvs-id]
- [nutrient_id ,(nutrient-id n)]
- [value_ppm ,v])))
- (get-nutrient-target #:effective-on effective-on))))
-
+ (query-exec (current-conn) (insert #:into nutrient_targets #:set [effective_on ,effective-on]))
+ (define nt-id
+ (query-value (current-conn)
+ (select id #:from nutrient_targets #:where (= effective_on ,effective-on))))
+ (query-exec (current-conn)
+ (insert #:into nutrient_value_sets #:set [nutrient_target_id ,nt-id]))
+ (define nvs-id
+ (query-value (current-conn)
+ (select id #:from nutrient_value_sets #:where (= nutrient_target_id ,nt-id))))
+ (for ([nv nutrient-values])
+ (match-define (cons n v) nv)
+ (query-exec (current-conn)
+ (insert #:into nutrient_values
+ #:set [value_set_id ,nvs-id]
+ [nutrient_id ,(nutrient-id n)]
+ [value_ppm ,v])))
+ (get-nutrient-target #:effective-on effective-on))))
;; READ
(struct acc (effective-on pairs) #:transparent)
(define joined
- (table-expr-qq
- (inner-join
- (inner-join
- (inner-join
- (as nutrient_targets nt)
- (as nutrient_value_sets nvs)
- #:on (= nvs.nutrient_target_id nt.id))
- (as nutrient_values nv)
- #:on (= nv.value_set_id nvs.id))
- (as nutrients n)
- #:on (= n.id nv.nutrient_id))))
+ (table-expr-qq (inner-join (inner-join (inner-join (as nutrient_targets nt)
+ (as nutrient_value_sets nvs)
+ #:on (= nvs.nutrient_target_id nt.id))
+ (as nutrient_values nv)
+ #:on (= nv.value_set_id nvs.id))
+ (as nutrients n)
+ #:on (= n.id nv.nutrient_id))))
(define (get-nutrient-targets)
- (define query (select nt.id nt.effective_on
- n.id n.canonical_name n.formula
- nv.value_ppm
- #:from (TableExpr:AST ,joined)
- #:order-by nt.effective_on #:desc))
+ (define query
+ (select nt.id
+ nt.effective_on
+ n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
+ #:from (TableExpr:AST ,joined)
+ #:order-by nt.effective_on
+ #:desc))
(define rows (query-rows (current-conn) query))
(define by-id
(for/fold ([h (hash)]) ([row (in-list rows)])
(match-define (vector nt-id effective-on n-id n-name n-formula value-ppm) row)
(define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm))
- (hash-update h nt-id
- (λ (old-acc)
- (acc (acc-effective-on old-acc)
- (cons nv-pair (acc-pairs old-acc))))
- (λ ()
- (acc effective-on
- (list nv-pair))))))
+ (hash-update h
+ nt-id
+ (λ (old-acc) (acc (acc-effective-on old-acc) (cons nv-pair (acc-pairs old-acc))))
+ (λ () (acc effective-on (list nv-pair))))))
(for/list ([(id a) (in-hash by-id)])
- (nutrient-target id
- (acc-effective-on a)
- (reverse (acc-pairs a)))))
+ (nutrient-target id (acc-effective-on a) (reverse (acc-pairs a)))))
-(define (get-nutrient-target #:id [nt-id #f]
- #:effective-on [effective-on #f])
+(define (get-nutrient-target #:id [nt-id #f] #:effective-on [effective-on #f])
(define where
(cond
[(and nt-id effective-on)
- (scalar-expr-qq (and (= nt.id ,nt-id)
- (= nt.effective_on ,effective-on)))]
- [nt-id
- (scalar-expr-qq (= nt.id ,nt-id))]
- [effective-on
- (scalar-expr-qq (= nt.effective_on ,effective-on))]))
- (define query (select nt.id nt.effective_on
- n.id n.canonical_name n.formula
- nv.value_ppm
- #:from (TableExpr:AST ,joined)
- #:where (ScalarExpr:AST ,where)))
+ (scalar-expr-qq (and (= nt.id ,nt-id) (= nt.effective_on ,effective-on)))]
+ [nt-id (scalar-expr-qq (= nt.id ,nt-id))]
+ [effective-on (scalar-expr-qq (= nt.effective_on ,effective-on))]))
+ (define query
+ (select nt.id
+ nt.effective_on
+ n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
+ #:from (TableExpr:AST ,joined)
+ #:where (ScalarExpr:AST ,where)))
(define rows (query-rows (current-conn) query))
(cond
[(null? rows) #f]
@@ -139,21 +126,22 @@
(define A #f)
(for ([row (in-list rows)])
(match-define (vector nt-id effective-on n-id n-name n-formula value-ppm) row)
- (unless the-id (set! the-id nt-id))
+ (unless the-id
+ (set! the-id nt-id))
(define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm))
- (set! A (if A
- (acc (acc-effective-on A)
- (cons nv-pair (acc-pairs A)))
- (acc effective-on (list nv-pair)))))
- (and A
- (nutrient-target the-id
- (acc-effective-on A)
- (reverse (acc-pairs A))))]))
+ (set! A
+ (if A
+ (acc (acc-effective-on A) (cons nv-pair (acc-pairs A)))
+ (acc effective-on (list nv-pair)))))
+ (and A (nutrient-target the-id (acc-effective-on A) (reverse (acc-pairs A))))]))
(define (get-nutrient-target-values nutrient-target)
(for/list ([(nutrient-id name formula value_ppm)
(in-query (current-conn)
- (select n.id n.canonical_name n.formula nv.value_ppm
+ (select n.id
+ n.canonical_name
+ n.formula
+ nv.value_ppm
#:from (TableExpr:AST ,joined)
#:where (= nm.id ,(nutrient-target-id nutrient-target))))])
(cons (nutrient nutrient-id name formula) value_ppm)))
@@ -170,17 +158,15 @@
(select value_ppm
#:from (TableExpr:AST ,joined)
#:where (= nv.nutrient_id ,(nutrient-id nutrient))
- #:order-by nt.effective_on #:desc
+ #:order-by nt.effective_on
+ #:desc
#:limit 1)))
;; UPDATE
-
;; DELETE
(define (delete-nutrient-target! nutrient-target)
(define id (nutrient-target-id nutrient-target))
- (query-exec (current-conn)
- (delete #:from nutrient_targets
- #:where (= id ,id))))
+ (query-exec (current-conn) (delete #:from nutrient_targets #:where (= id ,id))))
diff --git a/models/nutrient.rkt b/models/nutrient.rkt
index 944583e..49921d7 100644
--- a/models/nutrient.rkt
+++ b/models/nutrient.rkt
@@ -1,26 +1,27 @@
#lang racket
-(provide
- ;; Model struct
- nutrient
- nutrient?
- nutrient-id nutrient-name nutrient-formula
- ;; Contracts
- nutrient-value-pair/c
- (contract-out
- ;; SQL CRUD
- [create-nutrient! (-> string? string? nutrient?)]
- [get-nutrients (-> (listof nutrient?))]
- [get-nutrient (->* ()
- (#:id (or/c #f exact-nonnegative-integer?)
- #:name (or/c #f string?)
- #:formula (or/c #f string?))
- (or/c nutrient? #f))]
- [update-nutrient! (->* (nutrient?)
- (#:name (or/c #f string?)
- #:formula (or/c #f string?))
- (or/c nutrient? #f))]
- [delete-nutrient! (-> nutrient? void?)]))
+;; Model struct
+(provide nutrient
+ nutrient?
+ nutrient-id
+ nutrient-name
+ nutrient-formula
+ ;; Contracts
+ nutrient-value-pair/c
+ ;; SQL CRUD
+ (contract-out [create-nutrient! (-> string? string? nutrient?)]
+ [get-nutrients (-> (listof nutrient?))]
+ [get-nutrient
+ (->* ()
+ (#:id (or/c #f exact-nonnegative-integer?)
+ #:name (or/c #f string?)
+ #:formula (or/c #f string?))
+ (or/c nutrient? #f))]
+ [update-nutrient!
+ (->* (nutrient?)
+ (#:name (or/c #f string?) #:formula (or/c #f string?))
+ (or/c nutrient? #f))]
+ [delete-nutrient! (-> nutrient? void?)]))
(require racket/contract
db
@@ -30,14 +31,9 @@
(struct nutrient (id name formula)
#:transparent
#:property prop:custom-write
- (λ (v out _)
- (fprintf out "#<~a ~a>"
- (nutrient-id v)
- (nutrient-name v))))
-
-(define nutrient-value-pair/c
- (cons/c nutrient? (and/c real? (>=/c 0))))
+ (λ (v out _) (fprintf out "#<~a ~a>" (nutrient-id v) (nutrient-name v))))
+(define nutrient-value-pair/c (cons/c nutrient? (and/c real? (>=/c 0))))
;; CREATE
@@ -45,24 +41,18 @@
(or (get-nutrient #:name name #:formula formula)
(begin
(query-exec (current-conn)
- (insert #:into nutrients
- #:set [canonical_name ,name] [formula ,formula]))
+ (insert #:into nutrients #:set [canonical_name ,name] [formula ,formula]))
(get-nutrient #:name name))))
-
;; READ
(define (get-nutrients)
(for/list ([(id* name* formula*)
(in-query (current-conn)
- (select id canonical_name formula
- #:from nutrients
- #:order-by id #:asc))])
+ (select id canonical_name formula #:from nutrients #:order-by id #:asc))])
(nutrient id* name* formula*)))
-(define (get-nutrient #:id [id #f]
- #:name [name #f]
- #:formula [formula #f])
+(define (get-nutrient #:id [id #f] #:name [name #f] #:formula [formula #f])
(define (where-expr)
(define clauses
(filter values
@@ -73,47 +63,30 @@
[(null? clauses) ""]
[else (format "WHERE ~a" (string-join clauses " AND "))]))
(match (query-maybe-row (current-conn)
- (string-join
- `("SELECT id, canonical_name, formula"
- "FROM nutrients"
- ,(where-expr)
- "ORDER BY id ASC"
- "LIMIT 1")))
- [(vector id* name* formula*)
- (nutrient id* name* formula*)]
+ (string-join `("SELECT id, canonical_name, formula" "FROM nutrients"
+ ,(where-expr)
+ "ORDER BY id ASC"
+ "LIMIT 1")))
+ [(vector id* name* formula*) (nutrient id* name* formula*)]
[#f #f]))
-
;; UPDATE
-(define (update-nutrient! nutrient
- #:name [name #f]
- #:formula [formula #f])
- (define id(nutrient-id nutrient))
+(define (update-nutrient! nutrient #:name [name #f] #:formula [formula #f])
+ (define id (nutrient-id nutrient))
(cond
[(and name formula)
- (query-exec (current-conn)
- (update nutrients
- #:set [canonical_name ,name] [formula ,formula]
- #:where (= id ,id)))]
+ (query-exec
+ (current-conn)
+ (update nutrients #:set [canonical_name ,name] [formula ,formula] #:where (= id ,id)))]
[name
- (query-exec (current-conn)
- (update nutrients
- #:set [canonical_name ,name]
- #:where (= id ,id)))]
+ (query-exec (current-conn) (update nutrients #:set [canonical_name ,name] #:where (= id ,id)))]
[formula
- (query-exec (current-conn)
- (update nutrients
- #:set [formula ,formula]
- #:where (= id ,id)))]
+ (query-exec (current-conn) (update nutrients #:set [formula ,formula] #:where (= id ,id)))]
[else (void)])
- (or (get-nutrient #:id id)
- (error 'update-nutrient! "No nutrient with id ~a" id)))
-
+ (or (get-nutrient #:id id) (error 'update-nutrient! "No nutrient with id ~a" id)))
;; DELETE
(define (delete-nutrient! nutrient)
- (query-exec (current-conn)
- (delete #:from nutrients
- #:where (= id ,(nutrient-id nutrient)))))
+ (query-exec (current-conn) (delete #:from nutrients #:where (= id ,(nutrient-id nutrient)))))
diff --git a/models/user.rkt b/models/user.rkt
index a56b469..45ca154 100644
--- a/models/user.rkt
+++ b/models/user.rkt
@@ -1,16 +1,13 @@
#lang racket
-(provide
- ;; Model struct
- user
- user?
- user-id
- user-name
- user-role
- (contract-out
- ;; SQL CRUD
- [get-current-user (-> (or/c user? #f))]
- #; [delete-user! (-> user? void?)]))
+;; Model struct
+(provide user
+ user?
+ user-id
+ user-name
+ user-role
+ ;; SQL CRUD
+ (contract-out [get-current-user (-> (or/c user? #f))] #;[delete-user! (-> user? void?)]))
(require racket/contract
db
@@ -21,10 +18,7 @@
(define (get-current-user)
(define current-user-id "foobar")
- (define query (select id name role_id
- #:from users
- #:where (= id ,current-user-id)
- #:limit 1))
+ (define query (select id name role_id #:from users #:where (= id ,current-user-id) #:limit 1))
(define row (query-maybe-row (current-conn) query))
(cond
[(false? row) #f]
diff --git a/tests/models/nutrient-measurement.rkt b/tests/models/nutrient-measurement.rkt
index e2c2d59..c0c1ee1 100644
--- a/tests/models/nutrient-measurement.rkt
+++ b/tests/models/nutrient-measurement.rkt
@@ -11,59 +11,56 @@
(define measurement-date "2025-09-01")
(run-tests
- (test-suite
- "Nutrient measurement model"
- #:before (λ ()
- (connect! #:path 'memory)
- ;; (connect! #:path "test.sqlite3")
- (migrate-all!)
- (create-nutrient! "Nitrogen" "N")
- (create-nutrient! "Phosphorus" "P")
- (create-nutrient! "Potassium" "K"))
- #:after (λ ()
- (disconnect!))
+ (test-suite "Nutrient measurement model"
+ #:before (λ ()
+ (connect! #:path 'memory)
+ ;; (connect! #:path "test.sqlite3")
+ (migrate-all!)
+ (create-nutrient! "Nitrogen" "N")
+ (create-nutrient! "Phosphorus" "P")
+ (create-nutrient! "Potassium" "K"))
+ #:after (λ () (disconnect!))
- (test-case "Create measurement with date and values"
- (define nitrogen (get-nutrient #:name "Nitrogen"))
- (define phosphorus (get-nutrient #:name "Phosphorus"))
- (create-nutrient-measurement! measurement-date
- `((,nitrogen . 12.3)
- (,phosphorus . 4.5)))
- (check-equal? (length (get-nutrient-measurements)) 1)
- (define nm (get-nutrient-measurement #:measured-on measurement-date))
- (check-true (nutrient-measurement? nm))
- (check-equal? (nutrient-measurement-date nm) measurement-date))
+ (test-case "Create measurement with date and values"
+ (define nitrogen (get-nutrient #:name "Nitrogen"))
+ (define phosphorus (get-nutrient #:name "Phosphorus"))
+ (create-nutrient-measurement! measurement-date `((,nitrogen . 12.3) (,phosphorus . 4.5)))
+ (check-equal? (length (get-nutrient-measurements)) 1)
+ (define nm (get-nutrient-measurement #:measured-on measurement-date))
+ (check-true (nutrient-measurement? nm))
+ (check-equal? (nutrient-measurement-date nm) measurement-date))
- (test-case "Check all measurement values"
- (define nitrogen (get-nutrient #:name "Nitrogen"))
- (define phosphorus (get-nutrient #:name "Phosphorus"))
+ (test-case "Check all measurement values"
+ (define nitrogen (get-nutrient #:name "Nitrogen"))
+ (define phosphorus (get-nutrient #:name "Phosphorus"))
- (define nm (get-nutrient-measurement #:measured-on measurement-date))
- (check-equal? (get-nutrient-measurement-value nm nitrogen) 12.3)
- (check-equal? (get-nutrient-measurement-value nm phosphorus) 4.5)
+ (define nm (get-nutrient-measurement #:measured-on measurement-date))
+ (check-equal? (get-nutrient-measurement-value nm nitrogen) 12.3)
+ (check-equal? (get-nutrient-measurement-value nm phosphorus) 4.5)
- (define nmv (nutrient-measurement-values nm))
- (check-equal? (get-nutrient-measurement-values nm) nmv
- "return value of get-nutrient-measurement-values ≠ nutrient-measurement-values struct accessor")
- (check-equal? (length nmv) 2)
- (check-equal? (cdr (assoc nitrogen nmv)) 12.3)
- (check-equal? (cdr (assoc phosphorus nmv)) 4.5))
+ (define nmv (nutrient-measurement-values nm))
+ (check-equal?
+ (get-nutrient-measurement-values nm)
+ nmv
+ "return value of get-nutrient-measurement-values ≠ nutrient-measurement-values struct accessor")
+ (check-equal? (length nmv) 2)
+ (check-equal? (cdr (assoc nitrogen nmv)) 12.3)
+ (check-equal? (cdr (assoc phosphorus nmv)) 4.5))
- (test-case "Retrieve latest measurement values"
- (define nitrogen (get-nutrient #:name "Nitrogen"))
- (define phosphorus (get-nutrient #:name "Phosphorus"))
- (define second-measurement-date "2025-09-02")
- (create-nutrient-measurement! second-measurement-date
- `((,nitrogen . 6.7)
- (,phosphorus . 8.9)))
+ (test-case "Retrieve latest measurement values"
+ (define nitrogen (get-nutrient #:name "Nitrogen"))
+ (define phosphorus (get-nutrient #:name "Phosphorus"))
+ (define second-measurement-date "2025-09-02")
+ (create-nutrient-measurement! second-measurement-date `((,nitrogen . 6.7) (,phosphorus . 8.9)))
- (check-equal? (get-latest-nutrient-measurement-value nitrogen) 6.7)
- (check-equal? (get-latest-nutrient-measurement-value phosphorus) 8.9))
+ (check-equal? (get-latest-nutrient-measurement-value nitrogen) 6.7)
+ (check-equal? (get-latest-nutrient-measurement-value phosphorus) 8.9))
- (test-case "Delete measurement and cascade to measurement values"
- (define nm (get-nutrient-measurement #:measured-on measurement-date))
- (delete-nutrient-measurement! nm)
- (check-false (get-nutrient-measurement #:id (nutrient-measurement-id nm)))
- (check-equal? (length (get-nutrient-measurements)) 1
- "wrong number of nutrient measurements were deleted")
- (check-true (null? (get-nutrient-measurement-values nm)))))))
+ (test-case "Delete measurement and cascade to measurement values"
+ (define nm (get-nutrient-measurement #:measured-on measurement-date))
+ (delete-nutrient-measurement! nm)
+ (check-false (get-nutrient-measurement #:id (nutrient-measurement-id nm)))
+ (check-equal? (length (get-nutrient-measurements))
+ 1
+ "wrong number of nutrient measurements were deleted")
+ (check-true (null? (get-nutrient-measurement-values nm)))))))
diff --git a/tests/models/nutrient.rkt b/tests/models/nutrient.rkt
index 562e6ff..1e4fa8f 100644
--- a/tests/models/nutrient.rkt
+++ b/tests/models/nutrient.rkt
@@ -7,70 +7,62 @@
"../../db/migrations.rkt"
"../../models/nutrient.rkt")
- (run-tests
- (test-suite
- "Nutrient model"
- #:before (λ ()
- (connect! #:path 'memory)
- (migrate-all!))
- #:after (λ ()
- (disconnect!))
+ (run-tests (test-suite "Nutrient model"
+ #:before (λ ()
+ (connect! #:path 'memory)
+ (migrate-all!))
+ #:after (λ () (disconnect!))
- (test-case "Create nutrients"
- (create-nutrient! "Examplium" "Ex")
- (check-equal? (length (get-nutrients)) 1)
- (create-nutrient! "Ignorium" "Ig")
- (check-equal? (length (get-nutrients)) 2))
+ (test-case "Create nutrients"
+ (create-nutrient! "Examplium" "Ex")
+ (check-equal? (length (get-nutrients)) 1)
+ (create-nutrient! "Ignorium" "Ig")
+ (check-equal? (length (get-nutrients)) 2))
- (test-case "Read nutrient"
- (define examplium (get-nutrient #:id 1))
- (check-true (nutrient? examplium))
- (check-equal? (nutrient-id examplium) 1))
-
- (test-case "Read nutrient by name"
- (define examplium (get-nutrient #:name "Examplium"))
- (check-true (nutrient? examplium))
- (check-equal? (nutrient-name examplium) "Examplium"))
+ (test-case "Read nutrient"
+ (define examplium (get-nutrient #:id 1))
+ (check-true (nutrient? examplium))
+ (check-equal? (nutrient-id examplium) 1))
- (test-case "Read nutrient by formula"
- (define examplium (get-nutrient #:formula "Ex"))
- (check-true (nutrient? examplium))
- (check-equal? (nutrient-formula examplium) "Ex"))
-
- (test-case "Read inexisting nutrient"
- (check-false (get-nutrient #:name "Inexistium")))
+ (test-case "Read nutrient by name"
+ (define examplium (get-nutrient #:name "Examplium"))
+ (check-true (nutrient? examplium))
+ (check-equal? (nutrient-name examplium) "Examplium"))
- (test-case "Update nutrient name"
- (define examplium (get-nutrient #:name "Examplium"))
- (define examplium-nitrate
- (update-nutrient! examplium #:name "Examplium Nitrate"))
- (check-equal? (length (get-nutrients)) 2)
- (check-equal? (nutrient-name examplium-nitrate) "Examplium Nitrate")
- (check-equal? (nutrient-formula examplium-nitrate) "Ex"))
+ (test-case "Read nutrient by formula"
+ (define examplium (get-nutrient #:formula "Ex"))
+ (check-true (nutrient? examplium))
+ (check-equal? (nutrient-formula examplium) "Ex"))
- (test-case "Update nutrient formula"
- (define examplium-nitrate (get-nutrient #:name "Examplium Nitrate"))
- (define examplium-sulfate
- (update-nutrient! examplium-nitrate #:formula "ExSO4"))
- (check-equal? (length (get-nutrients)) 2)
- (check-equal? (nutrient-name examplium-sulfate) "Examplium Nitrate")
- (check-equal? (nutrient-formula examplium-sulfate) "ExSO4"))
+ (test-case "Read inexisting nutrient"
+ (check-false (get-nutrient #:name "Inexistium")))
- (test-case "Update nutrient name and formula"
- (define examplium-nitrate
- (get-nutrient #:name "Examplium Nitrate"))
- (define examplium-sulfate
- (update-nutrient! examplium-nitrate
- #:name "Examplium Sulfate"
- #:formula "ExNO3"))
- (check-equal? (length (get-nutrients)) 2)
- (check-equal? (nutrient-name examplium-sulfate) "Examplium Sulfate")
- (check-equal? (nutrient-formula examplium-sulfate) "ExNO3"))
+ (test-case "Update nutrient name"
+ (define examplium (get-nutrient #:name "Examplium"))
+ (define examplium-nitrate (update-nutrient! examplium #:name "Examplium Nitrate"))
+ (check-equal? (length (get-nutrients)) 2)
+ (check-equal? (nutrient-name examplium-nitrate) "Examplium Nitrate")
+ (check-equal? (nutrient-formula examplium-nitrate) "Ex"))
- (test-case "Delete nutrient"
- (define examplium-sulfate (get-nutrient #:name "Examplium Sulfate"))
- (delete-nutrient! examplium-sulfate)
- (check-equal? (length (get-nutrients)) 1)
- (define ignorium (get-nutrient #:name "Ignorium"))
- (delete-nutrient! ignorium)
- (check-equal? (length (get-nutrients)) 0)))))
+ (test-case "Update nutrient formula"
+ (define examplium-nitrate (get-nutrient #:name "Examplium Nitrate"))
+ (define examplium-sulfate (update-nutrient! examplium-nitrate #:formula "ExSO4"))
+ (check-equal? (length (get-nutrients)) 2)
+ (check-equal? (nutrient-name examplium-sulfate) "Examplium Nitrate")
+ (check-equal? (nutrient-formula examplium-sulfate) "ExSO4"))
+
+ (test-case "Update nutrient name and formula"
+ (define examplium-nitrate (get-nutrient #:name "Examplium Nitrate"))
+ (define examplium-sulfate
+ (update-nutrient! examplium-nitrate #:name "Examplium Sulfate" #:formula "ExNO3"))
+ (check-equal? (length (get-nutrients)) 2)
+ (check-equal? (nutrient-name examplium-sulfate) "Examplium Sulfate")
+ (check-equal? (nutrient-formula examplium-sulfate) "ExNO3"))
+
+ (test-case "Delete nutrient"
+ (define examplium-sulfate (get-nutrient #:name "Examplium Sulfate"))
+ (delete-nutrient! examplium-sulfate)
+ (check-equal? (length (get-nutrients)) 1)
+ (define ignorium (get-nutrient #:name "Ignorium"))
+ (delete-nutrient! ignorium)
+ (check-equal? (length (get-nutrients)) 0)))))
diff --git a/views.rkt b/views.rkt
index 172aab3..5893512 100644
--- a/views.rkt
+++ b/views.rkt
@@ -15,130 +15,102 @@
"models/nutrient-target.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"])))))
-
+ `(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"])
+ ((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 dropdown"])
- (a ([class "nav-link dropdown-toggle"]
- [href "#"]
- [id "navbarDropdown"]
- [role "button"]
- [data-bs-toggle "dropdown"]
- [aria-expanded "false"])
- "Dropdown")
- (ul ([class "dropdown-menu"] [aria-labelledby "navbarDropdown"])
- (li (a ([class "dropdown-item"] [href "#"]) "Action"))
- (li (a ([class "dropdown-item"] [href "#"]) "Another action"))
- (li (hr ([class "dropdown-divider"])))
- (li (a ([class "dropdown-item"] [href "#"]) "Something else here"))))
- (li ([class "nav-item"])
- (a ([class "nav-link disabled"]
- [href "#"]
- [tabindex "-1"]
- [aria-disabled "true"])
+ ((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 dropdown"))
+ (a ((class "nav-link dropdown-toggle") [href "#"]
+ [id "navbarDropdown"]
+ [role "button"]
+ [data-bs-toggle "dropdown"]
+ [aria-expanded "false"])
+ "Dropdown")
+ (ul ((class "dropdown-menu") [aria-labelledby "navbarDropdown"])
+ (li (a ((class "dropdown-item") [href "#"]) "Action"))
+ (li (a ((class "dropdown-item") [href "#"]) "Another action"))
+ (li (hr ((class "dropdown-divider"))))
+ (li (a ((class "dropdown-item") [href "#"]) "Something else here"))))
+ (li ((class "nav-item"))
+ (a ((class "nav-link disabled") [href "#"] [tabindex "-1"] [aria-disabled "true"])
"Clients"))
- (li ([class "nav-item"])
- (a ([class "nav-link active"]
- [aria-current "page"]
- [href "/ferti"])
- "Ferti"))
- (li ([class "nav-item"])
- (a ([class "nav-link disabled"]
- [href "#"]
- [tabindex "-1"]
- [aria-disabled "true"])
+ (li ((class "nav-item"))
+ (a ((class "nav-link active") [aria-current "page"] [href "/ferti"]) "Ferti"))
+ (li ((class "nav-item"))
+ (a ((class "nav-link disabled") [href "#"] [tabindex "-1"] [aria-disabled "true"])
"Cultures"))
- (li ([class "nav-item"])
- (a ([class "nav-link"]
- [href "/contact"])
- "Contact")))
- #; (form ([class "d-flex"])
- (input ([class "form-control me-2"]
- [type "search"]
- [placeholder "Search"]
- [aria-label "Search"]))
- (button ([class "btn btn-outline-success"] [type "submit"]) "Search"))))))
-
+ (li ((class "nav-item")) (a ((class "nav-link") [href "/contact"]) "Contact")))
+ #;(form ((class "d-flex"))
+ (input ((class "form-control me-2") [type "search"]
+ [placeholder "Search"]
+ [aria-label "Search"]))
+ (button ((class "btn btn-outline-success") [type "submit"]) "Search"))))))
;; Page helpers
(define (round n number)
(~r number #:precision `(= ,n)))
-
;; Pages
(define (ferti-page measurements ferti-recipe)
(page-template
"Ferti"
- `((h1 ([class "display-1 mb-3"]) "Ferti")
-
-
+ `((h1 ((class "display-1 mb-3")) "Ferti")
;;;;;;;;
;; Ferti
;;;;;;;;
-
(h2 () "Recette")
,(if (ormap (λ (pair) (not (zero? (cdr pair)))) ferti-recipe)
- `(table ([class "table"])
- (tr (th "Intrant")
- (th ([class "text-end"]) "Quantité (g/L)"))
+ `(table ((class "table"))
+ (tr (th "Intrant") (th ((class "text-end")) "Quantité (g/L)"))
,@(for/list ([fertilizer-amount ferti-recipe]
#:when (not (zero? (cdr fertilizer-amount))))
(match-define (cons fertilizer amount) fertilizer-amount)
`(tr (td () ,(fertilizer-name fertilizer))
- (td ([class "text-end font-monospace"]) ,(round 2 amount)))))
+ (td ((class "text-end font-monospace")) ,(round 2 amount)))))
`(p "La recette Ferti requiert au moins un relevé et une cible."))
-
-
;;;;;;;;;
;; Cibles
;;;;;;;;;
-
(h2 () "Dernière Cible")
- (a ([class "btn btn-primary mb-3"] [href "/target/new"]) "Créer une cible")
- (table ([class "table"])
+ (a ((class "btn btn-primary mb-3") [href "/target/new"]) "Créer une cible")
+ (table ((class "table"))
(tr (th "Nutriment")
- (th ([class "text-end"]) "Dernier Relevé")
- (th ([class "text-end"]) "Dernière Cible")
- (th ([class "text-end"]) "Delta (%)"))
+ (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-target-value n))
(define latest-measurement (get-latest-nutrient-measurement-value n))
@@ -163,14 +135,13 @@
;;;;;;;;;;
;; Relevés
;;;;;;;;;;
-
(h2 () "Relevés")
- (a ([class "btn btn-primary mb-3"] [href "/measurement/new"]) "Ajouter un relevé")
- (table ([class "table table-striped"])
+ (a ((class "btn btn-primary mb-3") [href "/measurement/new"]) "Ajouter un relevé")
+ (table ((class "table table-striped"))
(tr (th "Date")
- (th ([class "text-end"]) "N")
- (th ([class "text-end"]) "P")
- (th ([class "text-end"]) "K"))
+ (th ((class "text-end")) "N")
+ (th ((class "text-end")) "P")
+ (th ((class "text-end")) "K"))
,@(for/list ([m measurements])
(define measured-on (nutrient-measurement-date m))
(define-values (n p k)
@@ -182,47 +153,40 @@
(round 2 mnv)
"—"))))
`(tr (td ,measured-on)
- (td ([class "text-end font-monospace"]) ,n)
- (td ([class "text-end font-monospace"]) ,p)
- (td ([class "text-end font-monospace"]) ,k)))))))
+ (td ((class "text-end font-monospace")) ,n)
+ (td ((class "text-end font-monospace")) ,p)
+ (td ((class "text-end font-monospace")) ,k)))))))
(define (new-measurement-page)
- (page-template
- "Nouveau relevé"
- `((h1 ([class "display-1 mb-3"]) "Nouveau relevé")
- (div ([class "mb-3"] [style "max-width: 30em"])
- (form
- ([action "/measurement/create"]
- [method "POST"])
- ,@(formlet-display (measurements-formlet)))))))
+ (page-template "Nouveau relevé"
+ `((h1 ((class "display-1 mb-3")) "Nouveau relevé")
+ (div ((class "mb-3") [style "max-width: 30em"])
+ (form ([action "/measurement/create"] [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)))))))
+ (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 (index-page user)
(page-template
"Bienvenue à la FAPG"
- `((h1 ([class "display-1 mb-3"])
+ `((h1 ((class "display-1 mb-3"))
,(format "~a, ~a."
- (if (<= (->hours (current-time #:tz "Europe/Paris")) 17)
- "Bonjour"
- "Bonsoir")
- (if user (user-name user) "et bienvenue")))
- (a ([class "btn btn-primary mb-3"] [href "/ferti"]) "Accéder à Ferti"))))
+ (if (<= (->hours (current-time #:tz "Europe/Paris")) 17) "Bonjour" "Bonsoir")
+ (if user
+ (user-name user)
+ "et bienvenue")))
+ (a ((class "btn btn-primary mb-3") [href "/ferti"]) "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"))))
+ (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
@@ -240,8 +204,11 @@
[(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."]
+ [(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)]))))
Copyright 2019--2026 Marius PETER