diff options
| -rw-r--r-- | .gitignore | 6 | ||||
| -rw-r--r-- | db/conn.rkt | 41 | ||||
| -rw-r--r-- | db/data/dolibarr_crop_requirements_ppm.csv | 9 | ||||
| -rw-r--r-- | db/data/dolibarr_fertilizer_compositions_percentage.csv | 18 | ||||
| -rw-r--r-- | db/data/dolibarr_nutrient_measurements_ppm.csv | 44 | ||||
| -rw-r--r-- | db/migrations.rkt | 167 | ||||
| -rw-r--r-- | db/seed.rkt | 137 | ||||
| -rw-r--r-- | formlets.rkt | 53 | ||||
| -rw-r--r-- | handlers.rkt | 48 | ||||
| -rw-r--r-- | main.rkt | 14 | ||||
| -rw-r--r-- | models/crop-requirement.rkt | 180 | ||||
| -rw-r--r-- | models/crop.rkt | 103 | ||||
| -rw-r--r-- | models/fertilizer-product.rkt | 177 | ||||
| -rw-r--r-- | models/nutrient-measurement.rkt | 212 | ||||
| -rw-r--r-- | models/nutrient-target.rkt | 217 | ||||
| -rw-r--r-- | models/nutrient-value-set.rkt | 98 | ||||
| -rw-r--r-- | models/nutrient.rkt | 123 | ||||
| -rw-r--r-- | storage/.gitignore | 1 | ||||
| -rw-r--r-- | tests/nutrient-measurement-model.rkt | 72 | ||||
| -rw-r--r-- | tests/nutrient-model.rkt | 76 | ||||
| -rw-r--r-- | views.rkt | 152 |
21 files changed, 1948 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..55cf0fd --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +# Compilation artifacts +compiled/ +# Backup files +*~ +# SQLite3 database +*.sqlite
\ No newline at end of file diff --git a/db/conn.rkt b/db/conn.rkt new file mode 100644 index 0000000..e083d94 --- /dev/null +++ b/db/conn.rkt @@ -0,0 +1,41 @@ +#lang racket + +(require db) + +(provide current-conn + connect! + disconnect! + with-db + with-tx) + +(define current-conn (make-parameter #f)) + +(define (connect! #:path [path 'memory]) + (cond + [(connection? (current-conn)) + (printf "Database connection already exists: ~e\n" (current-conn))] + [else + (current-conn (sqlite3-connect #:database path + #:mode 'create)) + (printf "Created database connection at path: ~a\n" path)])) + +(define (disconnect!) + (disconnect (current-conn)) + (printf "Closing database connection: ~e\n" (current-conn)) + (current-conn #f)) + +(define-syntax-rule (with-db body ...) + (begin (connect!) body ...)) + +(define-syntax-rule (with-tx body ...) + (call-with-transaction (current-conn) (λ () body ...))) + +(module+ test + (require rackunit) + (check-equal? (current-conn) #f) + (connect!) + (check-true (connection? (current-conn))) + (disconnect!) + (check-equal? (current-conn) #f) + (with-db + (check-true (connection? (current-conn))))) diff --git a/db/data/dolibarr_crop_requirements_ppm.csv b/db/data/dolibarr_crop_requirements_ppm.csv new file mode 100644 index 0000000..e9bf8fd --- /dev/null +++ b/db/data/dolibarr_crop_requirements_ppm.csv @@ -0,0 +1,9 @@ +Plante,Profil,NNO3,P,K,Ca,Mg,S,Na,Cl,Si,Fe,Zn,B,Mn,Cu,Mo,NNH4 +,générique croissance,160,30,230,100,30,60,0,0,0,5,0.15,0.3,0.5,0.15,0.05,0 +,générique floraison,130,60,300,100,30,60,0,0,0,2,0.1,0.5,0.5,0.05,0.05,0 +Laitue,générique,190,50,210,200,50,66,0,0,0,5,0.15,0.3,0.5,0.15,0.05,0 +Tomate,cycle entier,140,50,352,180,50,168,0,0,0,5,0.1,0.3,0.8,0.07,0.03,0 +Tomate,10-14 jours,100,40,200,100,20,53,0,0,0,3,0.1,0.3,0.8,0.07,0.03,0 +Tomate,1ère grappe,130,55,300,150,33,109,0,0,0,3,0.1,0.3,0.8,0.07,0.03,0 +Tomate,à maturité,180,65,400,400,45,144,0,0,0,3,0.1,0.3,0.8,0.07,0.03,0 +Framboise,tous stades,70,12,88,90,24,48,0,0,50,0.56,0.325,0.11,0.11,0.032,0.01,0 diff --git a/db/data/dolibarr_fertilizer_compositions_percentage.csv b/db/data/dolibarr_fertilizer_compositions_percentage.csv new file mode 100644 index 0000000..f58042c --- /dev/null +++ b/db/data/dolibarr_fertilizer_compositions_percentage.csv @@ -0,0 +1,18 @@ +Ref,Libellé,Nom commercial,NNO3,P,K,Ca,Mg,S,Na,Cl,Fe,Zn,B,Mn,Cu,Mo,NNH4 +Nitrate_de_Potassium,Nitrate de potassium,Multi K Reci,13.50,0,38.60,0,0,0,0.015,0,0,0,0,0,0,0,0 +Acide_nitrique_53%,Acide nitrique 53%,,11.70,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +Bicarbonate_de_potassium,Bicarbonate de potassium,,0,0,0,39.05,0,0,0,0,0,0,0,0,0,0,0 +Boronia_LS,Bore-Molybdène,,0,0,0,0,0,0,0,0,0,13.50,0,0,0,0.028,0 +Phosphate_de_diammonium,Phosphate de diammonium,DAP 18/46/00,21.00,53.00,0,0,0,0,0,0,0,0,0,0,0,0,0 +Ferexel_D12,Fer chélaté DTPA,,0,0,0,0,0,0,0,0,0,11.80,0,0,0,0,0 +Nitrate_de_calcium,Nitrate de calcium,Multi-Cal Haïfa,15.50,0,0,18.94,0,0,0,0,0,0,0,0,0,0,0 +Sulfate_de_Potassium,Sulfate de potassium,Patenkali,0,22.66,0,0.44,6.16,17.77,2.16,3.34,0,0,0,0,0,0,0 +Sulfate_de_Manganese,Sulfate de Manganèse,Fixa Mn,0,0,0,0,0,7.17,0,0,0,0,12.00,0,0,0,0 +Sulfate_de_Magnesium,Sulfate de Magnésium,Eso Top,0,0,0,9.648,13.016,0,0,0,0,0,0,0,0,0,0 +Nitrate_d_ammonium,Nitrate d’ammonium,,27.00,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +Carbonate_de_Calcium,Carbonate de Calcium,,0,0,0,38.00,0,0,0,0,0,0,0,0,0,0,0 +Nitrate_d_ammonium_27kg,Nitrate d’ammonium 27 en 25 kg,Ammonitrate 27,13.50,0,0,0,0,0,0,0,0,0,0,0,0,0,13.5 +Fixa_Zinc,Fixa Zinc,,0,0,0,0,0,0,0,0,0,0,5.00,0,12.00,0,0 +HelioCuivre,HelioCuivre,,0,0,0,0,0,0,0,0,0,0,0,40.00,0,0,0 +Boronia_Molybdène_-_Boronia,Boronia MO12 10L,,0,0,0,0,0,0,0,0,0,0,8.90,0.089,0,0.89,0 +Molybdate_de_sodium,Molybdate de sodium,,0,0,0,0,0,0,39.50,0,0,0,0,0,0,0,0 diff --git a/db/data/dolibarr_nutrient_measurements_ppm.csv b/db/data/dolibarr_nutrient_measurements_ppm.csv new file mode 100644 index 0000000..c5d12e6 --- /dev/null +++ b/db/data/dolibarr_nutrient_measurements_ppm.csv @@ -0,0 +1,44 @@ +date,NNO3,P,K,Ca,Mg,S,Na,Cl,Si,Fe,Zn,B,Mn,Cu,Mo,NNH4 +08/05/2021,1.87,0.0031936,0.91,100.79,8.37,1.08666558,6.73,12.28,5.42,0.01,0.01,0.01,0.01,0.01,0.01,0.02 +02/07/2021,66.3,0.0095808,110.91,93.09,17.95,32.84663382,10.27,18.53,5.02,4.37,0.03,0.18,0.15,0,0,0.63 +12/07/2021,61.66,2.011968,122.53,73.5,17.44,47.64328569,0.45,0.82,0.36,1.76,0.05,0.13,0.32,0,0,0 +12/08/2021,67.27,0.351296,94.45,89.48,16.25,9.11665755,10.76,16.51,4.95,3.2,0.03,0.14,0.07,0,0,0.06 +06/09/2021,77.8,7.1153408,96.29,86.31,14.21,23.90664276,9.32,14.92,4.61,2.45,0.08,0.12,0.05,0.03,0,0.02 +21/09/2021,87.88,11.33728,117.24,90.64,17.25,29.90663676,9.92,15.96,4.68,2.4,0.08,0.27,0.12,0.04,0.01,0.02 +19/10/2021,77.84,13.4195072,121.91,94.71,18.3,33.19663347,12.36,15.28,4.47,2.72,0.11,0.74,0.04,0.04,0.02,0.03 +01/12/2021,57.09,6.6842048,81.46,61.45,10.52,17.72331561,17.36,23.05,2.11,1.27,0.17,0.32,0.01,0.03,0.02,0.07 +04/02/2022,43.56,6.5979776,63.1,63.72,9.92,17.3999826,17.08,21.15,1.44,1.6,0.22,0.34,0.01,0.04,0.01,0.03 +12/04/2022,38.36,6.5021696,83.48,49.75,6.42,14.14331919,29.8,38.85,0.23,0.3,0.2,0,0.02,0.01,0.4,0.07 +16/05/2022,24.63,0.542912,30.22,39.79,6.75,0.0666666,25.98,25.89,0.14,1.13,0.3,0.23,0.01,0.02,0.005,0.12 +15/06/2022,2.45,0.0606784,0.69,24.58,4.14,1.24999875,19.59,11.33,0.32,0.79,0.25,0.13,0.01,0.02,0.01,0.1 +04/07/2022,24.3,3.081824,42.34,39.79,8.09,0.41333292,19.79,11.32,1.24,0.7,0.18,0.07,0.02,0.01,0.005,0.68 +01/08/2022,4.88,0.2299392,27.77,22.48,6.71,18.68331465,23,5,0.64,0.97,0.17,0.04,0.005,0.005,0.005,0.07 +07/09/2022,29.28,2.07584,79.65,36.05,13.82,31.17663549,33.41,12.32,0.83,0.84,0.13,0.07,0.01,0.005,0.005,0.8 +24/10/2022,41.61,1.2646656,68.38,47.44,11.54,21.55664511,28.22,18.73,0.81,0.41,0.1,0.05,0.005,0.005,0.005,0.09 +21/11/2022,40.34,3.1105664,53.6,51.09,9.69,17.97331536,25.5,18.85,0.97,0.58,0.11,0.07,0.005,0.005,0.005,0.04 +09/01/2023,48.71,6.6171392,63.08,71.45,11.58,6.55666011,23.81,21.32,1.46,1.04,0.13,0.13,0.01,0.01,0.01,0.03 +21/02/2023,56.03,7.5273152,53.3,81.75,12.11,19.31998068,23.16,27.27,1.86,0.95,0.18,0.19,0.01,0.005,0.02,0.13 +20/04/2023,50.67,7.0546624,76.45,76.63,10.57,15.54331779,22.25,26.97,0.95,0.96,0.19,0.12,0.005,0.005,0.005,0.21 +07/06/2023,48.82,7.3005696,90.04,64.58,9.96,16.92664974,22.39,25.93,0.78,0.42,0.2,0.11,0.005,0.005,0.005,0.16 +13/07/2023,21.79,1.5712512,77.61,40.41,9.74,20.82331251,26.23,22.49,0.6,1.16,0.22,0.31,0,0,0.02,0.14 +17/07/2023,21.79,4.9213376,77.61,40.41,9.74,20.82331251,26.23,22.49,0.6,1.16,0.22,0.31,0.01,0.01,0.02,0.14 +23/08/2023,23.88,2.778432,97.75,49.74,26.25,31.24996875,31.11,16.43,1.33,0.8,0.18,0.14,0,0,0.01,1.01 +02/09/2023,23.88,2.778432,97.75,49.74,16.15,31.24996875,31.11,16.43,1.33,0.8,0.18,0.14,0,0,0.01,1.01 +13/10/2023,71.9,5.0905984,106.35,91.03,18.11,34.90663176,32.36,14.59,1.43,0.97,0.17,0.05,0,0,0,0.24 +28/12/2023,70.58,9.1368896,141.05,68.18,11.96,24.18664248,27.95,21.57,1.31,0.88,0.16,0.15,0,0,0.02,0.06 +16/01/2024,77.26,11.433088,149.17,68.71,12.14,23.24331009,29.88,27.04,1.15,1.14,0.26,0.14,0,0,0,0.09 +04/03/2024,84.65,13.4418624,185.21,66.05,15.61,30.69330264,40.12,36.82,0.66,0.93,0.39,0.35,0,0,0.03,0.16 +23/04/2024,69.17,11.2350848,116.41,52.96,14.07,28.95330438,80.73,37.54,0.57,0.79,0.42,0.38,0.01,0,0.03,0.16 +30/05/2024,46.74,7.520928,81.84,38.61,10.48,26.52997347,79.96,40.47,0.34,0.87,0.45,0.37,0,0.03,0.03,0.12 +05/07/2024,27.51,3.960064,75.58,27.78,8.29,25.99330734,92.2,44.74,0.32,0.59,0.45,0.37,0,0.03,0.03,0.15 +23/07/2024,16.55,2.4143616,83.62,16.52,4.9,20.45997954,79.04,40.51,0.32,0.77,0.43,0.26,0,0.03,0.02,0.43 +06/08/2024,0,0.3001984,74.41,6.82,2.56,17.28664938,78.79,35.04,0.42,0.9,0.37,0.29,0,0.03,0.02,0.13 +09/09/2024,18.3,2.87424,85.3,8.7,1.7,10.5666561,53.7,22.7,2.5,0.7,0.2,0.1,0,0,0,0 +01/10/2024,22.94,4.1740352,112.46,9.44,2,13.51998648,58.57,28.76,0.27,0.6,0.26,0.17,0,0.02,0,0.2 +22/11/2024,66,2.87424,127,33,9,7.333326,63,40,2.8,0.73,0.37,0.16,0.01,0.01,0.01,0 +20/01/2025,94.26,15.664608,146.27,76.06,14.24,32.05663461,64.29,46.99,0.45,0.37,0.48,0.16,0.08,0.03,0.01,0.11 +06/03/2025,95.82,20.007904,171.83,92.24,15.75,35.2332981,82.27,54.5,0.45,0.17,0.49,0.16,0.03,0.02,0,0.06 +04/04/2025,85.49,17.2646016,109.91,88.54,13.47,31.08663558,65.02,53.96,0.28,0.65,0.51,0.13,0.01,0.01,0,0 +22/05/2025,49.8,9.9927744,92.41,61.42,8.47,22.42331091,52.95,38.25,0.32,0.86,0.48,0.23,0.03,0,0.02,0.13 +11/06/2025,30.28,5.700576,50.2,48.96,5.73,22.10664456,51.34,33.41,0,0.96,0.51,0.26,0,0,0,0 +01/08/2025,1.34,0.4854272,77.64,16.45,5.52,22.93997706,58.45,25.83,0.5,0.48,0.44,0.17,0,0,0,0 diff --git a/db/migrations.rkt b/db/migrations.rkt new file mode 100644 index 0000000..95164e4 --- /dev/null +++ b/db/migrations.rkt @@ -0,0 +1,167 @@ +#lang racket + +(provide migrate-all!) + +(require db + sql + "conn.rkt") + +(define migrations-box (box '())) + +(define (migrate-all!) + (printf "Applying migrations on connection ~a...\n" + (dbsystem-name (connection-dbsystem (current-conn)))) + (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))) + (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))) + (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))))))) + + +;;;;;;;;;;;; +;; 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_measurement id) + #:on-delete #:cascade) + (foreign-key nutrient_target_id + #:references (nutrient_target 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)) + "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)))) + +(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)))) + + +;;;;;;;; +;; 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)))) + + +;;;;;;;;;;;;;; +;; 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)))) + +(module+ test + (connect!) + (migrate-all!)) diff --git a/db/seed.rkt b/db/seed.rkt new file mode 100644 index 0000000..6b253a6 --- /dev/null +++ b/db/seed.rkt @@ -0,0 +1,137 @@ +#lang racket + +;; Seed the database with default values. + +(provide seed-database!) + +(require csv-reading + "conn.rkt" + "../models/nutrient.rkt" + "../models/nutrient-measurement.rkt" + "../models/crop.rkt" + "../models/crop-requirement.rkt" + "../models/fertilizer-product.rkt") + +(define (seed-database!) + (seed-nutrients!) + (seeded "nutrients") + (seed-historical-nutrient-measurements!) + (seeded "historical nutrient measurements") + (seed-crops!) + (seeded "crops") + (seed-crop-requirements!) + (seeded "crop requirements") + (seed-existing-fertilizer-products!) + (seeded "existing fertilizer products")) + +(define (seeded entity) + (displayln (format "Seeded entity: ~a" entity))) + +(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))))) + +(define (seed-historical-nutrient-measurements!) + (define input-csv "/home/blendux/git/ferti-v2/db/data/dolibarr_nutrient_measurements_ppm.csv") + (define next-row (make-csv-reader (open-input-file input-csv))) + (define header (next-row)) + (define (row->seed! row) + (define row-alist (map cons header row)) + (define measured-on (cdar row-alist)) + (define nutrient-values + (for/list ([nm (in-list (cdr row-alist))]) + (define formula (car nm)) + (define n (get-nutrient #:formula formula)) + (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))) + +(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 (seed-crop-requirements!) + (define input-csv "/home/blendux/git/ferti-v2/db/data/dolibarr_crop_requirements_ppm.csv") + (define next-row (make-csv-reader (open-input-file input-csv))) + (define header (next-row)) + (define (row->seed! row) + (define row-alist (map cons header row)) + (define crop-name (string-downcase (cdr (assoc "Plante" row-alist)))) + (define profile (cdr (assoc "Profil" row-alist))) + (define nutrient-values + (for/list ([crop-requirement (in-list (list-tail row-alist 2))]) + (define formula (car crop-requirement)) + (define n (get-nutrient #:formula formula)) + (define v (string->number (cdr crop-requirement))) + (cons n v))) + (cond + [(non-empty-string? crop-name) + (define crop (get-crop #:name crop-name)) + (create-crop-requirement! profile nutrient-values crop)] + [else + (create-crop-requirement! profile nutrient-values)])) + (with-tx + (csv-for-each row->seed! next-row))) + +(define (seed-existing-fertilizer-products!) + (define input-csv "/home/blendux/git/ferti-v2/db/data/dolibarr_fertilizer_compositions_percentage.csv") + (define next-row (make-csv-reader (open-input-file input-csv))) + (define header (next-row)) + (define (row->seed! row) + (define row-alist (map cons header row)) + (define canonical-name (cdr (assoc "Libellé" row-alist))) + (define brand-name (cdr (assoc "Nom commercial" row-alist))) + (define nutrient-values + (for/list ([fertilizer-component (in-list (list-tail row-alist 3))]) + (define formula (car fertilizer-component)) + (define n (get-nutrient #:formula formula)) + (define v (string->number (cdr fertilizer-component))) + (cons n v))) + (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))) + +(module+ test + (require "migrations.rkt") + (connect! #:path "test.sqlite3" + ) + (migrate-all!) + (seed-database!)) diff --git a/formlets.rkt b/formlets.rkt new file mode 100644 index 0000000..406a54a --- /dev/null +++ b/formlets.rkt @@ -0,0 +1,53 @@ +#lang racket + +(provide measurements-formlet) + +(require gregor + web-server/http + web-server/formlets + "models/nutrient.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)) + +(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))))) + +(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)))) diff --git a/handlers.rkt b/handlers.rkt new file mode 100644 index 0000000..42e4a76 --- /dev/null +++ b/handlers.rkt @@ -0,0 +1,48 @@ +#lang racket + +(provide app-dispatch) + +(require web-server/dispatch + web-server/http + web-server/formlets + "views.rkt" + "formlets.rkt" + "models/nutrient.rkt" + "models/nutrient-measurement.rkt") + + +(define (index _) + (define measurements (get-nutrient-measurements)) + (response/xexpr + #:preamble #"<!DOCTYPE html>" + (index-page measurements))) + +(define (new-measurement _) + (response/xexpr + #:preamble #"<!DOCTYPE html>" + (new-measurement-page))) + +(define (create-measurement req) + (define-values (measured-on measurements) + (formlet-process (measurements-formlet) req)) + (create-nutrient-measurement! measured-on measurements) + (redirect-to "/")) + +(define (destroy-measurement req) + (define-values (measured-on measurements) + (formlet-process (measurements-formlet) req)) + (create-nutrient-measurement! measured-on measurements) + (redirect-to "/")) + +(define (fallback req) + (response/xexpr + #:preamble #"<!DOCTYPE html>" + (fallback-page 404))) + +(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])) diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..7b6c25e --- /dev/null +++ b/main.rkt @@ -0,0 +1,14 @@ +#lang racket + +(require web-server/dispatch + "handlers.rkt" + "db/conn.rkt" + "db/migrations.rkt" + "db/seed.rkt") + +(module+ main + (connect! #:path "storage/development.sqlite3") + (migrate-all!) + (seed-database!) + (serve/dispatch + app-dispatch)) diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt new file mode 100644 index 0000000..f213441 --- /dev/null +++ b/models/crop-requirement.rkt @@ -0,0 +1,180 @@ +#lang racket + +(provide + ;; Struct definitions + crop-requirement + crop-requirement? + crop-requirement-id crop-requirement-profile + ;; SQL CRUD + (contract-out + [create-crop-requirement! (->* (string? + (listof (cons/c + nutrient? + number?))) + ((or/c #f crop?)) + crop-requirement?)] + [get-crop-requirements (->* () + (#:id + (or/c #f exact-nonnegative-integer?) + #:profile + (or/c #f string?)) + (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 (cons/c + nutrient? + number?)))] + [get-crop-requirement-value (-> crop-requirement? + nutrient? + number?)] + [get-latest-crop-requirement-value (-> nutrient? number?)] + #; [update-crop-requirement! (->* (crop-requirement?) + (#:profile (or/c #f string?) + #:nutrient-values (or/c #f (listof (cons/c + nutrient? + number?)))) + (or/c crop-requirement? #f))] + [delete-crop-requirement! (-> crop-requirement? + void?)])) + +(require racket/contract + db + sql + "../db/conn.rkt" + "nutrient.rkt" + "crop.rkt") + +;; Instances of this struct are persisted in the crop_requirements table. +(struct crop-requirement (id profile) #:transparent) + + +;; CREATE + + +(define (create-crop-requirement! profile nutrient-values [crop #f]) + (define existing-crop-requirement (get-crop-requirement #:profile profile)) + (define (new-crop-requirement) + (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 nv + [(cons n v) + (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)) + (or existing-crop-requirement + (new-crop-requirement))) + + +;; READ + +(define (get-crop-requirements #:id [id #f] + #:profile [profile #f]) + (define (where-expr) + (define clauses + (filter values + (list (and id (format "id = ~e" id)) + (and profile (format "profile = ~e" profile))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, profile" + "FROM crop_requirements" + ,(where-expr) + "ORDER BY id ASC"))) + (for/list ([(id* profile*) + (in-query (current-conn) query)]) + (crop-requirement id* profile*))) + +(define (get-crop-requirement #:id [id #f] + #:profile [profile #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and profile (format "profile = ~e" profile))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, profile" + "FROM crop_requirements" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + (match (query-maybe-row (current-conn) query) + [(vector id* profile*) + (crop-requirement id* profile*)] + [#f #f])) + +(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")) + (crop-requirement-id crop-requirement))]) + (cons (nutrient nutrient-id name formula) value_ppm))) + +(define (get-crop-requirement-value crop-requirement nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT 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" + "WHERE cr.id = $1 AND nv.nutrient_id = $2")) + (crop-requirement-id crop-requirement) + (nutrient-id nutrient))) + +(define (get-latest-crop-requirement-value nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT 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" + "WHERE nv.nutrient_id = $1" + "ORDER BY cr.profile DESC" + "LIMIT 1")) + (nutrient-id nutrient))) + + +;; 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)))) diff --git a/models/crop.rkt b/models/crop.rkt new file mode 100644 index 0000000..7163cbd --- /dev/null +++ b/models/crop.rkt @@ -0,0 +1,103 @@ +#lang racket + +(provide + ;; Struct definitions + crop + crop? + crop-id crop-name + ;; SQL CRUD + (contract-out + [create-crop! (-> string? void?)] + [get-crops (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:name (or/c #f string?)) + (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 + sql + "../db/conn.rkt") + +(struct crop (id name) #:transparent) + + +;; CREATE + +(define (create-crop! name) + (query-exec (current-conn) + (insert #:into crops + #:set [canonical_name ,name]))) + + +;; READ + +(define (get-crops #:id [id #f] + #:name [name #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and name (format "canonical_name = ~e" name))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, canonical_name" + "FROM crops" + ,(where-expr) + "ORDER BY id ASC"))) + (for/list ([(id* name*) + (in-query (current-conn) query)]) + (crop id* name*))) + +(define (get-crop #:id [id #f] + #:name [name #f]) + (define (where-expr) + (define clauses + (filter values + (list (and id (format "id = ~e" id)) + (and name (format "canonical_name = ~e" name))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, canonical_name" + "FROM crops" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + (match (query-maybe-row (current-conn) query) + [(vector id* name*) + (crop id* name*)] + [#f #f])) + + +;; UPDATE + +(define (update-crop! id + #:name [name #f]) + (cond + [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))) + + +;; DELETE + +(define (delete-crop! id) + (query-exec (current-conn) + (delete #:from crops #:where (= id ,id)))) diff --git a/models/fertilizer-product.rkt b/models/fertilizer-product.rkt new file mode 100644 index 0000000..254ce35 --- /dev/null +++ b/models/fertilizer-product.rkt @@ -0,0 +1,177 @@ +#lang racket + +(provide + ;; Struct definitions + fertilizer-product + fertilizer-product? + fertilizer-product-id fertilizer-product-brand-name + ;; SQL CRUD + (contract-out + [create-fertilizer-product! (->* (string? + (listof (cons/c + nutrient? + number?))) + (string?) + fertilizer-product?)] + [get-fertilizer-products (->* () + (#:id + (or/c #f exact-nonnegative-integer?) + #:brand-name + (or/c #f string?)) + (listof fertilizer-product?))] + [get-fertilizer-product (->* () + (#:id + (or/c #f exact-nonnegative-integer?) + #:brand-name + (or/c #f string?)) + (or/c fertilizer-product? #f))] + [get-fertilizer-product-values (-> fertilizer-product? + (listof (cons/c + nutrient? + number?)))] + [get-fertilizer-product-value (-> fertilizer-product? + nutrient? + number?)] + [get-latest-fertilizer-product-value (-> nutrient? number?)] + [delete-fertilizer-product! (-> fertilizer-product? + void?)])) + +(require racket/contract + db + sql + "../db/conn.rkt" + "nutrient.rkt") + +;; Instances of this struct are persisted in the fertilizer_products table. +(struct fertilizer-product (id canonical-name brand-name) #:transparent) + + +;; CREATE + + +(define (create-fertilizer-product! canonical-name nutrient-values [brand-name #f]) + (define existing-fertilizer-product (get-fertilizer-product #:canonical-name canonical-name)) + (define (new-fertilizer-product) + (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 nm-id (fertilizer-product-id (get-fertilizer-product #:canonical-name canonical-name))) + (query-exec (current-conn) + (insert #:into nutrient_value_sets + #:set [fertilizer_product_id ,nm-id])) + (define nvs-id (query-value (current-conn) + (select id + #:from nutrient_value_sets + #:where (= fertilizer_product_id ,nm-id)))) + (for ([nv nutrient-values]) + (match nv + [(cons n v) + (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 existing-fertilizer-product + (new-fertilizer-product))) + + +;; READ + +(define (get-fertilizer-products #:id [id #f] + #:brand-name [brand-name #f]) + (define (where-expr) + (define clauses + (filter values + (list (and id (format "id = ~e" id)) + (and brand-name (format "brand_name = ~e" brand-name))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, brand_name" + "FROM fertilizer_products" + ,(where-expr) + "ORDER BY id ASC"))) + (for/list ([(id* brand-name*) + (in-query (current-conn) query)]) + (fertilizer-product id* brand-name*))) + +(define (get-fertilizer-product #:id [id #f] + #:canonical-name [canonical-name #f] + #:brand-name [brand-name #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and canonical-name (format "canonical_name = ~e" canonical-name)) + (and brand-name (format "brand_name = ~e" brand-name))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (match (query-maybe-row (current-conn) + (string-join + `("SELECT id, canonical_name, brand_name" + "FROM fertilizer_products" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + [(vector id* canonical-name* brand-name*) + (fertilizer-product id* canonical-name* brand-name*)] + [#f #f])) + +(define (get-fertilizer-product-values fertilizer-product) + (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 fertilizer_products nm ON nm.id = nvs.fertilizer_product_id" + "JOIN nutrients n ON n.id = nv.nutrient_id" + "WHERE nm.id = $1")) + (fertilizer-product-id fertilizer-product))]) + (cons (nutrient nutrient-id name formula) value_ppm))) + +(define (get-fertilizer-product-value fertilizer-product nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN fertilizer_products nm ON nm.id = nvs.fertilizer_product_id" + "WHERE nm.id = $1 AND nv.nutrient_id = $2")) + (fertilizer-product-id fertilizer-product) + (nutrient-id nutrient))) + +(define (get-latest-fertilizer-product-value nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN fertilizer_products nm ON nm.id = nvs.fertilizer_product_id" + "WHERE nv.nutrient_id = $1" + "ORDER BY nm.brand_name DESC" + "LIMIT 1")) + (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)))) diff --git a/models/nutrient-measurement.rkt b/models/nutrient-measurement.rkt new file mode 100644 index 0000000..8364aa7 --- /dev/null +++ b/models/nutrient-measurement.rkt @@ -0,0 +1,212 @@ +#lang racket + +(provide + ;; Struct definitions + nutrient-measurement + nutrient-measurement? + nutrient-measurement-id nutrient-measurement-measured-on + ;; SQL CRUD + (contract-out + [create-nutrient-measurement! (-> string? + (listof (cons/c + nutrient? + number?)) + nutrient-measurement?)] + [get-nutrient-measurements (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:measured-on (or/c #f string?)) + (listof nutrient-measurement?))] + [get-nutrient-measurement (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:measured-on (or/c #f string?)) + (or/c nutrient-measurement? #f))] + [get-nutrient-measurement-values (-> nutrient-measurement? + (listof (cons/c + nutrient? + number?)))] + [get-nutrient-measurement-value (-> nutrient-measurement? + nutrient? + number?)] + [get-latest-nutrient-measurement-value (-> nutrient? number?)] + #; [update-nutrient-measurement! (->* (nutrient-measurement?) + (#:measured-on (or/c #f string?) + #:nutrient-values (or/c #f (listof (cons/c + nutrient? + number?)))) + (or/c nutrient-measurement? #f))] + [delete-nutrient-measurement! (-> nutrient-measurement? + void?)])) + +(require racket/contract + db + sql + "../db/conn.rkt" + "nutrient.rkt") + +;; Instances of this struct are persisted in the nutrient_measurements table. +(struct nutrient-measurement (id measured-on) #:transparent) + + +;; CREATE + +(define (create-nutrient-measurement! measured-on nutrient-values) + (define existing-nutrient-measurement (get-nutrient-measurement #:measured-on measured-on)) + (define (new-nutrient-measurement) + (with-tx + (query-exec (current-conn) + (insert #:into nutrient_measurements + #:set [measured_on ,measured-on])) + (define nm-id (nutrient-measurement-id (get-nutrient-measurement #: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 nv + [(cons n v) + (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 existing-nutrient-measurement + (new-nutrient-measurement))) + + +;; READ + +(define (get-nutrient-measurements #:id [id #f] + #:measured-on [measured-on #f]) + (define (where-expr) + (define clauses + (filter values + (list (and id (format "id = ~e" id)) + (and measured-on (format "measured_on = ~e" measured-on))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, measured_on" + "FROM nutrient_measurements" + ,(where-expr) + "ORDER BY id ASC"))) + (for/list ([(id* measured-on*) + (in-query (current-conn) query)]) + (nutrient-measurement id* measured-on*))) + +(define (get-nutrient-measurement #:id [id #f] + #:measured-on [measured-on #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and measured-on (format "measured_on = ~e" measured-on))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, measured_on" + "FROM nutrient_measurements" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + (match (query-maybe-row (current-conn) query) + [(vector id* measured-on*) + (nutrient-measurement id* measured-on*)] + [#f #f])) + +(define (get-nutrient-measurement-values nutrient-measurement) + (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 nutrient_measurements nm ON nm.id = nvs.nutrient_measurement_id" + "JOIN nutrients n ON n.id = nv.nutrient_id" + "WHERE nm.id = $1")) + (nutrient-measurement-id nutrient-measurement))]) + (cons (nutrient nutrient-id name formula) value_ppm))) + +(define (get-nutrient-measurement-value nutrient-measurement nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN nutrient_measurements nm ON nm.id = nvs.nutrient_measurement_id" + "WHERE nm.id = $1 AND nv.nutrient_id = $2")) + (nutrient-measurement-id nutrient-measurement) + (nutrient-id nutrient))) + +(define (get-latest-nutrient-measurement-value nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN nutrient_measurements nm ON nm.id = nvs.nutrient_measurement_id" + "WHERE nv.nutrient_id = $1" + "ORDER BY nm.measured_on DESC" + "LIMIT 1")) + (nutrient-id nutrient))) + + +;; UPDATE + +#; (define (update-nutrient-measurement! nutrient-measurement + #:measured-on [measured-on #f] + #:nutrient-values [nutrient-values '()]) + (define nm-id (nutrient-measurement-id nutrient-measurement)) + (define (nvs-id nm-id) + (query-maybe-row (current-conn) + (select id + #:from nutrient_value_sets + #:where (= nutrient_measurement_id ,nm-id)))) + (with-tx + (when measured-on + (query-exec (current-conn) + (update nutrient_measurements + #:set [measured_on ,measured-on] + #:where (= id ,id)))) + (unless (null? nutrient-values) + (upsert-nutrient-values nm-id)) + (get-nutrient-measurement #:id id))) + +#; (define (upsert-nutrient-values nutrient-measurement-id) + (define maybe-nvs-id (nvs-id nm-id)) + (case maybe-nvs-id + [(#f) + (query-exec (current-conn) + (insert #:into nutrient_values_sets + #:set + [nutrient_measurement_id ,id])) + (define new-nvs-id (nvs-id nm-id)) + (query-exec (current-conn) + (string-join + '("INSERT INTO nutrient_values" + "VALUES $1 $2 $3" + "")) + new-nvs-id + )] + [else + (query-exec (current-conn) + (update nutrient_measurement_values + #:set [value ,value] + #:where (and (= measurement_id ,measurement-id) + (= nutrient_id ,nutrient-id))))])) + + +;; 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)))) diff --git a/models/nutrient-target.rkt b/models/nutrient-target.rkt new file mode 100644 index 0000000..6483997 --- /dev/null +++ b/models/nutrient-target.rkt @@ -0,0 +1,217 @@ +#lang racket + +(provide + ;; Struct definitions + nutrient-target + nutrient-target? + nutrient-target-id nutrient-target-effective-on + ;; SQL CRUD + (contract-out + [create-nutrient-target! (-> string? + (listof (cons/c + nutrient? + number?)) + nutrient-target?)] + [get-nutrient-targets (->* () + (#:id + (or/c #f exact-nonnegative-integer?) + #:effective-on + (or/c #f string?)) + (listof nutrient-target?))] + [get-nutrient-target (->* () + (#:id + (or/c #f exact-nonnegative-integer?) + #:effective-on + (or/c #f string?)) + (or/c nutrient-target? #f))] + [get-nutrient-target-values (-> nutrient-target? + (listof (cons/c + nutrient? + number?)))] + [get-nutrient-target-value (-> nutrient-target? + nutrient? + number?)] + [get-latest-nutrient-target-value (-> nutrient? number?)] + #; [update-nutrient-target! (->* (nutrient-target?) + (#:effective-on (or/c #f string?) + #:nutrient-values (or/c #f (listof (cons/c + nutrient? + number?)))) + (or/c nutrient-target? #f))] + [delete-nutrient-target! (-> nutrient-target? + void?)])) + +(require racket/contract + db + sql + "../db/conn.rkt" + "nutrient.rkt") + +;; Instances of this struct are persisted in the nutrient_targets table. +(struct nutrient-target (id effective-on) #:transparent) + + +;; CREATE + + +(define (create-nutrient-target! effective-on nutrient-values) + (define existing-nutrient-target (get-nutrient-target #:effective-on effective-on)) + (define (new-nutrient-target) + (with-tx + (query-exec (current-conn) + (insert #:into nutrient_targets + #:set [effective_on ,effective-on])) + (define nm-id (nutrient-target-id (get-nutrient-target #:effective-on effective-on))) + (query-exec (current-conn) + (insert #:into nutrient_value_sets + #:set [nutrient_target_id ,nm-id])) + (define nvs-id (query-value (current-conn) + (select id + #:from nutrient_value_sets + #:where (= nutrient_target_id ,nm-id)))) + (for ([nv nutrient-values]) + (match nv + [(cons n v) + (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)) + (or existing-nutrient-target + (new-nutrient-target))) + + +;; READ + +(define (get-nutrient-targets #:id [id #f] + #:effective-on [effective-on #f]) + (define (where-expr) + (define clauses + (filter values + (list (and id (format "id = ~e" id)) + (and effective-on (format "effective_on = ~e" effective-on))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, effective_on" + "FROM nutrient_targets" + ,(where-expr) + "ORDER BY id ASC"))) + (for/list ([(id* effective-on*) + (in-query (current-conn) query)]) + (nutrient-target id* effective-on*))) + +(define (get-nutrient-target #:id [id #f] + #:effective-on [effective-on #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and effective-on (format "effective_on = ~e" effective-on))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT id, effective_on" + "FROM nutrient_targets" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + (match (query-maybe-row (current-conn) query) + [(vector id* effective-on*) + (nutrient-target id* effective-on*)] + [#f #f])) + +(define (get-nutrient-target-values nutrient-target) + (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 nutrient_targets nm ON nm.id = nvs.nutrient_target_id" + "JOIN nutrients n ON n.id = nv.nutrient_id" + "WHERE nm.id = $1")) + (nutrient-target-id nutrient-target))]) + (cons (nutrient nutrient-id name formula) value_ppm))) + +(define (get-nutrient-target-value nutrient-target nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN nutrient_targets nm ON nm.id = nvs.nutrient_target_id" + "WHERE nm.id = $1 AND nv.nutrient_id = $2")) + (nutrient-target-id nutrient-target) + (nutrient-id nutrient))) + +(define (get-latest-nutrient-target-value nutrient) + (query-maybe-value (current-conn) + (string-join + '("SELECT value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN nutrient_targets nm ON nm.id = nvs.nutrient_target_id" + "WHERE nv.nutrient_id = $1" + "ORDER BY nm.effective_on DESC" + "LIMIT 1")) + (nutrient-id nutrient))) + + +;; UPDATE + +#; (define (update-nutrient-target! nutrient-target + #:effective-on [effective-on #f] + #:nutrient-values [nutrient-values '()]) + (define nm-id (nutrient-target-id nutrient-target)) + (define (nvs-id nm-id) + (query-maybe-row (current-conn) + (select id + #:from nutrient_value_sets + #:where (= nutrient_target_id ,nm-id)))) + (with-tx + (when effective-on + (query-exec (current-conn) + (update nutrient_targets + #:set [effective_on ,effective-on] + #:where (= id ,id)))) + (unless (null? nutrient-values) + (upsert-nutrient-values nm-id)) + (get-nutrient-target #:id id))) + +#; (define (upsert-nutrient-values nutrient-target-id) + (define maybe-nvs-id (nvs-id nm-id)) + (case maybe-nvs-id + [(#f) + (query-exec (current-conn) + (insert #:into nutrient_values_sets + #:set + [nutrient_target_id ,id])) + (define new-nvs-id (nvs-id nm-id)) + (query-exec (current-conn) + (string-join + '("INSERT INTO nutrient_values" + "VALUES $1 $2 $3" + "")) + new-nvs-id + )] + [else + (query-exec (current-conn) + (update nutrient_target_values + #:set [value ,value] + #:where (and (= target_id ,target-id) + (= nutrient_id ,nutrient-id))))])) + + +;; 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)))) diff --git a/models/nutrient-value-set.rkt b/models/nutrient-value-set.rkt new file mode 100644 index 0000000..5f3759a --- /dev/null +++ b/models/nutrient-value-set.rkt @@ -0,0 +1,98 @@ +#lang racket + +(provide nutrient-value-set + nutrient-value-set? + nutrient-value-set-id + ;; nutrient-value-set-nm-id + ;; nutrient-value-set-nt-id + ;; nutrient-value-set-cr-id + ;; nutrient-value-set-fp-id + ;; SQL CRUD + (contract-out + [create-nutrient-value-set! (-> symbol? + exact-nonnegative-integer? + (listof (cons/c + nutrient? + number?)) + void?)] + [get-nutrient-value-set (->* () + (#:id exact-nonnegative-integer? + #:nutrient-measurement-id exact-nonnegative-integer? + #:nutrient-target-id exact-nonnegative-integer? + #:crop-requirement-id exact-nonnegative-integer? + #:fertilizer-product-id exact-nonnegative-integer?) + (or/c nutrient-value-set? #f))])) + +(require racket/contract + db + sql + "../db/conn.rkt" + "nutrient.rkt") + +(struct nutrient-value-set (id nm-id nt-id cr-id fp-id) #:transparent) + + +;; CREATE + +(define (create-nutrient-value-set! type id nutrient-values) + (define nvs (case type + [(nutrient-measurement) + (query-exec (current-conn) + (insert #:into nutrient_value_sets + #:set [nutrient_measurement_id ,id])) + (get-nutrient-value-set #:nutrient-measurement-id id)] + [(nutrient-target) + (query-exec (current-conn) + (insert #:into nutrient_value_sets + #:set [nutrient_target_id ,id])) + (get-nutrient-value-set #:nutrient-target-id id)] + [(crop-requirement) + (query-exec (current-conn) + (insert #:into nutrient_value_sets + #:set [crop_requirement_id ,id])) + (get-nutrient-value-set #:crop-requirement-id id)] + [(fertilizer-product) + (query-exec (current-conn) + (insert #:into nutrient_value_sets + #:set [fertilizer_product_id ,id])) + (get-nutrient-value-set #:fertilizer-product-id id)])) + (for ([nv nutrient-values]) + (match nv + [(cons n v) + (query-exec (current-conn) + (insert #:into nutrient_values + #:set + [value_set_id ,(nutrient-value-set-id nvs)] + [nutrient_id ,(nutrient-id n)] + [value_ppm ,v]))]))) + + +;; READ + +(define (get-nutrient-value-set #:id [id #f] + #:nutrient-measurement-id [nm #f] + #:nutrient-target-id [nt #f] + #:crop-requirement-id [cr #f] + #:fertilizer-product-id [fp #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and nm (format "nutrient_measurement_id = ~e" nm)) + (and nt (format "nutrient_target_id = ~e" nt)) + (and cr (format "crop_requirement = ~e" cr)) + (and fp (format "fertilizer_product = ~e" fp))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (define query (string-join + `("SELECT *" + "FROM nutrient_value_sets" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + (match (query-maybe-row (current-conn) query) + [(vector id* nm-id* nt-id* cr-id* fp-id*) + (nutrient-value-set id* nm-id* nt-id* cr-id* fp-id*)] + [#f #f])) diff --git a/models/nutrient.rkt b/models/nutrient.rkt new file mode 100644 index 0000000..5a32e70 --- /dev/null +++ b/models/nutrient.rkt @@ -0,0 +1,123 @@ +#lang racket + +(provide + ;; Struct definitions + nutrient + nutrient? + nutrient-id nutrient-name nutrient-formula + ;; SQL CRUD + (contract-out + [create-nutrient! (-> string? string? void?)] + [get-nutrients (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:name (or/c #f string?) + #:formula (or/c #f string?)) + (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 + sql + "../db/conn.rkt") + +(struct nutrient (id name formula) #:transparent) + + +;; CREATE + +(define (create-nutrient! name formula) + (query-exec (current-conn) + (insert #:into nutrients + #:set [canonical_name ,name] [formula ,formula]))) + + +;; READ + +(define (get-nutrients #:id [id #f] + #:name [name #f] + #:formula [formula #f]) + (define (where-expr) + (define clauses + (filter values + (list + (and id (format "id = ~e" id)) + (and name (format "canonical_name = ~e" name)) + (and formula (format "formula = ~e" formula))))) + (cond + [(null? clauses) ""] + [else (format "WHERE ~a" (string-join clauses " AND "))])) + (for/list ([(id* name* formula*) + (in-query (current-conn) + (string-join + `("SELECT id, canonical_name, formula" + "FROM nutrients" + ,(where-expr) + "ORDER BY id ASC")))]) + (nutrient id* name* formula*))) + +(define (get-nutrient #:id [id #f] + #:name [name #f] + #:formula [formula #f]) + (define (where-expr) + (define clauses + (filter values + (list (and id (format "id = ~e" id)) + (and name (format "canonical_name = ~e" name)) + (and formula (format "formula = ~e" formula))))) + (cond + [(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*)] + [#f #f])) + + +;; UPDATE + +(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)))] + [name + (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)))] + [else (void)]) + (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))))) diff --git a/storage/.gitignore b/storage/.gitignore new file mode 100644 index 0000000..6e9bc0c --- /dev/null +++ b/storage/.gitignore @@ -0,0 +1 @@ +*.sqlite3
\ No newline at end of file diff --git a/tests/nutrient-measurement-model.rkt b/tests/nutrient-measurement-model.rkt new file mode 100644 index 0000000..b0b053d --- /dev/null +++ b/tests/nutrient-measurement-model.rkt @@ -0,0 +1,72 @@ +#lang racket + +(module+ test + (require rackunit + rackunit/text-ui + "../db/conn.rkt" + "../db/migrations.rkt" + "../models/nutrient.rkt" + "../models/nutrient-measurement.rkt") + + (define measured-on "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-case "Create measurement with values" + (define nitrogen (get-nutrient #:name "Nitrogen")) + (define phosphorus (get-nutrient #:name "Phosphorus")) + (create-nutrient-measurement! measured-on (list + (cons nitrogen 12.3) + (cons phosphorus 4.5))) + (check-equal? (length (get-nutrient-measurements)) 1) + (define nm (get-nutrient-measurement #:measured-on measured-on)) + (check-true (nutrient-measurement? nm)) + (check-equal? (nutrient-measurement-measured-on nm) measured-on) + (define mvs (get-nutrient-measurement-values nm)) + (check-equal? (length mvs) 2) + (check-equal? (cdr (assoc nitrogen mvs)) 12.3) + (check-equal? (cdr (assoc phosphorus mvs)) 4.5) + ) + + #;(test-case "Update a single measurement value" + (define nitrogen (get-nutrient #:name "Nitrogen")) + (define nm (get-nutrient-measurement #:measured-on measured-on)) + (update-nutrient-measurement! nm #:nutrient-values (list (cons nitrogen 1.1))) + (define mvs (get-nutrient-measurement-values nm)) + (check-equal? (length mvs) 2) + (check-equal? (cdr (assoc nitrogen mvs)) 1.1)) + + #;(test-case "Upsert measurement values" + (define nitrogen (get-nutrient #:name "Nitrogen")) + (define phosphorus (get-nutrient #:name "Phosphorus")) + (define potassium (get-nutrient #:name "Potassium")) + (define nm (get-nutrient-measurement #:measured-on measured-on)) + ;; Upsert: set K=8.8 and change N to 10.0, keep P as-is + (update-nutrient-measurement! nm + #:nutrient-values (list + (cons nitrogen 10.0) + (cons potassium 8.8))) + (define mvs (get-nutrient-measurement-values nm)) + (check-equal? (length mvs) 3) + (check-equal? (cdr (assoc nitrogen mvs)) 10.0) + (check-equal? (cdr (assoc potassium mvs)) 8.8) + ;; P should still be present at 4.5 + (check-equal? (cdr (assoc phosphorus mvs)) 4.5)) + + (test-case "Delete measurement cascades its values" + (define nm (get-nutrient-measurement #:measured-on measured-on)) + (delete-nutrient-measurement! nm) + (check-false (get-nutrient-measurement #:id (nutrient-measurement-id nm))) + (check-equal? (length (get-nutrient-measurements)) 0) + (check-true (null? (get-nutrient-measurement-values nm))))))) diff --git a/tests/nutrient-model.rkt b/tests/nutrient-model.rkt new file mode 100644 index 0000000..39a574c --- /dev/null +++ b/tests/nutrient-model.rkt @@ -0,0 +1,76 @@ +#lang racket + +(module+ test + (require rackunit + rackunit/text-ui + "../db/conn.rkt" + "../db/migrations.rkt" + "../models/nutrient.rkt") + + (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 "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 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 "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 "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 new file mode 100644 index 0000000..d78c370 --- /dev/null +++ b/views.rkt @@ -0,0 +1,152 @@ +#lang racket + +(provide index-page + new-measurement-page + fallback-page) + +(require web-server/formlets + "formlets.rkt" + "models/nutrient.rkt" + "models/nutrient-measurement.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"]))))) + + +;; Page components + +(define navbar + '(nav ([class "navbar"]) + (div ([class "container-fluid"]) + (a ([class "navbar-brand"] [href "/"]) "FAPG") + (button ([class "navbar-toggler"] + [type "button"] + [data-bs-toggle "collapse"] + [data-bs-target "#navbarNav"] + [aria-controls "navbarNav"] + [aria-expanded "false"] + [aria-label "Toggle navigation"]) + (span ([class "navbar-toggler-icon"]))) + (div ([class "collapse navbar-collapse"] [id "navbarNav"]) + (ul ([class "navbar-nav"]) + (li ([class "nav-item"]) + (a ([class "nav-link active"] + [aria-current "page"] + [href "/"]) + "Home")) + (li ([class "nav-item"]) + (a ([class "nav-link"] + [href "/about"]) + "About")) + (li ([class "nav-item"]) + (a ([class "nav-link"] + [href "/contact"]) + "Contact"))))))) + + +;; Page helpers + +(define (round n number) + (~r number #:precision n)) + + +;; Pages + +(define (index-page measurements) + (page-template + "Ferti" + `((h1 ([class "display-1 mb-3"]) "Ferti") + (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"]) "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))) + `(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))))) + + (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")) + ,@(for/list ([m measurements]) + (define measured-on (nutrient-measurement-measured-on m)) + (define-values (n p k) + (apply values + (for/list ([nutrient '("Nitrate Nitrogen" "Phosphorus" "Potassium")]) + (define n (get-nutrient #:name nutrient)) + (define mnv (get-nutrient-measurement-value m n)) + (if (real? mnv) + (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))))))) + +(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))))))) + +(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")))) + +(define (fallback-message request-code) + (string-join + `("Bonjour, je suis votre serveur." + ,(format "J'ai répondu '~a'" request-code) + "et" + ,(case (string-ref (number->string request-code) 0) + [(#\4) "c'est de votre faute, malheureusement."] + [(#\5) "c'est de ma faute, pardonnez-moi."] + [else "je ne sais pas qui est en tort."]) + ,(case request-code + ;; Client errors + [(400) "Votre requête ne fait pas sens."] + [(401) "Vous n'avez pas vérifié votre identité."] + [(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."] + ;; Fallback message + [else (format "Je ne sais pas encore interpréter le code ~a." request-code)])))) |