module MFlow.Forms.Internals where
import MFlow
import MFlow.Cookies
import Control.Applicative
import Data.Monoid
import Control.Monad.Trans
import Control.Monad.State
import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks)
import Data.Typeable
import Data.RefSerialize hiding((<|>))
import Data.TCache
import Data.TCache.Memoization
import Data.TCache.DefaultPersistence
import Data.Dynamic
import qualified Data.Map as M
import Unsafe.Coerce
import Control.Workflow as WF
import Control.Monad.Identity
import Data.List
import System.IO.Unsafe
instance Serialize a => Serializable a where
serialize= runW . showp
deserialize= runR readp
type UserStr= String
type PasswdStr= String
data User= User
{ userName :: String
, 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}= keyUserName user
keyUserName n= userPrefix++n
userRegister :: MonadIO m => String -> String -> m (DBRef User)
userRegister user password = liftIO . atomically $ newDBRef $ User user password
userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view)
userValidate (u,p) =
let user= eUser{userName=u}
in liftIO $ atomically
$ withSTMResources [user]
$ \ mu -> case mu of
[Nothing] -> resources{toReturn= err }
[Just (User _ pass )] -> resources{toReturn=
case pass==p of
True -> Nothing
False -> err
}
where
err= Just . fromStr $ "Username or password invalid"
data Config = Config UserStr deriving (Read, Show, Typeable)
keyConfig= "mflow.config"
instance Indexable Config where key _= keyConfig
rconf= getDBRef keyConfig
setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
setAdminUser user password= liftIO $ atomically $ do
newDBRef $ User user password
writeDBRef rconf $ Config user
getAdminName :: MonadIO m => m UserStr
getAdminName= liftIO $ atomically ( readDBRef rconf `onNothing` error "admin user not set" ) >>= \(Config u) -> return u
data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
instance (Serialize a) => Serialize (FailBack a ) where
showp (BackPoint x)= insertString (pack iCanFailBack) >> showp x
showp (NoBack x)= insertString (pack noFailBack) >> showp x
showp GoBack = insertString (pack repeatPlease)
readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
where
noFailBackp = symbol noFailBack >> readp >>= return . NoBack
icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
repeatPleasep = symbol repeatPlease >> return GoBack
iCanFailBack= "B"
repeatPlease= "G"
noFailBack= "N"
newtype BackT m a = BackT { runBackT :: m (FailBack a ) }
instance Monad m => Monad (BackT m) where
fail _ = BackT . return $ GoBack
return x = BackT . return $ NoBack x
x >>= f = BackT $ loop
where
loop = do
v <- runBackT x
case v of
NoBack y -> runBackT (f y)
BackPoint y -> do
z <- runBackT (f y)
case z of
GoBack -> loop
other -> return other
GoBack -> return $ GoBack
fromFailBack (NoBack x) = x
fromFailBack (BackPoint x)= x
toFailBack x= NoBack x
breturn :: (Monad m) => a -> FlowM v m a
breturn = flowM . BackT . return . BackPoint
instance (MonadIO m) => MonadIO (BackT m) where
liftIO f= BackT $ liftIO f >>= \ x -> return $ NoBack x
instance (Monad m,Functor m) => Functor (BackT m) where
fmap f g= BackT $ do
mr <- runBackT g
case mr of
BackPoint x -> return . BackPoint $ f x
NoBack x -> return . NoBack $ f x
GoBack -> return $ GoBack
liftBackT f = BackT $ f >>= \x -> return $ NoBack x
instance MonadTrans BackT where
lift f = BackT $ f >>= \x -> return $ NoBack x
instance MonadState s m => MonadState s (BackT m) where
get= lift get
put= lift . put
type WState view m = StateT (MFlowState view) m
type FlowMM view m= BackT (WState view m)
data FormElm view a = FormElm [view] (Maybe a) deriving Typeable
instance Serialize a => Serialize (FormElm view a) where
showp (FormElm _ x)= showp x
readp= readp >>= \x -> return $ FormElm [] x
newtype View v m a = View { runView :: WState v m (FormElm v a)}
newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,MonadState(MFlowState v))
flowM= FlowM
instance (FormInput v,Serialize a)
=> Serialize (a,MFlowState v) where
showp (x,s)= case mfDebug s of
False -> showp x
True -> showp(x, mfEnv s)
readp= choice[nodebug, debug]
where
nodebug= readp >>= \x -> return (x, mFlowState0)
debug= do
(x,env) <- readp
return (x,mFlowState0{mfEnv= env})
instance Functor (FormElm view ) where
fmap f (FormElm form x)= FormElm form (fmap f x)
instance (Monad m,Functor m) => Functor (View view m) where
fmap f x= View $ fmap (fmap f) $ runView x
instance (Functor m, Monad m) => Applicative (View view m) where
pure a = View $ return (FormElm [] $ Just a)
View f <*> View g= View $
f >>= \(FormElm form1 k) ->
g >>= \(FormElm form2 x) ->
return $ FormElm (form1 ++ form2) (k <*> x)
instance (Functor m, Monad m) => Alternative (View view m) where
empty= View $ return $ FormElm [] Nothing
View f <|> View g= View $
f >>= \(FormElm form1 k) ->
g >>= \(FormElm form2 x) ->
return $ FormElm (form1 ++ form2) (k <|> x)
instance (Monad m) => Monad (View view m) where
View x >>= f = View $ do
FormElm form1 mk <- x
case mk of
Just k -> do
FormElm form2 mk <- runView $ f k
return $ FormElm (form1++ form2) mk
Nothing -> return $ FormElm form1 Nothing
return= View . return . FormElm [] . Just
instance MonadTrans (View view) where
lift f = View $ (lift f) >>= \x -> return $ FormElm [] $ Just x
instance MonadTrans (FlowM view) where
lift f = FlowM $ lift (lift f) >>= \x -> return x
instance (Monad m)=> MonadState (MFlowState view) (View view m) where
get = View $ get >>= \x -> return $ FormElm [] $ Just x
put st = View $ put st >>= \x -> return $ FormElm [] $ Just x
instance (MonadIO m) => MonadIO (View view m) where
liftIO io= let x= liftIO io in x `seq` lift x
changeMonad :: (Monad m, Executable m1)
=> View v m1 a -> View v m a
changeMonad w= View . StateT $ \s ->
let (r,s')= execute $ runStateT ( runView w) s
in mfSequence s' `seq` return (r,s')
type Lang= String
data MFlowState view= MFlowState{
mfSequence :: Int,
mfCached :: Bool,
prevSeq :: [Int],
onInit :: Bool,
inSync :: Bool,
mfLang :: Lang,
mfEnv :: Params,
needForm :: Bool,
mfToken :: Token,
mfkillTime :: Int,
mfSessionTime :: Integer,
mfCookies :: [Cookie],
mfHttpHeaders :: Params,
mfHeader :: view -> view,
mfDebug :: Bool,
mfRequirements :: [Requirement],
mfData :: M.Map TypeRep Void,
mfAjax :: Maybe (M.Map String Void),
mfSeqCache :: Int,
notSyncInAction :: Bool
}
deriving Typeable
type Void = Char
mFlowState0 :: (FormInput view) => MFlowState view
mFlowState0 = MFlowState 0 False [] True False "en"
[] False (error "token of mFlowState0 used")
0 0 [] [] stdHeader False [] M.empty Nothing 0 False
setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m ()
setSessionData x=
modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a)
getSessionData = resp where
resp= gets mfData >>= \list ->
case M.lookup ( typeOf $ typeResp resp ) list of
Just x -> return . Just $ unsafeCoerce x
Nothing -> return $ Nothing
typeResp :: m (Maybe x) -> x
typeResp= undefined
getLang :: MonadState (MFlowState view) m => m String
getLang= gets mfLang
getToken :: MonadState (MFlowState view) m => m Token
getToken= gets mfToken
getEnv :: MonadState (MFlowState view) m => m Params
getEnv = gets mfEnv
stdHeader v = v
setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
setHeader header= do
fs <- get
put fs{mfHeader= header}
getHeader :: (Monad m) => FlowM view m (view -> view)
getHeader= gets mfHeader
setCookie :: MonadState (MFlowState view) m
=> String
-> String
-> String
-> Maybe Integer
-> m ()
setCookie n v p me= do
modify $ \st -> st{mfCookies= (n,v,p,fmap show me):mfCookies st }
setHttpHeader :: MonadState (MFlowState view) m
=> String
-> String
-> m ()
setHttpHeader n v = do
modify $ \st -> st{mfHttpHeaders= (n,v):mfHttpHeaders st }
setTimeouts :: Monad m => Int -> Integer -> FlowM view m ()
setTimeouts kt st= do
fs <- get
put fs{ mfkillTime= kt, mfSessionTime= st}
getWFName :: MonadState (MFlowState view) m => m String
getWFName = do
fs <- get
return . twfname $ mfToken fs
getCurrentUser :: MonadState (MFlowState view) m=> m String
getCurrentUser = return . tuser =<< gets mfToken
type Name= String
type Type= String
type Value= String
type Checked= Bool
type OnClick= Maybe String
normalize ::(Monad m, FormInput v) => View v m a -> View ByteString m a
normalize f= View . StateT $ \s ->do
(FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s
return (FormElm (map toByteString fs ) mx,unsafeCoerce s')
class (Monoid view,Typeable view) => FormInput view where
toByteString :: view -> ByteString
toHttpData :: view -> HttpData
fromStr :: String -> view
fromStrNoEncode :: String -> view
ftag :: String -> view -> view
inred :: view -> view
flink :: String -> view -> view
flink1:: String -> view
flink1 verb = flink verb (fromStr verb)
finput :: Name -> Type -> Value -> Checked -> OnClick -> view
ftextarea :: String -> String -> view
fselect :: String -> view -> view
foption :: String -> view -> Bool -> view
foption1 :: String -> Bool -> view
foption1 val msel= foption val (fromStr val) msel
formAction :: String -> view -> view
attrs :: view -> Attribs -> view
cachedWidget ::(MonadIO m,Typeable view
, FormInput view, Typeable a, Executable m )
=> String
-> Int
-> View view Identity a
-> View view m a
cachedWidget key t mf = View . StateT $ \s -> do
let((FormElm form _), sec)= execute $ cachedByKey key t $ proc mf s{mfCached=True}
let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True}
let s''= s{inSync = inSync s2
,mfRequirements=mfRequirements s2
,mfSeqCache= mfSeqCache s + mfSeqCache s2 sec}
return $ (mfSeqCache s'') `seq` ((FormElm form mx2), s'')
where
proc mf s= runStateT (runView mf) s >>= \(r,_) ->mfSeqCache s `seq` return (r,mfSeqCache s )
wcached ::(MonadIO m,Typeable view
, FormInput view, Typeable a, Executable m )
=> String
-> Int
-> View view Identity a
-> View view m a
wcached= cachedWidget
wfreeze ::(MonadIO m,Typeable view
, FormInput view, Typeable a, Executable m )
=> String
-> Int
-> View view m a
-> View view m a
wfreeze key t mf = View . StateT $ \s -> do
((FormElm f mx), req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True}
return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq,mfAjax=ajax})
where
proc mf s= do
(r,s) <- runStateT (runView mf) s
return (r,mfRequirements s, mfSeqCache s,mfAjax s)
--wrender
runFlow :: (FormInput view, Monad m)
=> FlowM view m () -> Token -> m ()
runFlow f t=
loop (runFlowOnce1 f) t
where
loop f t= f t >>= \t -> loop f t
clearEnv :: MonadState (MFlowState view) m => m ()
clearEnv= do
st <- get
put st{ mfEnv= []}
runFlowOnce :: (FormInput view, Monad m)
=> FlowM view m () -> Token -> m ()
runFlowOnce f t= runFlowOnce1 f t >> return ()
runFlowOnce1 f t =
evalStateT (runBackT . runFlowM $ (clearEnv >> breturn ()) >> f >> getToken) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack
runFlowIn
:: (MonadIO m,
FormInput view)
=> String
-> FlowM view (Workflow IO) b
-> FlowM view m b
runFlowIn wf f= do
t <- gets mfToken
FlowM . BackT $ liftIO $ WF.exec1nc wf $ runFlow1 f t
where
runFlow1 f t= evalStateT (runBackT . runFlowM $ f) mFlowState0{mfToken=t,mfEnv= tenv t}
step
:: (Serialize a,
Typeable view,
FormInput view,
MonadIO m,
Typeable a) =>
FlowM view m a
-> FlowM view (Workflow m) a
step f= do
s <- get
flowM $ BackT $ do
(r,s') <- lift . WF.step $ runStateT (runBackT $ runFlowM f) s
when( mfSequence s' >0) $ put s'
return r
--stepWFRef
--stepDebug
getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
=> String -> Params -> [v] -> m (FormElm v a)
getParam1 par req form= r
where
r= case lookup par req of
Just x -> do
modify $ \s -> s{inSync= True}
maybeRead x
Nothing -> return $ FormElm form Nothing
getType :: m (FormElm v a) -> a
getType= undefined
x= getType r
maybeRead str= do
if typeOf x == (typeOf ( undefined :: String))
then return . FormElm form . Just $ unsafeCoerce str
else case readsPrec 0 $ str of
[(x,"")] -> return . FormElm form $ Just x
_ -> do
let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
return $ FormElm (form++[err]) Nothing
requires rs =do
st <- get
let l = mfRequirements st
put st {mfRequirements= l ++ map Requirement rs}
data Requirement= forall a.(Typeable a,Requirements a) => Requirement a deriving Typeable
class Requirements a where
installRequirements :: (Monad m,FormInput view) => [a] -> m view
installAllRequirements ::( Monad m, FormInput view) => WState view m view
installAllRequirements= do
rs <- gets mfRequirements
installAllRequirements1 mempty rs
where
installAllRequirements1 v []= return v
installAllRequirements1 v rs= do
let typehead= case head rs of {Requirement r -> typeOf r}
(rs',rs'')= partition1 typehead rs
v' <- installRequirements2 rs'
installAllRequirements1 (v `mappend` v') rs''
where
installRequirements2 []= return $ fromStrNoEncode ""
installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs
unmap []=[]
unmap (Requirement r:rs)= unsafeCoerce r:unmap rs
partition1 typehead xs = foldr select ([],[]) xs
where
select x ~(ts,fs)=
let typer= case x of Requirement r -> typeOf r
in if typer== typehead then ( x:ts,fs)
else (ts, x:fs)
loadjsfile filename lcallbacks=
"var fileref=document.createElement('script');\
\fileref.setAttribute('type','text/javascript');\
\fileref.setAttribute('src',\'" ++ filename ++ "\');\
\document.getElementsByTagName('head')[0].appendChild(fileref);"
++ onload
where
onload= case lcallbacks of
[] -> ""
cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};"
loadjs content= content
loadcssfile filename=
"var fileref=document.createElement('link');\
\fileref.setAttribute('rel', 'stylesheet');\
\fileref.setAttribute('type', 'text/css');\
\fileref.setAttribute('href', \'"++filename++"\');\
\document.getElementsByTagName('head')[0].appendChild(fileref);"
loadcss content=
"var fileref=document.createElement('link');\
\fileref.setAttribute('rel', 'stylesheet');\
\fileref.setAttribute('type', 'text/css');\
\fileref.innerText=\""++content++"\";\
\document.getElementsByTagName('head')[0].appendChild(fileref);"
data WebRequirement= JScriptFile
String
[String]
| CSSFile String
| CSS String
| JScript String
| ServerProc (String, Flow)
deriving(Typeable,Eq,Ord,Show)
instance Eq (String, Flow) where
(x,_) == (y,_)= x == y
instance Ord (String, Flow) where
compare(x,_) (y,_)= compare x y
instance Show (String, Flow) where
show (x,_)= show x
instance Requirements WebRequirement where
installRequirements= installWebRequirements
installWebRequirements :: (Monad m,FormInput view) =>[WebRequirement] -> m view
installWebRequirements rs= do
let s = aggregate $ sort rs
return $ ftag "script" (fromStrNoEncode s)
where
aggregate []= ""
aggregate (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs)
| f==f'= aggregate $ JScriptFile f (nub c++c'):rs
| otherwise= strRequirement r++aggregate (r':rs)
aggregate (r:r':rs)
| r== r' = aggregate $ r:rs
| otherwise= strRequirement r ++ aggregate (r':rs)
aggregate (r:rs)= strRequirement r++aggregate rs
strRequirement (CSSFile s') = loadcssfile s'
strRequirement (CSS s') = loadcss s'
strRequirement (JScriptFile s' call) = loadjsfile s' call
strRequirement (JScript s') = loadjs s'
strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` ""
ajaxScript=
"function loadXMLObj()" ++
"{" ++
"var xmlhttp;" ++
"if (window.XMLHttpRequest)" ++
"{"++
" xmlhttp=new XMLHttpRequest();" ++
" }" ++
"else" ++
"{"++
" xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
" }" ++
"return xmlhttp" ++
"};" ++
" xmlhttp= loadXMLObj();" ++
" noparam= '';"++
""++
"function doServer (servproc,param,param2){" ++
" xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
" xmlhttp.send();};" ++
""++
"xmlhttp.onreadystatechange=function()" ++
" {" ++
" if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
" {" ++
" eval(xmlhttp.responseText);" ++
" }" ++
" };" ++
""