diff options
Diffstat (limited to 'models')
| -rw-r--r-- | models/crop-requirement.rkt | 121 | ||||
| -rw-r--r-- | models/crop.rkt | 91 | ||||
| -rw-r--r-- | models/fertilizer-product.rkt | 224 | ||||
| -rw-r--r-- | models/nutrient-measurement.rkt | 86 | ||||
| -rw-r--r-- | models/nutrient-target.rkt | 152 | ||||
| -rw-r--r-- | models/nutrient.rkt | 109 | ||||
| -rw-r--r-- | models/user.rkt | 24 |
7 files changed, 348 insertions, 459 deletions
diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt index e5f8ae6..8d99434 100644 --- a/models/crop-requirement.rkt +++ b/models/crop-requirement.rkt @@ -1,29 +1,29 @@ #lang racket -(provide - ;; Model struct - crop-requirement - crop-requirement? - crop-requirement-id crop-requirement-profile crop-requirement-crop-id - (contract-out - ;; SQL CRUD - [create-crop-requirement! (->* (string? - (listof nutrient-value-pair/c)) - ((or/c #f crop?)) - crop-requirement?)] - [get-crop-requirements (-> (listof crop-requirement?))] - [get-crop-requirement (->* () - (#:id (or/c #f exact-nonnegative-integer?) - #:profile (or/c #f string?)) - (or/c crop-requirement? #f))] - [get-crop-requirement-values (-> crop-requirement? (listof nutrient-value-pair/c))] - [get-crop-requirement-value (-> crop-requirement? nutrient? number?)] - [get-latest-crop-requirement-value (-> nutrient? number?)] - [delete-crop-requirement! (-> crop-requirement? void?)] - ;; Helpers - [average-crop-requirement-nutrient-values (-> (listof (cons/c crop-requirement? - (and/c real? (>=/c 0) (<=/c 100)))) - (listof nutrient-value-pair/c))])) +;; Model struct +(provide crop-requirement + crop-requirement? + crop-requirement-id + crop-requirement-profile + crop-requirement-crop-id + (rename-out [crop-requirement-nutrient-values crop-requirement-values]) + (contract-out + ;; SQL CRUD + [create-crop-requirement! + (->* (string? (listof nutrient-value-pair/c)) ((or/c #f crop?)) crop-requirement?)] + [get-crop-requirements (-> (listof crop-requirement?))] + [get-crop-requirement + (->* () + (#:id (or/c #f exact-nonnegative-integer?) #:profile (or/c #f string?)) + (or/c crop-requirement? #f))] + [get-crop-requirement-values (-> crop-requirement? (listof nutrient-value-pair/c))] + [get-crop-requirement-value (-> crop-requirement? nutrient? number?)] + [get-latest-crop-requirement-value (-> nutrient? number?)] + [delete-crop-requirement! (-> crop-requirement? void?)] + ;; Helpers + [average-crop-requirement-nutrient-values + (-> (listof (cons/c crop-requirement? (and/c real? (>=/c 0) (<=/c 100)))) + (listof nutrient-value-pair/c))])) (require racket/contract db @@ -41,30 +41,25 @@ (define (create-crop-requirement! profile nutrient-values [crop #f]) (or (get-crop-requirement #:profile profile) (with-tx - (query-exec (current-conn) - (if crop - (insert #:into crop_requirements - #:set [crop_id ,(crop-id crop)] [profile ,profile]) - (insert #:into crop_requirements - #:set [profile ,profile]))) - (define cr-id (crop-requirement-id (get-crop-requirement #:profile profile))) - (query-exec (current-conn) - (insert #:into nutrient_value_sets - #:set [crop_requirement_id ,cr-id])) - (define nvs-id (query-value (current-conn) - (select id - #:from nutrient_value_sets - #:where (= crop_requirement_id ,cr-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) - (query-exec (current-conn) - (insert #:into nutrient_values - #:set - [value_set_id ,nvs-id] - [nutrient_id ,(nutrient-id n)] - [value_ppm ,v]))) - (get-crop-requirement #:profile profile)))) - + (query-exec + (current-conn) + (if crop + (insert #:into crop_requirements #:set [crop_id ,(crop-id crop)] [profile ,profile]) + (insert #:into crop_requirements #:set [profile ,profile]))) + (define cr-id (crop-requirement-id (get-crop-requirement #:profile profile))) + (query-exec (current-conn) + (insert #:into nutrient_value_sets #:set [crop_requirement_id ,cr-id])) + (define nvs-id + (query-value (current-conn) + (select id #:from nutrient_value_sets #:where (= crop_requirement_id ,cr-id)))) + (for ([nv nutrient-values]) + (match-define (cons n v) nv) + (query-exec (current-conn) + (insert #:into nutrient_values + #:set [value_set_id ,nvs-id] + [nutrient_id ,(nutrient-id n)] + [value_ppm ,v]))) + (get-crop-requirement #:profile profile)))) ;; READ @@ -103,13 +98,12 @@ (define (get-crop-requirement-values crop-requirement) (for/list ([(nutrient-id name formula value_ppm) (in-query (current-conn) - (string-join - '("SELECT n.id, n.canonical_name, n.formula, nv.value_ppm" - "FROM nutrient_values nv" - "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" - "JOIN crop_requirements cr ON cr.id = nvs.crop_requirement_id" - "JOIN nutrients n ON n.id = nv.nutrient_id" - "WHERE cr.id = $1")) + (string-join '("SELECT n.id, n.canonical_name, n.formula, nv.value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN crop_requirements cr ON cr.id = nvs.crop_requirement_id" + "JOIN nutrients n ON n.id = nv.nutrient_id" + "WHERE cr.id = $1")) (crop-requirement-id crop-requirement))]) (cons (nutrient nutrient-id name formula) value_ppm))) @@ -139,28 +133,21 @@ ;; UPDATE - ;; DELETE (define (delete-crop-requirement! crop-requirement) (define id (crop-requirement-id crop-requirement)) - (query-exec (current-conn) - (delete #:from crop_requirements - #:where (= id ,id)))) - + (query-exec (current-conn) (delete #:from crop_requirements #:where (= id ,id)))) ;; Helpers (define (average-crop-requirement-nutrient-values mix) (define average-values (for/fold ([acc (hash)]) ([pair (in-list mix)]) - (define crop-requirement (car pair)) - (define percentage (/ (cdr pair) 100)) - (for/fold ([acc acc]) - ([nv (in-list (get-crop-requirement-values crop-requirement))]) + (match-define (cons crop-requirement percentage) pair) + (for/fold ([acc acc]) ([nv (in-list (get-crop-requirement-values crop-requirement))]) (match-define (cons n v) nv) - (hash-update acc n - (λ (old) (+ old (* v percentage))) - (λ () (* v percentage)))))) + (define nutrient-contribution (* v (/ percentage 100))) + (hash-update acc n (λ (old) (+ old nutrient-contribution)) (λ () nutrient-contribution))))) (for/list ([(n v) (in-hash average-values)]) (cons n v))) diff --git a/models/crop.rkt b/models/crop.rkt index 51b332d..edbb7a3 100644 --- a/models/crop.rkt +++ b/models/crop.rkt @@ -1,22 +1,20 @@ #lang racket -(provide - ;; Model struct - crop - crop? - crop-id crop-name - (contract-out - ;; SQL CRUD - [create-crop! (-> string? crop?)] - [get-crops (-> (listof crop?))] - [get-crop (->* () - (#:id (or/c #f exact-nonnegative-integer?) - #:name (or/c #f string?)) - (or/c crop? #f))] - [update-crop! (->* (exact-nonnegative-integer?) - (#:name (or/c #f string?)) - (or/c crop? #f))] - [delete-crop! (-> exact-nonnegative-integer? void?)])) +;; Model struct +(provide crop + crop? + crop-id + crop-name + ;; SQL CRUD + (contract-out [create-crop! (-> string? crop?)] + [get-crops (-> (listof crop?))] + [get-crop + (->* () + (#:id (or/c #f exact-nonnegative-integer?) #:name (or/c #f string?)) + (or/c crop? #f))] + [update-crop! + (->* (exact-nonnegative-integer?) (#:name (or/c #f string?)) (or/c crop? #f))] + [delete-crop! (-> exact-nonnegative-integer? void?)])) (require racket/contract db @@ -25,67 +23,48 @@ (struct crop (id name) #:transparent) - ;; CREATE (define (create-crop! name) (or (get-crop #:name name) (begin - (query-exec (current-conn) - (insert #:into crops - #:set [canonical_name ,name])) + (query-exec (current-conn) (insert #:into crops #:set [canonical_name ,name])) (get-crop #:name name)))) - ;; READ (define (get-crops) - (for/list ([(id* name*) - (in-query (current-conn) - (select id canonical_name - #:from crops - #:order-by id #:asc))]) + (for/list ([(id* name*) (in-query (current-conn) + (select id canonical_name #:from crops #:order-by id #:asc))]) (crop id* name*))) -(define (get-crop #:id [id #f] - #:name [name #f]) +(define (get-crop #:id [id #f] #:name [name #f]) (define where (cond - [(and id name) - (scalar-expr-qq (and (= id ,id) - (= canonical_name ,name)))] - [id - (scalar-expr-qq (= id ,id))] - [name - (scalar-expr-qq (= canonical_name ,name))])) - (define query (select id canonical_name - #:from crops - #:where (ScalarExpr:AST ,where) - #:order-by id #:asc - #:limit 1)) + [(and id name) (scalar-expr-qq (and (= id ,id) (= canonical_name ,name)))] + [id (scalar-expr-qq (= id ,id))] + [name (scalar-expr-qq (= canonical_name ,name))])) + (define query + (select id + canonical_name + #:from crops + #:where (ScalarExpr:AST ,where) + #:order-by id + #:asc + #:limit 1)) (match (query-maybe-row (current-conn) query) - [(vector id* name*) - (crop id* name*)] + [(vector id* name*) (crop id* name*)] [#f #f])) - ;; UPDATE -(define (update-crop! id - #:name [name #f]) +(define (update-crop! id #:name [name #f]) (cond - [name - (query-exec (current-conn) - (update crops - #:set [canonical_name ,name] - #:where (= id ,id)))] + [name (query-exec (current-conn) (update crops #:set [canonical_name ,name] #:where (= id ,id)))] [else (void)]) - (or (get-crop #:id id) - (error 'update-crop! "No crop with id ~a" id))) - + (or (get-crop #:id id) (error 'update-crop! "No crop with id ~a" id))) ;; DELETE (define (delete-crop! id) - (query-exec (current-conn) - (delete #:from crops #:where (= id ,id)))) + (query-exec (current-conn) (delete #:from crops #:where (= id ,id)))) diff --git a/models/fertilizer-product.rkt b/models/fertilizer-product.rkt index 0809f73..225af10 100644 --- a/models/fertilizer-product.rkt +++ b/models/fertilizer-product.rkt @@ -1,29 +1,24 @@ #lang racket -(provide - ;; Model struct - fertilizer-product - fertilizer-product? - fertilizer-product-id - (rename-out - [fertilizer-product-canonical-name fertilizer-name] - [fertilizer-product-nutrient-values fertilizer-product-values] - [fertilizer-product-brand-name fertilizer-brand-name]) - (contract-out - ;; SQL CRUD - [create-fertilizer-product! (->* (string? - (listof nutrient-value-pair/c)) - (string?) - fertilizer-product?)] - [get-fertilizer-products (-> (listof fertilizer-product?))] - [get-fertilizer-product (->* () - (#:id (or/c #f exact-nonnegative-integer?) - #:canonical-name (or/c #f string?)) - (or/c fertilizer-product? #f))] - [get-fertilizer-product-values (-> fertilizer-product? - (listof nutrient-value-pair/c))] - [get-fertilizer-product-value (-> fertilizer-product? nutrient? number?)] - [delete-fertilizer-product! (-> fertilizer-product? void?)])) +;; Model struct +(provide fertilizer-product + fertilizer-product? + fertilizer-product-id + (rename-out [fertilizer-product-canonical-name fertilizer-name] + [fertilizer-product-nutrient-values fertilizer-product-values] + [fertilizer-product-brand-name fertilizer-brand-name]) + (contract-out + ;; SQL CRUD + [create-fertilizer-product! + (->* (string? (listof nutrient-value-pair/c)) (string?) fertilizer-product?)] + [get-fertilizer-products (-> (listof fertilizer-product?))] + [get-fertilizer-product + (->* () + (#:id (or/c #f exact-nonnegative-integer?) #:canonical-name (or/c #f string?)) + (or/c fertilizer-product? #f))] + [get-fertilizer-product-values (-> fertilizer-product? (listof nutrient-value-pair/c))] + [get-fertilizer-product-value (-> fertilizer-product? nutrient? number?)] + [delete-fertilizer-product! (-> fertilizer-product? void?)])) (require racket/contract db @@ -34,123 +29,112 @@ ;; Instances of this struct are persisted in the fertilizer_products table. (struct fertilizer-product (id canonical-name nutrient-values brand-name) #:transparent - #:guard - (λ (id canonical-name nutrient-values brand-name _) - (values id - canonical-name - nutrient-values - (if (sql-null? brand-name) #f brand-name))) + #:guard (λ (id canonical-name nutrient-values brand-name _) + (values id canonical-name nutrient-values (if (sql-null? brand-name) #f brand-name))) #:property prop:custom-write (λ (v out _mode) (fprintf out "Fertilizer #~a\n" (fertilizer-product-id v)) (if (fertilizer-product-brand-name v) - (fprintf out "~a (~a)\n" + (fprintf out + "~a (~a)\n" (fertilizer-product-canonical-name v) (fertilizer-product-brand-name v)) - (fprintf out "~a\n" - (fertilizer-product-canonical-name v))) + (fprintf out "~a\n" (fertilizer-product-canonical-name v))) (for ([nv (in-list (fertilizer-product-nutrient-values v))]) (match-define (cons n v) nv) - (fprintf out "~a ~a\n" + (fprintf out + "~a ~a\n" (~a (nutrient-name n) #:min-width 14) (~a v #:max-width 6 #:align 'right))))) - ;; CREATE (define (create-fertilizer-product! canonical-name nutrient-values [brand-name #f]) - (or (get-fertilizer-product #:canonical-name canonical-name) - (with-tx - (query-exec (current-conn) - (cond - [brand-name - (insert #:into fertilizer_products - #:set [canonical_name ,canonical-name] [brand_name ,brand-name])] - [else - (insert #:into fertilizer_products - #:set [canonical_name ,canonical-name])])) - (define fp-id (query-value (current-conn) - (select id - #:from fertilizer_products - #:where (= canonical_name ,canonical-name)))) - (query-exec (current-conn) - (insert #:into nutrient_value_sets - #:set [fertilizer_product_id ,fp-id])) - (define nvs-id (query-value (current-conn) - (select id - #:from nutrient_value_sets - #:where (= fertilizer_product_id ,fp-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) - (query-exec (current-conn) - (insert #:into nutrient_values - #:set - [value_set_id ,nvs-id] - [nutrient_id ,(nutrient-id n)] - [value_ppm ,v]))) - (get-fertilizer-product #:canonical-name canonical-name)))) - + (or + (get-fertilizer-product #:canonical-name canonical-name) + (with-tx + (query-exec (current-conn) + (cond + [brand-name + (insert #:into fertilizer_products + #:set [canonical_name ,canonical-name] + [brand_name ,brand-name])] + [else (insert #:into fertilizer_products #:set [canonical_name ,canonical-name])])) + (define fp-id + (query-value (current-conn) + (select id #:from fertilizer_products #:where (= canonical_name ,canonical-name)))) + (query-exec (current-conn) + (insert #:into nutrient_value_sets #:set [fertilizer_product_id ,fp-id])) + (define nvs-id + (query-value (current-conn) + (select id #:from nutrient_value_sets #:where (= fertilizer_product_id ,fp-id)))) + (for ([nv nutrient-values]) + (match-define (cons n v) nv) + (query-exec (current-conn) + (insert #:into nutrient_values + #:set [value_set_id ,nvs-id] + [nutrient_id ,(nutrient-id n)] + [value_ppm ,v]))) + (get-fertilizer-product #:canonical-name canonical-name)))) ;; READ (struct acc (canonical-name brand-name pairs) #:transparent) (define joined - (table-expr-qq - (inner-join - (inner-join - (inner-join - (as fertilizer_products fp) - (as nutrient_value_sets nvs) - #:on (= nvs.fertilizer_product_id fp.id)) - (as nutrient_values nv) - #:on (= nv.value_set_id nvs.id)) - (as nutrients n) - #:on (= n.id nv.nutrient_id)))) + (table-expr-qq (inner-join (inner-join (inner-join (as fertilizer_products fp) + (as nutrient_value_sets nvs) + #:on (= nvs.fertilizer_product_id fp.id)) + (as nutrient_values nv) + #:on (= nv.value_set_id nvs.id)) + (as nutrients n) + #:on (= n.id nv.nutrient_id)))) (define (get-fertilizer-products) - (define query (select fp.id fp.canonical_name fp.brand_name - n.id n.canonical_name n.formula - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:order-by fp.canonical_name #:asc)) + (define query + (select fp.id + fp.canonical_name + fp.brand_name + n.id + n.canonical_name + n.formula + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:order-by fp.canonical_name + #:asc)) (define rows (query-rows (current-conn) query)) (define by-id (for/fold ([h (hash)]) ([row (in-list rows)]) (match-define (vector fp-id canonical-name brand-name n-id n-name n-formula value-ppm) row) (define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm)) - (hash-update h fp-id + (hash-update h + fp-id (λ (old-acc) (acc (acc-canonical-name old-acc) (acc-brand-name old-acc) (cons nv-pair (acc-pairs old-acc)))) - (λ () - (acc canonical-name - brand-name - (list nv-pair)))))) + (λ () (acc canonical-name brand-name (list nv-pair)))))) (for/list ([(id a) (in-hash by-id)]) - (fertilizer-product id - (acc-canonical-name a) - (reverse (acc-pairs a)) - (acc-brand-name a)))) + (fertilizer-product id (acc-canonical-name a) (reverse (acc-pairs a)) (acc-brand-name a)))) -(define (get-fertilizer-product #:id [fp-id #f] - #:canonical-name [canonical-name #f]) +(define (get-fertilizer-product #:id [fp-id #f] #:canonical-name [canonical-name #f]) (define where (cond [(and fp-id canonical-name) - (scalar-expr-qq (and (= fp.id ,fp-id) - (= fp.canonical_name ,canonical-name)))] - [fp-id - (scalar-expr-qq (= fp.id ,fp-id))] - [canonical-name - (scalar-expr-qq (= fp.canonical_name ,canonical-name))])) - (define query (select fp.id fp.canonical_name fp.brand_name - n.id n.canonical_name n.formula - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:where (ScalarExpr:AST ,where) - #:limit 1)) + (scalar-expr-qq (and (= fp.id ,fp-id) (= fp.canonical_name ,canonical-name)))] + [fp-id (scalar-expr-qq (= fp.id ,fp-id))] + [canonical-name (scalar-expr-qq (= fp.canonical_name ,canonical-name))])) + (define query + (select fp.id + fp.canonical_name + fp.brand_name + n.id + n.canonical_name + n.formula + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:where (ScalarExpr:AST ,where) + #:limit 1)) (define rows (query-rows (current-conn) query)) (cond [(null? rows) #f] @@ -160,24 +144,22 @@ (define A #f) (for ([row (in-list rows)]) (match-define (vector fp-id canonical-name brand-name n-id n-name n-formula value-ppm) row) - (unless the-id (set! the-id fp-id)) + (unless the-id + (set! the-id fp-id)) (define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm)) - (set! A (if A - (acc (acc-canonical-name A) - (acc-brand-name A) - (cons nv-pair (acc-pairs A))) - (acc canonical-name - brand-name - (list nv-pair))))) - (fertilizer-product the-id - (acc-canonical-name A) - (reverse (acc-pairs A)) - (acc-brand-name A))])) + (set! A + (if A + (acc (acc-canonical-name A) (acc-brand-name A) (cons nv-pair (acc-pairs A))) + (acc canonical-name brand-name (list nv-pair))))) + (fertilizer-product the-id (acc-canonical-name A) (reverse (acc-pairs A)) (acc-brand-name A))])) (define (get-fertilizer-product-values fertilizer-product) (for/list ([(nutrient-id name formula value_ppm) (in-query (current-conn) - (select n.id n.canonical_name n.formula nv.value_ppm + (select n.id + n.canonical_name + n.formula + nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= nm.id ,(fertilizer-product-id fertilizer-product))))]) (cons (nutrient nutrient-id name formula) value_ppm))) @@ -189,14 +171,10 @@ #:where (and (= nm.id ,(fertilizer-product-id fertilizer-product)) (= nv.nutrient_id ,(nutrient-id nutrient)))))) - ;; UPDATE - ;; DELETE (define (delete-fertilizer-product! fertilizer-product) (define id (fertilizer-product-id fertilizer-product)) - (query-exec (current-conn) - (delete #:from fertilizer_products - #:where (= id ,id)))) + (query-exec (current-conn) (delete #:from fertilizer_products #:where (= id ,id)))) diff --git a/models/nutrient-measurement.rkt b/models/nutrient-measurement.rkt index ee336fe..5b999d8 100644 --- a/models/nutrient-measurement.rkt +++ b/models/nutrient-measurement.rkt @@ -35,62 +35,53 @@ #:transparent #:property prop:custom-write (λ (v out _) - (fprintf out "Measurement #~a on ~a\n" + (fprintf out + "Measurement #~a on ~a\n" (nutrient-measurement-id v) (nutrient-measurement-measured-on v)) (for ([nv (nutrient-measurement-nutrient-values v)]) (match-define (cons n v) nv) - (fprintf out "~a ~a\n" + (fprintf out + "~a ~a\n" (~a (nutrient-name n) #:min-width 14) (~a v #:max-width 6 #:align 'right))))) - ;; CREATE (define (create-nutrient-measurement! measured-on nutrient-values) - (or (get-nutrient-measurement #:measured-on measured-on) - (with-tx - (query-exec (current-conn) - (insert #:into nutrient_measurements - #:set [measured_on ,measured-on])) - (define nm-id (query-value (current-conn) - (select id - #:from nutrient_measurements - #:where (= measured_on ,measured-on)))) - (query-exec (current-conn) - (insert #:into nutrient_value_sets - #:set [nutrient_measurement_id ,nm-id])) - (define nvs-id (query-value (current-conn) - (select id - #:from nutrient_value_sets - #:where (= nutrient_measurement_id ,nm-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) - (query-exec (current-conn) - (insert #:into nutrient_values - #:set - [value_set_id ,nvs-id] - [nutrient_id ,(nutrient-id n)] - [value_ppm ,v]))) - (get-nutrient-measurement #:measured-on measured-on)))) - + (or + (get-nutrient-measurement #:measured-on measured-on) + (with-tx + (query-exec (current-conn) (insert #:into nutrient_measurements #:set [measured_on ,measured-on])) + (define nm-id + (query-value (current-conn) + (select id #:from nutrient_measurements #:where (= measured_on ,measured-on)))) + (query-exec (current-conn) + (insert #:into nutrient_value_sets #:set [nutrient_measurement_id ,nm-id])) + (define nvs-id + (query-value (current-conn) + (select id #:from nutrient_value_sets #:where (= nutrient_measurement_id ,nm-id)))) + (for ([nv nutrient-values]) + (match-define (cons n v) nv) + (query-exec (current-conn) + (insert #:into nutrient_values + #:set [value_set_id ,nvs-id] + [nutrient_id ,(nutrient-id n)] + [value_ppm ,v]))) + (get-nutrient-measurement #:measured-on measured-on)))) ;; READ (struct acc (measured-on pairs) #:transparent) - (define joined - (table-expr-qq - (inner-join - (inner-join - (inner-join - (as nutrient_measurements nm) - (as nutrient_value_sets nvs) - #:on (= nvs.nutrient_measurement_id nm.id)) - (as nutrient_values nv) - #:on (= nv.value_set_id nvs.id)) - (as nutrients n) - #:on (= n.id nv.nutrient_id)))) + (table-expr-qq (inner-join (inner-join (inner-join (as nutrient_measurements nm) + (as nutrient_value_sets nvs) + #:on (= nvs.nutrient_measurement_id nm.id)) + (as nutrient_values nv) + #:on (= nv.value_set_id nvs.id)) + (as nutrients n) + #:on (= n.id nv.nutrient_id)))) + (define (get-nutrient-measurements) (define query (select nm.id nm.measured_on @@ -155,7 +146,10 @@ (define (get-nutrient-measurement-values nutrient-measurement) (for/list ([(nutrient-id name formula value_ppm) (in-query (current-conn) - (select n.id n.canonical_name n.formula nv.value_ppm + (select n.id + n.canonical_name + n.formula + nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= nm.id ,(nutrient-measurement-id nutrient-measurement))))]) (cons (nutrient nutrient-id name formula) value_ppm))) @@ -172,17 +166,15 @@ (select value_ppm #:from (TableExpr:AST ,joined) #:where (= nv.nutrient_id ,(nutrient-id nutrient)) - #:order-by nm.measured_on #:desc + #:order-by nm.measured_on + #:desc #:limit 1))) ;; UPDATE - ;; DELETE (define (delete-nutrient-measurement! nutrient-measurement) (define id (nutrient-measurement-id nutrient-measurement)) - (query-exec (current-conn) - (delete #:from nutrient_measurements - #:where (= id ,id)))) + (query-exec (current-conn) (delete #:from nutrient_measurements #:where (= id ,id)))) diff --git a/models/nutrient-target.rkt b/models/nutrient-target.rkt index c2f9c2e..922dba7 100644 --- a/models/nutrient-target.rkt +++ b/models/nutrient-target.rkt @@ -34,102 +34,89 @@ #:transparent #:property prop:custom-write (λ (v out _) - (fprintf out "Target #~a on ~a\n" - (nutrient-target-id v) - (nutrient-target-effective-on v)) + (fprintf out "Target #~a on ~a\n" (nutrient-target-id v) (nutrient-target-effective-on v)) (for ([nv (nutrient-target-nutrient-values v)]) (match-define (cons n v) nv) - (fprintf out "~a ~a\n" + (fprintf out + "~a ~a\n" (~a (nutrient-name n) #:min-width 14) (~a v #:max-width 6 #:align 'right))))) - ;; CREATE (define (create-nutrient-target! effective-on nutrient-values) (or (get-nutrient-target #:effective-on effective-on) (with-tx - (query-exec (current-conn) - (insert #:into nutrient_targets - #:set [effective_on ,effective-on])) - (define nt-id (query-value (current-conn) - (select id - #:from nutrient_targets - #:where (= effective_on ,effective-on)))) - (query-exec (current-conn) - (insert #:into nutrient_value_sets - #:set [nutrient_target_id ,nt-id])) - (define nvs-id (query-value (current-conn) - (select id - #:from nutrient_value_sets - #:where (= nutrient_target_id ,nt-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) - (query-exec (current-conn) - (insert #:into nutrient_values - #:set - [value_set_id ,nvs-id] - [nutrient_id ,(nutrient-id n)] - [value_ppm ,v]))) - (get-nutrient-target #:effective-on effective-on)))) - + (query-exec (current-conn) (insert #:into nutrient_targets #:set [effective_on ,effective-on])) + (define nt-id + (query-value (current-conn) + (select id #:from nutrient_targets #:where (= effective_on ,effective-on)))) + (query-exec (current-conn) + (insert #:into nutrient_value_sets #:set [nutrient_target_id ,nt-id])) + (define nvs-id + (query-value (current-conn) + (select id #:from nutrient_value_sets #:where (= nutrient_target_id ,nt-id)))) + (for ([nv nutrient-values]) + (match-define (cons n v) nv) + (query-exec (current-conn) + (insert #:into nutrient_values + #:set [value_set_id ,nvs-id] + [nutrient_id ,(nutrient-id n)] + [value_ppm ,v]))) + (get-nutrient-target #:effective-on effective-on)))) ;; READ (struct acc (effective-on pairs) #:transparent) (define joined - (table-expr-qq - (inner-join - (inner-join - (inner-join - (as nutrient_targets nt) - (as nutrient_value_sets nvs) - #:on (= nvs.nutrient_target_id nt.id)) - (as nutrient_values nv) - #:on (= nv.value_set_id nvs.id)) - (as nutrients n) - #:on (= n.id nv.nutrient_id)))) + (table-expr-qq (inner-join (inner-join (inner-join (as nutrient_targets nt) + (as nutrient_value_sets nvs) + #:on (= nvs.nutrient_target_id nt.id)) + (as nutrient_values nv) + #:on (= nv.value_set_id nvs.id)) + (as nutrients n) + #:on (= n.id nv.nutrient_id)))) (define (get-nutrient-targets) - (define query (select nt.id nt.effective_on - n.id n.canonical_name n.formula - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:order-by nt.effective_on #:desc)) + (define query + (select nt.id + nt.effective_on + n.id + n.canonical_name + n.formula + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:order-by nt.effective_on + #:desc)) (define rows (query-rows (current-conn) query)) (define by-id (for/fold ([h (hash)]) ([row (in-list rows)]) (match-define (vector nt-id effective-on n-id n-name n-formula value-ppm) row) (define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm)) - (hash-update h nt-id - (λ (old-acc) - (acc (acc-effective-on old-acc) - (cons nv-pair (acc-pairs old-acc)))) - (λ () - (acc effective-on - (list nv-pair)))))) + (hash-update h + nt-id + (λ (old-acc) (acc (acc-effective-on old-acc) (cons nv-pair (acc-pairs old-acc)))) + (λ () (acc effective-on (list nv-pair)))))) (for/list ([(id a) (in-hash by-id)]) - (nutrient-target id - (acc-effective-on a) - (reverse (acc-pairs a))))) + (nutrient-target id (acc-effective-on a) (reverse (acc-pairs a))))) -(define (get-nutrient-target #:id [nt-id #f] - #:effective-on [effective-on #f]) +(define (get-nutrient-target #:id [nt-id #f] #:effective-on [effective-on #f]) (define where (cond [(and nt-id effective-on) - (scalar-expr-qq (and (= nt.id ,nt-id) - (= nt.effective_on ,effective-on)))] - [nt-id - (scalar-expr-qq (= nt.id ,nt-id))] - [effective-on - (scalar-expr-qq (= nt.effective_on ,effective-on))])) - (define query (select nt.id nt.effective_on - n.id n.canonical_name n.formula - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:where (ScalarExpr:AST ,where))) + (scalar-expr-qq (and (= nt.id ,nt-id) (= nt.effective_on ,effective-on)))] + [nt-id (scalar-expr-qq (= nt.id ,nt-id))] + [effective-on (scalar-expr-qq (= nt.effective_on ,effective-on))])) + (define query + (select nt.id + nt.effective_on + n.id + n.canonical_name + n.formula + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:where (ScalarExpr:AST ,where))) (define rows (query-rows (current-conn) query)) (cond [(null? rows) #f] @@ -139,21 +126,22 @@ (define A #f) (for ([row (in-list rows)]) (match-define (vector nt-id effective-on n-id n-name n-formula value-ppm) row) - (unless the-id (set! the-id nt-id)) + (unless the-id + (set! the-id nt-id)) (define nv-pair (cons (nutrient n-id n-name n-formula) value-ppm)) - (set! A (if A - (acc (acc-effective-on A) - (cons nv-pair (acc-pairs A))) - (acc effective-on (list nv-pair))))) - (and A - (nutrient-target the-id - (acc-effective-on A) - (reverse (acc-pairs A))))])) + (set! A + (if A + (acc (acc-effective-on A) (cons nv-pair (acc-pairs A))) + (acc effective-on (list nv-pair))))) + (and A (nutrient-target the-id (acc-effective-on A) (reverse (acc-pairs A))))])) (define (get-nutrient-target-values nutrient-target) (for/list ([(nutrient-id name formula value_ppm) (in-query (current-conn) - (select n.id n.canonical_name n.formula nv.value_ppm + (select n.id + n.canonical_name + n.formula + nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= nm.id ,(nutrient-target-id nutrient-target))))]) (cons (nutrient nutrient-id name formula) value_ppm))) @@ -170,17 +158,15 @@ (select value_ppm #:from (TableExpr:AST ,joined) #:where (= nv.nutrient_id ,(nutrient-id nutrient)) - #:order-by nt.effective_on #:desc + #:order-by nt.effective_on + #:desc #:limit 1))) ;; UPDATE - ;; DELETE (define (delete-nutrient-target! nutrient-target) (define id (nutrient-target-id nutrient-target)) - (query-exec (current-conn) - (delete #:from nutrient_targets - #:where (= id ,id)))) + (query-exec (current-conn) (delete #:from nutrient_targets #:where (= id ,id)))) diff --git a/models/nutrient.rkt b/models/nutrient.rkt index 944583e..49921d7 100644 --- a/models/nutrient.rkt +++ b/models/nutrient.rkt @@ -1,26 +1,27 @@ #lang racket -(provide - ;; Model struct - nutrient - nutrient? - nutrient-id nutrient-name nutrient-formula - ;; Contracts - nutrient-value-pair/c - (contract-out - ;; SQL CRUD - [create-nutrient! (-> string? string? nutrient?)] - [get-nutrients (-> (listof nutrient?))] - [get-nutrient (->* () - (#:id (or/c #f exact-nonnegative-integer?) - #:name (or/c #f string?) - #:formula (or/c #f string?)) - (or/c nutrient? #f))] - [update-nutrient! (->* (nutrient?) - (#:name (or/c #f string?) - #:formula (or/c #f string?)) - (or/c nutrient? #f))] - [delete-nutrient! (-> nutrient? void?)])) +;; Model struct +(provide nutrient + nutrient? + nutrient-id + nutrient-name + nutrient-formula + ;; Contracts + nutrient-value-pair/c + ;; SQL CRUD + (contract-out [create-nutrient! (-> string? string? nutrient?)] + [get-nutrients (-> (listof nutrient?))] + [get-nutrient + (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:name (or/c #f string?) + #:formula (or/c #f string?)) + (or/c nutrient? #f))] + [update-nutrient! + (->* (nutrient?) + (#:name (or/c #f string?) #:formula (or/c #f string?)) + (or/c nutrient? #f))] + [delete-nutrient! (-> nutrient? void?)])) (require racket/contract db @@ -30,14 +31,9 @@ (struct nutrient (id name formula) #:transparent #:property prop:custom-write - (λ (v out _) - (fprintf out "#<~a ~a>" - (nutrient-id v) - (nutrient-name v)))) - -(define nutrient-value-pair/c - (cons/c nutrient? (and/c real? (>=/c 0)))) + (λ (v out _) (fprintf out "#<~a ~a>" (nutrient-id v) (nutrient-name v)))) +(define nutrient-value-pair/c (cons/c nutrient? (and/c real? (>=/c 0)))) ;; CREATE @@ -45,24 +41,18 @@ (or (get-nutrient #:name name #:formula formula) (begin (query-exec (current-conn) - (insert #:into nutrients - #:set [canonical_name ,name] [formula ,formula])) + (insert #:into nutrients #:set [canonical_name ,name] [formula ,formula])) (get-nutrient #:name name)))) - ;; READ (define (get-nutrients) (for/list ([(id* name* formula*) (in-query (current-conn) - (select id canonical_name formula - #:from nutrients - #:order-by id #:asc))]) + (select id canonical_name formula #:from nutrients #:order-by id #:asc))]) (nutrient id* name* formula*))) -(define (get-nutrient #:id [id #f] - #:name [name #f] - #:formula [formula #f]) +(define (get-nutrient #:id [id #f] #:name [name #f] #:formula [formula #f]) (define (where-expr) (define clauses (filter values @@ -73,47 +63,30 @@ [(null? clauses) ""] [else (format "WHERE ~a" (string-join clauses " AND "))])) (match (query-maybe-row (current-conn) - (string-join - `("SELECT id, canonical_name, formula" - "FROM nutrients" - ,(where-expr) - "ORDER BY id ASC" - "LIMIT 1"))) - [(vector id* name* formula*) - (nutrient id* name* formula*)] + (string-join `("SELECT id, canonical_name, formula" "FROM nutrients" + ,(where-expr) + "ORDER BY id ASC" + "LIMIT 1"))) + [(vector id* name* formula*) (nutrient id* name* formula*)] [#f #f])) - ;; UPDATE -(define (update-nutrient! nutrient - #:name [name #f] - #:formula [formula #f]) - (define id(nutrient-id nutrient)) +(define (update-nutrient! nutrient #:name [name #f] #:formula [formula #f]) + (define id (nutrient-id nutrient)) (cond [(and name formula) - (query-exec (current-conn) - (update nutrients - #:set [canonical_name ,name] [formula ,formula] - #:where (= id ,id)))] + (query-exec + (current-conn) + (update nutrients #:set [canonical_name ,name] [formula ,formula] #:where (= id ,id)))] [name - (query-exec (current-conn) - (update nutrients - #:set [canonical_name ,name] - #:where (= id ,id)))] + (query-exec (current-conn) (update nutrients #:set [canonical_name ,name] #:where (= id ,id)))] [formula - (query-exec (current-conn) - (update nutrients - #:set [formula ,formula] - #:where (= id ,id)))] + (query-exec (current-conn) (update nutrients #:set [formula ,formula] #:where (= id ,id)))] [else (void)]) - (or (get-nutrient #:id id) - (error 'update-nutrient! "No nutrient with id ~a" id))) - + (or (get-nutrient #:id id) (error 'update-nutrient! "No nutrient with id ~a" id))) ;; DELETE (define (delete-nutrient! nutrient) - (query-exec (current-conn) - (delete #:from nutrients - #:where (= id ,(nutrient-id nutrient))))) + (query-exec (current-conn) (delete #:from nutrients #:where (= id ,(nutrient-id nutrient))))) diff --git a/models/user.rkt b/models/user.rkt index a56b469..45ca154 100644 --- a/models/user.rkt +++ b/models/user.rkt @@ -1,16 +1,13 @@ #lang racket -(provide - ;; Model struct - user - user? - user-id - user-name - user-role - (contract-out - ;; SQL CRUD - [get-current-user (-> (or/c user? #f))] - #; [delete-user! (-> user? void?)])) +;; Model struct +(provide user + user? + user-id + user-name + user-role + ;; SQL CRUD + (contract-out [get-current-user (-> (or/c user? #f))] #;[delete-user! (-> user? void?)])) (require racket/contract db @@ -21,10 +18,7 @@ (define (get-current-user) (define current-user-id "foobar") - (define query (select id name role_id - #:from users - #:where (= id ,current-user-id) - #:limit 1)) + (define query (select id name role_id #:from users #:where (= id ,current-user-id) #:limit 1)) (define row (query-maybe-row (current-conn) query)) (cond [(false? row) #f] |