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.TCache.Memoization
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
import Control.Concurrent.MVar
import Control.Workflow(WFErrors(Timeout))
import Control.Exception as CE(catch,SomeException,AsyncException,throw,fromException)
import Control.Concurrent
import Control.Monad.Loc
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 Sup m a = Sup { runSup :: m (FailBack a ) }
class MonadState s m => Supervise s m where
supBack :: s -> m ()
supBack = const $ return ()
supervise :: m (FailBack a) -> m (FailBack a)
supervise= id
instance (Supervise s m)=> Monad (Sup m) where
fail _ = Sup . return $ GoBack
return x = Sup . return $ NoBack x
x >>= f = Sup $ loop
where
loop = do
s <- get
v <- supervise $ runSup x
case v of
NoBack y -> supervise $ runSup (f y)
BackPoint y -> do
z <- supervise $ runSup (f y)
case z of
GoBack -> supBack s >> 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 . Sup . return . BackPoint
instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
instance (Monad m,Functor m) => Functor (Sup m) where
fmap f g= Sup $ do
mr <- runSup g
case mr of
BackPoint x -> return . BackPoint $ f x
NoBack x -> return . NoBack $ f x
GoBack -> return $ GoBack
liftSup f = Sup $ f >>= \x -> return $ NoBack x
instance MonadTrans Sup where
lift f = Sup $ f >>= \x -> return $ NoBack x
instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
get= lift get
put= lift . put
type WState view m = StateT (MFlowState view) m
type FlowMM view m= Sup (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)}
instance Monad m => Supervise (MFlowState v) (WState v m) where
supBack st= do
MFlowState{..} <- get
put st{ mfEnv= mfEnv,mfToken=mfToken
, mfPath=mfPath,mfPIndex= mfPIndex
, mfData=mfData
, mfTrace= mfTrace
, inSync=False,newAsk=False}
instance MonadLoc (FlowM v IO) where
withLoc loc f = FlowM . Sup $ do
withLoc loc $ do
s <- get
(r,s') <- lift $ do
rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
`CE.catch` (handler1 loc s)
case mfTrace s' of
[] -> return rs
trace -> return(r, s'{mfTrace= loc:trace})
put s'
return r
where
handler1 loc s (e :: SomeException)= do
case CE.fromException e :: Maybe WFErrors of
Just e -> CE.throw e
Nothing ->
case CE.fromException e :: Maybe AsyncException of
Just e -> CE.throw e
Nothing ->
return (GoBack, s{mfTrace= [show e]})
instance MonadLoc (View v IO) where
withLoc loc f = View $ do
withLoc loc $ do
s <- get
(r,s') <- lift $ do
rs@(r,s') <- runStateT (runView f) s
`CE.catch` (handler1 loc s)
case mfTrace s' of
[] -> return rs
trace -> return(r, s'{mfTrace= loc:trace})
put s'
return r
where
handler1 loc s (e :: SomeException)= do
case CE.fromException e :: Maybe WFErrors of
Just e -> CE.throw e
Nothing ->
case CE.fromException e :: Maybe AsyncException of
Just e -> CE.throw e
Nothing ->
return (FormElm [] Nothing, s{mfTrace= [show e]})
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{mfSequence= 1})
debug= do
(x,env) <- readp
return (x,mFlowState0{mfEnv= env,mfSequence= 1})
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 $ do
FormElm form1 k <- f
FormElm form2 x <- g
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
modify $ \st -> st{linkMatched= False}
FormElm form2 mk <- runView $ f k
return $ FormElm (form1 ++ form2) mk
Nothing ->
return $ FormElm form1 Nothing
View x >> f = View $ do
FormElm form1 mk <- x
case mk of
Just k -> do
modify $ \st -> st{linkMatched= False}
FormElm form2 mk <- runView f
return $ FormElm (form1 ++ form2) mk
Nothing ->
return $ FormElm form1 Nothing
return = View . return . FormElm [] . Just
instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where
mappend x y = mappend <$> x <*> y
mempty= return mempty
wcallback
:: Monad m =>
View view m a -> (a -> View view m b) -> View view m b
wcallback (View x) f = View $ do
FormElm form1 mk <- x
case mk of
Just k -> do
modify $ \st -> st{linkMatched= False}
runView (f k)
Nothing -> return $ FormElm form1 Nothing
--incLinkDepth
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)
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')
goingBack :: MonadState (MFlowState view) m => m Bool
goingBack = do
st <- get
return $ not (inSync st) && not (newAsk st)
preventGoingBack
:: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
preventGoingBack msg= do
back <- goingBack
if not back then breturn() else do
breturn()
clearEnv
modify $ \s -> s{newAsk= True}
msg
type Lang= String
data MFlowState view= MFlowState{
mfSequence :: Int,
mfCached :: Bool,
newAsk :: 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,
mfPath :: [String],
mfPrefix :: String,
mfPIndex :: Int,
mfPageIndex :: Maybe Int,
linkMatched :: Bool,
mfLinks :: M.Map String Int,
mfAutorefresh :: Bool,
mfTrace :: [String]
}
deriving Typeable
type Void = Char
mFlowState0 :: (FormInput view) => MFlowState view
mFlowState0 = MFlowState 0 False True True "en"
[] False (error "token of mFlowState0 used")
0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] "" 1 Nothing False M.empty False []
setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
setSessionData x=
modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
delSessionData x=
modify $ \st -> st{mfData= M.delete (typeOf 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
addHeader new= do
fhtml <- getHeader
setHeader $ fhtml . new
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 :: ( MonadState (MFlowState v) m) => Int -> Integer -> 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 = do
st<- gets mfToken
return $ tuser st
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
,mfPath= mfPath s2
,mfPIndex= mfPIndex s2
,mfPageIndex= mfPageIndex 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, MonadIO m)
=> FlowM view m () -> Token -> m ()
runFlow f t=
loop (runFlowOnce1 f) t
where
loop f t = do
t' <- f t
let t''= t'{tpath=[twfname t']}
liftIO $ do
flushRec t''
sendToMF t'' t''
loop f t''
runFlowOnce :: (MonadIO m, FormInput view, Monad m)
=> FlowM view m () -> Token -> m ()
runFlowOnce f t= runFlowOnce1 f t >> return ()
runFlowOnce1 f t =
evalStateT (runSup . runFlowM $ do
backInit
f
getToken)
mFlowState0{mfToken=t
,mfPath= tpath t
,mfEnv= tenv t} >>= return . fromFailBack
where
backInit= do
s <- get
case mfTrace s of
[] -> do
modify $ \s -> s{mfEnv=[], newAsk= True}
breturn ()
tr -> do
error $ disp tr
where
disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
runFlowIn
:: (MonadIO m,
FormInput view)
=> String
-> FlowM view (Workflow IO) b
-> FlowM view m b
runFlowIn wf f= do
t <- gets mfToken
FlowM . Sup $ liftIO $ WF.exec1nc wf $ runFlow1 f t
where
runFlow1 f t= evalStateT (runSup . runFlowM $ f) mFlowState0{mfToken=t,mfEnv= tenv t}
runFlowConf :: (FormInput view, MonadIO m)
=> FlowM view m a -> m a
runFlowConf f = do
q <- liftIO newEmptyMVar
qr <- liftIO newEmptyMVar
let t= Token "" "" "" [] [] q qr
evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack
clearEnv :: MonadState (MFlowState view) m => m ()
clearEnv= do
st <- get
put st{ mfEnv= []}
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 $ Sup $ do
(r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
when( mfSequence s' /= 1) $ put s'
return r
transientNav
:: (Serialize a,
Typeable view,
FormInput view,
Typeable a) =>
FlowM view IO a
-> FlowM view (Workflow IO) a
transientNav f= do
s <- get
flowM $ Sup $ do
(r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
put s'
return r
--stepWFRef
--stepDebug
data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
=> String -> Params -> m (ParamResult v a)
getParam1 par req = r
where
r= case lookup par req of
Just x -> do
modify $ \s -> s{inSync= True}
maybeRead x
Nothing -> return NoParam
getType :: m (ParamResult v a) -> a
getType= undefined
x= getType r
maybeRead str= do
if typeOf x == (typeOf ( undefined :: String))
then return . Validated $ unsafeCoerce str
else case readsPrec 0 $ str of
[(x,"")] -> return $ Validated x
_ -> do
let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
return $ NotValidated str err
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);" ++
" }" ++
" };" ++
""
formPrefix index verb st form anchored= do
let path = currentPath False index (mfPath st) verb
(anchor,anchorf)
<- case anchored of
True -> do
anchor <- genNewId
return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
False -> return (mempty,mempty)
return $ formAction (path ++ anchor ) $ mconcat ( anchorf:form)
currentPath insInBackTracking index lpath verb =
(if null lpath then verb
else case insInBackTracking of
True -> concat $ take index ['/':v | v <- lpath]
False -> concat ['/':v| v <- lpath])
genNewId :: MonadState (MFlowState view) m => m String
genNewId= do
st <- get
case mfCached st of
False -> do
let n= mfSequence st
prefseq= mfPrefix st
put $ st{mfSequence= n+1}
return $ 'p':show n++prefseq
True -> do
let n = mfSeqCache st
put $ st{mfSeqCache=n+1}
return $ 'c' : (show n)