Absorb existing domain data.

1 files changed, 217 insertions, 0 deletions

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))))