MFlow code example

Chunks.hs

data AppFlow
  = Navigate SiteSection
  | Shop ShopAction
  | Admin AdminAction
  | Authenticate String

data AdminAction
  = CreateCategory ProductCategory
  | AdminAction {- other actions, not implemented yet -} deriving (Show)
---------------------------------------------------------------
contentsOf :: SiteSection -> W AppFlow
contentsOf s =
  htmlContents s ++>
    case s of
      Management -> Admin <$> adminControls -- append admin forms after page header (currently only one form)
      _          -> noWidget
      
adminControls =
  {- Having troubles to get rid of `do`s, could be used applicative operator I suppose -}
  do r <- wform $
            do pc <- ProductCategory <$> getString Nothing `hint` "название"
                                     <*> getString Nothing `hint` "описание"
               return pc
     return (CreateCategory r)

Main.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
module Main where

import           MFlow.Wai.Blaze.Html.All hiding (Tag, User, contents, div, id,
                                           main)
import qualified MFlow.Wai.Blaze.Html.All as H

import           Data.Monoid              ((<>))


data AppFlow
  = Navigate SiteSection
  | Shop ShopAction
  | Admin AdminAction
  | Authenticate String
  deriving (Show)

data SiteSection
  = Home
  | Products
  | About
  | Contacts
  | Cart
  | User
  | Management
  deriving (Show)

data ShopAction = ShopAction deriving (Show)

data AdminAction
  = CreateCategory ProductCategory
  | AdminAction deriving (Show)


data ProductCategory = ProductCategory
  { productCategoryName :: String
  , productCategoryDesc :: String }
  deriving (Show, Read)

data Product = Product
  { productCategory :: ProductCategory
  , productTags     :: [Tag]
  , productName     :: ProductName
  , productDesc     :: Description
  , productPrice    :: Price
  , productStock    :: Stock }
  deriving (Show, Read)

type Tag         = String
type ProductName = String
type Description = String
type Price       = Double
type Stock       = Int


main :: IO ()
main = runNavigation "store" . step $ storeWebApp

storeWebApp :: FlowM Html IO ()
storeWebApp =
  do setTimeouts 120 (30 * 24 * 60 * 60)
     -- останавливает процесс после двух минут простоя (120 секунд)
     -- очищает данные сессии пользователя (корзину и прочее) через месяц
     setOuterWrapper
     setFilesPath $
       "/Users/arthurfayzrakhmanov/"
       <> "Haskell/sites/mflow-fixture-store/src/Static/"
     requires [CSSFile "style.css"]
     userRegister "admin" "admin"
     r <- layout . contentsOf $ Home
     case r of
       Navigate c -> layout . contentsOf $ c
       --_ -> defPage
     return ()
     -- user <- getCurrentUser
     -- when (user == "heraldhoi@gmail.com") adminSection

contentsOf :: SiteSection -> W AppFlow
contentsOf s =
  htmlContents s ++>
    case s of
      Management -> Admin <$> adminControls
      _          -> noWidget

htmlContents :: SiteSection -> Html
htmlContents Home       = h1 "Главная"
htmlContents Products   = h1 "Продукция"
htmlContents About      = h1 "О компании"
htmlContents Contacts   = h1 "Контакты"
htmlContents User       = h1 "Мой профиль"
htmlContents Management = h1 "Управление"

adminControls =
  do r <- wform $
            do pc <- ProductCategory <$> getString Nothing `hint` "название"
                                     <*> getString Nothing `hint` "описание"
               return pc
     return (CreateCategory r)



commonMenu :: W SiteSection
commonMenu = absLink Home "Главная"
             <|> absLink Products "Продукция"
             <|> absLink About "О компании"
             <|> absLink Contacts "Контакты"
             <|> absLink User "Мой профиль"

adminMenu :: W SiteSection
adminMenu = absLink Management "Управление"


authenticateWidget :: W AppFlow
authenticateWidget = wform $
  do uname <- getCurrentUser
     if uname /= anonymous
        then pass uname
        else loginForm
     `wcallback` userForm `wcallback` userAction
  where pass = ((private >> noCache >> noStore) >>) . return
        userAction (Authenticate _) = invokeLogout
        userAction n@(Navigate _)   = return n

loginForm :: W String
loginForm =
  do (nm, pwd) <- (,) <$> getString    Nothing `hint` "логин"
                      <*> getPassword          `hint` "пароль"
                      <** submitButton "Войти"
     mr <- userValidate (nm, pwd)
     case mr of
       Nothing  -> invokeLogin nm
       Just msg -> notValid msg

userForm :: String -> W AppFlow
userForm n =
  b << n ++> links
  where links = Navigate <$> (adminLink n) <|> Authenticate <$> logoutLink
        adminLink "admin" = absLink Management "Управление" <++ br
        adminLink _       = noWidget
        logoutLink        = pageFlow "log out" $ submitButton "Выход"


invokeLogin :: String -> W String
invokeLogin n = do login n
                   clearEnv
                   return n

invokeLogout :: W AppFlow
invokeLogout  = do logout
                   clearEnv
                   authenticateWidget

type F a = FlowM Html IO a

type W a = View Html IO a

-- layout :: View Html IO a -> W AppFlow
layout contents = do
  r <- page $
         topMenu
         <|> leftAside
         <|> mainBlock contents
         <|> rightAside
         <|> layoutFooter
  case r of
    Navigate c -> presentContents c

presentContents c = layout (htmlContents c ++> noWidget)

topMenu :: W AppFlow
topMenu = nav' (Navigate <$> commonMenu)
  where nav' x = (H.nav <<< x) `tagClass` "Top-Nav"

leftAside = p "LEFT" ++> noWidget
rightAside = authenticateWidget <++ rightAsideContent
mainBlock = id
rightAsideContent = p "RIGHT"
layoutFooter = p "FOOTER" ++> noWidget

tagClass :: W a -> String ->  W a
tagClass v c = v <! [("class", c)]

hint v h = v <! [("placeholder", h)]

setOuterWrapper :: F ()
setOuterWrapper = setHeader $
  docTypeHtml . (html ! lang "ru") . body