MFlow-0.4.5: Demos/SearchCart.hs

{-# OPTIONS   -XCPP -XDeriveDataTypeable #-}
module SearchCart (
 searchCart
) where
import Data.TCache.DefaultPersistence
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 Control.Workflow (Workflow)
import qualified Data.Text.Lazy as T
import Data.ByteString.Lazy.Char8
import Data.Typeable

-- #define ALONE -- to execute it alone, uncomment this
#ifdef ALONE
import MFlow.Wai.Blaze.Html.All
main= runNavigation "" searchCart
#else
import MFlow.Wai.Blaze.Html.All hiding(retry, page)
import Menu
#endif

type ProductName= String
type Quantity= Int
type Price= Float

type Cart= M.Map ProductName (Quantity, Price)

showCart :: Cart -> String
showCart = show


data Product= Product{ namep :: String
                     , typep :: [String]
                     , descriptionp :: String
                     , pricep :: Price
                     , stock :: Int}
              deriving (Read,Show,Typeable)

instance Indexable Product where
   key prod= "Prod "++ namep prod

instance Serializable Product where
  serialize= pack . show
  deserialize= read . unpack
  setPersist= const $ Just filePersist

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
    ]

searchCart :: FlowM Html (Workflow IO) ()
searchCart = do
   liftIO $ runConfiguration "createprods" $ do  -- better put this in main
        ever $ Q.index namep
        ever $ indexList typep (Prelude.map T.pack)
        ever $ indexText descriptionp T.pack
        once createProducts
   catalog
   where
   catalog = do
       bought <-  step  buyProduct
       shoppingCart bought
       catalog



   buyProduct :: FlowM Html  IO ProductName
   buyProduct =  do
        ttypes   <-  atomic $ allElemsOf typep
        let types= Prelude.map T.unpack ttypes
        r  <- page $   h1 << "Product catalog"
                  ++> p << "search" ++> (Left <$> getString Nothing)
                  <|> p << "or choose product types" ++>  (Right <$> showList types)

        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 []

        if Prelude.null prods
         then do
             page $ b << "no match " ++> wlink () << b << "search again"
             buyProduct
         else do
            let search= case r of
                            Left str ->              "for search of the term " ++ str
                            Right (Just type1) ->    "of the type "++ type1

            r <- page $ h1 << ("Products " ++ search) ++> showList prods
            case r of
              Nothing   -> buyProduct
              Just prod -> breturn prod

   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
       step $ do
         r <- page $  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 page $ wlink () << "not implemented, click here"
              else breturn ()


   atomic= liftIO . atomically
   showList []= wlink Nothing << p << "no results"
   showList xs= Just <$> firstOf [wlink  x << p <<  x | x <- xs]