module MFlow.Forms(
FlowM, View(..), FormElm(..), FormInput(..)
,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName
,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget,getLang,
ask, clearEnv, wstateless, transfer,
getString,getInt,getInteger, getTextBox
,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
getRadio, setRadio, setRadioActive, getCheckBoxes, genCheckBoxes, setCheckBox,
submitButton,resetButton, whidden, wlink, returning, wform, firstOf, manyOf, wraw, wrender
,validate, noWidget, waction, wmodify,
cachedWidget, wcached, wfreeze,
(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
(<<<),(<++),(++>),(<!),
(.<<.),(.<++.),(.++>.)
,btag,bhtml,bbody
, flatten, normalize
,runFlow,runFlowIn,MFlow.Forms.Internals.step, goingBack,breturn
,setHeader
,setSessionData
,getSessionData
,getHeader
,setTimeouts
,setCookie
,ajax
,ajaxSend
,ajaxSend_
,Requirements(..)
,WebRequirement(..)
,requires
,genNewId
,changeMonad
)
where
import Data.RefSerialize hiding ((<|>))
import Data.TCache
import Data.TCache.Memoization
import MFlow
import MFlow.Forms.Internals
import MFlow.Cookies
import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks)
import Data.List
import qualified Data.CaseInsensitive as CI
import Data.Typeable
import Data.Monoid
import Control.Monad.State.Strict
import Data.Maybe
import Control.Applicative
import Control.Exception
import Control.Concurrent
import Control.Workflow as WF
import Control.Monad.Identity
import Unsafe.Coerce
import Data.List(intersperse)
import Data.IORef
import qualified Data.Map as M
import System.IO.Unsafe
import Data.Char(isNumber)
import Network.HTTP.Types.Header
validate
:: (FormInput view, Monad m) =>
View view m a
-> (a -> WState view m (Maybe String))
-> View view m a
validate formt val= View $ do
FormElm form mx <- (runView formt)
case mx of
Just x -> do
me <- val x
modify (\s -> s{inSync= True})
case me of
Just str ->
return $ FormElm ( inred (fromStr str) : form) Nothing
Nothing -> return $ FormElm [] mx
_ -> return $ FormElm form mx
waction
:: (FormInput view, Monad m)
=> View view m a
-> (a -> FlowM view m b)
-> View view m b
waction f ac = do
x <- f
s <- get
let env = mfEnv s
let seq = mfSequence s
put s{mfSequence=mfSequence s+ 100,mfEnv=[]}
r <- flowToView $ ac x
modify $ \s-> s{mfSequence= seq, mfEnv= env}
return r
where
flowToView x=
View $ do
r <- runBackT $ runFlowM x
case r of
NoBack x ->
return (FormElm [] $ Just x)
BackPoint x->
return (FormElm [] $ Just x)
GoBack-> do
modify $ \s ->s{notSyncInAction= True}
return (FormElm [] Nothing)
wmodify :: (Monad m, FormInput v)
=> View v m a
-> ([v] -> Maybe a -> WState v m ([v], Maybe b))
-> View v m b
wmodify formt act = View $ do
FormElm f mx <- runView formt
(f',mx') <- act f mx
return $ FormElm f' mx'
getString :: (FormInput view,Monad m) =>
Maybe String -> View view m String
getString = getTextBox
getInteger :: (FormInput view, MonadIO m) =>
Maybe Integer -> View view m Integer
getInteger = getTextBox
getInt :: (FormInput view, MonadIO m) =>
Maybe Int -> View view m Int
getInt = getTextBox
getPassword :: (FormInput view,
Monad m) =>
View view m String
getPassword = getParam Nothing "password" Nothing
data Radio= Radio String
setRadioActive :: (FormInput view, MonadIO m) =>
String -> String -> View view m Radio
setRadioActive v n = View $ do
st <- get
put st{needForm= True}
let env = mfEnv st
FormElm form mn <- getParam1 n env []
return $ FormElm [finput n "radio" v
( isJust mn && v== fromJust mn) (Just "this.form.submit()")]
(fmap Radio mn)
setRadio :: (FormInput view, MonadIO m) =>
String -> String -> View view m Radio
setRadio v n= View $ do
st <- get
put st{needForm= True}
let env = mfEnv st
FormElm f mn <- getParam1 n env []
return $ FormElm
(f++[finput n "radio" v
( isJust mn && v== fromJust mn) Nothing])
(fmap Radio mn)
getRadio
:: (Monad m, Functor m, FormInput view) =>
[String -> View view m Radio] -> View view m String
getRadio rs= do
id <- genNewId
Radio r <- firstOf $ map (\r -> r id) rs
return r
data CheckBoxes = CheckBoxes [String]
instance Monoid CheckBoxes where
mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
mempty= CheckBoxes []
instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where
mappend x y = mappend <$> x <*> y
mempty= return mempty
setCheckBox :: (FormInput view, MonadIO m) =>
Bool -> String -> View view m CheckBoxes
setCheckBox checked v= View $ do
n <- genNewId
st <- get
put st{needForm= True}
let env = mfEnv st
strs= map snd $ filter ((==) n . fst) env
mn= if null strs then Nothing else Just $ head strs
val <- gets inSync
let ret= case val of
True -> Just $ CheckBoxes strs
False -> Nothing
return $ FormElm
( [ finput n "checkbox" v
( checked || (isJust mn && v== fromJust mn)) Nothing])
ret
genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes
genCheckBoxes v= View $ do
n <- genNewId
st <- get
put st{needForm= True}
let env = mfEnv st
strs= map snd $ filter ((==) n . fst) env
mn= if null strs then Nothing else Just $ head strs
val <- gets inSync
let ret= case val of
True -> Just $ CheckBoxes strs
False -> Nothing
return $ FormElm [ftag "span" v `attrs`[("id",n)]] ret
whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
whidden x= View $ do
n <- genNewId
env <- gets mfEnv
let showx= case cast x of
Just x' -> x'
Nothing -> show x
getParam1 n env [finput n "hidden" showx False Nothing]
getCheckBoxes ::(FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
getCheckBoxes boxes = View $ do
n <- genNewId
env <- gets mfEnv
FormElm form (mr :: Maybe String) <- getParam1 n env [finput n "hidden" "" False Nothing]
st <- get
let env = mfEnv st
put st{needForm= True}
FormElm form2 mr2 <- runView boxes
return $ FormElm (form ++ form2) $
case (mr,mr2) of
(Nothing,_) -> Nothing
(Just _,Nothing) -> Just []
(Just _, Just (CheckBoxes rs)) -> Just rs
getTextBox
:: (FormInput view,
Monad m,
Typeable a,
Show a,
Read a) =>
Maybe a -> View view m a
getTextBox ms = getParam Nothing "text" ms
getParam
:: (FormInput view,
Monad m,
Typeable a,
Show a,
Read a) =>
Maybe String -> String -> Maybe a -> View view m a
getParam look type1 mvalue = View $ do
tolook <- case look of
Nothing -> genNewId
Just n -> return n
let nvalue= case mvalue of
Nothing -> ""
Just v ->
case cast v of
Just v' -> v'
Nothing -> show v
form= [finput tolook type1 nvalue False Nothing]
st <- get
let env = mfEnv st
put st{needForm= True}
getParam1 tolook env form
genNewId :: MonadState (MFlowState view) m => m String
genNewId= do
st <- get
case mfCached st of
False -> do
let n= mfSequence st
put $ st{mfSequence= n+1}
return $ 'p':(show n)
True -> do
let n = mfSeqCache st
put $ st{mfSeqCache=n+1}
return $ 'c' : (show n)
getCurrentName :: MonadState (MFlowState view) m => m String
getCurrentName= do
st <- get
let parm = mfSequence st
return $ "p"++show parm
getMultilineText :: (FormInput view,
Monad m) =>
String -> View view m String
getMultilineText nvalue = View $ do
tolook <- genNewId
env <- gets mfEnv
let form= [ftextarea tolook nvalue]
getParam1 tolook env form
getBool :: (FormInput view,
Monad m) =>
Bool -> String -> String -> View view m Bool
getBool mv truestr falsestr= View $ do
tolook <- genNewId
st <- get
let env = mfEnv st
put st{needForm= True}
r <- getParam1 tolook env $ [fselect tolook(foption1 truestr mv `mappend` foption1 falsestr (not mv))]
return $ fmap fromstr r
where
fromstr x= if x== truestr then True else False
getSelect :: (FormInput view,
Monad m,Typeable a, Read a) =>
View view m (MFOption a) -> View view m a
getSelect opts = View $ do
tolook <- genNewId
st <- get
let env = mfEnv st
put st{needForm= True}
FormElm form mr <- (runView opts)
getParam1 tolook env [fselect tolook $ mconcat form]
data MFOption a= MFOption
instance (Monad m, Functor m) => Monoid (View view m (MFOption a)) where
mappend = (<|>)
mempty = Control.Applicative.empty
setOption n v = setOption1 n v False
setSelectedOption n v= setOption1 n v True
setOption1 :: (FormInput view,
Monad m, Typeable a, Show a) =>
a -> view -> Bool -> View view m (MFOption a)
setOption1 nam val check= View $ do
st <- get
let env = mfEnv st
put st{needForm= True}
let n= if typeOf nam== typeOf(undefined :: String) then unsafeCoerce nam else show nam
return . FormElm [foption n val check] $ Just MFOption
(<<<) :: (Monad m, Monoid view)
=> (view ->view)
-> View view m a
-> View view m a
(<<<) v form= View $ do
FormElm f mx <- runView form
return $ FormElm [v $ mconcat f] mx
infixr 5 <<<
(<++) :: (Monad m)
=> View v m a
-> v
-> View v m a
(<++) form v= View $ do
FormElm f mx <- runView form
return $ FormElm ( f ++ [ v]) mx
infixr 6 <++ , .<++. , ++> , .++>.
(++>) :: (Monad m, Monoid view)
=> view -> View view m a -> View view m a
html ++> digest = (html `mappend`) <<< digest
infix 8 <!
widget <! atrs= View $ do
FormElm fs mx <- runView widget
return $ FormElm [attrs (head fs) atrs] mx
userFormLine :: (FormInput view, Functor m, Monad m)
=> View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
userFormLine=
((,) <$> getString (Just "enter user") <! [("size","5")]
<*> getPassword <! [("size","5")]
<** submitButton "login")
<+> (fromStr " password again" ++> getPassword <! [("size","5")]
<* submitButton "register")
userLogin :: (FormInput view, Functor m, Monad m)
=> View view m (Maybe (UserStr,PasswdStr), Maybe String)
userLogin=
((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
<*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
<** submitButton "login")
<+> (noWidget
<* noWidget)
noWidget :: (FormInput view,
Monad m) =>
View view m a
noWidget= View . return $ FormElm [] Nothing
wrender
:: (Monad m, Functor m, Show a, FormInput view) =>
a -> View view m a
wrender x = (wraw . fromStr $ show x) **> return x
wraw :: Monad m => view -> View view m ()
wraw x= View . return . FormElm [x] $ Just ()
isLogged :: MonadState (MFlowState v) m => m Bool
isLogged= do
rus <- return . tuser =<< gets mfToken
return . not $ rus == anonymous
userWidget :: ( MonadIO m, Functor m
, FormInput view)
=> Maybe String
-> View view m (Maybe (UserStr,PasswdStr), Maybe String)
-> View view m String
userWidget muser formuser= do
user <- getCurrentUser
if muser== Just user
then return user
else formuser `validate` val muser `waction` login
where
val _ (Nothing,_) = return $ Just "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
val mu (Just us, Nothing)=
if isNothing mu || isJust mu && fromJust mu == fst us
then userValidate us
else return $ Just "wrong user for the operation"
val mu (Just us, Just p)=
if isNothing mu || isJust mu && fromJust mu == fst us
then if length p > 0 && snd us== p
then return Nothing
else return $ Just "The passwords do not match"
else return $ Just "wrong user for the operation"
login (Just (u,p), Nothing)= do
let uname= u
st <- get
let t = mfToken st
t'= t{tuser= uname}
moveState (twfname t) t t'
put st{mfToken= t'}
liftIO $ deleteTokenInList t
liftIO $ addTokenToList t'
setCookie cookieuser uname "/" (Just $ 365*24*60*60)
return uname
login (Just us@(u,p), Just _)= do
userRegister u p
login (Just us , Nothing)
logout :: (MonadIO m, MonadState (MFlowState view) m) => m ()
logout= do
st <- get
let t = mfToken st
t'= t{tuser= anonymous}
moveState (twfname t) t t'
put st{mfToken= t'}
liftIO $ deleteTokenInList t
liftIO $ addTokenToList t'
setCookie cookieuser anonymous "/" (Just $ 1000)
getUserSimple :: ( FormInput view, Typeable view
, MonadIO m, Functor m)
=> FlowM view m String
getUserSimple= getUser Nothing userFormLine
getUser :: ( FormInput view, Typeable view
, MonadIO m, Functor m)
=> Maybe String
-> View view m (Maybe (UserStr,PasswdStr), Maybe String)
-> FlowM view m String
getUser mu form= ask $ userWidget mu form
(<+>) , mix :: Monad m
=> View view m a
-> View view m b
-> View view m (Maybe a, Maybe b)
mix digest1 digest2= View $ do
FormElm f1 mx' <- runView digest1
FormElm f2 my' <- runView digest2
return $ FormElm (f1++f2)
$ case (mx',my') of
(Nothing, Nothing) -> Nothing
other -> Just other
infixr 2 <+>, .<+>.
(<+>) = mix
(**>) :: (Functor m, Monad m)
=> View view m a -> View view m b -> View view m b
(**>) form1 form2 = valid form1 *> form2
infixr 1 **> , .**>. , <** , .<**.
(<**)
:: (Functor m, Monad m) =>
View view m a -> View view m b -> View view m a
(<**) form1 form2 = form1 <* valid form2
valid form= View $ do
FormElm form mx <- runView form
return $ FormElm form $ Just undefined
ask
:: (FormInput view,
MonadIO m,
Typeable view) =>
View view m b -> FlowM view m b
ask w = do
st1 <- get
let env= mfEnv st1
let mv1= lookup "ajax" env
let majax1= mfAjax st1
case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of
(Just ajaxl,Just v1,Just f, Just v2) -> do
FlowM . lift $ (unsafeCoerce f) v2
FlowM $ lift receiveWithTimeouts
ask w
_ -> do
let st= st1{needForm= False, inSync= False, mfRequirements= []}
put st
FormElm forms mx <- FlowM . lift $ runView w
st' <- get
if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w else
case mx of
Just x -> do
put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]}
breturn x
Nothing ->
if not (inSync st') && not (onInit st') && hasParams (mfSequence st') (mfSeqCache st') ( mfEnv st')
then do
put st'{mfSequence= head1 $ prevSeq st'
,prevSeq= tail1 $ prevSeq st' }
fail ""
else do
reqs <- FlowM $ lift installAllRequirements
let header= mfHeader st'
t= mfToken st'
cont = case (needForm st') of
True -> header $ reqs <> (formAction (twfname t ) $ mconcat forms)
_ -> header $ reqs <> mconcat forms
HttpData ctype c s= toHttpData cont
liftIO . sendFlush t $ HttpData (ctype++mfHttpHeaders st') (mfCookies st' ++ c) s
put st{mfCookies=[],mfHttpHeaders=[], onInit= False, mfToken= t, mfAjax= mfAjax st', mfSeqCache= mfSeqCache st' }
FlowM $ lift receiveWithTimeouts
ask w
where
head1 []=0
head1 xs= head xs
tail1 []=[]
tail1 xs= tail xs
hasParams seq cseq= not . null . filter (\(p,_) ->
let tailp = tail p
in and (map isNumber tailp) &&
let rt= read tailp
in case head p of
'p' -> rt <= seq
'c' -> rt <= cseq
_ -> False)
goingBack :: MonadState (MFlowState view) m => m Bool
goingBack = do
st <- get
return $ not (inSync st) && not (onInit st)
clearEnv :: MonadState (MFlowState view) m => m ()
clearEnv= do
st <- get
put st{ mfEnv= []}
receiveWithTimeouts :: MonadIO m => WState view m ()
receiveWithTimeouts= do
st <- get
let t= mfToken st
t1= mfkillTime st
t2= mfSessionTime st
req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t)
put st{mfEnv= req}
wstateless
:: (Typeable view, FormInput view) =>
View view IO a -> Flow
wstateless w = transient $ runFlow loop
where
loop= do
ask w
env <- get
put $ env{ mfSequence= 0,prevSeq=[]}
loop
--wstatelessLog
transfer :: MonadIO m => String -> FlowM v m ()
transfer flowname =do
t <- gets mfToken
let t'= t{twfname= flowname}
liftIO $ do
(r,_) <- msgScheduler t'
sendFlush t r
wform :: (Monad m, FormInput view)
=> View view m b -> View view m b
wform x = View $ do
FormElm form mr <- (runView $ x )
st <- get
let t = mfToken st
anchor <- genNewId
put st{needForm=False}
let anchorf= (ftag "a") mempty `attrs` [("name",anchor)]
let form1= formAction (twfname t ) $ mconcat ( anchorf:form)
return $ FormElm [form1] mr
resetButton :: (FormInput view, Monad m) => String -> View view m ()
resetButton label= View $ return $ FormElm [finput "reset" "reset" label False Nothing] $ Just ()
submitButton :: (FormInput view, Monad m) => String -> View view m String
submitButton label= getParam Nothing "submit" $ Just label
newtype AjaxSessionId= AjaxSessionId String deriving Typeable
ajax :: (MonadIO m)
=> (String -> View v m ByteString)
-> View v m (String -> String)
ajax f = do
requires[JScript ajaxScript]
t <- gets mfToken
id <- genNewId
installServerControl id $ \x-> do
setSessionData $ AjaxSessionId id
r <- f x
liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
return ()
installServerControl :: MonadIO m => String -> (String -> View v m ()) -> View v m (String -> String)
installServerControl id f= do
t <- gets mfToken
st <- get
let ajxl = fromMaybe M.empty $ mfAjax st
let ajxl'= M.insert id (unsafeCoerce f ) ajxl
put st{mfAjax=Just ajxl'}
return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")"
ajaxSend
:: (Read a,MonadIO m) => View v m ByteString -> View v m a
ajaxSend cmd= View $ do
AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"
env <- getEnv
t <- getToken
case (lookup "ajax" $ env, lookup "val" env) of
(Nothing,_) -> return $ FormElm [] Nothing
(Just id, Just _) -> do
FormElm __ (Just str) <- runView cmd
liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"
receiveWithTimeouts
env <- getEnv
case (lookup "ajax" $ env,lookup "val" env) of
(Nothing,_) -> return $ FormElm [] Nothing
(Just id, Just v2) -> do
return $ FormElm [] . Just $ read v2
where
readEvalLoop t id v = "doServer('"<> pack (twfname t)<>"','"<> pack id<>"',"<>v<>");" :: ByteString
ajaxSend_
:: MonadIO m => View v m ByteString -> View v m ()
ajaxSend_ = ajaxSend
wlink :: (Typeable a, Read a, Show a, MonadIO m, Functor m, FormInput view)
=> a -> view -> View view m a
wlink x v= View $ do
verb <- getWFName
name <- genNewId
env <- gets mfEnv
let
showx= if typeOf x== typeOf (undefined :: String) then unsafeCoerce x else show x
toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v
getParam1 name env [toSend]
returning ::(Typeable a, Read a, Show a,Monad m, FormInput view)
=> ((a->String) ->view) -> View view m a
returning expr=View $ do
verb <- getWFName
name <- genNewId
env <- gets mfEnv
let string x=
let showx= case cast x of
Just x' -> x'
_ -> show x
in (verb ++ "?" ++ name ++ "=" ++ showx)
toSend= expr string
getParam1 name env [toSend]
firstOf :: (Monoid view, Monad m, Functor m)=> [View view m a] -> View view m a
firstOf xs= View $ do
forms <- mapM runView xs
let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms
res = filter isJust $ map (\(FormElm _ r) -> r) forms
res1= if null res then Nothing else head res
return $ FormElm vs res1
manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a]
manyOf xs= whidden () *> (View $ do
forms <- mapM runView xs
let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms
res1= catMaybes $ map (\(FormElm _ r) -> r) forms
return $ FormElm vs $ Just res1)
(>:>) ::(Monad m)=> View v m a -> View v m [a] -> View v m [a]
(>:>) w ws= View $ do
FormElm fs mxs <- runView $ ws
FormElm f1 mx <- runView w
return $ FormElm (f1++ fs)
$ case( mx,mxs) of
(Just x, Just xs) -> Just $ x:xs
(Nothing, mxs) -> mxs
(Just x, _) -> Just [x]
(|*>) :: (MonadIO m, Functor m,Monoid view)
=> View view m r
-> [View view m r']
-> View view m (Maybe r,Maybe r')
(|*>) x xs= View $ do
FormElm fxs rxs <- runView $ firstOf xs
FormElm fx rx <- runView $ x
return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx)
$ case (rx,rxs) of
(Nothing, Nothing) -> Nothing
other -> Just other
infixr 5 |*>, .|*>.
(|+|) :: (Functor m, Monoid view, MonadIO m)
=> View view m r
-> View view m r'
-> View view m (Maybe r, Maybe r')
(|+|) w w'= w |*> [w']
infixr 1 |+|, .|+|.
flatten :: Flatten (Maybe tree) list => tree -> list
flatten res= doflat $ Just res
class Flatten tree list where
doflat :: tree -> list
type Tuple2 a b= Maybe (Maybe a, Maybe b)
type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)
type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)
type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)
type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)
instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
doflat (Just(ma,mb))= (ma,mb)
doflat Nothing= (Nothing,Nothing)
instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where
doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)
doflat Nothing= (Nothing,Nothing,Nothing)
instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where
doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)
doflat Nothing= (Nothing,Nothing,Nothing,Nothing)
instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where
doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)
doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)
instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where
doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)
doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
infixr 7 .<<.
(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
(.<<.) w x = w ( toByteString x)
(.<+>.)
:: (Monad m, FormInput v, FormInput v1) =>
View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
(.<+>.) x y = normalize x <+> normalize y
(.|*>.)
:: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
View v m r
-> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
(.|*>.) x y = normalize x |*> map normalize y
(.|+|.)
:: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
(.|+|.) x y = normalize x |+| normalize y
(.**>.)
:: (Monad m, Functor m, FormInput v, FormInput v1) =>
View v m a -> View v1 m b -> View ByteString m b
(.**>.) x y = normalize x **> normalize y
(.<**.)
:: (Monad m, Functor m, FormInput v, FormInput v1) =>
View v m a -> View v1 m b -> View ByteString m a
(.<**.) x y = normalize x <** normalize y
(.<|>.)
:: (Monad m, Functor m, FormInput v, FormInput v1) =>
View v m a -> View v1 m a -> View ByteString m a
(.<|>.) x y= normalize x <|> normalize y
(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
(.<++.) x v= normalize x <++ toByteString v
(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
(.++>.) v x= toByteString v ++> normalize x
instance FormInput ByteString where
toByteString= id
toHttpData = HttpData [contentHtml ] []
ftag x= btag x []
inred = btag "b" [("style", "color:red")]
finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []
++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""
ftextarea name text= btag "textarea" [("name", name)] $ pack text
fselect name options= btag "select" [("name", name)] options
foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
where
selected msel = if msel then [("selected","true")] else []
attrs = addAttrs
formAction action form = btag "form" [("action", action),("method", "post")] form
fromStr = pack
fromStrNoEncode= pack
flink v str = btag "a" [("href", v)] str