Item-Fixed.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Data.Text           (Text)
import           Data.Time.Clock
import           Yesod


data App = App

mkYesod "App" [parseRoutes|
/ ItemR GET POST
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

-- The datatype we wish to receive from the form
data Item = Item
    { itemPrice :: Int
    }
  deriving Show

validateMinimumPrice :: Int -> Either Text Int
validateMinimumPrice price =
    if (price <= 0)
        then Left "Price should be above 0"
        else Right price

-- Validate price inside the Handler.
validateMinimumPriceInHandler :: Int -> Handler (Either Text Int)
validateMinimumPriceInHandler price = do
    liftIO $ print  "handler!!!!"
    currentTime <- liftIO getCurrentTime
    return $ if (price <= 0)
        then Left "Price should be above 0, sent from inside Handler"
        else Right price


itemForm :: Html -> MForm Handler (FormResult Item, Widget)
itemForm = renderDivs $ Item
    <$> areq priceField "Price" Nothing
    where priceField = (check validateMinimumPrice . checkM validateMinimumPriceInHandler) intField

-- The GET handler displays the form
getItemR :: Handler Html
getItemR = do
    -- Generate the form to be displayed
    (widget, enctype) <- generateFormPost itemForm
    defaultLayout
        [whamlet|
            <form method=post action=@{ItemR} enctype=#{enctype}>
                ^{widget}
                <button>Submit
        |]


postItemR :: Handler Html
postItemR = do
    ((result, widget), enctype) <- runFormPost itemForm
    case result of
        FormSuccess item ->
            defaultLayout [whamlet|<p>#{show item}|]
        _ -> defaultLayout
            [whamlet|
                <p>Invalid input, let's try again.
                <form method=post action=@{ItemR} enctype=#{enctype}>
                    ^{widget}
                    <button>Submit
            |]

main :: IO ()
main = warp 3000 App

Item.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Data.Text           (Text)
import           Data.Time.Clock
import           Yesod


data App = App

mkYesod "App" [parseRoutes|
/ ItemR GET POST
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

-- The datatype we wish to receive from the form
data Item = Item
    { itemPrice :: Int
    }
  deriving Show

validateMinimumPrice :: Int -> Either Text Int
validateMinimumPrice price =
    if (price <= 0)
        then Left "Price should be above 0"
        else Right price

-- Validate price inside the Handler.
validateMinimumPriceInHandler :: Int -> Handler (Either Text Int)
validateMinimumPriceInHandler price = do
    currentTime <- liftIO getCurrentTime
    return $ if (price <= 0)
        then Left "Price should be above 0, sent from inside Handler"
        else Right price


itemForm :: Html -> MForm Handler (FormResult Item, Widget)
itemForm = renderDivs $ Item
    <$> areq priceField "Price" Nothing
    where priceField = check validateMinimumPrice intField

-- The GET handler displays the form
getItemR :: Handler Html
getItemR = do
    -- Generate the form to be displayed
    (widget, enctype) <- generateFormPost itemForm
    defaultLayout
        [whamlet|
            <form method=post action=@{ItemR} enctype=#{enctype}>
                ^{widget}
                <button>Submit
        |]


postItemR :: Handler Html
postItemR = do
    ((result, widget), enctype) <- runFormPost itemForm
    case result of
        FormSuccess item ->
            defaultLayout [whamlet|<p>#{show item}|]
        _ -> defaultLayout
            [whamlet|
                <p>Invalid input, let's try again.
                <form method=post action=@{ItemR} enctype=#{enctype}>
                    ^{widget}
                    <button>Submit
            |]

main :: IO ()
main = warp 3000 App