Wednesday, April 24, 2013

MFlow: What about the data tier? Adding it to the shopping example

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 = 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 ()

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

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

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= 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 $ namep $ descriptionp `contains` str
      Right (Just type1) -> atomic $ 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 $ 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 $ pricep $ namep .==. bought


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:

 The MFlow package:

Post a Comment