module MFlow.Forms(
Widget(..),FormLet(..), Launchable(..)
,View, FormInput(..), FormT(..),FormElm(..)
,Form(..),Selection(..)
,userRegister, userAuthenticate, User(userName)
,getUser,
ask,
getString,getInt,getInteger
,getMultilineText,getBool,getOption, getPassword,validate
,mix,wrap,addToForm
,FlowM,runFlow,MFlow.Forms.step
,setHeader
,setTimeouts
,setCookie
)
where
import Data.TCache
import MFlow
import MFlow.Cookies
import Data.RefSerialize (Serialize)
import Control.Workflow as WF
import Data.Typeable
import Data.Monoid
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Applicative
import Control.Exception
import Control.Workflow(exec1,Workflow, waitUntilSTM, step, unsafeIOtoWF)
import Debug.Trace
(!>)= flip trace
type UserName= String
data User= User
{ userName :: UserName
, upassword :: String
} deriving (Read, Show, Typeable)
eUser= User (error1 "username") (error1 "password")
error1 s= error $ s ++ " undefined"
userPrefix= "User#"
instance Indexable User where
key User{userName= user}= userPrefix++user
maybeError err iox = runMaybeT iox >>= \x ->
case x of
Nothing -> error err
Just x -> return x
userRegister :: String -> String -> IO()
userRegister user password = withResources [] $ const [ User user password]
userAuthenticate :: MonadIO m => User -> m (Maybe String)
userAuthenticate user@User{..} = liftIO $ atomically
$ withSTMResources [user]
$ \ mu -> case mu of
[Nothing] -> resources{toReturn= err }
[Just (User _ p )] -> resources{toReturn=
case upassword==p of
True -> Nothing
False -> err
}
where
err= Just "Username or password invalid"
type FlowM view = StateT (MFlowState view)
runFlow :: (FormInput view, Monoid view, Monad m)
=> FlowM view m () -> Token -> m ()
runFlow f = \t -> evalStateT f mFlowState0{mfToken=t}
step
:: (Serialize a,
MonadIO m,
Typeable a) =>
FlowM view m a
-> FlowM view (Workflow m) a
step f=do
s <- get
lift . WF.step $ evalStateT f s
cookieuser= "cookieuser"
instance (MonadIO m, Functor m, FormInput view) => FormLet User m view where
digest muser =
(User <$> getString (fmap userName muser)
<*> getPassword)
`validate` userAuthenticate
newtype Lang= Lang String
data MFlowState view= MFlowState{
mfSequence :: Int,
mfUser :: String,
mfLang :: Lang,
mfEnv :: Params,
mfToken :: Token,
mfkillTime :: Int,
mfStateTime :: Integer,
mfCookies :: [Cookie],
mfHeader :: view -> view}
stdHeader v= v
anonymous= "anonymous"
mFlowState0 :: (FormInput view, Monoid view) => MFlowState view
mFlowState0= MFlowState 0 anonymous (Lang "en") [] undefined 0 0 [] stdHeader
setHeader :: Monad m => (view -> view) -> FlowM view m ()
setHeader header= do
fs <- get
put fs{mfHeader= header}
setCookie :: Monad m
=> String
-> String
-> String
-> Maybe String
-> FlowM view m ()
setCookie n v p me= do
st <- get
put st{mfCookies= (n,v,p,me):mfCookies st }
setTimeouts :: (Monad m)=> Int -> Integer -> FlowM view m ()
setTimeouts kt st= do
fs <- get
put fs{ mfkillTime= kt, mfStateTime= st}
getUser :: ( FormInput view, Monoid view, Typeable view
, ConvertTo (HttpData view) display, Typeable display
, MonadIO m, Functor m)
=> FlowM view m String
getUser = do
rus <- gets mfUser
case rus == anonymous of
False -> return rus
True -> do
env <- do
env <- gets mfEnv
if null env then receiveWithTimeouts>> gets mfEnv
else return env
ref <- case lookup cookieuser env of
Nothing -> do
us <- ask (Form (Nothing :: Maybe User))
ref <- liftIO . atomically $ newDBRef us
setCookie cookieuser (userName us) "/" Nothing
get >>= \s -> liftIO $ print (mfCookies s)
return $ userName us
Just usname -> return usname
return ref
class Widget a b m view => Launchable a b m view
instance (MonadIO m, Functor m)
=> Widget(View view m a) a m view where
widget = id
instance (MonadIO m, Functor m)
=> Launchable (View view m a) a m view
mix :: ( FormInput view , Monad m)
=> View view m a'
-> View view m b'
-> View view m (Either a' b')
mix digest1 digest2= FormT $ \env -> do
FormElm f1 mx' <- (runFormT $ digest1) env
FormElm f2 my' <- (runFormT $ digest2) env
return $ FormElm (f1++f2)
$ case (mx',my') of
(Nothing, Nothing) -> Nothing
(Just x,Nothing) -> Just $ Left x
(Nothing,Just x) -> Just $ Right x
(Just _,Just _) -> error "malformed getters in widget combination"
ask
:: ( Launchable a b m view
, FormInput view, Monoid view
, Typeable view, ConvertTo (HttpData view) display
, Typeable display )
=> a -> FlowM view m b
ask mx = do
st <- get
let t= mfToken st
FormElm forms mx' <- generateForm mx
case mx' of
Just x -> return x
_ -> do
let header= mfHeader st
liftIO . sendFlush t $ HttpData (mfCookies st) (header $ mconcat forms)
put st{mfCookies=[]}
receiveWithTimeouts
ask mx
receiveWithTimeouts :: MonadIO m => FlowM view m ()
receiveWithTimeouts= do
st <- get
let t= mfToken st
t1= mfkillTime st
t2= mfStateTime st
req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t)
put st{mfEnv= req}
data Selection a view= Selection{stitle:: view, sheader :: [view] , sbody :: [([view],a)]}
instance (MonadIO m, Functor m, FormInput view, Typeable a, Show a, Read a, Eq a)
=> Launchable (Selection a view) a m view
instance (MonadIO m, Functor m
,FormInput view, Read a , Show a, Eq a, Typeable a)
=> Widget (Selection a view) a m view where
widget Selection {..} =FormT(\env -> do
t <- fmap mfToken get
let mn = getParam1 "select" env
toSend = fformAction (twfname t) . ftable stitle sheader $
map(\(vs,x) -> vs ++ [finput "select" "radio" (show x)
( Just x== mn) (Just "this.form.submit()")] ) sbody
return $ FormElm [toSend] mn)
newtype Form a= Form a
instance (FormInput view, Monoid view, Widget a b m view)
=> Launchable (Form a) b m view
instance (FormInput view, Monoid view, Widget a b m view)
=> Widget (Form a) b m view
where
widget (Form x) = FormT $ \env -> do
FormElm form mr <- (runFormT $ widget x ) env
t <- fmap mfToken get
let form1= fformAction (twfname t) . mconcat
$ form
++ [finput "reset" "reset" "Reset" False Nothing
,finput "submit" "submit" "Submit" False Nothing]
return $ FormElm [form1] mr
data FormElm view a = FormElm [view] (Maybe a)
newtype FormT view m a = FormT { runFormT :: Params -> m (FormElm view a) }
instance Functor (FormElm view ) where
fmap f (FormElm form x)= FormElm form (fmap f x)
instance Functor m => Functor (FormT view m) where
fmap f = FormT .(\env -> fmap (fmap f) . (runFormT env) )
instance (Functor m, Monad m) => Applicative (FormT view m) where
pure a = FormT $ \env -> return (FormElm [] $ Just a)
FormT f <*> FormT g= FormT $ \env ->
f env >>= \(FormElm form1 k) ->
g env >>= \(FormElm form2 x) ->
return (FormElm (form1 ++ form2) (k <*> x))
instance (Monad m, Functor m) => Monad (FormT view m) where
x >>= f = join $ fmap f x
return= pure
type View view m a= FormT view (FlowM view m) a
class (Functor m, MonadIO m) => FormLet a m view where
digest :: Maybe a
-> View view m a
class (Functor m, MonadIO m) => Widget a b m view | a -> view where
widget :: a
-> View view m b
instance FormLet a m view => Widget (Maybe a) a m view where
widget = digest
validate
:: (FormInput view,
Functor m, MonadIO m)
=> View view m a
-> (a -> m (Maybe String))
-> View view m a
validate formt val= FormT $ \env -> do
FormElm form mx <- (runFormT formt) env
case mx of
Just x -> do
me <- lift $ val x
case me of
Just str ->do
return $ FormElm ( inred (fromString str) : form) Nothing
Nothing -> return $ FormElm [] mx
_ -> return $ FormElm form mx
generateForm
:: (Widget a b m view, FormInput view ) =>
a -> FlowM view m (FormElm view b)
generateForm mx = do
st <- get
(runFormT $ widget mx ) $ mfEnv st
instance (FormInput view, FormLet a m view , FormLet b m view )
=> FormLet (a,b) m view where
digest mxy = do
let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y)
(,) <$> digest x <*> digest y
instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view )
=> FormLet (a,b,c) m view where
digest mxy = do
let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z)
(,,) <$> digest x <*> digest y <*> digest z
getString :: (FormInput view,Monad m) =>
Maybe String -> View view m String
getString = getElem
getInteger :: (FormInput view, Functor m, MonadIO m) =>
Maybe Integer -> View view m Integer
getInteger = getElem
getInt :: (FormInput view, Functor m, MonadIO m) =>
Maybe Int -> View view m Int
getInt = getElem
getPassword :: (FormInput view,
Monad m) =>
View view m String
getPassword = getParam Nothing "password" (Just "enter password")
getElem
:: (FormInput view,
Monad m,
Typeable a,
Show a,
Read a) =>
Maybe a -> View view m a
getElem 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 = FormT $ \env -> do
tolook <- case look of
Nothing -> getnewname
Just n -> return n
let nvalue= case mvalue of
Nothing -> ""
Just v -> show v
form= [finput tolook type1 nvalue False Nothing]
case getParam1 tolook env of
Nothing -> return $ FormElm form Nothing
justx -> return $ FormElm form justx
getnewname :: Monad m => FlowM view m String
getnewname= do
st <- get
let n= mfSequence st
put $ st{mfSequence= n+1}
return $ "Parm"++show n
getMultilineText :: (FormInput view,
Monad m) =>
Maybe [Char] -> View view m String
getMultilineText mt = FormT $ \env -> do
tolook <- getnewname
let nvalue= case mt of
Nothing -> ""
Just v -> show v
case (getParam1 tolook env, mt) of
(Nothing, Nothing) -> return $ FormElm [ftextarea tolook nvalue] Nothing
(Nothing, Just v) -> return $ FormElm [] $ Just v
(justx,_) -> return $ FormElm [] justx
instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
digest mv = getBool b "True" "False"
where
b= case mv of
Nothing -> Nothing
Just bool -> Just $ show bool
getBool :: (FormInput view,
Monad m) =>
Maybe String -> String -> String -> View view m Bool
getBool mv truestr falsestr= FormT $ \env -> do
tolook <- getnewname
case (getParam1 tolook env, mv) of
(Nothing, Nothing) -> return $ FormElm [foption1 tolook [truestr,falsestr] mv] Nothing
(Nothing,Just x) -> return . FormElm [] . Just $ fromstr x
(Just x,_) -> return . FormElm [] . Just $ fromstr x
where
fromstr x= if x== truestr then True else False
getOption :: (FormInput view,
Monad m) =>
Maybe String ->[(String,String)] -> View view m String
getOption mv strings = FormT $ \env -> do
tolook <- getnewname
case (getParam1 tolook env, mv) of
(Nothing, Nothing) -> return $ FormElm [foption tolook strings mv] Nothing
(Nothing,Just x) -> return . FormElm [] $ Just x
(justx,_) -> return $ FormElm [] justx
wrap :: (Monad m, FormInput view, Monoid view)
=> (view ->view)
-> View view m a
-> View view m a
wrap v form= FormT $ \env -> do
FormElm f mx <- runFormT form env
return $ FormElm [v $ mconcat f] mx
addToForm :: (Monad m, FormInput view, Monoid view)
=> View view m a
-> view
-> View view m a
addToForm form v= FormT $ \env -> do
FormElm f mx <- runFormT form env
return $ FormElm (f++[v]) mx
type Name= String
type Type= String
type Value= String
type Checked= Bool
type OnClick= Maybe String
class FormInput view where
inred :: view -> view
ftable:: view -> [view] -> [[view]] -> view
fromString :: String -> view
flink :: String -> view -> view
flink1:: String -> view
flink1 verb = flink verb (fromString verb)
finput :: Name -> Type -> Value -> Checked -> OnClick -> view
ftextarea :: String -> String -> view
foption :: String -> [(String,String)] -> Maybe String -> view
foption1 :: String -> [String] -> Maybe String -> view
foption1 name list msel= foption name (zip list list) msel
fformAction :: String -> view -> view