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.UTF8 as B hiding (length, foldr, take)
import qualified Data.ByteString.UTF8 as SB
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 qualified Data.Text as T
import Data.Char
import Data.List(stripPrefix)
import Data.Maybe(isJust)
import Control.Concurrent.STM
import Data.TCache.Memoization
import Control.Exception as CE
import Control.Concurrent
import Control.Monad.Loc
import Debug.Trace
(!>) = flip trace
infixl 9 !>
data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
instance Functor FailBack where
fmap f GoBack= GoBack
fmap f (BackPoint x)= BackPoint $ f x
fmap f (NoBack x)= NoBack $ f x
instance Applicative FailBack where
pure x = NoBack x
_ <*> GoBack = GoBack
GoBack <*> _ = GoBack
k <*> x = NoBack $ (fromFailBack k) (fromFailBack x)
instance Alternative FailBack where
empty= GoBack
GoBack <|> f = f
f <|> _ = f
instance (Serialize a) => Serialize (FailBack a ) where
showp (BackPoint x)= insertString (fromString iCanFailBack) >> showp x
showp (NoBack x) = insertString (fromString noFailBack) >> showp x
showp GoBack = insertString (fromString 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
instance (Monad m,Applicative m) => Applicative (Sup m) where
pure x = Sup . return $ NoBack x
f <*> g= Sup $ do
k <- runSup f
x <- runSup g
return $ k <*> x
instance(Monad m, Applicative m) => Alternative (Sup m) where
empty = Sup . return $ GoBack
f <|> g= Sup $ do
x <- runSup f
case x of
GoBack -> runSup g !> "GOBACK"
_ -> return x
newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a}
deriving (Applicative,Alternative,Monad,MonadIO,Functor
,MonadState(MFlowState v))
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 (Monoid view,Serialize a) => Serialize (FormElm view a) where
showp (FormElm _ x)= showp x
readp= readp >>= \x -> return $ FormElm mempty 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
, mfData=mfData
, mfTrace= mfTrace
, inSync=False
, mfSomeNotValidates= 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 FormInput v => 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 mempty Nothing, s{mfTrace= [show e]})
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 (Monoid view,Functor m, Monad m) => Applicative (View view m) where
pure a = View . return . FormElm mempty $ Just a
View f <*> View g= View $
f >>= \(FormElm form1 k) ->
g >>= \(FormElm form2 x) ->
return $ FormElm (form1 `mappend` form2) (k <*> x)
instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
empty= View $ return $ FormElm mempty Nothing
View f <|> View g= View $ do
path <- gets mfPagePath
FormElm form1 k <- f
s1 <- get
let path1 = mfPagePath s1
put s1{mfPagePath=path}
FormElm form2 x <- g
s2 <- get
(mix,hasform) <- controlForms s1 s2 form1 form2
let path2 = mfPagePath s2
let path3 = case (k,x) of
(Just _,_) -> path1
(_,Just _) -> path2
_ -> path
if hasform then put s2{needForm= HasForm,mfPagePath= path3}
else put s2{mfPagePath=path3}
return $ FormElm mix (k <|> x)
instance (FormInput view, Monad m) => Monad (View view m) where
View x >>= f = View $ do
FormElm form1 mk <- x
case mk of
Just k -> do
st'' <- get
let st = st''{ linkMatched = False }
put st
FormElm form2 mk <- runView $ f k
st' <- get
(mix, hasform) <- controlForms st st' form1 form2
when hasform $ put st'{needForm= HasForm}
return $ FormElm mix mk
Nothing ->
return $ FormElm form1 Nothing
return = View . return . FormElm mempty . Just
instance (FormInput v,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, needForm=NoElems}
runView (f k)
Nothing -> return $ FormElm form1 Nothing
instance Monoid view => MonadTrans (View view) where
lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
instance MonadTrans (FlowM view) where
lift f = FlowM $ lift (lift f)
instance (FormInput view, Monad m)=> MonadState (MFlowState view) (View view m) where
get = View $ get >>= \x -> return $ FormElm mempty $ Just x
put st = View $ put st >>= \x -> return $ FormElm mempty $ Just x
instance (FormInput view,MonadIO m) => MonadIO (View view m) where
liftIO io= let x= liftIO io in x `seq` lift x
changeMonad :: (Monad m, Executable m')
=> View v m' 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')
(<+>) , mix :: (Monad m, FormInput view)
=> 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
s1 <- get
FormElm f2 my' <- runView digest2
s2 <- get
(mix, hasform) <- controlForms s1 s2 f1 f2
when hasform $ put s2{needForm= HasForm}
return $ FormElm mix
$ case (mx',my') of
(Nothing, Nothing) -> Nothing
other -> Just other
infixr 2 <+>
(<+>) = mix
(**>) :: (Functor m, Monad m, FormInput view)
=> View view m a -> View view m b -> View view m b
(**>) f g = View $ do
FormElm form1 k <- runView $ valid f
s1 <- get
FormElm form2 x <- runView g
s2 <- get
(mix,hasform) <- controlForms s1 s2 form1 form2
when hasform $ put s2{needForm= HasForm}
return $ FormElm mix (k *> x)
valid form= View $ do
FormElm form mx <- runView form
return $ FormElm form $ Just undefined
infixr 1 **> , <**
(<**) :: (Functor m, Monad m, FormInput view) =>
View view m a -> View view m b -> View view m a
(<**) f g = View $ do
FormElm form1 k <- runView f
s1 <- get
FormElm form2 x <- runView $ valid g
s2 <- get
(mix,hasform) <- controlForms s1 s2 form1 form2
when hasform $ put s2{needForm= HasForm}
return $ FormElm mix (k <* x)
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
onBacktrack :: Monad m => m a -> FlowM v m a -> FlowM v m a
onBacktrack doit onback= do
back <- goingBack
case back of
False -> (lift doit) >>= breturn
True -> onback
compensate :: Monad m => m a -> m a -> FlowM v m a
compensate doit undoit= doit `onBacktrack` ( (lift undoit) >> fail "")
type Lang= String
data NeedForm= HasForm | HasElems | NoElems deriving Show
data MFlowState view= MFlowState{
mfSequence :: Int,
mfCached :: Bool,
newAsk :: Bool,
inSync :: Bool,
mfSomeNotValidates :: Bool,
mfLang :: Lang,
mfEnv :: Params,
needForm :: NeedForm,
mfFileUpload :: Bool,
mfToken :: Token,
mfkillTime :: Int,
mfSessionTime :: Integer,
mfCookies :: [Cookie],
mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
mfHeader :: view -> view,
mfDebug :: Bool,
mfRequirements :: [Requirement],
mfInstalledScripts :: [WebRequirement],
mfData :: M.Map TypeRep Void,
mfAjax :: Maybe (M.Map String Void),
mfSeqCache :: Int,
notSyncInAction :: Bool,
mfPath :: [String],
mfPagePath :: [String],
mfPrefix :: String,
mfPageFlow :: Bool,
linkMatched :: Bool,
mfAutorefresh :: Bool,
mfTrace :: [String],
mfClear :: Bool
}
deriving Typeable
type Void = Char
mFlowState0 :: (FormInput view) => MFlowState view
mFlowState0 = MFlowState 0 False True True False "en"
[] NoElems False (error "token of mFlowState0 used")
0 0 [] [] stdHeader False [] [] M.empty Nothing 0 False
[] [] "" False False False [] 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
getSData :: (Monad m,Typeable a,Monoid v) => View v m a
getSData= View $ do
r <- getSessionData
return $ FormElm mempty r
getSessionId :: MonadState (MFlowState v) m => m String
getSessionId= gets mfToken >>= return . key
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=
modify $ \st -> st{mfCookies= (UnEncryptedCookie
( SB.fromString n,
SB.fromString v,
SB.fromString p,
fmap (SB.fromString . show) me)):mfCookies st }
setParanoidCookie :: MonadState (MFlowState view) m
=> String
-> String
-> String
-> Maybe Integer
-> m ()
setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
setEncryptedCookie :: MonadState (MFlowState view) m
=> String
-> String
-> String
-> Maybe Integer
-> m ()
setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
setEncryptedCookie' n v p me encFunc=
modify $ \st -> st{mfCookies =
(unsafePerformIO $ encFunc
( SB.fromString n,
SB.fromString v,
SB.fromString p,
fmap (SB.fromString . show) me)):mfCookies st }
setHttpHeader :: MonadState (MFlowState view) m
=> SB.ByteString
-> SB.ByteString
-> m ()
setHttpHeader n v =
modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (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 B.ByteString m a
normalize f= View . StateT $ \s ->do
(FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s
return (FormElm (toByteString fs ) mx,unsafeCoerce s')
class (Monoid view,Typeable view) => FormInput view where
toByteString :: view -> B.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 -> T.Text -> view
fselect :: String -> view -> view
foption :: String -> view -> Bool -> view
foption1 :: String -> Bool -> view
foption1 val msel= foption val (fromStr val) msel
formAction :: String -> 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
,mfSomeNotValidates= mfSomeNotValidates s2
,mfRequirements=mfRequirements s2
,mfPath= mfPath s2
,mfPagePath= mfPagePath s2
,needForm= needForm s2
,mfPageFlow= mfPageFlow s2
,mfSeqCache= mfSeqCache s + mfSeqCache s2 sec}
return $ (mfSeqCache s'') `seq` form `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)
runFlow :: (FormInput view, MonadIO m)
=> FlowM view (Workflow m) () -> Token -> Workflow m ()
runFlow f t=
loop (startState t) f t
where
loop s f t = do
(mt,s) <- runFlowOnce2 s f
let t'= fromFailBack mt
let t''= t'{tpath=[twfname t']}
liftIO $ do
flushRec t''
sendToMF t'' t''
let s'= case mfSequence s of
1 -> s
_ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]}
loop s' f t''{tpath=[]}
inRecovery= 1
runFlowOnce :: (FormInput view, MonadIO m)
=> FlowM view (Workflow m) () -> Token -> Workflow m ()
runFlowOnce f t= runFlowOnce1 f t >> return ()
runFlowOnce1 f t = runFlowOnce2 (startState t) f
startState t= mFlowState0{mfToken=t
,mfSequence= inRecovery
,mfPath= tpath t
,mfEnv= tenv t
,mfPagePath=[]}
runFlowOnce2 s f =
runStateT (runSup . runFlowM $ do
backInit
f
getToken) s
where
backInit= do
s <- get
case mfTrace s of
[] -> do
let t = mfToken s
back <- goingBack
recover <- lift $ isInRecover
when (back && not recover) . modify $ \s -> s{ newAsk= True,mfPagePath=[twfname t]}
breturn ()
tr -> error $ disp tr
where
disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
runFlowOnceReturn
:: FormInput v => MFlowState v -> FlowM v m a -> Token -> m (FailBack a, MFlowState v)
runFlowOnceReturn s f t =
runStateT (runSup $ runFlowM f) (startState t)
runFlowIn
:: (MonadIO m,
FormInput view)
=> String
-> FlowM view (Workflow IO) b
-> FlowM view m b
runFlowIn wf f= FlowM . Sup $ do
st <- get
let t = mfToken st
(r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
put st{mfPath= mfPath st'}
case r of
GoBack -> delWF wf ()
return r
where
runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a
runFlowConf f = do
q <- liftIO newEmptyMVar
qr <- liftIO newEmptyMVar
block <- liftIO $ newMVar True
let t= Token "" "" "" [] [] block q qr
evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack
clearEnv :: MonadState (MFlowState view) m => m ()
clearEnv= do
st <- get
put st{ mfEnv= []}
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= inRecovery})
debug= do
(x,env) <- readp
return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
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' /= inRecovery) $ 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)
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
getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
=> String -> Params -> m (ParamResult v a)
getParam1 par req = case lookup par req of
Just x -> readParam x
Nothing -> return NoParam
getRestParam :: (Read a, Typeable a, Monad m, Functor m, MonadState (MFlowState v) m, FormInput v)
=> m (Maybe a)
getRestParam= do
st <- get
let lpath = mfPath st
if linkMatched st
then return Nothing
else case stripPrefix (mfPagePath st) lpath of
Nothing -> return Nothing
Just [] -> return Nothing
Just xs -> do
let name= head xs
r <- fmap valToMaybe $ readParam name
when (isJust r) $ modify $ \s -> s{inSync= True
,linkMatched= True
,mfPagePath= mfPagePath s++[name]}
return r
getKeyValueParam par= do
st <- get
r <- getParam1 par $ mfEnv st
return $ valToMaybe r
readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
=> String -> m (ParamResult v a)
readParam x1 = r
where
r= do
modify $ \s -> s{inSync= True}
maybeRead x1
getType :: m (ParamResult v a) -> a
getType= undefined
x= getType r
maybeRead str= do
let typeofx = typeOf x
if typeofx == typeOf ( undefined :: String) then
return . Validated $ unsafeCoerce str
else if typeofx == typeOf (undefined :: T.Text) then
return . Validated . unsafeCoerce $ T.pack 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)
modify $ \st -> st{mfSomeNotValidates= True}
return $ NotValidated str err
requires rs =do
st <- get
let l = mfRequirements st
put st {mfRequirements= l ++ map Requirement rs}
unfold (JScriptFile f ss)= JScript loadScript:map (\s-> JScriptFile f [s]) ss
unfold x= [x]
data Requirement= forall a.(Show a,Typeable a,Requirements a) => Requirement a deriving Typeable
class Requirements a where
installRequirements :: (MonadState (MFlowState view) m,MonadIO m,FormInput view) => [a] -> m view
instance Show Requirement where
show (Requirement a)= show a ++ "\n"
installAllRequirements :: ( MonadIO m, FormInput view) => WState view m view
installAllRequirements= do
st <- get
let rs = mfRequirements st
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=
let name= addrStr filename
in "\n"++name++"=loadScript('"++name++"','"++filename++"');\n"
loadScript ="function loadScript(name, filename){\
\var fileref = document.getElementById(name);\
\if (fileref === null){\
\fileref=document.createElement('script');\
\fileref.setAttribute('id',name);\
\fileref.setAttribute('type','text/javascript');\
\fileref.setAttribute('src',filename);\
\document.getElementsByTagName('head')[0].appendChild(fileref);}\
\return fileref};\n\
\function addLoadEvent(elem,func) {\
\var oldonload = elem.onload;\
\if (typeof elem.onload != 'function') {\
\elem.onload = func;\
\} else {\
\elem.onload = function() {\
\if (oldonload) {\
\oldonload();\
\}\
\func();\
\}\
\}\
\}"
loadCallback depend script=
let varname= addrStr depend in
"\naddLoadEvent("++varname++",function(){"++ script++"});"
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
:: (MonadState(MFlowState view) m,MonadIO m,FormInput view) => [WebRequirement] -> m view
installWebRequirements rs= do
installed <- gets mfInstalledScripts
let rs'= (nub rs) \\ installed
strs <- mapM strRequirement rs'
case null strs of
True -> return mempty
False -> return . ftag "script" . fromStrNoEncode $ concat strs
strRequirement r=do
r1 <- strRequirement' r
modify $ \st -> st{mfInstalledScripts= mfInstalledScripts st ++ [r]}
return r1
strRequirement' (CSSFile scr) = return $ loadcssfile scr
strRequirement' (CSS scr) = return $ loadcss scr
strRequirement' (JScriptFile file scripts) = do
installed <- gets mfInstalledScripts
let hasLoadScript (JScriptFile _ _)= True
hasLoadScript _= False
inst2= dropWhile (not . hasLoadScript) installed
hasSameFile file (JScriptFile fil _)= if file== fil then True else False
hasSameFile _ _= False
case (inst2,find (hasSameFile file) inst2) of
([],_) ->
return $ loadScript <> loadjsfile file <> concatMap(loadCallback file) scripts
(_,Just _) -> do
autorefresh <- gets mfAutorefresh
case autorefresh of
False -> return $ concatMap(loadCallback file) scripts
True -> return $ concat scripts
_ -> return $ loadjsfile file <> concatMap(loadCallback file) scripts
strRequirement' (JScript scr) = return scr
strRequirement' (ServerProc f)= do
liftIO $ addMessageFlows [f]
return ""
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 st form anchored= do
let verb = twfname $ mfToken st
path = currentPath st
hasfile= mfFileUpload st
attr= case hasfile of
True -> [("enctype","multipart/form-data")]
False -> []
(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 ) "POST" ( anchorf <> form ) `attrs` attr
insertForm w=View $ do
FormElm forms mx <- runView w
st <- get
cont <- case needForm st of
HasElems -> do
frm <- formPrefix st forms False
put st{needForm= HasForm}
return frm
_ -> return forms
return $ FormElm cont mx
controlForms :: (FormInput v, MonadState (MFlowState v) m)
=> MFlowState v -> MFlowState v -> v -> v -> m (v,Bool)
controlForms s1 s2 v1 v2= case (needForm s1, needForm s2) of
(HasElems, HasForm) -> do
v1' <- formPrefix s1 v1 True
return (v1' <> v2 , True)
_ -> return (v1 <> v2, False)
currentPath st= concat ['/':v| v <- mfPagePath st ]
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)
getNextId :: MonadState (MFlowState view) m => m String
getNextId= do
st <- get
case mfCached st of
False -> do
let n= mfSequence st
prefseq= mfPrefix st
return $ 'p':show n++prefseq
True -> do
let n = mfSeqCache st
return $ 'c' : (show n)