In the
previous post I created an skeleton of a shopping application where the back button in the web browser is used for navigation, instead of a way to undo a transaction. The purpose here is to add a small database of products, to search the database by different ways. This is the original program, where three products are hardcoded:
module Main where
import MFlow.Wai.Blaze.Html.All
import Data.Typeable
import Data.String(fromString)
import qualified Data.Vector as V
main= do
addMessageFlows [("", runFlow $ shop ["iphone","ipad","ipod"])]
wait $ run 8081 waiMessageFlow
shop products= do
setHeader $ html . body
setTimeouts 120 (30*24*60*60)
catalog
where
catalog = do
bought <- step . ask $ showProducts products
cart <- getSessionData `onNothing` return emptyCart
let n = cart V.! bought
setSessionData $ cart V.// [(bought,n+1)]
step $ do
r <- ask $ do
cart <- getSessionData `onNothing` return emptyCart
p << showCart cart ++> wlink True << b << "continue shopping"
<|> wlink False << p << "proceed to buy"
if( r== False) then ask $ wlink () << "not implemented, click here"
else return ()
catalog
emptyCart= V.fromList $ take (length products) (repeat (0::Int))
showProducts xs= firstOf $ map (\(i,x) -> wlink i (p << x)) $ zip [0..] xs
First, some headers:
{-# LANGUAGE DeriveDataTypeable #-}
module Main where
import MFlow.Wai.Blaze.Html.All as MF
import Data.Typeable
import Data.String(fromString)
import Data.TCache.DefaultPersistence
import Data.TCache.IndexQuery as Q
import Data.TCache.IndexText
import Data.Maybe
import qualified Data.Map as M
import Control.Workflow.Configuration
import Data.Text.Lazy as T
Lets define a product, and we will create some of them:
type ProductName= String
type Quantity= Int
type Price= Float
data Product= Product{ namep :: ProductName
, typep :: [String]
, descriptionp :: String
, pricep :: Price
, stock :: Int}
deriving (Read,Show,Typeable)
createProducts= atomically $ mapM newDBRef
[ Product "ipad 3G" ["gadget","pad"] "ipad 8GB RAM, 3G" 400 200
, Product "ipad" ["gadget","pad"] "ipad 8 GB RAM" 300 300
, Product "iphone 3" ["gadget","phone"] "iphone 3 nice and beatiful" 200 100
]
We will use
TCache for persistence. It adds STM transactions, and user defined persistence. It also bring default persistence in files, that is what I will use now.
newDBRef (above) creates a database reference and the record pointed too. To do so we need only to define the indexable instance for the record, that defines a unique key:
instance Indexable Product where
key prod= "Prod "++ namep prod
We need to search by the product name
namep, to search product by types
typep and to perform text search in the description
descriptionp.
main= do
Q.index namep -- for field indexation
indexList typep (Prelude.map T.pack) -- for list indexation
indexText descriptionp T.pack -- for text indexation
These indexation statements create triggers that inspect creations and modifications of these fields in the registers. (Use
http://holumbus.fh-wedel.de/hayoo/hayoo.html for fast documentation about these and other primitives used in the application)
Then, we create the products one and one single time.
runConfiguration "createprods" $ once createProducts
runConfiguration is a
Workflow functionality for configuration. The purpose is to execute (
once) things one and one single time.
And the start of the shop, that will be defined later:
addMessageFlows [("", runFlow shop )]
wait $ run 8081 waiMessageFlow
Lets redefine the shopping cart. Instead of a Vector, we will have the product name, the quantity and the unit price in a map:
type Cart= M.Map ProductName (Quantity, Price)
showCart :: Cart -> String
showCart = show
shop = do
setHeader $ html . body
setTimeouts 120 (30*24*60*60)
catalog
The catalog loop will do the same than in the previous static application: The user choose a product from the catalog, the shopping cart will be shown with the new product and so on:
catalog = do
bought <- buyProduct
shoppingCart bought
catalog
Now the reservation (buyProduct) and the
shoppingCart processing is more complex and with more steps:
Let's tell something about Workflows and
step. This statement writes the result of a computation in a log. When the program is restarted, each
step call will read an entry in the log and return it, instead of executing the computation. So the program will execute the steps already logged, so at the end of the log, the process instruction pointer is located after the last step saved. the
shop computation will need to remember the state of the shopping cart after restar from a timeout set with
setTimeouts (see previous posts about this), so it need to use
step.
buyProduct return a product name. Now there are two options: Either a search for products or a navigation trough product types. To obtain the types, it is necessary to get all of them from all the products. This is what
allElemsOf does.
atomic= liftIO . atomically
showList []= wlink Nothing << p << "no results"
showList xs= Just <$> firstOf [wlink x << p << x | x <- xs]
buyProduct = step $ do
ttypes <- atomic $ allElemsOf typep
let types= Prelude.map T.unpack ttypes
r <- ask $ h1 << "Product catalog"
++> p << "search" ++> (Left <$> getString Nothing)
<|> p << "or choose product types" ++> (Right <$> showList types)
So
r will have either the search string (by
getString) or what
showList produces. And what it produces is
Nothing if the list of types is empty or one of the links pressed -
wlink- corresponding to a product name.
firstOf applied to a list of widgets, return the one activated by the user.
And now given either the search string or the type of product, it is necessary to read the product that meet the condition in the database:
prods <- case r of
Left str -> atomic $ Q.select namep $ descriptionp `contains` str
Right (Just type1) -> atomic $ Q.select namep $ typep `containsElem` type1
Right Nothing -> return []
Here there are two kind of queries: the first is the names of products which contains the search terms in the description field. The second query is all the products that include the type in the
typep field
The result is the list of product names. If no search result of no types of products, we return to the page again:
if Prelude.null prods then buyProduct else do
let search= case r of
Left str -> "for search of the term " ++ str
Right (Just type1) -> "of the type "++ type1
r <- ask $ h1 << ("Products " ++ search) ++> showList prods
case r of
Nothing -> buyProduct
Just prod -> breturn prod
Here
showList present the products as links. so
r will return the chosen product or Nothing if there was no result for the previous query for products (It is not the case, since the that has been ruled out in the first line).
Now, the
shoppingCart. First the shopping cart is retrieved form the session context with
getSessionData (see the previous post). then, to know the price, the register with this name is retrieved. Then the cart is updated.
shoppingCart bought= do
cart <- getSessionData `onNothing` return (M.empty ::Cart)
let (n,price) = fromMaybe (0,undefined) $ M.lookup bought cart
(n,price) <- step $ do
if n /= 0 then return (n,price) else do
[price] <- atomic $ Q.select pricep $ namep .==. bought
return (n, price)
setSessionData $ M.insert bought (n+1,price) cart
Since
namep determine the main key (see the
Indexable instance), we would substitute the query
[price] <- atomic $ Q.select pricep $ namep .==. bought
By
price <- readResource Product{ namep= bought} >>= return . pricep . fromJust
Which is quite faster. So, really, there is no need to index the main key. But it has been done in this case for a matter of example.
readResource gets an incomplete object with defined key and returns
Maybe the complete register.
Finally, the shopping cart is visualized:
step $ do
r <- ask $ do
cart <- getSessionData `onNothing` return (M.empty :: Cart)
h1 << "Shopping cart:"
++> p << showCart cart
++> wlink True << b << "continue shopping"
<|> wlink False << p << "proceed to buy"
if not r then ask $ wlink () << "not implemented, click here" else breturn ()
breturn means that the procedure return, but may be called back when backtracking as a result of the button back pressed in the web browser.
Here there is no real "buy" operation implemented. The naming as "buy" operations what are really reservations of products in a shopping cart are just in order to maintain the names of the previous version. Actually, they are shopping cart reservations. Buy It means to modify the stock of the product in the database and avoid to roll-back when backtracking. I will do it in the next post.
The code above is complete. This example is embedded in this source file:
https://github.com/agocorona/MFlow/blob/master/Demos/loginUserPage.hs
The MFlow package:
https://github.com/agocorona/MFlow
