{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}
module Main where
import Control.Arrow
import Control.Applicative
import Control.Applicative.Error
import Control.Concurrent
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Identity
import Happstack.Data (defaultValue)
import Happstack.State
import Happstack.Server hiding (Web)
import Happstack.Server.Extra
import HSP
import HSP.HTML
import Text.Formlets hiding (contentType)
import HSP.Formlets
import Index (page, checkboxesForm, dateForm, radiosForm, selectForm, selectMultiForm, createForm)
import Interface
import HSP.IdentityT
import HSP.Identity
import Happstack.Server.HSP.HTML
import qualified HSX.XMLGenerator as HSX
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Lazy.UTF8 as L
-- import Generics
-- * Move to SimpleHTTP
{-
instance Functor Result where
fmap f NoHandle = NoHandle
fmap f (Ok g a) = Ok g (f a)
fmap f (Escape response) = Escape response
instance (Functor m) => Functor (WebT m) where
fmap f (WebT m) = WebT (fmap (fmap f) m)
instance (Functor m, Monad m) => Applicative (WebT m) where
pure = return
(<*>) = ap
-}
instance ToMessage (XMLGenT Identity XML) where
toContentType _ = P.pack "text/html"
toMessage xml = toMessage (html4Strict, evalIdentity xml) -- L.fromString (renderAsHTML xml)
{-
instance ToMessage XML where
toContentType _ = P.pack "text/html"
toMessage xml = toMessage (html4Strict, xml) -- L.fromString (renderAsHTML xml)
instance ToMessage (Maybe XMLMetaData, XML) where
toContentType (Just md,_) = P.pack (contentType md)
toContentType _ = P.pack "text/html"
toMessage (Just (XMLMetaData (showDt, dt) _ pr), xml) =
L.fromString ((if showDt then (dt ++) else id) (pr xml))
toMessage (Nothing, xml) =
L.fromString (renderAsHTML xml)
-}
-- * Main
main :: IO ()
main =
do tid <- forkIO $ simpleHTTP nullConf {- validateConf -} $ impl
putStrLn "running..."
waitForTermination
killThread tid
putStrLn "shutting down..."
impl :: ServerPart Response
impl = msum
[ dir "checkboxes" $ handleForm "prefix" "/checkboxes" page checkboxesForm (ok . toResponse . show)
, dir "date" $ handleForm "prefix" "/date" page dateForm (ok . toResponse . show)
, dir "radios" $ handleForm "prefix" "/radios" page radiosForm (ok . toResponse . show)
, dir "select" $ handleForm "prefix" "/select" page selectForm (ok . toResponse)
, dir "selectMulti" $ handleForm "prefix" "/selectMulti" page selectMultiForm (ok . toResponse . show)
, methodM GET >> ok (toResponse
(evalIdentity
(
Index of HAppS+HSP+Formlets examples
Checkboxes Form
Date Widget
Radios Form
Select Widget
Select Multi Widget
Sample Widget
)))
, debug404
]
handleForm :: String -> String -> (XMLGenT Identity XML -> XMLGenT Identity XML) -> Form [XMLGenT Identity XML] IO a -> (a -> ServerPart Response) -> ServerPart Response
handleForm prefix action page frm handleOk =
msum
[ do methodM GET
ok (toResponse (page (createForm [] prefix action [] frm)))
, withDataFn lookPairs $ \env' ->
do let env = map (second Left) env'
(collector, _, _) = runFormState env frm
res <- liftIO $ collector
case res of
Failure faults ->
ok (toResponse (page (createForm env prefix action faults frm)))
Success s -> handleOk s
]