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/nutrient-target.rkt | 217 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 217 insertions(+) create mode 100644 models/nutrient-target.rkt (limited to 'models/nutrient-target.rkt') 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)))) -- cgit v1.2.3