MFlow 0.1.5.3 → 0.1.5.4
raw patch · 6 files changed
+146/−68 lines, 6 files
Files
- Demos/demos.hs +8/−4
- MFlow.cabal +1/−1
- src/MFlow/FileServer.hs +7/−5
- src/MFlow/Forms.hs +104/−44
- src/MFlow/Forms/Admin.hs +4/−4
- src/MFlow/Forms/Ajax.hs +22/−10
Demos/demos.hs view
@@ -43,8 +43,9 @@ linkShop= toHtml $ hotlink "shop" << "shopping" options= do- r <- ask $ getSelect (setOption "blue" (bold << "blue") <|>- setSelectedOption "Red" (bold << "red") ) <! dosummit+ r <- ask $ getSelect (setSelectedOption "" (p <<"select a option") <|>+ setOption "blue" (bold << "blue") <|>+ setOption "Red" (bold << "red") ) <! dosummit ask $ p << (r ++ " selected") ++> wlink () (p<< " menu") breturn() where@@ -69,10 +70,13 @@ ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html ++ ajaxsample= do setHeader ajaxheader- ajaxc <- ajaxCommand "document.getElementById('text1').value"- (\n -> return $ "document.getElementById('text1').value='"++show(read n +1)++"'")+ let ajaxf n= return $ "document.getElementById('text1').value='"++show(read n +1)++"'"+ ajaxc <- ajaxCommand "document.getElementById('text1').value" ajaxf+ ask $ (getInt (Just 0) <! [("id","text1"),("onclick", ajaxc)]) breturn()
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow-version: 0.1.5.3+version: 0.1.5.4 cabal-version: >= 1.6 build-type: Simple license: BSD3
src/MFlow/FileServer.hs view
@@ -95,15 +95,17 @@ -- This app includes the fileServe flow: -- -- @+-- main= do -- addFileServerWF--- run 80 $ hackMessageFlow messageFlows+-- addMessageFlows messageFlows+-- run 80 hackMessageFlow -- adminLoop -- where--- messageFlows= [("noscript" , transient $ runFlow showStories)--- ,("admin" , transient $ runFlow admin)--- ,("mail" , transient $ runFlow mail)]@+-- messageFlows= [(\"noscript\" , transient $ runFlow showStories)+-- ,("\admin\" , transient $ runFlow admin)+-- ,("\mail\" , transient $ runFlow mail)]@ ----- | Add the fileServer to the list of server flows+-- Add the fileServer to the list of server flows addFileServerWF= addMessageFlows [("file", fileServe)]
src/MFlow/Forms.hs view
@@ -66,7 +66,8 @@ Links defined with `wlink` are treated the same way than forms. They are type safe and return values to the same flow of execution. It is posssible to combine links and forms in the same widget by using applicative combinators but also-additional applicative combinators like \<+> !*> , |*|.+additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can+be combined as such. * NEW IN THIS RELEASE: @@ -93,21 +94,22 @@ [@attributes for formLet elements@] it is not only possible to add Html formatting, but also to add atributes to a formlet element. This example has three formLet elements with the attribute "size" added, and a string prepended to the second password box. -@-userFormLine=- (User \<$> getString (Just "enter user") <! [("size","5")]- \<*> getPassword <! [("size","5")]- \<+> submitButton "login")- \<+> fromString " password again" ++> getPassword <! [("size","5")]- \<* submitButton "register"-@+> userFormLine=+> (User <$> getString (Just "enter user") <! [("size","5")]+> <*> getPassword <! [("size","5")]+> <+> submitButton "login")+> <+> fromString " password again" ++> getPassword <! [("size","5")]+> <* submitButton "register" + [@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the ByteString level, and to permit many formatring styles in the same page, there are operators that combine different formats which are converted to ByteStrings. For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml. + [@AJAX@] See "MFlow.Forms.Ajax" + [@File Server@] With file caching. See "MFlow.FileServer" This is a complete example, that can be run with runghc, which show some of these features:@@ -229,7 +231,7 @@ -- * Users ,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName ,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin, userWidget, --- * User interaction +-- * User interaction ask, clearEnv, -- * formLets -- | they mimic the HTML form elements.@@ -239,16 +241,16 @@ -- modifiers change their presentation and behaviour getString,getInt,getInteger, getTextBox ,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,-getRadio, getRadioActive, getCheckBox,+getRadio, getRadioActive, getCheckBoxes, setCheckBox, submitButton,resetButton, wlink, wform,-getCurrentName,+ firstOf, -- * FormLet modifiers validate, noWidget, wrender, waction, wmodify, -- * Caching widgets cachedWidget, -- * Widget combinators -(<+>),(|*>),(|+|), (**>),(<**),wconcat,(<|>),(<*),(<$>),(<*>),+(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>), -- * Normalized (convert to ByteString) widget combinators -- | these dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings@@ -271,7 +273,7 @@ , flatten, normalize, ToByteString(..) -- * Running the flow monad -,runFlow,MFlow.Forms.step, goingBack,breturn+,runFlow,runFlowIn,MFlow.Forms.step, goingBack,breturn -- * Setting parameters ,setHeader@@ -280,9 +282,7 @@ -- * Cookies ,setCookie---- * Internal use-,MFlowState, getNewName + ) where import Data.TCache@@ -302,7 +302,7 @@ import Control.Applicative import Control.Exception -import Control.Workflow as WF(step,exec1,Workflow, waitUntilSTM, moveState, unsafeIOtoWF) +import Control.Workflow as WF import Control.Monad.Identity import Unsafe.Coerce import Data.List(intersperse) @@ -642,13 +642,30 @@ @ -} runFlow :: (FormInput view, Monoid view, Monad m) - => FlowM view m () -> Token -> m () -runFlow f = \ t -> evalStateT (runBackT $ backp >> f) mFlowState0{mfToken=t} >> return ()+ => FlowM view m a -> Token -> m a +runFlow f = \ t -> evalStateT (runBackT $ backp >> f) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return () where -- to restart the flow in case of going back before the first page of the flow backp = breturn()+ fromFailBack (NoBack x)= x+ fromFailBack (BackPoint x)= x +-- | run a persistent flow inside the current flow. It is identified by the procedure and+-- the string identifier.+-- unlike the normal flows, that are infinite loops, runFlowIn executes finite flows+-- once executed, in subsequent executions the flow will return the stored result+-- without asking again. This is useful for asking/storing/retrieving user defined configurations.+runFlowIn+ :: (MonadIO m,+ FormInput view)+ => String+ -> FlowM view (Workflow IO) b+ -> FlowM view m b+runFlowIn wf f= do+ t <- gets mfToken+ liftIO $ WF.exec1nc wf $ runFlow f t + step :: (Serialize a, Typeable view,@@ -699,7 +716,9 @@ getParam1 par req form= r where r= case lookup par req of- Just x -> maybeRead x+ Just x -> do+ modify $ \s -> s{validated= True}+ maybeRead x -- !> x Nothing -> return $ FormElm form Nothing getType :: m (FormElm v a) -> a getType= undefined@@ -711,7 +730,7 @@ else case readsPrec 0 $ str of [(x,"")] -> return . FormElm form $ Just x _ -> do- modify $ \s -> s{validated= True}+ let err= inred . fromString $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) return $ FormElm (err:form) Nothing @@ -756,7 +775,7 @@ GoBack -> do modify (\s -> s{validated= False}) return $ FormElm form Nothing- NoBack r -> return . FormElm form $ Just r+ NoBack r -> return . FormElm form $ Just r BackPoint r -> return . FormElm form $ Just r -- bad. no backpoints _ -> return $ FormElm form Nothing@@ -846,21 +865,56 @@ ( isJust mn && v== fromJust mn) Nothing]) mn +data CheckBoxes = CheckBoxes [String]++instance Monoid CheckBoxes where+ mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys+ mempty= CheckBoxes []++instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where+ mappend x y= mappend <$> x <*> y+ mempty= return (CheckBoxes [])++instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where+ mappend x y = mappend <$> x <*> y+ mempty= return mempty+ -- | display a text box and return the value entered if it is readable( Otherwise, fail the validation)-getCheckBox :: (FormInput view, Functor m, MonadIO m) => - String -> Bool -> View view m String-getCheckBox v checked= View $ do+setCheckBox :: (FormInput view, Functor m, MonadIO m) => + String -> Bool -> View view m CheckBoxes+setCheckBox v checked= View $ do n <- getNewName st <- get put st{needForm= True} let env = mfEnv st FormElm f mn <- getParam1 n env []+ val <- gets validated+ let ret= case val of+ True -> Just . CheckBoxes $ maybeToList mn+ False -> Nothing return $ FormElm- (f++[finput n "checkbox" v - ( checked || (isJust mn && v== fromJust mn)) Nothing])- mn+ (f ++ [ finput n "checkbox" v + ( checked || (isJust mn && v== fromJust mn)) Nothing])+ ret +getCheckBoxes ::(FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]+getCheckBoxes boxes = View $ do+ n <- getNewName+ env <- gets mfEnv+ FormElm form (mr :: Maybe String) <- getParam1 n env [finput n "hidden" "" False Nothing]+ st <- get+ let env = mfEnv st+ put st{needForm= True}+ FormElm form2 mr2 <- runView boxes+ return $ FormElm (form ++ form2) $+ case (mr,mr2) of+ (Nothing,_) -> Nothing+ (Just _,Nothing) -> Just []+ (Just _, Just (CheckBoxes rs)) -> Just rs+ + + -- get a parameter form the las received response getEnv :: MonadState (MFlowState view) m => String -> m(Maybe String) getEnv n= gets mfEnv >>= return . lookup n@@ -968,6 +1022,10 @@ data MFOption a= MFOption +instance (Monad m, Functor m) => Monoid (View view m (MFOption a)) where+ mappend = (<|>)+ mempty = Control.Applicative.empty+ -- | set the option for getSelect. Options are concatenated with `<|>` setOption n v = setOption1 n v False @@ -1138,13 +1196,9 @@ mfHeader :: view -> view, mfDebug :: Bool }- deriving Typeable - - -stdHeader v = v - +stdHeader v = v mFlowState0 :: (FormInput view, Monoid view) => MFlowState view @@ -1195,6 +1249,8 @@ fs <- get put fs{mfHeader= header} ++ -- | return the current header getHeader :: Monad m => FlowM view m (view -> view) getHeader= gets mfHeader@@ -1403,10 +1459,9 @@ -- | It is the way to interact with the user. --- It takes a widget and return the user result+-- It takes a widget and return the user result. -- If the environment has the result, ask don't ask to the user. -- To force asking in any case, put an `clearEnv` statement before --- in the FlowM monad ask :: ( ToHttpData view,@@ -1420,7 +1475,7 @@ let st= st1{hasForm= False, needForm= False,validated= False} put st FormElm forms mx <- lift $ runView x -- !> "runWidget" - st' <- mx `seq` get+ st' <- get case mx of Just x -> do put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]}@@ -1470,8 +1525,8 @@ -- op1 -> setGoStraighTo (Just goop1) >> goop1 -- op2 -> setGoStraighTo (Just goop2) >> goop2@ ----- This pseudocode would execute the ask of the menu once. But if the user press the--- back button he will see again the menu. To let him choose other option, the code+-- This pseudocode below would execute the ask of the menu once. But the user will never have+-- the possibility to see the menu again. To let him choose other option, the code -- has to be change to -- -- @menu= do@@ -1484,7 +1539,10 @@ -- case r of -- op1 -> setGoStraighTo (Just goop1) >> goop1 -- op2 -> setGoStraighTo (Just goop2) >> goop2@-+--+-- However this is very specialized. normally the back button detection is not necessary.+-- In a persistent flow (with step) even this default entry option would be completely automatic,+-- since the process would restar at the last page visited. No setting is necessary. goingBack :: MonadState (MFlowState view) m => m Bool goingBack = do st <- get@@ -1562,22 +1620,24 @@ -- res1= if null res then Nothing else head res -- return $ FormElm [mconcat vs] res1 --- | Concat a list of widgets of the same type, to return a single result -wconcat :: (Monoid view, MonadIO m, Functor m)=> [View view m a] -> View view m a -wconcat xs= View $ do +-- | Concat a list of widgets of the same type, return a the first validated result +firstOf :: (Monoid view, MonadIO m, Functor m)=> [View view m a] -> View view m a +firstOf xs= View $ do forms <- mapM(\x -> (runView x )) 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 ++ -- | intersperse a widget in a list of widgets. the results is a 2-tuple of both types (|*>) :: (MonadIO m, Functor m,Monoid view) => View view m r -> [View view m r'] -> View view m (Maybe r,Maybe r') (|*>) x xs= View $ do- FormElm fxs rxs <- runView $ wconcat xs+ FormElm fxs rxs <- runView $ firstOf xs FormElm fx rx <- runView $ x return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx)
src/MFlow/Forms/Admin.hs view
@@ -70,7 +70,7 @@ -- this gives access to an administrator page. It is necessary to -- create an admin user with `setAdminUser`. ----- The administration page is reached with the path @"adminserv"@+-- The administration page is reached with the path \"adminserv"\ addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)] @@ -130,9 +130,9 @@ showFormList ls nav l where- list= table <<< wconcat (span1 n l [tr <<< cols e | e <- ls ])+ list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ]) - cols e= wconcat[td <<< c | c <- e]+ 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 @@ -144,6 +144,6 @@ if null wfss then ask $ bold << " not logs for this user" ++> wlink () (bold << "Press here") else do- wf <- ask $ wconcat [ wlink wf (p << wf) | (wf,_) <- wfss]+ 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/Ajax.hs view
@@ -24,17 +24,22 @@ import MFlow.Forms import Text.XHtml import Control.Monad.Trans-import Data.ByteString.Lazy.Char8-+--import Data.ByteString.Lazy.Char8+import Data.RefSerialize (newContext,addrHash)+import Data.IORef+import System.IO.Unsafe import Data.Maybe import Control.Monad.State import Data.Map (keys) import qualified Data.CaseInsensitive as CI --- | Install the server code and return the client code for an AJAX interaction.---+--import Debug.Trace+--(!>)= flip trace -ajaxCommand :: (MonadIO m, MonadState (MFlowState view) m)+context= unsafePerformIO newContext++-- | Install the server code and return the client code for an AJAX interaction.+ajaxCommand :: MonadIO m => String -- ^ The javScript variable whose value will be sent to the server -> (String -> IO String) -- ^ The server procedure to be executed with the -- variable value as parameter. It must return a string with valid@@ -42,15 +47,22 @@ -> m (String) -- ^ return the javascript of the event handler, to be inserted in -- the HTML to be sent to the client ajaxCommand jsparam serverProc = do- servname <- getNewName- liftIO $ addMessageFlows [( servname, serverp)]+ r <- liftIO $ addrHash context serverProc+ servname <- case r of+ Left h -> do+ let servname= "ajax"++ show h+ liftIO $ addMessageFlows [( servname, serverp)]+ return servname+ Right h -> return $ "ajax"++ show h -- liftIO $ getMessageFlows >>= return . keys >>= print return $ "doServer("++"'" ++ servname++"',"++jsparam++")" where serverp = stateless $ \env -> do- let c = lookup "ajax" env -- `justify` (error "not found ajax command") -- :: String- serverProc $ fromJust c- justify = flip . fromMaybe+ let c = lookup "ajax" env `justify` (error "not found ajax command") -- :: String+ serverProc c+ justify = flip fromMaybe++ -- | @ajaxHead@ must be used instead of `header` when using ajax(see example).