> {-# LANGUAGE OverloadedStrings #-}
> {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
> import Control.Applicative ((<$>), (<*>))
> import Data.Maybe (isJust)
> import Data.Text (Text)
> import Text.Blaze ((!))
> import qualified Data.Text as T
> import qualified Happstack.Server as Happstack
> import qualified Text.Blaze.Html5 as H
> import qualified Text.Blaze.Html5.Attributes as A
> import Text.Digestive
> import Text.Digestive.Blaze.Html5
> import Text.Digestive.Happstack
> import Text.Digestive.Util
> data User = User
> { userName :: Text
> , userMail :: Text
> } deriving (Show)
> userForm :: Monad m => Form Text m User
> userForm = User
> <$> "name" .: text Nothing
> <*> "mail" .: check "Not a valid email address" checkEmail (text Nothing)
> checkEmail :: Text -> Bool
> checkEmail = isJust . T.find (== '@')
> type Version = [Int]
> validateVersion :: Text -> Result Text Version
> validateVersion = maybe (Error "Cannot parse version") Success .
> mapM (readMaybe . T.unpack) . T.split (== '.')
> data Category = Web | Text | Math
> deriving (Bounded, Enum, Eq, Show)
> data Package = Package Text Version Category
> deriving (Show)
> packageForm :: Monad m => Form Text m Package
> packageForm = Package
> <$> "name" .: text Nothing
> <*> "version" .: validate validateVersion (text (Just "0.0.0.1"))
> <*> "category" .: choice categories Nothing
> where
> categories = [(x, T.pack (show x)) | x <- [minBound .. maxBound]]
> data Release = Release User Package
> deriving (Show)
> releaseForm :: Monad m => Form Text m Release
> releaseForm = Release
> <$> "author" .: userForm
> <*> "package" .: packageForm
> userView :: View H.Html -> H.Html
> userView view = do
> label "name" view "Name: "
> inputText "name" view
> H.br
>
> errorList "mail" view
> label "mail" view "Email address: "
> inputText "mail" view
> H.br
> releaseView :: View H.Html -> H.Html
> releaseView view = do
> H.h2 "Author"
> userView $ subView "author" view
>
> H.h2 "Package"
> childErrorList "package" view
>
> label "package.name" view "Name: "
> inputText "package.name" view
> H.br
>
> label "package.version" view "Version: "
> inputText "package.version" view
> H.br
>
> label "package.category" view "Category: "
> inputSelect "package.category" view
> H.br
> site :: Happstack.ServerPart Happstack.Response
> site = do
> Happstack.decodeBody $ Happstack.defaultBodyPolicy "/tmp" 4096 4096 4096
> r <- runForm "test" releaseForm
> case r of
> (view, Nothing) -> do
> let view' = fmap H.toHtml view
> Happstack.ok $ Happstack.toResponse $
> template $
> form view' "/" $ do
> releaseView view'
> H.br
> inputSubmit "Submit"
> (_, Just release) -> Happstack.ok $ Happstack.toResponse $
> template $ do
> css
> H.h1 "Release received"
> H.p $ H.toHtml $ show release
>
> main :: IO ()
> main = Happstack.simpleHTTP Happstack.nullConf site
> template :: H.Html -> H.Html
> template body = H.docTypeHtml $ do
> H.head $ do
> H.title "digestive-functors tutorial"
> css
> H.body body
> css :: H.Html
> css = H.style ! A.type_ "text/css" $ do
> "label {width: 130px; float: left; clear: both}"
> "ul.digestive-functors-error-list {"
> " color: red;"
> " list-style-type: none;"
> " padding-left: 0px;"
> "}"