/ test /
/test/shop.lisp
  1 ;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
  2 ;;;
  3 ;;; Copyright (c) 2006 by the authors.
  4 ;;;
  5 ;;; See LICENCE for details.
  6 
  7 (in-package :cl-perec-test)
  8 
  9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 10 ;;; Define the classes for the shop
 11 
 12 ;; the defpclass is used to define persistent classes
 13 ;; defpclass* is a shortcut and means that accessors and
 14 ;; initargs will be derived from slot names
 15 ;; (slot-name) -> (slot-name :initarg :slot-name :accessor slot-name-of)
 16 (defpclass* basket ()
 17   ((created-at (transaction-timestamp) :type timestamp)
 18    (ordered #f :type boolean :documentation "The consumer confirmed the order and willing to pay"))
 19   (:documentation "Holds a list of product, quantity pairs"))
 20 
 21 ;; abstract classes cannot be instantiated
 22 ;; an error will be thrown if make-instance is called for them
 23 (defpclass* product ()
 24   ((name :type (text 30) :unique #t)
 25    (unit-price :type number))
 26   (:abstract #t)
 27   (:documentation "Serves as base class for products"))
 28 
 29 ;; for availabe slot type see the cl-perec home page
 30 (defpclass* products-in-basket ()
 31   ((quantity :type integer-16))
 32   (:documentation "Specifies the quantity of a product in a basket"))
 33 
 34 ;; defassociation is used to define 1-1, 1-n, m-n persistent associations
 35 ;; referential integrity is kept between the two slots in the two owner classes
 36 (defassociation*
 37   ((:class basket :slot products-in-basket :type (set products-in-basket))
 38    (:class products-in-basket :slot basket :type basket)))
 39 
 40 (defassociation*
 41   ((:class product :slot products-in-basket :type (set products-in-basket))
 42    (:class products-in-basket :slot product :type product)))
 43 
 44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 45 ;;; Define some actual products
 46 
 47 ;; subclass product
 48 (defpclass* computer (product)
 49   ((kind :type (member :desktop :notebook))
 50    (memory :type integer-32)))
 51 
 52 (defpclass* bicycle (product)
 53   ((size :type integer-16)))
 54 
 55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 56 ;;; The following functions require a transaction context, use with-transaction
 57 
 58 (defun purge-shop ()
 59   "Purges all data from the shop"
 60   ;; we could simply do (purge-instance 'persistent-object)
 61   ;; but that may affect other loaded progams data, so make it safe
 62   (purge-instances 'product) ;; this is polymorph
 63   (purge-instances 'basket)
 64   (purge-instances 'products-in-basket))
 65 
 66 (defun create-products ()
 67   "Creates some products which can be bought"
 68   (list
 69    (make-instance 'computer
 70                   :name "Apple"
 71                   :kind :desktop
 72                   :unit-price 1200
 73                   :memory 1024)
 74    (make-instance 'computer
 75                   :name "Orange"
 76                   :kind :notebook
 77                   :unit-price 1400
 78                   :memory 2048)
 79    (make-instance 'bicycle
 80                   :name "Csengi"
 81                   :unit-price 400
 82                   :size 26)
 83    (make-instance 'bicycle
 84                   :name "Nandi"
 85                   :unit-price 500
 86                   :size 28)))
 87 
 88 (defun find-product (name)
 89   ;; query a single instance
 90   (select-instance (p product)
 91     (where (equal (name-of p) name))))
 92 
 93 (defun create-baskets ()
 94   "Creates hypotetical baskets with products"
 95   (bind ((b1 (make-instance 'basket :ordered #t))
 96          (b2 (make-instance 'basket))
 97          (b3 (make-instance 'basket :ordered #t)))
 98     (make-instance 'products-in-basket
 99                    :basket b1
100                    :product (find-product "Apple")
101                    :quantity 1)
102     (make-instance 'products-in-basket
103                    :basket b1
104                    :product (find-product "Csengi")
105                    :quantity 2)
106     (make-instance 'products-in-basket
107                    :basket b2
108                    :product (find-product "Nandi")
109                    :quantity 1)
110     (make-instance 'products-in-basket
111                    :basket b3
112                    :product (find-product "Orange")
113                    :quantity 3)
114     (list b1 b2 b3)))
115 
116 (defun select-ordered-baskets (created-before)
117   "Selects the baskets which have been ordered (confirmed) and created before
118 the provided timestamp. Returns a list of basket and total price pairs.
119 
120 This query compiles into the following SQL either at compile time or
121 at runtime based on the :compile-at-macroexpand parameter. The compiled
122 query is always cached, so subsequent calls reuse the result. Use macroexpand
123 when the parameter is set to #t or trace cl-perec::compile-query when it is set
124 to #f to see how the query compiler compiles down parts to static SQL and how
125 it leaves other parts in lisp.
126 
127 SELECT _pib._basket_id, SUM((_pib._quantity * _product3355._unit_price))
128 FROM _product _product3355, _basket _basket3354, _products_in_basket _pib
129 WHERE ((_product3355._id = _pib._product_id) AND
130        (_basket3354._id = _pib._basket_id) AND
131         _basket3354._ordered AND
132        ((_basket3354._created_at = $1::TIMESTAMP WITH TIME ZONE)))
133 GROUP BY _pib._basket_id"
134   (select ((basket-of pib)
135            (sum (* (quantity-of pib)
136                    (unit-price-of (product-of pib)))))
137     (from (pib products-in-basket))
138     (where (and (ordered-p (basket-of pib))
139                 (timestamp<= (created-at-of (basket-of pib)) created-before)))
140     (group-by (basket-of pib))))
141 
142 (deftest test/shop/1 ()
143   (with-transaction
144     (purge-shop)
145     (create-products)
146     (create-baskets)
147     (bind ((result (select-ordered-baskets (transaction-timestamp))))
148       (is (= 2 (length result)))
149       (is (= 2000 (second (first result))))
150       (is (= 4200 (second (second result))))))
151   (with-transaction
152     (dolist (basket
153               (select-instances (b basket)
154                 (where (not (ordered-p b)))))
155       (setf (ordered-p basket) #t))
156     (bind ((result (select-ordered-baskets (transaction-timestamp))))
157       (is (= 3 (length result)))
158       result)))