MFlow 0.4.2 → 0.4.4
raw patch · 8 files changed
+297/−211 lines, 8 filesdep −xhtml
Dependencies removed: xhtml
Files
- MFlow.cabal +8/−5
- src/MFlow.hs +65/−24
- src/MFlow/Forms.hs +84/−70
- src/MFlow/Forms/Admin.hs +17/−17
- src/MFlow/Forms/Internals.hs +95/−71
- src/MFlow/Forms/WebApi.hs +4/−2
- src/MFlow/Forms/Widgets.hs +19/−18
- src/MFlow/Wai/Blaze/Html/All.hs +5/−4
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow-version: 0.4.2+version: 0.4.4 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -89,6 +89,8 @@ src/MFlow/Hack/Response.hs src/MFlow/Hack/XHtml.hs src/MFlow/Hack/XHtml/All.hs src/MFlow/Forms/HSP.hs+ src/MFlow/Forms/XHtml.hs+ src/MFlow/Wai/XHtml/All.hs source-repository head type: git@@ -96,7 +98,7 @@ library build-depends: Workflow -any, transformers -any, mtl -any,- extensible-exceptions -any, xhtml -any, base >4.0 && <5,+ extensible-exceptions -any, base >4.0 && <5, bytestring -any, containers -any, RefSerialize -any, TCache -any, stm >2, old-time -any, vector -any, directory -any, utf8-string -any, wai >=2.0.0, case-insensitive -any,@@ -104,15 +106,16 @@ warp-tls -any, random -any, blaze-html -any, blaze-markup -any, monadloc -any, clientsession ==0.9.0.3 exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms- MFlow.Forms.Admin MFlow.Cookies MFlow.Wai MFlow.Wai.XHtml.All- MFlow.Forms.XHtml MFlow.Forms.Blaze.Html MFlow.Forms.Test+ MFlow.Forms.Admin MFlow.Cookies MFlow.Wai+ MFlow.Forms.Blaze.Html MFlow.Forms.Test MFlow.Forms.Widgets MFlow.Forms.Internals MFlow.Forms.WebApi exposed: True buildable: True hs-source-dirs: src . other-modules: MFlow.Wai.Response --- executable demos-blaze++--executable demos-blaze -- build-depends: MFlow -any, RefSerialize -any, TCache -any, -- tcache-AWS -any, directory -any, Workflow -any, base -any, -- blaze-html -any, bytestring -any, containers -any, mtl -any,
src/MFlow.hs view
@@ -54,7 +54,7 @@ ,RecordWildCards ,OverloadedStrings ,ScopedTypeVariables - ,TemplateHaskell + #-} module MFlow ( Flow, Params, HttpData(..),Processable(..) @@ -72,7 +72,7 @@ , userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod -- * static files -- * config-,Config(..), config +,Config(..), config, getConfig, setConfig ,setFilesPath -- * internal use ,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow @@ -111,7 +111,7 @@ import Data.RefSerialize hiding (empty) import qualified Data.Text as T import System.Posix.Internals - +import Control.Exception import Debug.Trace (!>) = flip trace @@ -510,35 +510,75 @@ reg u p - +newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable) ++defConfig= Config1 $ M.fromList+ [("cadmin","admin")+ ,("cjqueryScript","//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js")+ ,("cjqueryCSS","//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css")+ ,("cjqueryUI","//code.jquery.com/ui/1.10.3/jquery-ui.js")+ ,("cnicEditUrl","//js.nicedit.com/nicEdit-latest.js")] -data Config = Config{cadmin :: UserStr -- ^ Administrator name- ,cjqueryScript :: String -- ^ URL of jquery- ,cjqueryCSS :: String -- ^ URL of jqueryCSS- ,cjqueryUI :: String -- ^ URL of jqueryUI- ,cnicEditUrl :: String -- ^ URL of the nicEdit editor- }+data Config0 = Config{cadmin :: UserStr -- ^ Administrator name+ ,cjqueryScript :: String -- ^ URL of jquery+ ,cjqueryCSS :: String -- ^ URL of jqueryCSS+ ,cjqueryUI :: String -- ^ URL of jqueryUI+ ,cnicEditUrl :: String -- ^ URL of the nicEdit editor+ } deriving (Read, Show, Typeable) -defConfig= Config "admin" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"- "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"- "//code.jquery.com/ui/1.10.3/jquery-ui.js"- "//js.nicedit.com/nicEdit-latest.js"+--defConfig0= Config "admin" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"+-- "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"+-- "//code.jquery.com/ui/1.10.3/jquery-ui.js"+-- "//js.nicedit.com/nicEdit-latest.js"+--+--writeDefConfig0= writeFile "sal" $ show defConfig0 -config= unsafePerformIO $! atomically $! readConfig+change :: Config0 -> Config+change Config{..} = Config1 $ M.fromList+ [("cadmin",cadmin )+ ,("cjqueryScript", cjqueryScript)+ ,("cjqueryCSS",cjqueryCSS)+ ,("cjqueryUI",cjqueryUI)+ ,("cnicEditUrl",cnicEditUrl)] -readConfig= readDBRef rconf `onNothing` return defConfig+config :: M.Map String String+config= unsafePerformIO $! do+ Config1 c <- atomically $! readConfig+ return c +readConfig= readDBRef rconf `onNothing` return defConfig +readOld :: ByteString -> Config+readOld s= (change . read . B.unpack $ s) keyConfig= "mflow.config" -instance Indexable Config where key _= keyConfig +instance Indexable Config where key _= keyConfig++rconf :: DBRef Config rconf= getDBRef keyConfig instance Serializable Config where - serialize= B.pack . show - deserialize= read . B.unpack - setPersist = \_ -> Just filePersist + serialize = B.pack . show + deserialize s = unsafePerformIO $ do+ let r = read $! B.unpack s+ print r+ return r+ `CE.catch` \(e :: SomeException) -> return (readOld s) + setPersist = \_ -> Just filePersist ++-- | read a config variable from the config+getConfig s= case M.lookup s config of+ Nothing -> ""+ Just s -> s++-- | set an user-defined config variable+setConfig k v= atomically $ do+ Config1 conf <- readConfig + writeDBRef rconf $ Config1 $ M.insert k v conf +++-- user --- type UserStr= String type PasswdStr= String @@ -550,13 +590,14 @@ setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m () setAdminUser user password= liftIO $ do userRegister user password- atomically $ do- conf <- readConfig - writeDBRef rconf $ conf{cadmin= user} + setConfig "cadmin" user+-- atomically $ do+-- Config1 conf <- readConfig +-- writeDBRef rconf $ Config1 $ M.insert "cadmin" user conf -getAdminName= cadmin config +getAdminName= getConfig "cadmin" --------------- ERROR RESPONSES --------
src/MFlow/Forms.hs view
@@ -843,7 +843,7 @@ if back then noWidget else return x -- | forces backtracking if the widget validates, because a previous page handle this widget response --- . This is useful for recurrent cached widgets that are present in multiple pages. For example +-- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example -- in the case of menus or common options. The active elements of this widget must be cached with no timeout. retry :: Monad m => View v m a -> View v m () retry w = View $ do @@ -1105,7 +1105,9 @@ ask :: (FormInput view) => View view IO a -> FlowM view IO a ask w = do - st1 <- get + st1 <- get >>= \s -> return s{mfSequence=+ let seq= mfSequence s in+ if seq ==inRecovery then 0 else seq} if not . null $ mfTrace st1 then fail "" else do -- AJAX let env= mfEnv st1 @@ -1119,7 +1121,18 @@ ask w -- END AJAX - _ -> do + _ -> do++-- mfPagePath : contains the REST path of the page.+-- it is set for each page+-- if it does not exist, backtrack (to fill the field)+ let pagepath = mfPagePath st1+ if null pagepath then fail ""+-- if exist and it is not prefix of the current path being navigated to, backtrack+ else if not $ pagepath `isPrefixOf` mfPath st1 then fail "" -- !> ("pagepath fail with "++ show (mfPath st1))+ else do+-- wlinks set it for the next page+ let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False} put st @@ -1131,20 +1144,15 @@ else case mx of Just x -> do - put st'{newAsk= True, mfEnv=[]} - breturn x -- !> "BRETURN" + put st'{newAsk= True , mfEnv=[]+ ,mfPagePath= mfPagePath st'} + breturn x -- !> ("BRETURN "++ show (mfPagePath st') ) Nothing -> if not (inSync st') && not (newAsk st') --- !> ("pageIndex="++ show (mfPageIndex st')) -- !> ("insync="++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 "" -- !> "FAIL**********" + then fail "" -- !> "FAIL**********" else if mfAutorefresh st' then do resetState st st' FlowM $ lift nextMessage @@ -1163,23 +1171,16 @@ liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s - resetState st st'- let path= mfPath st + resetState st st' FlowM $ lift nextMessage -- !> "NEXTMESSAGE"- st <- get- let path' = mfPath st- env' = mfEnv st - if isJust(lookup "ajax" env') then ask w- else if not $ path `isPrefixOf` path'- then fail ""- else ask w + ask w where resetState st st'= put st{mfCookies=[] -- ,mfHttpHeaders=[] ,newAsk= False ,mfToken= mfToken st' - ,mfPageIndex= mfPageIndex st' + ,mfPageFlow= mfPageFlow st' ,mfAjax= mfAjax st' ,mfSeqCache= mfSeqCache st' ,mfData= mfData st' } @@ -1205,16 +1206,13 @@ env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow) npath= pwfPath msg path= mfPath st - inPageFlow= case (comparep,mfPageIndex st) of - (n, Just n') -> if n < n' then Nothing else Just n' - _ -> Nothing - comparep= comparePaths (mfPIndex st) 1 path npath + inPageFlow= mfPagePath st `isPrefixOf` npath + put st{ mfPath= npath --- , mfPIndex= min (mfPIndex st) comparep - , mfPageIndex= inPageFlow -- !> ("pageflow="++ (show $ mfPageIndex st)- -- ++ " "++show inPageFlow) + , mfPageFlow= inPageFlow + , mfEnv= env } @@ -1225,9 +1223,9 @@ comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath | otherwise= n - updateParams :: Maybe Int -> Params -> Params -> Params - updateParams Nothing _ req= req - updateParams (Just _) env req= + updateParams :: Bool -> Params -> Params -> Params + updateParams False _ req= req + updateParams True env req= let params= takeWhile isparam env fs= fst $ head req parms= (case findIndex (\p -> fst p == fs) params of @@ -1250,7 +1248,7 @@ wstateless :: (Typeable view, FormInput view) => View view IO () -> Flow -wstateless w = transient . runFlow . ask $ w **> stop -- loop +wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w) -- loop -- where -- loop= do -- ask w @@ -1375,38 +1373,30 @@ -- It points to the page that created it. wlink :: (Typeable a, Show a, MonadIO m, FormInput view) => a -> view -> View view m a -wlink x v= View $ do +wlink x v= View $ do verb <- getWFName - st <- get - let - name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String) + 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 - - - index = if index'== 0 then 1 else index' - lpath = mfPath st - - path= currentPath True index lpath verb ++ ('/':name) - -- !> (show $ mfPath st) - toSend = flink path v - + lpath = mfPath st+ newPath= mfPagePath st ++ [name] - r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page - else - case index < Data.List.length lpath && name== lpath !! index of + r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page + else + case newPath `isPrefixOf` lpath of True -> do modify $ \s -> s{inSync= True ,linkMatched= True- ,mfPIndex= index+1 } - - return $ Just x -- !> (name ++ "<-" ++show index++ " " ++ show (mfPIndex st) ++ "lpath=" ++show lpath) - False -> return Nothing -- !> ( "NOT MATCHED "++name++"<-" ++show index++ " LP= "++show lpath) + ,mfPagePath= mfPagePath st ++ [name] } - length path `seq` return $ FormElm [toSend] r + return $ Just x -- !> (name ++ "<-" ++ "lpath=" ++show (mfPagePath st)) + False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show (mfPagePath st)) + let path= currentPath st ++ ('/':name) + return $ FormElm [flink path v ] r + -- Creates an absolute link. While a `wlink` path depend on the page where it is located and -- ever points to the code of the page that had it inserted, an absLink point to the first page -- in the flow that inserted it. It is useful for creating a backtracking point in combination with `retry`@@ -1428,10 +1418,34 @@ -- > p << "second statement" ++> wlink () << p << "click here" -- > p << "third statement" ++> (absLink "here" << p << "will present the first statement alone") -- > p << "fourth statement" ++> wlink () << p << "will not reach here"-absLink x = wcached (show x) 0 . wlink x+--absLink x = wcached (show x) 0 . wlink x+absLink 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) + lpath = mfPath st+ newPath= mfPagePath st ++ [name] + r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page + else + case newPath `isPrefixOf` lpath of + True -> do + modify $ \s -> s{inSync= True + ,linkMatched= True+ ,mfPagePath= mfPagePath st ++ [name] } + return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath) + False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath) ++ path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name) ++ return $ FormElm [flink path v ] r -- !> name +++ -- | When some user interface return some response to the server, but it is not produced by -- a form or a link, but for example by an script, @returning@ convert this code into a -- widget. @@ -1469,13 +1483,14 @@ -- return $ FormElm [mconcat vs] res1 -- | Concat a list of widgets of the same type, return a the first validated result -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 - return $ FormElm vs res1 +firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a] -> View view m a +firstOf xs= foldl' (<|>) noWidget 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 +-- return $ FormElm vs res1 -- | from a list of widgets, it return the validated ones. manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a] @@ -1504,7 +1519,7 @@ -- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types. -- -- it has a infix priority @infixr 5@ -(|*>) :: (MonadIO m, Functor m,Monoid view) +(|*>) :: (MonadIO m, Functor m, FormInput view) => View view m r -> [View view m r'] -> View view m (Maybe r,Maybe r') @@ -1525,7 +1540,7 @@ -- and at the bottom of a page. -- It has a low infix priority: @infixr 1@ -(|+|) :: (Functor m, Monoid view, MonadIO m) +(|+|) :: (Functor m, FormInput view, MonadIO m) => View view m r -> View view m r' -> View view m (Maybe r, Maybe r') @@ -1668,18 +1683,17 @@ pageFlow str widget=do s <- get - if isNothing $ mfPageIndex s + if mfPageFlow s == False then do put s{mfPrefix= str ++ mfPrefix s ,mfSequence=0 - ,mfPageIndex= Just $ mfPIndex s+ ,mfPageFlow= True } -- !> ("PARENT pageflow. prefix="++ str) r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s ,mfPrefix= mfPrefix s--- ,mfPageIndex=Nothing })) - modify (\s -> s{mfPageIndex=Nothing} )+ modify (\s -> s{mfPageFlow=False} ) return r -- !> ("END PARENT pageflow. prefix="++ str))
src/MFlow/Forms/Admin.hs view
@@ -3,10 +3,10 @@ #-} module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where -import MFlow.Forms -import MFlow.Forms.XHtml -import MFlow -import Text.XHtml.Strict hiding (widget) +import MFlow.Forms+import MFlow+import MFlow.Forms.Blaze.Html +import Text.Blaze.Html5 hiding (map) import Control.Applicative import Control.Workflow import Control.Monad.Trans @@ -96,19 +96,19 @@ -- create an admin user with `setAdminUser`. -- -- The administration page is reached with the path \"adminserv\" -addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)] +addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)] adminMFlow :: FlowM Html IO () adminMFlow= do let admin = getAdminName - u <- getUser (Just admin) $ p << bold << "Please login as Administrator" ++> userLogin - op <- ask $ p <<< wlink "sync" (bold << "sync") - <|> p <<< wlink "flush" (bold << "flush") - <|> p <<< wlink "errors"(bold << "errors") - <|> p <<< wlink "users" (bold << "users") - <|> p <<< wlink "end" (bold << "end") - <|> wlink "abort" (bold << "abort") + u <- getUser (Just admin) $ p << b << "Please login as Administrator" ++> userLogin + op <- ask $ p <<< wlink "sync" (b << "sync") + <|> p <<< wlink "flush" (b << "flush") + <|> p <<< wlink "errors"(b << "errors") + <|> p <<< wlink "users" (b << "users") + <|> p <<< wlink "end" (b << "end") + <|> wlink "abort" (b << "abort") case op of "users" -> users @@ -125,13 +125,13 @@ errors= do size <- liftIO $ hFileSize hlog if size == 0 - then ask $ wlink () (bold << "no error log") + then ask $ wlink () (b << "no error log") else do liftIO $ hSeek hlog AbsoluteSeek 0 log <- liftIO $ hGetNonBlocking hlog (fromIntegral size) let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]" - let rows= [wlink (head e) (bold << head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls] + let rows= [wlink (Prelude.head e) (b << Prelude.head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls] showFormList rows 0 10 breturn() @@ -144,7 +144,7 @@ users= do users <- liftIO $ atomically $ return . map fst =<< indexOf userName - showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<- users] 0 10 + showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10 showFormList :: [[View Html IO ()]] @@ -158,7 +158,7 @@ cols e= firstOf[td <<< c | c <- e] span1 n l = take l . drop n - updown n l= wlink ( n +l) (bold << "up ") <|> wlink ( n -l) (bold << "down ") <++ br + updown n l= wlink ( n +l) (b << "up ") <|> wlink ( n -l) (b << "down ") <++ br optionsUser us = do wfs <- liftIO $ return . M.keys =<< getMessageFlows @@ -166,7 +166,7 @@ in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us u u u u u)) wfs let wfss= filter (isJust . snd) $ zip wfs stats if null wfss - then ask $ bold << " not logs for this user" ++> wlink () (bold << "Press here") + then ask $ b << " not logs for this user" ++> wlink () (b << "Press here") else do wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss] ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")
src/MFlow/Forms/Internals.hs view
@@ -49,6 +49,8 @@ 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.String -- @@ -84,8 +86,8 @@ newtype Sup m a = Sup { runSup :: m (FailBack a ) } class MonadState s m => Supervise s m where - supBack :: s -> m () - supBack = const $ return () + supBack :: s -> m () -- called before backtracing. state passed is the previous + supBack = const $ return () -- By default the state passed is the last one supervise :: m (FailBack a) -> m (FailBack a) supervise= id @@ -99,13 +101,13 @@ where loop = do s <- get - v <- supervise $ runSup x -- !> "loop" + v <- supervise $ runSup x -- !> "loop" case v of - NoBack y -> supervise $ runSup (f y) -- !> "runback" + NoBack y -> supervise $ runSup (f y) -- !> "runback" BackPoint y -> do z <- supervise $ runSup (f y) -- !> "BACK" case z of - GoBack -> supBack s >> loop -- !> "BACKTRACKING" + GoBack -> supBack s >> loop -- !> "BACKTRACKING" other -> return other GoBack -> return $ GoBack @@ -206,13 +208,14 @@ instance Monad m => Supervise (MFlowState v) (WState v m) where - supBack st= do + supBack st= do -- the previous state is recovered, with the exception of these fields: MFlowState{..} <- get put st{ mfEnv= mfEnv,mfToken=mfToken - , mfPath=mfPath -- ,mfPIndex= mfPIndex + , mfPath=mfPath , mfData=mfData , mfTrace= mfTrace - , inSync=False,newAsk=False} + , inSync=False+ , newAsk=False} @@ -289,10 +292,10 @@ True -> showp(x, mfEnv s) readp= choice[nodebug, debug] where - nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= -1}) + nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery}) debug= do (x,env) <- readp - return (x,mFlowState0{mfEnv= env,mfSequence= -1}) + return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery}) instance Functor (FormElm view ) where @@ -311,38 +314,49 @@ instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where empty= View $ return $ FormElm [] Nothing - View f <|> View g= View $ do + View f <|> View g= View $ do+ path <- gets mfPagePath FormElm form1 k <- f- s1 <- get + s1 <- get+ let path1 = mfPagePath s1+ put s1{mfPagePath=path} FormElm form2 x <- g s2 <- get (mix,hasform) <- controlForms s1 s2 form1 form2- when hasform $ put s2{needForm= HasForm} + 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 - put st{linkMatched = False} - 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 + 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} - Nothing -> - return $ FormElm form1 Nothing + return $ FormElm mix mk + Nothing -> + return $ FormElm form1 Nothing return = View . return . FormElm [] . Just -- fail msg= View . return $ FormElm [inRed msg] Nothing - ++ instance (FormInput v,Monad m, Functor m, Monoid a) => Monoid (View v m a) where mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum @@ -365,7 +379,8 @@ FormElm form1 mk <- x case mk of Just k -> do - modify $ \st -> st{linkMatched= False, needForm=NoElems} + modify $ \st -> st{linkMatched= False, needForm=NoElems}+ runView (f k) Nothing -> return $ FormElm form1 Nothing @@ -539,11 +554,13 @@ notSyncInAction :: Bool, -- Link management - mfPath :: [String], + mfPath :: [String],+ mfPagePath :: [String], mfPrefix :: String, - mfPIndex :: Int, - mfPageIndex :: Maybe Int, - linkMatched :: Bool, +-- mfPIndex :: Int, + mfPageFlow :: Bool, + linkMatched :: Bool,+-- mfPendingPath :: [String], mfAutorefresh :: Bool, @@ -557,7 +574,7 @@ mFlowState0 :: (FormInput view) => MFlowState view mFlowState0 = MFlowState 0 False True True "en" [] NoElems (error "token of mFlowState0 used") - 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] "" 1 Nothing False False [] False + 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] [] "" False False False [] False -- | Set user-defined data in the context of the session. @@ -813,10 +830,11 @@ 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 + ,mfPath= mfPath s2+ ,mfPagePath= mfPagePath s2+-- ,mfPendingPath=mfPendingPath s2 ,needForm= needForm s2 - ,mfPIndex= mfPIndex s2 - ,mfPageIndex= mfPageIndex s2 + ,mfPageFlow= mfPageFlow s2 ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec} return $ (mfSeqCache s'') `seq` form `seq` ((FormElm form mx2), s'') @@ -867,8 +885,8 @@ adminLoop @ -} -runFlow :: (FormInput view, MonadIO m) - => FlowM view m () -> Token -> m () +--runFlow :: (FormInput view, MonadIO m) +-- => FlowM view m () -> Token -> m () runFlow f t= loop (startState t) f t where @@ -878,20 +896,25 @@ let t''= t'{tpath=[twfname t']} liftIO $ do flushRec t'' - sendToMF t'' t'' -- !> "SEND" - loop s{mfPIndex=0,mfPath=[],mfEnv=[]} f t''{tpath=[]} -- !> "LOOPAGAIN" - + sendToMF t'' t''+ let s'= case mfSequence s of+ -1 -> s -- !> "end of recovery loop"+ _ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]} + loop s' f t''{tpath=[]} -- !> "LOOPAGAIN" +inRecovery= -1 -runFlowOnce :: (MonadIO m, FormInput view) - => FlowM view m () -> Token -> m () +--runFlowOnce :: (MonadIO m, FormInput view) +-- => FlowM view m () -> Token -> m () runFlowOnce f t= runFlowOnce1 f t >> return () runFlowOnce1 f t = runFlowOnce2 (startState t) f -startState t= mFlowState0{mfToken=t +startState t= mFlowState0{mfToken=t+ ,mfSequence= inRecovery ,mfPath= tpath t - ,mfEnv= tenv t} + ,mfEnv= tenv t+ ,mfPagePath=[]} runFlowOnce2 s f = runStateT (runSup . runFlowM $ do @@ -904,8 +927,11 @@ backInit= do s <- get -- !> "BackInit" case mfTrace s of - [] -> do - modify $ \s -> s{{-mfEnv=[],-} newAsk= True} + [] -> 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 @@ -981,9 +1007,9 @@ (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s -- when recovery of a workflow, the MFlow state is not considered - when( mfSequence s' /= -1) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True} + when( mfSequence s' /= inRecovery) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True} return r - + -- | to execute transient flows as if they were persistent -- it can be used instead of step, but it does log nothing. -- Thus, it is faster and convenient when no session state must be stored beyond the lifespan of@@ -1076,29 +1102,32 @@ 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 +getParam1 par req = case lookup par req of Just x -> readParam x Nothing -> return NoParam -- Read a segment in the REST path. if it does not match with the type requested -- or if there is no remaining segment, it returns Nothing -getRestParam :: (Read a, Typeable a,Monad m,Functor m, MonadState (MFlowState v) m, FormInput v) => m (Maybe a) +getRestParam :: (Read a, Typeable a, Monad m, Functor m, MonadState (MFlowState v) m, FormInput v)+ => m (Maybe a) getRestParam= do - st <- get + st <- get let lpath = mfPath st - index' = mfPIndex st -- + if Just (mfPIndex st)== mfPageIndex st then 1 else 0 - index = if index'== 0 then 1 else index'- name = lpath !! index - if linkMatched st+ if linkMatched st then return Nothing - else case index < length lpath of - True -> do - modify $ \s -> s{inSync= True - ,linkMatched= True- ,mfPIndex= index+1 } - fmap valToMaybe $ readParam name - False -> 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 + + -- | return the value of a post or get param in the form ?param=value¶m2=value2... getKeyValueParam par= do st <- get@@ -1288,10 +1317,9 @@ " };" ++ "" -formPrefix st form anchored= do - let index= mfPIndex st- verb= twfname $ mfToken st- path = currentPath False index (mfPath st) verb +formPrefix st form anchored= do+ let verb = twfname $ mfToken st+ path = currentPath st (anchor,anchorf) <- case anchored of True -> do @@ -1326,11 +1354,7 @@ _ -> return (v1 ++ v2, False) -currentPath insInBackTracking index lpath verb = - (if null lpath then '/':verb - else case insInBackTracking of - True -> concat $ take index ['/':v | v <- lpath] -- !> ("index= " ++ show index) - False -> concat ['/':v| v <- lpath]) +currentPath st= concat ['/':v| v <- mfPagePath st ] -- | Generate a new string. Useful for creating tag identifiers and other attributes. --
src/MFlow/Forms/WebApi.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- ----- A haskell formlet is the combination of a parameter parser plus a writer to generate HTTP+-- A haskell formlet is the combination of a parameter parser to read input plus a writer to generate HTTP -- output -- -- I use this similarity to create parsec-like combinators that use the formlet monad in MFlow@@ -53,7 +53,9 @@ -- therefore a monadic sequence in the View monad will not continue rest v= do r <- restp- if r==v then return v else modify (\s -> s{mfPIndex= mfPIndex s-1}) >> stop+ if r==v then return v+ else+ modify (\s -> s{mfPagePath= reverse . tail . reverse $ mfPagePath s}) >> stop -- | get a parameter from a GET or POST key-value input. wparam par= View $ do
src/MFlow/Forms/Widgets.hs view
@@ -77,10 +77,10 @@ --jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js" --jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js" -jqueryScript= cjqueryScript config -jqueryCSS= cjqueryCSS config -jqueryUI= cjqueryUI config -nicEditUrl= cnicEditUrl config +jqueryScript= getConfig "cjqueryScript" +jqueryCSS= getConfig "cjqueryCSS" +jqueryUI= getConfig "cjqueryUI" +nicEditUrl= getConfig "cnicEditUrl" ------- User Management ------ -- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented. @@ -125,13 +125,16 @@ -- -- normally to be used with autoRefresh and pageFlow when used with other widgets. wlogin :: (MonadIO m,Functor m,FormInput v) => View v m () -wlogin= do +wlogin= do username <- getCurrentUser if username /= anonymous then return username else do - name <- getString Nothing <! hint "login name" <! size 9 <++ ftag "br" mempty - pass <- getPassword <! hint "password" <! size 9 + name <- getString Nothing <! hint "login name"+ <! size 9+ <++ ftag "br" mempty + pass <- getPassword <! hint "password"+ <! size 9 <++ ftag "br" mempty <** submitButton "login" val <- userValidate (name,pass) @@ -140,7 +143,7 @@ Nothing -> login name >> (return name) `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ") - ++> submitButton "logout") -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout")) + ++> pageFlow "logout" (submitButton "logout")) -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout")) `wcallback` const (logout >> wlogin) focus = [("onload","this.focus()")] @@ -629,11 +632,10 @@ name <- genNewId setSessionData $ IteratedId name st <- get - let index= mfPIndex st let t= mfkillTime st let installAutoEval= "$(document).ready(function(){\n\ - \autoEvalLink('"++name++"','"++ show index ++"');\ + \autoEvalLink('"++name++"',0);\ \autoEvalForm('"++name++"');\ \})\n" let r = lookup ("auto"++name) $ mfEnv st @@ -650,8 +652,6 @@ Just sind -> View $ do let t= mfToken st --- let index= read sind --- put st{mfPIndex= index} modify $ \s -> s{mfRequirements=[]} FormElm _ mr <- runView w @@ -659,7 +659,7 @@ reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements let js = jsRequirements reqs liftIO . sendFlush t $ HttpData - (("Cache-Control", "no-cache, no-store"):mfHttpHeaders st) + (mfHttpHeaders st) (mfCookies st) (fromString js) modify $ \st -> st{mfAutorefresh=True,inSync=True} return $ FormElm [] mr @@ -982,8 +982,9 @@ ++ "})\n" FormElm form mr <- runView $ insertForm w st <- get- let insync = inSync st - let r= lookup ("auto"++id) $ mfEnv st + let insync = inSync st+ let env= mfEnv st + let r= lookup ("auto"++id) env if r == Nothing || insync == False then do requires [JScript $ timeoutscript t @@ -1005,7 +1006,7 @@ where -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal -- \ url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\- ajaxGetLink = "\nfunction ajaxGetLink(id){\n\ + ajaxGetLink = "\nfunction ajaxGetLink(id){\n\ \var id1= $('#'+id);\n\ \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\n\ \ida.click(function () {\n\ @@ -1018,7 +1019,7 @@ \ data: pdata,\n\ \ success: function (resp) {\n\ \ var ind= resp.indexOf(' ');\n\ - \ var dat = resp.substr(ind);\n\ + \ var dat= resp.substr(ind);\n\ \ var method= resp.substr(0,ind);\n\ \ if(method== 'html')id1.html(dat);\n\ \ else if (method == 'append') id1.append(dat);\n\ @@ -1207,7 +1208,7 @@ when new $ do killWF procname token{twfname= procname} - let proc= transient . runFlow . ask $ w' + let proc=runFlow . transientNav . ask $ w' requires [ServerProc (procname, proc), JScript $ ajaxPush procname, JScriptFile jqueryScript [installscript]]
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -22,7 +22,8 @@ ,module Control.Applicative ,module Text.Blaze.Html5 ,module Text.Blaze.Html5.Attributes -,module Control.Monad.IO.Class +,module Control.Monad.IO.Class+,module MFlow.Forms.WebApi ,runNavigation ,runSecureNavigation ) where @@ -31,9 +32,9 @@ import MFlow.Wai import MFlow.Forms import MFlow.Forms.Widgets -import MFlow.Forms.XHtml import MFlow.Forms.Admin -import MFlow.Forms.Blaze.Html +import MFlow.Forms.Blaze.Html+import MFlow.Forms.WebApi import Text.Blaze.Html5 hiding (map) import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form) import Network.Wai @@ -71,7 +72,7 @@ -- | run a persistent flow. It uses `getPort` to get the port -- The first parameter is the first element in the URL path. -- It also set the home page -runNavigation :: String -> FlowM Html (Workflow IO) () -> IO () +runNavigation :: String -> FlowM Html (Workflow IO) () -> IO () runNavigation n f= do unless (null n) $ setNoScript n addMessageFlows[(n, runFlow f)]