[added example which does not use happs-hsp-template jeremy@n-heptane.com**20080830050416] { adddir ./examples/happs-hsp addfile ./examples/happs-hsp/Index.hs addfile ./examples/happs-hsp/Interface.hs addfile ./examples/happs-hsp/Main.hs hunk ./examples/happs-hsp/Index.hs 1 - +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, TypeFamilies, UndecidableInstances, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-} +module Index where + +import Control.Applicative +import Control.Applicative.Error +import Control.Monad.Writer +import Data.Monoid +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans +import Control.Monad.Identity +import HSP +import HSP.Formlets +import Interface +import Text.Formlets +import qualified HSX.XMLGenerator as HSX +import HSP.IdentityT +import HSP.Identity + +data FormState + = FormState { env :: Env + , prefix :: String + , action :: String + , faults :: [String] + } + deriving (Read, Show) + +inputField :: (Monad m, HSX.XMLGenerator x) => Maybe String -> (Form [XMLGenT x (HSX.XML x)] m String) +inputField mStr = input' (\n v -> []) mStr + +submit :: (Monad m, HSX.XMLGenerator x) => String -> (Form [XMLGenT x (HSX.XML x)] m String) +submit value = input' (\n v -> []) (Just value) + +createForm :: (HSX.XMLGenerator x, Monad m) => Env -> String -> String -> [String] -> Form (XMLGenT x (HSX.XML x)) m a -> XMLGenT x (HSX.XML x) +createForm env prefix action' faults frm = + do let (_extractor, xml, _ct) = runFormState env prefix frm + let faultsXML = if null faults + then [] + else [

<% show faults %>

] +
+ <% faultsXML %> + <% xml %> +
+ +-- * demo + + +dateComponent :: (HSX.XMLGenerator x, Applicative m, Monad m) => Form [XMLGenT x (HSX.XML x)] m Date +dateComponent = Date <$> inputInteger (Just 1) <*> inputInteger (Just 16) <* submit "hit it!" + +dateFull :: (HSX.XMLGenerator x, Applicative m, Monad m) => Form [XMLGenT x (HSX.XML x)] m Date +dateFull = dateComponent `check` ensure validDate "This is not a valid date" + +page :: (EmbedAsChild m [Char], EmbedAsChild m xml) => + Form xml m1 a -> Form (XMLGenT m (HSX.XML m)) m1 a +page form = template `plug` form + where + template xml = + + + HAppS + HSP + Formlets + + + <% xml %> + + + +inputPage :: Form (XMLGenT Identity XML) IO String +inputPage = page (inputField Nothing <* (submit "go!")) + +datePage :: (HSX.XMLGenerator x, Monad m, Applicative m) => Form (XMLGenT x (HSX.XML x)) m Date +datePage = page dateFull + +test = + do putStrLn (renderAsHTML (evalIdentity (createForm [] "prefix" "/" [] inputPage))) + putStrLn (renderAsHTML (evalIdentity (createForm [] "prefix" "/" [] (datePage :: Form (XMLGenT Identity XML) IO Date)))) +{- +{- +createForm :: (Monad m) => Form' m a -> XMLGenT (IdentityT (Reader FormState)) XML +createForm frm = + do formState <- lift (lift ask) + let (_extractor, xml, _ct) = runFormState (env formState) (prefix formState) frm + faultsXML <- if null (faults formState) + then return [] + else return [

<% show (faults formState) %>

] +
+
+ <% faultsXML %> + <% xml %> + +
+
+ +inputPage = page (inputField Nothing <* (submit "go!")) +-} +-} hunk ./examples/happs-hsp/Interface.hs 1 - +module Interface where + +import HSP.Formlets +import HSP +import HAppS.Template.HSP + +data Date = Date {month :: Integer, day :: Integer} deriving Show + +validDate :: Date -> Bool +validDate (Date m d) = m `elem` [1..12] && d `elem` [1..31] + +-- type WebFormT m a = FormHSXT (WebT m a hunk ./examples/happs-hsp/Main.hs 1 - +{-# LANGUAGE FlexibleInstances #-} +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 HAppS.Server hiding (Web) +import HAppS.Server.Extra +import HSP +import HSP.HTML +import Text.Formlets hiding (contentType) +import HSP.Formlets +import Index +import Interface +import HSP.IdentityT +import HSP.Identity +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 + +-- * 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 XML where + toContentType _ = P.pack "text/html" + toMessage 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 $ impl + putStrLn "running..." + waitForTermination + killThread tid + +impl :: [ServerPart Response] +impl = handleForm "prefix" "/" (datePage :: Form (XMLGenT Identity XML) IO Date) (ok . toResponse . show) + +handleForm :: String -> String -> Form (XMLGenT Identity XML) IO a -> (a -> WebT IO Response) -> [ServerPart Response] +handleForm prefix action page handleOk = + [ method GET $ ok (toResponse (html4Strict, (evalIdentity (createForm [] prefix action [] page)))) + , withDataFn lookPairs $ \env' -> + [ method POST $ + do let (extractor, _, _) = runFormState [] prefix page + env = map (second Left) env' + res <- lift $ extractor env + case res of + Failure faults -> + ok (toResponse (html4Strict, evalIdentity (createForm env prefix action faults page))) + Success s -> handleOk s + ] + , debug404 + ] + +{- +handleForm :: (Monad m) => + String + -> (Form' m a -> XMLGenT (IdentityT (Reader FormState)) XML) + -> Form' m a + -> (a -> WebT m Response) + -> [ServerPartT m Response] +handleForm prefix page frm handleOk = + [ method GET $ evalForm page frm (FormState [] prefix "/" []) + , withDataFn lookPairs $ \env' -> + [ method POST $ + do let (extractor, _, _) = runFormState [] prefix frm + env = map (second Left) env' + res <- lift $ extractor env + case res of + Failure faults -> + evalForm page frm (FormState env prefix "/" faults) + Success s -> handleOk s + ] + ] + +evalForm :: (Monad m) => (Form' m a -> XMLGenT (IdentityT (Reader FormState)) XML) -> Form' m a -> FormState -> WebT m Response +evalForm page frm formState = ok (toResponse (runReader (runIdentityT $ unXMLGenT (page frm)) formState )) + + +-} }