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 ,@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 () ,@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