implementation module WebShop import StdClass, StdList from StdFunc import o, flip import iTasks import StdListExt, iTaskCombinatorsExt, ShopDSL webShopExample :: [Workflow] webShopExample = [ { name = "Examples/Miscellaneous/Webshop/Manage catalog" , label = "Manage catalog" , roles = [] , mainTask = defaultProduct >>= \defProd -> manageCatalog defProd catalogPrompt >>| return Void } , { name = "Examples/Miscellaneous/Webshop/Browse shop" , label = "Browse shop" , roles = [] , mainTask = defaultCart >>= \defCart -> browseShop defCart shopPrompt cartPrompt } ] shopPrompt = ruleText "Welcome to My Shop" cartPrompt = ruleText "My Shop Shopping Cart" catalogPrompt = ruleText "My Shop Product Catalogue Browser" // The shop management workflow: manageCatalog :: a [HtmlTag] -> Task a | iTask, DB a manageCatalog _ prompt = stopTask (showStickyMessage prompt ||- forever (dbReadAll >>= browseCatalog)) where browseCatalog :: [a] -> Task a | iTask, DB a browseCatalog items = orTasksVert (map itemActions items ++ [showMessage "Append?" >>| new]) where new = dbCreateItem >>= \first -> updateInformation "Enter details of new item:" first >>= dbUpdateItem itemActions :: a -> Task a | iTask, DB a itemActions item = enterChoiceAbout "" item [(updateInformation "Please update the following item:" item >>= dbUpdateItem) <<@ "Edit" ,(dbDeleteItem (getItemId item) >>| return item) <<@ "Delete" ] >>= \task -> task // The customer workflow: browseShop :: (Cart a) [HtmlTag] [HtmlTag] -> Task Void | iTask, DB, Product a browseShop initCart shopPrompt cartPrompt = dbReadAll >>= \items -> doShopping initCart items >>= doAction initCart items where doShopping :: (Cart a) [a] -> Task (ShopAction,Cart a) | iTask, Product a doShopping cart [] = showMessage (shopPrompt ++ [normalText "Currently no items in catalogue, sorry."]) >>| return (LeaveShop,cart) doShopping cart items = orTasksVert [ navigateShop shopPrompt cart : map (itemActions cart) items ] where itemActions :: (Cart a) a -> Task (ShopAction,Cart a) | iTask, Product a itemActions cart item = showMessageAbout "Add to cart" item >>| return (ToCart, add (toCartItem item) cart) where add :: (CartItem a) [CartItem a] -> [CartItem a] add new [] = [new] add new [item:items] = if (eqItemNr new item) [amountOrderedUpd item (amountOrderedOf item+1):items] [item:add new items] navigateShop :: [HtmlTag] (Cart a) -> Task (ShopAction, Cart a) | iTask a navigateShop prompt cart = (enterChoice "" [ return (ToShop, cart) <<@ "Do Shopping" , return (ToPay, cart) <<@ "Check Out And Pay" , return (ToCart, cart) <<@ "Show Cart" , return (LeaveShop,cart) <<@ "Leave Shop" ] >>= \task -> task) -||- (( showStickyMessageAbout [BrTag [], boldText "Total cost of ordered items = "] (totalCost cart) -&&- showStickyMessage prompt ) >>| getDefaultValue) doAction :: (Cart a) [a] (ShopAction, Cart a) -> Task Void | iTask, DB, Product a doAction initCart items (action,cart) = case action of LeaveShop = return Void ToCart = showCart cart >>= doAction initCart items ToShop = doShopping cart items >>= doAction initCart items ToPay = checkOutAndPay cart >>| browseShop initCart shopPrompt cartPrompt showCart :: (Cart a) -> Task (ShopAction,Cart a) | iTask a showCart cart=:[] = navigateShop cartPrompt cart -||- (showStickyMessage [normalText "No items in cart yet!"] >>| getDefaultValue) showCart cart = orTasksVert [ navigateShop cartPrompt cart : map (itemActions cart) cart ] where itemActions :: (Cart a) (CartItem a) -> Task (ShopAction,Cart a) | iTask a itemActions cart item = showStickyMessageAbout "Item: " item ||- updateInformation "Change amount: " {orderAmount = amountOrderedOf item} >>= \{orderAmount=n} -> return (ToCart,if (n <= 0) (filter (not o eqItemNr item) cart) (lreplace eqItemNr (amountOrderedUpd item n) cart) ) checkOutAndPay :: (Cart a) -> Task Void | iTask a checkOutAndPay cart = dbCreateItem >>= \order -> fillInClientInfo {order & itemsOrdered = cart} >>= \order -> yesOrNo [normalText "Confirm Order"] (dbUpdateItem order >>| getCurrentUser >>= \me -> spawnProcess me.User.userId True (showMessageAbout "Order:" (order,costOrder order) <<@ "Order Confirmed") >>| spawnProcess shopOwner True (showMessageAbout "Order" (order,costOrder order) <<@ "New Order from " <+++ me.User.displayName) >>| return Void ) (return Void) where costOrder order = totalCost order.itemsOrdered fillInClientInfo order = fillInData name_prompt nameOf nameUpd order >>= \order -> fillInData billing_prompt billingAddressOf billingAddressUpd order >>= \order -> yesOrNo ([ normalText "Billing address:" :visualizeAsHtmlDisplay (billingAddressOf order) ] ++ [ normalText "Is the shipping addres same as the billing address above?" ]) (return {order & shippingAddress = billingAddressOf order}) (fillInData shipping_prompt shippingAddressOf shippingAddressUpd order) >>= \order -> yesOrNo (showOrder order) (return order) (fillInClientInfo order) where name_prompt = "Please fill in your name:" billing_prompt = "Please fill in the billing address:" shipping_prompt = "Please fill in the shipping address:" fillInData prompt valueOf updateOf record = updateInformation [normalText prompt] (valueOf record) >>= \value -> return (updateOf record value) showOrder order = section "name:" (visualizeAsHtmlDisplay (nameOf order)) ++ section "billing address:" (visualizeAsHtmlDisplay (billingAddressOf order)) ++ section "shipping address:" (visualizeAsHtmlDisplay (shippingAddressOf order)) ++ section "ordered items:" (flatten (map (visualizeAsHtmlDisplay o toInCart) order.itemsOrdered) ++ [DivTag [] (visualizeAsHtmlDisplay (costOrder order))]) ++ section "Confirm:" [normalText "Is the data above correct?"] // little markup functions: boldText text = BTag [] [Text text, BrTag [], BrTag []] normalText text = BodyTag [] [Text text, BrTag [], BrTag []] ruleText text = section text [HrTag []] section label content = [HrTag [], boldText label : content]