[bknr-cvs] hans changed trunk/projects/quickhoney/src/
BKNR Commits
bknr at bknr.net
Mon Nov 10 08:27:59 UTC 2008
Revision: 4027
Author: hans
URL: http://bknr.net/trac/changeset/4027
work on shopping system
U trunk/projects/quickhoney/src/packages.lisp
U trunk/projects/quickhoney/src/quickhoney.asd
U trunk/projects/quickhoney/src/shop.lisp
Modified: trunk/projects/quickhoney/src/packages.lisp
===================================================================
--- trunk/projects/quickhoney/src/packages.lisp 2008-11-10 08:25:02 UTC (rev 4026)
+++ trunk/projects/quickhoney/src/packages.lisp 2008-11-10 08:27:59 UTC (rev 4027)
@@ -21,7 +21,16 @@
(:use :cl
:bknr.datastore
:bknr.indices
- :bknr.user))
+ :bknr.user)
+ (:export #:download-product
+ #:emailable-product
+ #:mailable-product
+ #:product-stock-count
+ #:shopping-cart
+ #:put-to-cart
+ #:insufficient-inventory
+ #:product-already-in-shopping-cart
+ #:fulfill))
(defpackage :quickhoney
(:use :cl
Modified: trunk/projects/quickhoney/src/quickhoney.asd
===================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd 2008-11-10 08:25:02 UTC (rev 4026)
+++ trunk/projects/quickhoney/src/quickhoney.asd 2008-11-10 08:27:59 UTC (rev 4027)
@@ -24,7 +24,8 @@
:bknr.web
:bknr.datastore
:bknr.modules
- :cl-gd)
+ :cl-gd
+ :unit-test)
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
Modified: trunk/projects/quickhoney/src/shop.lisp
===================================================================
--- trunk/projects/quickhoney/src/shop.lisp 2008-11-10 08:25:02 UTC (rev 4026)
+++ trunk/projects/quickhoney/src/shop.lisp 2008-11-10 08:27:59 UTC (rev 4027)
@@ -28,7 +28,6 @@
:update
:type string
:index-type string-unique-index
- :index-reader product-with-name
:documentation
"Short name of the product, must be unique, should be identifier")
(description
@@ -41,10 +40,13 @@
(:documentation
"Sell PRODUCT, adjusting the stock count if needed. Returns the product sold."))
-(defgeneric stock-count (product)
+(defgeneric product-stock-count (product)
(:documentation
"Return the number of instances of PRODUCT available, or NIL if the
- product can be sold in infinite amounts."))
+ product can be sold in infinite amounts.")
+ (:method (product)
+ "By default, assume infinite supply"
+ nil))
(define-persistent-class download-product (product)
()
@@ -54,9 +56,6 @@
address. Once paid, the system makes the product available to the
customer for download."))
-(defmethod stock-count ((product download-product))
- nil)
-
(define-persistent-class emailable-product (product)
()
(:documentation
@@ -65,20 +64,40 @@
be supplied by the customer. Once paid, the system sends the
order to the store personnel for fulfillment."))
-(defmethod stock-count ((product emailable-product))
- nil)
-
(define-persistent-class mailable-product (product)
((stock-count :update
:type integer
- :accessor stock-count
+ :accessor product-stock-count
:documentation
- "Number of instances of this product that are available to be sold."))
+ "Number of instances of this product that are
+ available to be sold, including reserved amounts in
+ shopping carts.")
+ (reserved-count :update
+ :type integer
+ :initform 0))
(:documentation
"A product that is sent to the customer by regular mail \(i.e. a
t-shirt or poster). Once paid, the system sends the order to the
store personell for fulfillment."))
+(defgeneric available-p (product count)
+ (:documentation "Return a true value if COUNT units of PRODUCT are
+ currently available. Should be called with the store guard locked.")
+ (:method (product count)
+ (or (null (product-stock-count product))
+ (<= count (product-stock-count product)))))
+
+(defmethod product-stock-count ((product mailable-product))
+ "The available stock count for a mailable product is reduced by the reserved count and returned."
+ (- (slot-value product 'stock-count)
+ (mailable-product-reserved-count product)))
+
+(defmethod (setf product-stock-count) (newval (product mailable-product))
+ "The available sock count for a mailable product is set to NEWVAL."
+ (when (< newval (mailable-product-reserved-count product))
+ (error "cannot reduce the available stock count below the reserved count"))
+ (setf (slot-value product 'stock-count) newval))
+
(define-persistent-class shipping-address ()
((country :read))
(:documentation
@@ -99,9 +118,28 @@
"List of shipping addresses with the preferred address being the
CAR of the list.")))
+(define-persistent-class number-generator ()
+ ((name :read
+ :type symbol
+ :initform (error "cannot make number-generator instance without name")
+ :index-type string-unique-index
+ :index-reader number-generator-with-name)
+ (next :update
+ :type integer
+ :initarg :next
+ :initform 1)))
+
+(defun get-next-number (name)
+ (with-transaction (:get-next-number)
+ (let* ((number-generator (or (number-generator-with-name name)
+ (make-instance 'number-generator :name name)))
+ (number (number-generator-next number-generator)))
+ (incf (number-generator-next number-generator))
+ number)))
+
(define-persistent-class order ()
((number :read
- :initform (make-order-number))
+ :initform (get-next-number 'orders))
(customer :read)
(items :update)))
@@ -112,6 +150,161 @@
(define-persistent-class invoice ()
((number :read
- :initform (make-invoice-number))
+ :initform (get-next-number 'invoices))
(items :update)))
+(define-persistent-class lease ()
+ ((product :read
+ :initform (error "missing :product initarg to lease creation")
+ :documentation "product that has been leased")
+ (count :read
+ :initform (error "missing :count initarg to lease creation")
+ :documentation "number of units of product held by this lease")
+ (fulfilled :update
+ :initform nil
+ :documentation "Set to a true value when the lease has
+ been fulfilled. Used during lease descruction in order
+ to determine whether to return the leased inventory to
+ the product stock."))
+ (:documentation "Instance representing a lease for a product."))
+
+(defgeneric update-reserved-stock (product count)
+ (:documentation "Update the reserved counter of PRODUCT by COUNT units")
+ (:method (product count)
+ (declare (ignore product count))))
+
+(defgeneric note-sale (product count)
+ (:documentation "Update the stock count of the PRODUCT by COUNT
+ units after a sale has been done")
+ (:method (product count)
+ (declare (ignore product count))))
+
+(defmethod initialize-instance :after ((lease lease) &key)
+ (update-reserved-stock (lease-product lease) (lease-count lease)))
+
+(defmethod destroy-object :before ((lease lease))
+ (unless (lease-fulfilled lease)
+ (update-reserved-stock (lease-product lease) (- (lease-count lease)))))
+
+(defmethod update-reserved-stock ((product mailable-product) count)
+ (incf (mailable-product-reserved-count product) count))
+
+(defmethod note-sale ((product mailable-product) count)
+ (decf (slot-value product 'stock-count) count)
+ (update-reserved-stock product (- count)))
+
+(define-persistent-class shopping-cart ()
+ ((leases :update
+ :initform nil)
+ (expires :read
+ :initform (error "missing :expires initarg to shopping cart creation")
+ :documentation "universal time at which this shopping cart expires"))
+ (:documentation "Represents the intent to buy goods, in the form of LEASE objects"))
+
+(defmethod destroy-object :before ((shopping-cart shopping-cart))
+ (mapc #'delete-object (shopping-cart-leases shopping-cart)))
+
+(define-condition insufficient-inventory (error)
+ ((product :initarg :product
+ :reader product)
+ (requested :initarg :requested
+ :reader requested)
+ (available :initarg :available
+ :reader available))
+ (:report (lambda (c stream)
+ (format stream "Insufficient inventory for product ~A - Requested ~A, but~[~; only~]~:* ~A available"
+ (product c) (requested c) (available c))
+ c)))
+
+(define-condition product-already-in-shopping-cart (error)
+ ((product :initarg :product
+ :reader product))
+ (:report (lambda (c stream)
+ (format stream "Product ~A is already in shopping cart"
+ (product c)))))
+
+(defun put-to-shopping-cart (count product shopping-cart)
+ "Reserve COUNT units of PRODUCT, signalling a INSUFFICIENT-INVENTORY
+ error if not enough inventory of PRODUCT is available. Returns a
+ LEASE object."
+ (with-store-guard ()
+ (unless (available-p product count)
+ (error 'insufficient-inventory
+ :product product
+ :requested count
+ :available (product-stock-count product)))
+ (when (find product (shopping-cart-leases shopping-cart)
+ :key #'lease-product)
+ (error 'product-already-in-shopping-cart
+ :product product))
+ (with-transaction (:make-lease)
+ (push (make-instance 'lease
+ :product product
+ :count count)
+ (shopping-cart-leases shopping-cart)))))
+
+(defun fulfill (shopping-cart)
+ "Fulfill the given shopping cart."
+ (with-transaction (:fulfill)
+ (dolist (lease (shopping-cart-leases shopping-cart))
+ (let ((product (lease-product lease))
+ (count (lease-count lease)))
+ (setf (lease-fulfilled lease) t)
+ (note-sale product count)))
+ (delete-object shopping-cart)))
+
+;;; TESTING
+
+(defmacro with-temporary-directory ((pathname) &body body)
+ `(let ((,pathname (pathname (format nil "/tmp/store-test-~A/" (sb-posix:getpid)))))
+ (asdf:run-shell-command "rm -rf ~A" ,pathname)
+ (prog1
+ (progn , at body)
+ (asdf:run-shell-command "rm -rf ~A" ,pathname))))
+
+(defun do-with-test-store (thunk)
+ (when (and (boundp '*store*) *store*)
+ (warn "closing open store *store* to run tests")
+ (close-store))
+ (with-temporary-directory (store-directory)
+ (make-instance 'mp-store
+ :subsystems (list (make-instance 'store-object-subsystem))
+ :directory store-directory)
+ (funcall thunk)
+ (close-store)))
+
+(defmacro with-test-store (() &body body)
+ `(do-with-test-store (lambda () , at body)))
+
+(unit-test:deftest :shop "lease and cart tests"
+ (with-test-store ()
+ (let* ((t-shirt (make-instance 'mailable-product :name 't-shirt :stock-count 10))
+ (file (make-instance 'download-product :name 'file))
+ (shopping-cart (make-instance 'shopping-cart :expires (+ (* 60 10) (get-universal-time)))))
+ (unit-test:test-equal 10 (product-stock-count t-shirt))
+ (put-to-shopping-cart 10 t-shirt shopping-cart)
+ (unit-test:test-equal 0 (product-stock-count t-shirt))
+ (unit-test:test-assert (product-stock-count t-shirt))
+ (with-transaction (:add-to-inventory)
+ (incf (slot-value t-shirt 'stock-count) 10))
+ (put-to-shopping-cart 5 t-shirt shopping-cart)
+ (unit-test:test-equal 5 (product-stock-count t-shirt))
+ (delete-object shopping-cart)
+ (unit-test:test-equal 20 (product-stock-count t-shirt))
+ (setf shopping-cart (make-instance 'shopping-cart :expires (+ (* 60 10) (get-universal-time))))
+ (put-to-shopping-cart 5 t-shirt shopping-cart)
+ (put-to-shopping-cart 500 file shopping-cart)
+ (unit-test:test-equal 15 (product-stock-count t-shirt)))))
+
+(unit-test:deftest :shop "fulfill test"
+ (with-test-store ()
+ (let* ((t-shirt (make-instance 'mailable-product :name 't-shirt :stock-count 10))
+ (file (make-instance 'download-product :name 'file))
+ (shopping-cart (make-instance 'shopping-cart :expires (+ (* 60 10) (get-universal-time)))))
+ (put-to-shopping-cart 3 t-shirt shopping-cart)
+ (put-to-shopping-cart 7 file shopping-cart)
+ (fulfill shopping-cart)
+ (unit-test:test-equal 7 (product-stock-count t-shirt))
+ (unit-test:test-equal 0 (length (class-instances 'shopping-cart)))
+ (unit-test:test-equal 0 (length (class-instances 'lease)))
+ (unit-test:test-equal 0 (mailable-product-reserved-count t-shirt)))))
\ No newline at end of file
More information about the Bknr-cvs
mailing list