module MFlow.Forms(
FlowM, View(..), FormElm(..), FormInput(..)
,userRegister, userValidate, isLogged, setAdminUser, getAdminName
,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget,getLang, login,
userName,
ask, page, askt, clearEnv, wstateless, transfer, pageFlow,
getString,getInt,getInteger, getTextBox
,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
submitButton,resetButton, whidden, wlink, returning, wform, firstOf, manyOf, wraw, wrender, notValid
,validate, noWidget, waction, wcallback, wmodify,
cachedWidget, wcached, wfreeze,
(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
(<<<),(++>),(<++),(<!),
(.<<.),(.<++.),(.++>.)
,btag,bhtml,bbody
, flatten, normalize
,runFlow, transientNav,runFlowOnce,runFlowIn,runFlowConf,MFlow.Forms.Internals.step, goingBack,breturn, preventGoingBack
,setHeader
,setSessionData
,getSessionData
,getHeader
,setTimeouts
,setCookie
,ajax
,ajaxSend
,ajaxSend_
,Requirements(..)
,WebRequirement(..)
,requires
,genNewId
,changeMonad
,FailBack
,fromFailBack
,toFailBack
,MFlowState
)
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 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,toLower)
import Network.HTTP.Types.Header
validate
:: (FormInput view, Monad m) =>
View view m a
-> (a -> WState view m (Maybe view))
-> 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 ( form ++ [inred str]) Nothing
Nothing -> return $ FormElm form 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=[],newAsk=True}
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 ms = getTextBox ms
`validate`
\s -> if null s then return (Just $ fromStr "")
else return Nothing
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
newtype Radio a= Radio a
setRadioActive :: (FormInput view, MonadIO m,
Read a, Typeable a, Eq a, Show a) =>
a -> String -> View view m (Radio a)
setRadioActive v n = View $ do
st <- get
put st{needForm= True}
let env = mfEnv st
mn <- getParam1 n env
let str = if typeOf v == typeOf(undefined :: String)
then unsafeCoerce v else show v
return $ FormElm [finput n "radio" str
( isValidated mn && v== fromValidated mn) (Just "this.form.submit()")]
(fmap Radio $ valToMaybe mn)
valToMaybe (Validated x)= Just x
valToMaybe _= Nothing
isValidated (Validated x)= True
isValidated _= False
fromValidated (Validated x)= x
fromValidated NoParam= error $ "fromValidated : NoParam"
fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
setRadio :: (FormInput view, MonadIO m,
Read a, Typeable a, Eq a, Show a) =>
a -> String -> View view m (Radio a)
setRadio v n= View $ do
st <- get
put st{needForm= True}
let env = mfEnv st
mn <- getParam1 n env
let str = if typeOf v == typeOf(undefined :: String)
then unsafeCoerce v else show v
return $ FormElm [finput n "radio" str
( isValidated mn && v== fromValidated mn) Nothing]
(fmap Radio $ valToMaybe mn)
getRadio
:: (Monad m, Functor m, FormInput view) =>
[String -> View view m (Radio a)] -> View view m a
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 []
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 !> "head 3"
val = inSync st
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
r <- getParam1 n env
return $ FormElm [finput n "hidden" showx False Nothing] $ valToMaybe r
getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
getCheckBoxes boxes = View $ do
n <- genNewId
st <- get
let env = mfEnv st
let form= [finput n "hidden" "" False Nothing]
mr <- getParam1 n env
let env = mfEnv st
modify $ \st -> st{needForm= True}
FormElm form2 mr2 <- runView boxes
return $ FormElm (form ++ form2) $
case (mr `asTypeOf` Validated ("" :: String),mr2) of
(NoParam,_) -> Nothing
(Validated _,Nothing) -> Just []
(Validated _, 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 x= case x of
Nothing -> ""
Just v ->
case cast v of
Just v' -> v'
Nothing -> show v
st <- get
let env = mfEnv st
put st{needForm= True}
r <- getParam1 tolook env
case r of
Validated x -> return $ FormElm [finput tolook type1 (nvalue $ Just x) False Nothing] $ Just x
NotValidated s err -> return $ FormElm ([finput tolook type1 s False Nothing]++[err]) $ Nothing
NoParam -> return $ FormElm [finput tolook type1 (nvalue mvalue) False Nothing] $ Nothing
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
r <- getParam1 tolook env
case r of
Validated x -> return $ FormElm [ftextarea tolook (show x) ] $ Just x
NotValidated s err -> return $ FormElm [ftextarea tolook s ] $ Nothing
NoParam -> return $ FormElm [ftextarea tolook nvalue ] $ Nothing
getBool :: (FormInput view,
Monad m, Functor m) =>
Bool -> String -> String -> View view m Bool
getBool mv truestr falsestr= do
r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])
<|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
if r == truestr then return True else return 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}
r <- getParam1 tolook env
setSessionData $ fmap MFOption $ valToMaybe r
FormElm form mr <- (runView opts)
return $ FormElm [fselect tolook $ mconcat form] $ valToMaybe r
newtype MFOption a= MFOption a deriving Typeable
instance (Monad m, Functor m) => Monoid (View view m (MFOption a)) where
mappend = (<|>)
mempty = Control.Applicative.empty
setOption
:: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
a -> view -> View view m (MFOption a)
setOption n v = do
mo <- getSessionData
case mo of
Nothing -> setOption1 n v False
Just Nothing -> setOption1 n v False
Just (Just (MFOption o)) -> setOption1 n v $ n == o
setSelectedOption
:: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
a -> view -> View view m (MFOption a)
setSelectedOption n v= do
mo <- getSessionData
case mo of
Nothing -> setOption1 n v True
Just Nothing -> setOption1 n v True
Just (Just o) -> setOption1 n v $ n == o
setOption1 :: (FormInput view,
Monad m, Typeable a, Eq 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 nam
(<<<) :: (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
infixl 8 <!
widget <! attribs= View $ do
FormElm fs mx <- runView widget
return $ FormElm (head fs `attrs` attribs:tail fs) mx !> "head 4"
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 = (fromStr $ show x) ++> return x
wraw :: Monad m => view -> View view m ()
wraw x= View . return . FormElm [x] $ Just ()
notValid :: Monad m => view -> View view m a
notValid x= View . return $ FormElm [x] Nothing
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 || isNothing muser && user/= anonymous
then return user
else formuser `validate` val muser `waction` login1
where
val _ (Nothing,_) = return . Just $ fromStr "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 $ fromStr "This user has no permissions for this task"
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 $ fromStr "The passwords do not match"
else return . Just $ fromStr "wrong user for the operation"
login1
:: (MonadIO m, MonadState (MFlowState view) m) =>
(Maybe (String, String), Maybe String) -> m String
login1 (Just (uname,_), Nothing)= login uname >> return uname
login1 (Just us@(u,p), Just _)= do
userRegister u p
login u
return u
login uname= do
st <- get
let t = mfToken st
u = tuser t
if u == uname then return () else do
let 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 ()
logout :: (MonadIO m, MonadState (MFlowState view) m) => m ()
logout= do
st <- get
let t = mfToken st
t'= t{tuser= anonymous}
if tuser t == anonymous then return () else do
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)
=> FlowM view IO String
getUserSimple= getUser Nothing userFormLine
getUser :: ( FormInput view, Typeable view)
=> Maybe String
-> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
-> FlowM view IO 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
askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
askt v w = ask w
ask
:: (FormInput view) =>
View view IO a -> FlowM view IO a
ask w = do
st1 <- get
let env= mfEnv st1
mv1= lookup "ajax" env
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 nextMessage
ask w
_ -> do
let st= st1{needForm= False, inSync= False, mfRequirements= [],linkMatched=False}
put st
FormElm forms mx <- FlowM . lift $ runView w
st' <- get
if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
else if mfAutorefresh st' then resetState st st' >> FlowM (lift nextMessage) >> ask w
else
case mx of
Just x -> do
put st'{newAsk= True , mfEnv=[]
,mfPageIndex=Nothing
,mfPIndex= case isJust $ mfPageIndex st' of
True -> length (mfPath st') 1
False -> mfPIndex st'
}
breturn x
Nothing ->
if not (inSync st') && not (newAsk st')
!> ("pageIndex="++ show (mfPageIndex st'))
!> ("insinc="++show (inSync st'))
!> ("newask="++show (newAsk st'))
!> ("mfPIndex="++ show( mfPIndex st'))
then do
let index = mfPIndex st'
nindex= if index== 0 then 1 else index 1
put st'{mfPIndex= nindex} !> "BACKTRACK"
fail ""
else do
reqs <- FlowM $ lift installAllRequirements
let header= mfHeader st'
t= mfToken st'
cont <- case (needForm st') of
True -> do
frm <- formPrefix (mfPIndex st') (twfname t ) st' forms False
return . header $ reqs <> frm
_ -> return . header $ reqs <> mconcat forms
let HttpData ctype c s= toHttpData cont
liftIO . sendFlush t $ HttpData (ctype++mfHttpHeaders st') (mfCookies st' ++ c) s
resetState st st'
FlowM $ lift nextMessage
ask w
where
resetState st st'=
put st{mfCookies=[]
,mfHttpHeaders=[]
,newAsk= False
,mfToken= mfToken st'
,mfPageIndex= mfPageIndex st'
,mfAjax= mfAjax st'
,mfSeqCache= mfSeqCache st' }
page
:: (FormInput view) =>
View view IO a -> FlowM view IO a
page= ask
comparePaths _ n [] xs= n
comparePaths o n _ [] = o
comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath
| otherwise= n
nextMessage :: MonadIO m => WState view m ()
nextMessage= do
st <- get
let t= mfToken st
t1= mfkillTime st
t2= mfSessionTime st
msg <- liftIO ( receiveReqTimeout t1 t2 t)
let req= getParams msg
env= updateParams inPageFlow (mfEnv st) req
npath= pwfPath msg
path= mfPath st
inPageFlow= isJust $ mfPageIndex st
put st{ mfPath= npath
, mfPIndex= case mfPageIndex st !> ("mfPageIndex=" ++ show (mfPageIndex st)) of
Just n -> n
Nothing ->
comparePaths (mfPIndex st) 1 (tail path) (tail npath)
, mfEnv= env }
where
updateParams :: Bool -> Params -> Params -> Params
updateParams False _ req= req !> "NOT IN PAGE FLOW"
updateParams True env req=
let params= takeWhile isparam env
fs= fst $ head req !> "head 1"
parms= (case findIndex (\p -> fst p == fs) params of
Nothing -> params
Just i -> take i params)
++ req
in parms !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
!> ("env=" ++ show env)
!> ("req=" ++ show req)
isparam ('p': r:_,_)= isNumber r
isparam ('c': r:_,_)= isNumber r
isparam _= False
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}
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
verb <- getWFName
form1 <- formPrefix (mfPIndex st) verb st form True
put st{needForm=False}
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 "''"
nextMessage
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
wlabel
:: (Monad m, FormInput view) => view -> View view m a -> View view m a
wlabel str w = do
id <- genNewId
ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
wlink :: (Typeable a, Show a, MonadIO m, FormInput view)
=> a -> view -> View view m a
wlink x v= View $ do
verb <- getWFName
st <- get
let
name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
then unsafeCoerce x
else show x)
index' = mfPIndex st
+ if linkMatched st then 1 else 0
+ if Just (mfPIndex st)== mfPageIndex st then 1 else 0
index = if index'== 0 then 1 else index'
lpath = mfPath st
back = True
let path= currentPath back index lpath verb ++ ('/':name)
!> (show $ mfPath st)
toSend = flink path v
r <- if linkMatched st then return Nothing
else
if isJust $ mfPageIndex st !> (show $ mfPageIndex st)
then
case M.lookup name $ mfLinks st !> (show $ mfLinks st)of
Just 0 -> do
modify $ \st -> st{ inSync= True}
return Nothing !> (name ++ " 0 Fail")
Just n -> do
modify $ \st -> st{ inSync= True,linkMatched= True
, mfPIndex= index + 1
, mfLinks= M.insert name (n1) $ mfLinks st}
!> (name ++" "++ show n ++ " Match")
return $ Just x
Nothing -> return Nothing !> (name ++ " 0 Fail")
else
case index < length lpath && name== lpath !! index of
True -> do
modify $ \s -> s{inSync= True
, linkMatched= True, mfPIndex= index+1 } !> (name ++ "<-" ++show index++ " MATCHED")
return $ Just x
False -> return Nothing !> (name++"<-" ++show index++ " "++(if index < length lpath then lpath !! index else ""))
return $ FormElm [toSend] r
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
r <- getParam1 name env
return $ FormElm [toSend] $ valToMaybe r
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 !> "head 2"
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
pageFlow
:: (Monad m, Functor m, FormInput view) =>
String -> View view m a -> View view m a
pageFlow str flow=do
s <- get
if isNothing $ mfPageIndex s
then do
put s{mfPrefix= str ++ mfPrefix s
,mfSequence=0
,mfLinks= acum M.empty $ drop (mfPIndex s) (mfPath s)
,mfPageIndex= Just $ mfPIndex s } !> ("PARENT pageflow. prefix="++ str)
flow <** (modify (\s' -> s'{mfSequence= mfSequence s
,mfPrefix= mfPrefix s})
!> ("END PARENT pageflow. prefix="++ str))
else do
put s{mfPrefix= str++ mfPrefix s
,mfLinks= acum M.empty $ drop (fromJust $ mfPageIndex s) (mfPath s)
,mfSequence=0} !> ("CHILD pageflow. prefix="++ str)
flow <** (modify (\s' -> s'{mfSequence= mfSequence s
,mfPrefix= mfPrefix s})
!> ("END CHILD pageflow. prefix="++ str))
acum map []= map
acum map (x:xs) =
let map' = case M.lookup x map of
Nothing -> M.insert x 1 map
Just n -> M.insert x (n+1) map
in acum map' xs