#lang racket (provide fertilizer-product fertilizer-product? fertilizer-product-id (rename-out [fertilizer-product-canonical-name fertilizer-product-name] [fertilizer-product-nutrient-values fertilizer-product-values] [fertilizer-product-brand-name fertilizer-brand-name]) (contract-out [create-fertilizer-product! (-> string? string? nutrient-value-hash/c fertilizer-product?)] [get-fertilizer-products (-> (listof fertilizer-product?))] [get-fertilizer-product (->* () (#:id db-id? #:canonical-name string?) (or/c fertilizer-product? #f))] [get-fertilizer-product-values (-> fertilizer-product-or-id/c nutrient-value-hash/c)] [get-fertilizer-product-value (-> fertilizer-product-or-id/c nutrient? maybe-nutrient-value?)] [delete-fertilizer-product! (-> fertilizer-product-or-id/c void?)])) (require racket/contract db sql "../db/conn.rkt" "nutrient.rkt" "nutrient-value.rkt" "utils.rkt") (struct fertilizer-product (id canonical-name brand-name nutrient-values) #:transparent #:guard (λ (id canonical-name brand-name nutrient-values _) (values id canonical-name (if (or (sql-null? brand-name) (= (string-length brand-name) 0)) #f brand-name) nutrient-values)) #: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" (fertilizer-product-canonical-name v) (fertilizer-product-brand-name v)) (fprintf out "~a\n" (fertilizer-product-canonical-name v))) (for ([(n v) (in-hash (fertilizer-product-nutrient-values v))]) (fprintf out "~a ~a\n" (~a (nutrient-canonical-name n) #:min-width 14) (~a v #:max-width 6 #:align 'right))))) (define fertilizer-product-or-id/c (or/c fertilizer-product? db-id?)) (define (->fp-id fp-or-id) (match fp-or-id [(? db-id? id) id] [(fertilizer-product id _ _ _) id])) ;; CREATE (define (create-fertilizer-product! canonical-name brand-name nutrient-values) (with-tx (define fp-id (insert-id (query (current-conn) (insert #:into fertilizer_products #:set [canonical_name ,canonical-name] [brand_name ,brand-name])))) (define nvs-id (insert-id (query (current-conn) (insert #:into nutrient_value_sets #:set [fertilizer_product_id ,fp-id])))) (insert-nutrient-values (current-conn) nvs-id nutrient-values) (fertilizer-product nvs-id canonical-name brand-name nutrient-values))) ;; READ (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)))) (define (grouped-row->fertilizer-product grouped-row) (match-define (vector fp-id canonical-name brand-name residuals) grouped-row) (fertilizer-product fp-id canonical-name brand-name (residuals->nutrient-value-hash residuals))) (define (get-fertilizer-products) (define grouped-rows (query-rows (current-conn) (select fp.id fp.canonical_name fp.brand_name n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:order-by fp.canonical_name #:asc) #:group '#(0 1 2))) (map grouped-row->fertilizer-product grouped-rows)) (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))] [else (error 'get-fertilizer-product "either #:id or #:canonical-name must be provided")])) (define grouped-rows (query-rows (current-conn) (select fp.id fp.canonical_name fp.brand_name n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:where (ScalarExpr:AST ,where) #:order-by fp.canonical_name #:asc) #:group '#(0 1 2))) (match grouped-rows ['() #f] [(list grouped-row) (grouped-row->fertilizer-product grouped-row)] [many (error 'get-fertilizer-product "expected 1 fertilizer product, got ~a" (length many))])) (define (get-fertilizer-product-values fp-or-id) (for/hash ([(nutrient-id canonical-name french-name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name n.french_name n.formula nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= fp.id ,(->fp-id fp-or-id))))]) (values (nutrient nutrient-id canonical-name french-name formula) value_ppm))) (define (get-fertilizer-product-value fp-or-id nutrient) (query-maybe-value (current-conn) (select value_ppm #:from (TableExpr:AST ,joined) #:where (and (= fp.id ,(->fp-id fp-or-id)) (= nv.nutrient_id ,(nutrient-id nutrient)))))) ;; UPDATE ;; DELETE (define (delete-fertilizer-product! fp-or-id) (query-exec (current-conn) (delete #:from fertilizer_products #:where (= id ,(->fp-id fp-or-id))))) (module+ test (require rackunit rackunit/text-ui "../db/conn.rkt" "../db/migrations.rkt" "../models/nutrient.rkt") (define canonical-product-name "MasterBlend 4-20") (run-tests (test-suite "Fertilizer product model" #:before (λ () (connect! #:path 'memory) (migrate-all!) (create-nutrient! "Nitrogen" "Azote" "N") (create-nutrient! "Phosphorus" "Phosphore" "P") (create-nutrient! "Potassium" "Potassium" "K")) #:after (λ () (disconnect!)) (test-case "Create product with name, brand, and values" (define nitrogen (get-nutrient #:name "Nitrogen")) (define phosphorus (get-nutrient #:name "Phosphorus")) (create-fertilizer-product! canonical-product-name "MasterBlend" (hash nitrogen 40 phosphorus 200)) (check-equal? (length (get-fertilizer-products)) 1) (define fp (get-fertilizer-product #:canonical-name canonical-product-name)) (check-true (fertilizer-product? fp)) (check-equal? (fertilizer-product-canonical-name fp) canonical-product-name) (check-equal? (fertilizer-product-brand-name fp) "MasterBlend")) (test-case "Create product without brand name" (define nitrogen (get-nutrient #:name "Nitrogen")) (define fp (create-fertilizer-product! "Generic N" "" (hash nitrogen 100))) (check-false (fertilizer-product-brand-name fp))) (test-case "Check all product values" (define nitrogen (get-nutrient #:name "Nitrogen")) (define phosphorus (get-nutrient #:name "Phosphorus")) (define fp (get-fertilizer-product #:canonical-name canonical-product-name)) (check-= (get-fertilizer-product-value fp nitrogen) 40 0) (check-= (get-fertilizer-product-value fp phosphorus) 200 0) (define fpv (fertilizer-product-nutrient-values fp)) (check-equal? (get-fertilizer-product-values fp) fpv "return value of get-fertilizer-product-values ≠ fertilizer-product-values struct accessor") (check-equal? (hash-count fpv) 2)) (test-case "Get product by id" (define fp (get-fertilizer-product #:canonical-name canonical-product-name)) (define fp-by-id (get-fertilizer-product #:id (fertilizer-product-id fp))) (check-equal? fp fp-by-id)) (test-case "Handle missing nutrient in product" (define potassium (get-nutrient #:name "Potassium")) (define fp (get-fertilizer-product #:canonical-name canonical-product-name)) (check-false (get-fertilizer-product-value fp potassium))) (test-case "Custom write property formatting" (define nitrogen (get-nutrient #:name "Nitrogen")) (define fp (create-fertilizer-product! "Test Fertilizer" "TestBrand" (hash nitrogen 50))) (define output (open-output-string)) (write fp output) (define result (get-output-string output)) (check-true (string-contains? result "Fertilizer #")) (check-true (string-contains? result "Test Fertilizer")) (check-true (string-contains? result "TestBrand"))) (test-case "Delete product and cascade to product values" (define fp (get-fertilizer-product #:canonical-name canonical-product-name)) (delete-fertilizer-product! fp) (check-false (get-fertilizer-product #:id (fertilizer-product-id fp))) (check-equal? (length (get-fertilizer-products)) 2 "wrong number of fertilizer products were deleted") (check-true (hash-empty? (get-fertilizer-product-values fp)))))))