<% show d %>
) - -data User = User {name :: String, passwd :: String, birthdate :: Date} deriving Show - -userFull :: (Applicative m, Monad m) => WebForm m User -userFull = User <$> input Nothing <*> password Nothing <*> dateFull - -handleUser :: [ServerPart Response] -handleUser = withForm "user" "/user" "user" userFull showErrorsInline (\u -> okHtml $<% show u %>
) +-- * hunk ./FormletsWebT.hs 52 -createForm :: (Monad m) => Env -> String -> WebForm m a -> String -> Web XML +createForm :: (Monad m) => Env -> String -> WebFormT m a -> String -> Web XML hunk ./FormletsWebT.hs 62 - -withForm :: String -> String -> String -> WebForm (WebT IO) a -> (Web XML -> [String] -> WebT IO Response) -> (a -> WebT IO Response) -> [ServerPart Response] +{- +withForm :: String -> String -> String -> WebFormT (WebT IO) a -> (Web XML -> [String] -> WebT IO Response) -> (a -> WebT IO Response) -> [ServerPart Response] hunk ./FormletsWebT.hs 76 - -showErrorsInline :: Web XML -> [String] -> WebT IO Response -showErrorsInline renderedForm errors = - okHtml $<% show errors %>
] %><% show faults %>
+ return [HSX.xmlToChild x] + xml <- createForm env prefix form action + return (faultsXML ++ [ HSX.xmlToChild xml]) + where + toEnv (a,b) = (a, Left b) hunk ./Interface.hs 1 +module Interface where + +data Date = Date {month :: Integer, day :: Integer} deriving Show + +validDate :: Date -> Bool +validDate (Date m d) = m `elem` [1..12] && d `elem` [1..31] hunk ./Main.hs 1 - +module Main where + +import Control.Arrow +import Control.Applicative +import Control.Applicative.Error +import Control.Concurrent +import Control.Monad.State +import HAppS.Server hiding (Web) +import HAppS.Template.HSP +import HAppS.Template.HSP.Handle +import HSP +import Text.Formlets +import FormletsWebT +import Index +import Interface + +main :: IO () +main = + do store <- newStore + tid <- forkIO $ simpleHTTP validateConf $ impl store + putStrLn "running..." + waitForTermination + killThread tid + destroyStore store + +impl :: Store -> [ServerPart Response] +impl store = + [ runHSPHandle "." "objfiles" store $ multi $ + withForm "/" "date" dateFull "Index.hs" (ok . toResponse . show) + ] + +-- PROBLEMS +-- 1. there is no type-checking to ensure that pageFP and frm are the same type +-- 2. the params we pass in might collide with other params if there is more than one form +-- 3. supporting more than one form per page period +withForm :: String + -> String + -> Form [Web XML] (WebT (StateT HSPState IO)) a + -> FilePath + -> (a -> WebT (StateT HSPState IO) Response) + -> [ServerPartT (StateT HSPState IO) Response] +withForm action prefix frm pageFP handleOk = + [ method GET $ do addParam "formData" ([] :: [(String, String)]) + addParam "prefix" prefix + addParam "action" action + addParam "faults" ([] :: [String]) + execTemplate Nothing pageFP + , withDataFn lookPairs $ \env -> + [ method POST $ + do let (extractor, _xml, _ct) = runFormState [] prefix frm + res <- extractor (map (second Left) env) + case res of + Failure faults -> + do addParam "formData" env + addParam "prefix" prefix + addParam "action" "/" + addParam "faults" faults + execTemplate Nothing pageFP + Success s -> handleOk s + ] + ] + +{- + +withForm :: String -> String -> String -> WebForm (WebT IO) a -> (Web XML -> [String] -> WebT IO Response) -> (a -> WebT IO Response) -> [ServerPart Response] +withForm name action prefix frm handleErrors handleOk = + [dir name + [ method GET $ okHtml $ createForm [] prefix frm action + , withDataFn lookPairs $ \d -> [method POST $ handleOk' (map (second Left) d)] + ] + ] + where (extractor, _xml, _ct) = runFormState [] prefix frm + handleOk' d = + do res <- extractor d + case res of + Failure faults -> handleErrors (createForm d prefix frm action) faults + Success s -> handleOk s +-} + +-- * demo + +-- dateComponent :: (Applicative m, Monad m) => WebForm m Date +-- dateComponent = Date <$> inputInteger (Just 1) <*> inputInteger (Just 16) + + +{- +handleDate :: [ServerPart Response] +handleDate = withForm "date" "/date" "date" dateFull showErrorsInline (\d -> okHtml $<% show d %>
) + +data User = User {name :: String, passwd :: String, birthdate :: Date} deriving Show + +userFull :: (Applicative m, Monad m) => WebForm m User +userFull = User <$> input Nothing <*> password Nothing <*> dateFull + +handleUser :: [ServerPart Response] +handleUser = withForm "user" "/user" "user" userFull showErrorsInline (\u -> okHtml $<% show u %>
) + +createForm :: (Monad m) => Env -> String -> WebForm m a -> String -> Web XML +createForm env prefix frm action' = + + where + (_extractor, xml, _ct) = runFormState env prefix frm + +withForm :: String -> String -> String -> WebForm (WebT IO) a -> (Web XML -> [String] -> WebT IO Response) -> (a -> WebT IO Response) -> [ServerPart Response] +withForm name action prefix frm handleErrors handleOk = + [dir name + [ method GET $ okHtml $ createForm [] prefix frm action + , withDataFn lookPairs $ \d -> [method POST $ handleOk' (map (second Left) d)] + ] + ] + where (extractor, _xml, _ct) = runFormState [] prefix frm + handleOk' d = + do res <- extractor d + case res of + Failure faults -> handleErrors (createForm d prefix frm action) faults + Success s -> handleOk s + +showErrorsInline :: Web XML -> [String] -> WebT IO Response +showErrorsInline renderedForm errors = + okHtml $<% show errors %>
] %>