From 3008eb25f79ef1ed54fcc2b3f5b6635b34394680 Mon Sep 17 00:00:00 2001 From: Marius Peter Date: Sun, 19 Oct 2025 21:15:18 +0200 Subject: Absorb existing domain data. --- models/crop-requirement.rkt | 180 +++++++++++++++++++++++++++++++++ models/crop.rkt | 103 +++++++++++++++++++ models/fertilizer-product.rkt | 177 ++++++++++++++++++++++++++++++++ models/nutrient-measurement.rkt | 212 +++++++++++++++++++++++++++++++++++++++ models/nutrient-target.rkt | 217 ++++++++++++++++++++++++++++++++++++++++ models/nutrient-value-set.rkt | 98 ++++++++++++++++++ models/nutrient.rkt | 123 +++++++++++++++++++++++ 7 files changed, 1110 insertions(+) create mode 100644 models/crop-requirement.rkt create mode 100644 models/crop.rkt create mode 100644 models/fertilizer-product.rkt create mode 100644 models/nutrient-measurement.rkt create mode 100644 models/nutrient-target.rkt create mode 100644 models/nutrient-value-set.rkt create mode 100644 models/nutrient.rkt (limited to 'models') 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))))) -- cgit v1.2.3