MFlow 0.2.0.6 → 0.2.0.7
raw patch · 13 files changed
+656/−379 lines, 13 files
Files
- Demos/demos.blaze.hs +138/−114
- MFlow.cabal +6/−2
- src/MFlow.hs +66/−18
- src/MFlow/Forms.hs +113/−64
- src/MFlow/Forms/Admin.hs +5/−4
- src/MFlow/Forms/Blaze/Html.hs +3/−0
- src/MFlow/Forms/Internals.hs +93/−51
- src/MFlow/Forms/Test.hs +198/−75
- src/MFlow/Forms/Widgets.hs +29/−10
- src/MFlow/Hack.hs +0/−20
- src/MFlow/Wai.hs +2/−20
- src/MFlow/Wai/Blaze/Html/All.hs +2/−0
- src/MFlow/Wai/Response.hs +1/−1
Demos/demos.blaze.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} module Main where import MFlow.Wai.Blaze.Html.All import Text.Blaze.Html5 as El@@ -29,57 +29,37 @@ wait $ run 8081 waiMessageFlow -stdheader c= docTypeHtml $ body $- a ! At.style "text-align:center" ! href ( fromString "html/MFlow/index.html") << h1 << text "MFlow"- <> (El.div ! At.style "position:fixed;top:40px;left:0%\- \;width:50%;min-height:100%\- \;margin-left:10px;margin-right:10px" $- h2 << text "Example of some features."- <> h3 << text "This demo uses warp and blaze-html"- <> hr- <> c)- <> (El.div ! At.style "position:fixed;top:40px;left:50%;width:50%;min-height:100%" $- h2 << text "Documentation"- <> p << a ! href ( fromString "html/MFlow/index.html") << text "MFlow package description and documentation"- <> p << a ! href ( fromString "demos.blaze.hs") << text "download demo source code"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/11/mflow-now-widgets-can-express.html") << text "MFlow: now the widgets can express requirements"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/12/on-spirit-of-mflow-anatomy-of-widget.html") << text "On the \"spirit\" of MFlow. Anatomy of a Widget"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2013/01/now-example-of-use-of-active-widget.html") << text "MFlow active widgets example"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2013/01/stateful-but-stateless-at-last-thanks.html") << text "Stateful, but virtually stateless, thanks to event sourcing"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/11/i-just-added-some-templatingcontent.html") << text "Content Management and multilanguage in MFlow"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/10/testing-mflow-applications_9.html") << text "Testing MFlow applications"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/09/a.html") << text "A Web app. that creates Haskel computations from form responses, that store, retrieve and execute them? It´s easy"- <> p << a ! href ( fromString "http://haskell-web.blogspot.com.es/2012/09/announce-mflow-015.html") << text "ANNOUNCE MFlow 0.1.5 Web app server for stateful processes with safe, composable user interfaces."- )+fstr= fromString data Options= CountI | CountS | Radio | Login | TextEdit |Grid | Autocomp | AutocompList | ListEdit |Shop | Action | Ajax | Select- | CheckBoxes deriving (Bounded, Enum,Read, Show,Typeable)+ | CheckBoxes | PreventBack deriving (Bounded, Enum,Read, Show,Typeable) mainmenu= do setHeader stdheader setTimeouts 100 0- r <- ask $ wcached "menu" 0 $- b << text "BASIC"- ++> br ++> wlink CountI (b << text "increase an Int")- <|> br ++> wlink CountS (b << text "increase a String")- <|> br ++> wlink Action (b << text "Example of action, executed when a widget is validated")- <|> br ++> wlink Select (b << text "select options")- <|> br ++> wlink CheckBoxes (b << text "checkboxes")- <|> br ++> wlink Radio (b << text "Radio buttons")- <++ br <> br <> b << text "DYNAMIC WIDGETS"- <|> br ++> wlink Ajax (b << text "AJAX example")- <|> br ++> wlink Autocomp (b << text "autocomplete")- <|> br ++> wlink AutocompList (b << text "autocomplete List")- <|> br ++> wlink ListEdit (b << text "list edition")- <|> br ++> wlink Grid (b << text "grid")- <|> br ++> wlink TextEdit (b << text "Content Management")- <++ br <> br <> b << text "STATEFUL PERSISTENT FLOW"- <> br <> a ! href "shop" << text "shopping" -- ordinary Blaze.Html link- <> br <> br <> b << text "OTHERS"+ r <- ask $ wcached "menu" 0+ $ b << "BASIC"+ ++> br ++> wlink CountI << b << "increase an Int"+ <|> br ++> wlink CountS << b << "increase a String"+ <|> br ++> wlink Action << b << "Example of action, executed when a widget is validated"+ <|> br ++> wlink Select << b << "select options"+ <|> br ++> wlink CheckBoxes << b << "checkboxes"+ <|> br ++> wlink Radio << b << "Radio buttons"+ <++ br <> br <> b << "DYNAMIC WIDGETS"+ <|> br ++> wlink Ajax << b << "AJAX example"+ <|> br ++> wlink Autocomp << b << "autocomplete"+ <|> br ++> wlink AutocompList << b << "autocomplete List"+ <|> br ++> wlink ListEdit << b << "list edition"+ <|> br ++> wlink Grid << b << "grid"+ <|> br ++> wlink TextEdit << b << "Content Management"+ <++ br <> br <> b << "STATEFUL PERSISTENT FLOW"+ <> br <> a ! href (fstr "shop") << "shopping" -- ordinary Blaze.Html link+ <> br <> br <> b << "OTHERS" - <|> br ++> wlink Login (b << text "login/logout")+ <|> br ++> wlink Login << b << "login/logout"+ <|> br ++> wlink PreventBack << b << "Prevent going back after a transaction" case r of@@ -95,86 +75,99 @@ AutocompList -> autocompList ListEdit -> wlistEd Radio -> radio- Login -> login-+ Login -> loginSample+ PreventBack -> preventBack +preventBack= do+ ask $ wlink () << b << "press here to pay 100000 $ "+ payIt+ preventGoingBack . ask $ b << "You already paid 100000 before" ++> wlink () << b << " Please press here to continue"+ ask $ wlink () << b << "you paid just one time. press here to go to the menu or press the back button to verify that you can not pay again"+ where+ payIt= liftIO $ print "paying" options= do- r <- ask $ getSelect (setSelectedOption ("" :: String) (p << text "select a option") <|>- setOption "blue" (b << text "blue") <|>- setOption "Red" (b << text "red") ) <! dosummit- ask $ p << (r ++ " selected") ++> wlink () (p << text " menu")+ r <- ask $ getSelect (setSelectedOption ("" :: String) (p << "select a option") <|>+ setOption "blue" (b << "blue") <|>+ setOption "Red" (b << "red") ) <! dosummit+ ask $ p << (r ++ " selected") ++> wlink () (p << " menu") mainmenu -- breturn() would do it as well where dosummit= [("onchange","this.form.submit()")] checkBoxes= do- r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << text "red")- <> (setCheckBox False "Green" <++ b << text "green")- <> (setCheckBox False "blue" <++ b << text "blue"))+ r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << "red")+ <> (setCheckBox False "Green" <++ b << "green")+ <> (setCheckBox False "blue" <++ b << "blue")) <** submitButton "submit" - ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") mainmenu autocomplete1= do- r <- ask $ wautocomplete (Just "red,green,blue") filter1+ r <- ask $ p << "Autocomplete "+ ++> p << "enter "+ ++> p << "when su press submit, the box is returned"+ ++> wautocomplete (Just "red,green,blue") filter1 <** submitButton "submit"- ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") mainmenu where filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] autocompList= do- r <- ask $ wautocompleteList "red,green,blue" filter1 ["red"]+ r <- ask $ p << "Autocomplete with a list of selected entries"+ ++> p << "enter and press enter"+ ++> p << "when su press submit, the entries are returned"+ ++> wautocompleteList "red,green,blue" filter1 ["red"] <** submitButton "submit"- ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") mainmenu where filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] grid = do let row _= tr <<< ( (,) <$> tdborder <<< getInt (Just 0)- <*> tdborder <<< getString (Just "text")+ <*> tdborder <<< getString (Just "") <++ tdborder << delLink)- addLink= a ! href "#"- ! At.id "wEditListAdd"- << text "add"- delLink= a ! href "#"- ! onclick "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)"- << text "delete"- tdborder= td ! At.style "border: solid 1px"+ addLink= a ! href (fstr "#")+ ! At.id (fstr "wEditListAdd")+ << "add"+ delLink= a ! href (fstr "#")+ ! onclick (fstr "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)")+ << "delete"+ tdborder= td ! At.style (fstr "border: solid 1px") - r <- ask $ addLink ++> ( wEditList table row ["",""]) <** submitButton "submit"+ r <- ask $ addLink ++> ( wEditList table row ["",""] "wEditListAdd") <** submitButton "submit" ask $ p << (show r ++ " returned")- ++> wlink () (p << text " back to menu")+ ++> wlink () (p << " back to menu") mainmenu wlistEd= do r <- ask $ addLink ++> br- ++> (El.div `wEditList` getString1 $ ["hi", "how are you"])+ ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd") <++ br <** submitButton "send" ask $ p << (show r ++ " returned")- ++> wlink () (p << text " back to menu")+ ++> wlink () (p << " back to menu") mainmenu where- addLink = a ! At.id "wEditListAdd"- ! href "#"- $ text "add"- delBox = input ! type_ "checkbox"- ! checked ""- ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"+ addLink = a ! At.id (fstr "wEditListAdd")+ ! href (fstr "#")+ $ b << "add"+ delBox = input ! type_ (fstr "checkbox")+ ! checked (fstr "")+ ! onclick (fstr "this.parentNode.parentNode.removeChild(this.parentNode)") getString1 mx= El.div <<< delBox ++> getString mx <++ br clickn n= do- r <- ask $ p << b << text "increase an Int"- ++> wlink ("menu" :: String) (p << text "menu")+ r <- ask $ p << b << "increase an Int"+ ++> wlink ("menu" :: String) (p << "menu") |+| getInt (Just n) <* submitButton "submit" case r of (Just _,_) -> mainmenu@@ -182,41 +175,42 @@ clicks s= do- s' <- ask $ p << b << text "increase a String"+ s' <- ask $ p << b << "increase a String"+ ++> p << b << "press the back button to go back to the menu" ++>(getString (Just s) <* submitButton "submit")- `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing )+ `validate` (\s -> return $ if length s > 5 then Just (b << "length must be < 5") else Nothing ) clicks $ s'++ "1" radio = do- r <- ask $ p << b << text "Radio buttons"+ r <- ask $ p << b << "Radio buttons" ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]]- ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") mainmenu ajaxsample= do- r <- ask $ p << b << text "Ajax example that increment the value in a box"+ r <- ask $ p << b << "Ajax example that increment the value in a box" ++> do let elemval= "document.getElementById('text1').value"- ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"- b << text "click the box"- ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc . B.unpack $ elemval)]<** submitButton "submit"- ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu")+ ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'"+ b << "click the box"+ ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]<** submitButton "submit"+ ask $ p << ( show r ++ " returned") ++> wlink () (p << " menu") mainmenu ---- recursive callbacks --actions n=do--- ask $ wlink () (p << text "exit from action")+-- ask $ wlink () (p << "exit from action") -- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) actions n= do- r<- ask $ p << b << text "Two text boxes with one action each one"+ r<- ask $ p << b << "Two boxes with one action each one" ++> getString (Just "widget1") `waction` action <+> getString (Just "widget2") `waction` action <** submitButton "submit"- ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu")+ ask $ p << ( show r ++ " returned") ++> wlink () (p << " menu") mainmenu where action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action"@@ -224,7 +218,7 @@ data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum,Read, Show, Typeable) shopCart = do- setHeader $ \html -> p << (text+ setHeader $ \html -> p << ( El.span << "A persistent flow (uses step). The process is killed after 10 seconds of inactivity \ \but it is restarted automatically. Event If you restart the whole server, it remember the shopping cart\n\n \ \Defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.\n\@@ -235,14 +229,14 @@ where shopCart1 cart= do o <- step . ask $- table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"- <<< caption << text "choose an item"- ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")+ table ! At.style (fstr "border:1;width:20%;margin-left:auto;margin-right:auto")+ <<< caption << "choose an item"+ ++> thead << tr << ( th << b << "item" <> th << b << "times chosen") ++> (tbody- <<< tr ! rowspan "2" << td << linkHome- ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))- <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))- <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))+ <<< tr ! rowspan (fstr "2") << td << linkHome+ ++> (tr <<< td <<< wlink IPhone (b << "iphone") <++ td << ( b << show ( cart V.! 0))+ <|> tr <<< td <<< wlink IPod (b << "ipad") <++ td << ( b << show ( cart V.! 1))+ <|> tr <<< td <<< wlink IPad (b << "ipod") <++ td << ( b << show ( cart V.! 2))) <++ tr << td << linkHome ) let i =fromEnum o@@ -250,14 +244,14 @@ shopCart1 newCart where- linkHome= a ! href (fromString noScript) << b << text "home"+ linkHome= a ! href (fstr noScript) << b << "home" -login= do- ask $ p << text "Please login with admin/admin"+loginSample= do+ ask $ p << "Please login with admin/admin" ++> userWidget (Just "admin") userLogin user <- getCurrentUser- ask $ b << text ("user logged as " <> T.pack user) ++> wlink () (p << text " logout and go to menu")+ ask $ b << ("user logged as " <> user) ++> wlink () (p << " logout and go to menu") logout mainmenu @@ -265,37 +259,67 @@ textEdit= do let first= p << i <<- (El.span << text "this is a page with"- <> b << text " two " <> El.span << text "paragraphs. this is the first")+ (El.span << "this is a page with"+ <> b << " two " <> El.span << "paragraphs. this is the first") - second= p << i << text "This is the original text of the second paragraph"+ second= p << i << "This is the original of the second paragraph" - ask $ p << b << text "An example of content management"+ ask $ p << b << "An example of content management" ++> first ++> second- ++> wlink () (p << text "click here to edit it")+ ++> wlink () (p << "click here to edit it") - ask $ p << text "Please login with admin/admin to edit it"+ ask $ p << "Please login with admin/admin to edit it" ++> userWidget (Just "admin") userLogin - ask $ p << text "now you can click the fields and edit them"- ++> p << b << text "to save an edited field, double click on it"+ ask $ p << "now you can click the fields and edit them"+ ++> p << b << "to save an edited field, double click on it" ++> tFieldEd "first" first **> tFieldEd "second" second- **> wlink () (p << text "click here to see it as a normal user")+ **> wlink () (p << "click here to see it as a normal user") logout - ask $ p << text "the user sees the edited content. He can not edit"+ ask $ p << "the user sees the edited content. He can not edit" ++> tFieldEd "first" first **> tFieldEd "second" second- **> wlink () (p << text "click to continue")+ **> wlink () (p << "click to continue") - ask $ p << text "When texts are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key"+ ask $ p << "When texts are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key" ++> tField "first" **> tField "second"- **> p << text "End of edit field demo" ++> wlink () (p << text "click here to go to menu")+ **> p << "End of edit field demo" ++> wlink () (p << "click here to go to menu") +++stdheader c= docTypeHtml $ body $+ a ! At.style (fstr "-align:center") ! href ( fstr "html/MFlow/index.html") << h1 << "MFlow"+ <> br+ <> hr+ <> (El.div ! At.style (fstr "position:fixed;top:40px;left:0%\+ \;width:50%;min-height:100%\+ \;margin-left:10px;margin-right:10px") $+ h2 << "Example of some features."+-- <> h3 << "This demo uses warp and blaze-html"++ <> br <> c)+ <> (El.div ! At.style (fstr "position:fixed;top:40px;left:50%;width:50%;min-height:100%") $+ h2 << "Documentation"+ <> br+ <> p << a ! href (fstr "html/MFlow/index.html") << "MFlow package description and documentation"+ <> p << a ! href (fstr "demos.blaze.hs") << "download demo source code"+ <> p << a ! href (fstr "https://github.com/agocorona/MFlow/issues") << "bug tracker"+ <> p << a ! href (fstr "https://github.com/agocorona/MFlow") << "source repository"+ <> p << a ! href (fstr "http://hackage.haskell.org/package/MFlow") << "Hackage repository"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2012/11/mflow-now-widgets-can-express.html") << "MFlow: now the widgets can express requirements"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2012/12/on-spirit-of-mflow-anatomy-of-widget.html") << "On the \"spirit\" of MFlow. Anatomy of a Widget"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2013/01/now-example-of-use-of-active-widget.html") << "MFlow active widgets example"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2013/01/stateful-but-stateless-at-last-thanks.html") << "Stateful, but virtually stateless, thanks to event sourcing"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2012/11/i-just-added-some-templatingcontent.html") << "Content Management and multilanguage in MFlow"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2012/10/testing-mflow-applications_9.html") << "Testing MFlow applications"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2012/09/a.html") << "A Web app. that creates Haskel computations from form responses, that store, retrieve and execute them? It´s easy"+ <> p << a ! href (fstr "http://haskell-web.blogspot.com.es/2012/09/announce-mflow-015.html") << "ANNOUNCE MFlow 0.1.5 Web app server for stateful processes with safe, composable user interfaces."+ )
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow-version: 0.2.0.6+version: 0.2.0.7 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -11,7 +11,9 @@ description: A Web framework with some unique features thanks to the power of the Haskell language. MFlow run stateful server processes; All the flow of requests and responses are coded by the programmer in a single function. Allthoug single request-response flows and callbacks are possible. Therefore, the code is- more understandable.+ more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking forall+ handling the back button. Because that the persistent state is small and can be synchronized. So+ potentially that makes the MFlow architecture scalable . These processes are stopped and restarted by the application server on demand, including its execution state. Therefore session management@@ -41,6 +43,8 @@ . Although still it is experimental, it is being used in at least one future commercial project. So I have te commitment to continue its development. There are many examples in the documentation and in the package.+ .+ In this release preventGoingBack was added . To do: .
src/MFlow.hs view
@@ -70,8 +70,8 @@ -- * static files ,setFilesPath -- * internal use-,addTokenToList,deleteTokenInList, msgScheduler,serveFile)-+,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow+) where import Control.Concurrent.MVar import Data.IORef @@ -88,6 +88,7 @@ import Unsafe.Coerce import System.IO.Unsafe+import Data.TCache import Data.TCache.DefaultPersistence hiding(Indexable(..)) import Data.TCache.Memoization import Data.ByteString.Lazy.Char8 as B (readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks) @@ -140,7 +141,7 @@ pind = tind getParams = tenv -instance Processable Req where +instance Processable Req where pwfname (Req x)= pwfname x puser (Req x)= puser x pind (Req x)= pind x @@ -223,7 +224,7 @@ return $ debug x (str++" => Workflow "++ show x) -} -- | send a complete response -send :: Token -> HttpData -> IO() +--send :: Token -> HttpData -> IO() send t@(Token _ _ _ _ _ qresp) msg= do ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ thread t) @@ -342,11 +343,35 @@ - ---data Error= Error String deriving (Read, Show, Typeable) +--processData t= do +-- token <- getToken t+-- th <- startMessageFlow (pwfname t) token+-- tellToWF token t+-- where+-- startMessageFlow wfname token = +-- forkIO $ do +-- r <- start wfname (process mempty) token -- !>( "init wf " ++ wfname) +-- case r of +-- Left NotFound -> do+-- error $ "Not found: " ++ wfname+-- deleteTokenInList token +-- Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)+-- Left Timeout -> return() -- !> "Timeout in msgScheduler"+-- Left (WFException e)-> do+-- let user= key token+-- print e+-- logError user wfname e+-- moveState wfname token token{tuser= "error/"++tuser token}+--+--+-- process val t= do+-- r <- step $ receive t+-- let val'= r <> val+-- recover <- isInRecover+-- when(not recover) . liftIO $ sendFlush t val'+-- process val' t+-- ---instance ToHttpData String where--- toHttpData= HttpData [] [] . pack -- | The scheduler creates a Token with every `Processable` -- message that arrives and send the mesage to the appropriate flow, then waht for the response@@ -378,13 +403,16 @@ let user= key token print e logError user wfname e- moveState wfname token token{tuser= "error/"++tuser token}+-- moveState wfname token token{tuser= "error/"++tuser token}+ fresp<- getNotFoundResponse+ sendFlush token $ HttpData [("Content-Type", "text/html")] [] $+ fresp $+ case user of+ "admin" -> pack $ show e+ _ -> mempty - sendFlush token $ HttpData [("Content-Type", "text/plain")] [] $- case user of- "admin" -> pack $ show e- _ -> "An Error has ocurred." + Right _ -> do -- let msg= "finished Flow "++ wfname++ " restarting" -- logError (key token) wfname msg@@ -393,13 +421,15 @@ delMsgHistory token; return () -- !> ("finished " ++ wfname) - logError u wf e= do+logError u wf e= do hSeek hlog SeekFromEnd 0- TOD t _ <- getClockTime- hPutStrLn hlog (","++show [u,show t,wf,e]) >> hFlush hlog + t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime+ hPutStrLn hlog (","++show [u, t,wf,e]) >> hFlush hlog logFileName= "errlog" ++ -- | The handler of the error log hlog= unsafePerformIO $ openFile logFileName ReadWriteMode @@ -408,7 +438,7 @@ "<html><h4>Error 404: Page not found or error ocurred:</h4><h3>" <> msg <> "</h3><br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>" - where + where paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows opts= "options: " <> B.concat (Prelude.map (\s -> "<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)@@ -417,7 +447,7 @@ -- | set the 404 "not found" response setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f-getNotFoundResponse= unsafePerformIO $ readIORef notFoundResponse+getNotFoundResponse= liftIO $ readIORef notFoundResponse -- basic bytestring tags type Attribs= [(String,String)]@@ -480,6 +510,24 @@ ioerr x= \(e :: CE.IOException) -> x setMime x= ("Content-Type",x) +data NFlow= NFlow !Integer deriving (Read, Show, Typeable) + +instance Serializable NFlow where + serialize= B.pack . show + deserialize= read . B.unpack + +instance Indexable NFlow where + key _= "Flow" + + +rflow= getDBRef . key $ NFlow undefined + +newFlow= do + TOD t _ <- getClockTime + atomically $ do + NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) + writeDBRef rflow . NFlow $ n+1 + return . show $ t + n mimeTable=[
src/MFlow/Forms.hs view
@@ -123,7 +123,8 @@ [@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator -[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the ByteString level, and to permit many formatring styles+[@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. @@ -139,10 +140,11 @@ FlowM, View(..), FormElm(..), FormInput(..) -- * Users -,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName -,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget,getLang, +,userRegister, userValidate, isLogged, setAdminUser, getAdminName +,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget,getLang, login,+userName, -- * User interaction -ask, clearEnv, wstateless, transfer, +ask, askt, clearEnv, wstateless, transfer, -- * formLets -- | They usually produce the HTML form elements (depending on the FormInput instance used) -- It is possible to modify their attributes with the `<!` operator.@@ -183,7 +185,7 @@ , flatten, normalize -- * Running the flow monad -,runFlow,runFlowIn,MFlow.Forms.Internals.step, goingBack,breturn+,runFlow,runFlowOnce,runFlowIn,MFlow.Forms.Internals.step, goingBack,breturn, preventGoingBack -- * Setting parameters ,setHeader@@ -204,7 +206,12 @@ ,requires -- * Utility ,genNewId-,changeMonad +,changeMonad+,FailBack+,fromFailBack+,toFailBack+-- * The monster of the deep+,MFlowState ) where @@ -216,7 +223,7 @@ import MFlow.Cookies import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) import Data.List-import qualified Data.CaseInsensitive as CI +--import qualified Data.CaseInsensitive as CI import Data.Typeable import Data.Monoid import Control.Monad.State.Strict @@ -234,9 +241,9 @@ import Data.Char(isNumber) import Network.HTTP.Types.Header --- ---import Debug.Trace---(!>)= flip trace + +import Debug.Trace+(!>)= flip trace @@ -246,19 +253,18 @@ validate :: (FormInput view, Monad m) => View view m a- -> (a -> WState view m (Maybe String))+ -> (a -> WState view m (Maybe view)) -> View view m a validate formt val= View $ do - FormElm form mx <- (runView formt) + FormElm form mx <- (runView formt) case mx of Just x -> do me <- val x modify (\s -> s{inSync= True}) case me of Just str -> - --FormElm form mx' <- generateForm [] (Just x) noValidate - return $ FormElm ( inred (fromStr str) : form) Nothing - Nothing -> return $ FormElm [] mx + return $ FormElm ( form ++ [inred str]) Nothing + Nothing -> return $ FormElm [] mx _ -> return $ FormElm form mx -- | Actions are callbacks that are executed when a widget is validated.@@ -662,10 +668,12 @@ -- -- it has a fixity @infix 8@ infix 8 <!-widget <! atrs= View $ do+widget <! attribs= View $ do FormElm fs mx <- runView widget- return $ FormElm [attrs (head fs) atrs] mx-+ return $ FormElm (head fs `attrs` attribs:tail fs) mx+-- case fs of+-- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx+-- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs -- | Is an example of login\/register validation form needed by 'userWidget'. In this case@@ -689,7 +697,7 @@ -- | Example of user\/password form (no validation) to be used with 'userWidget' userLogin :: (FormInput view, Functor m, Monad m)- => View view m (Maybe (UserStr,PasswdStr), Maybe String)+ => View view m (Maybe (UserStr,PasswdStr), Maybe String) userLogin= ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")] <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]@@ -705,11 +713,11 @@ View view m a noWidget= View . return $ FormElm [] Nothing --- | Render a value and return it+-- | Render a Show-able value and return it wrender :: (Monad m, Functor m, Show a, FormInput view) => a -> View view m a-wrender x = (wraw . fromStr $ show x) **> return x+wrender x = (fromStr $ show x) ++> return x -- | Render raw view formatting. It is useful for displaying information wraw :: Monad m => view -> View view m ()@@ -734,42 +742,56 @@ -> View view m String userWidget muser formuser= do user <- getCurrentUser- if muser== Just user+ if muser== Just user || isNothing muser && user/= anonymous then return user- else formuser `validate` val muser `waction` login + else formuser `validate` val muser `waction` login1 where- val _ (Nothing,_) = return $ Just "Plese fill in the user/passwd to login, or user/passwd/passwd to register"+ val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register" val mu (Just us, Nothing)= if isNothing mu || isJust mu && fromJust mu == fst us then userValidate us- else return $ Just "wrong user for the operation"+ else return . Just $ fromStr "wrong user for the operation" val mu (Just us, Just p)= if isNothing mu || isJust mu && fromJust mu == fst us then if length p > 0 && snd us== p then return Nothing- else return $ Just "The passwords do not match"- else return $ Just "wrong user for the operation"+ else return . Just $ fromStr "The passwords do not match"+ else return . Just $ fromStr "wrong user for the operation" --- val _ _ = return $ Just "Please fill in the fields for login or register"+-- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register" - login (Just (u,p), Nothing)= do- let uname= u- st <- get - let t = mfToken st- t'= t{tuser= uname}- moveState (twfname t) t t'- put st{mfToken= t'}- liftIO $ deleteTokenInList t- liftIO $ addTokenToList t'- setCookie cookieuser uname "/" (Just $ 365*24*60*60) - return uname+ login1+ :: (MonadIO m, MonadState (MFlowState view) m) =>+ (Maybe (String, String), Maybe String) -> m String+ login1 (Just (uname,_), Nothing)= login uname >> return uname - login (Just us@(u,p), Just _)= do- userRegister u p- login (Just us , Nothing)+ login1 (Just us@(u,p), Just _)= do -- register button pressed+ userRegister u p+ login u+ return u +-- | change the user+--+-- It is supposed that the user has been validated+++login uname= do+ st <- get+ let t = mfToken st+ u = tuser t+ if u== uname then return () else do+ let t'= t{tuser= uname}+ moveState (twfname t) t t'+ put st{mfToken= t'}+ liftIO $ deleteTokenInList t+ liftIO $ addTokenToList t'+ setCookie cookieuser uname "/" (Just $ 365*24*60*60) + return ()+++ -- | logout. The user is resetted to the `anonymous` user logout :: (MonadIO m, MonadState (MFlowState view) m) => m () logout= do@@ -786,9 +808,8 @@ -- | If not logged, perform login. otherwise return the user -- -- @getUserSimple= getUser Nothing userFormLine@-getUserSimple :: ( FormInput view, Typeable view - , MonadIO m, Functor m)- => FlowM view m String+getUserSimple :: ( FormInput view, Typeable view)+ => FlowM view IO String getUserSimple= getUser Nothing userFormLine -- | Very basic user authentication. The user is stored in a cookie. @@ -798,11 +819,10 @@ -- otherwise, the stored username is returned. -- -- @getUser mu form= ask $ userWidget mu form@ -getUser :: ( FormInput view, Typeable view - , MonadIO m, Functor m) +getUser :: ( FormInput view, Typeable view) => Maybe String- -> View view m (Maybe (UserStr,PasswdStr), Maybe String)- -> FlowM view m String + -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)+ -> FlowM view IO String getUser mu form= ask $ userWidget mu form @@ -869,6 +889,15 @@ FormElm form mx <- runView form return $ FormElm form $ Just undefined +-- | for compatibility with the same procedure in 'MFLow.Forms.Text.askt'.+-- This is the non testing version+--+-- > askt v w= ask w+--+-- hide one or the other+askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a+askt v w = ask w+ -- | It is the way to interact with the user. -- It takes a widget and return the user result.@@ -879,10 +908,8 @@ -- it will not ask to the user. -- To force asking in any case, put an `clearEnv` statement before ask- :: (FormInput view,- MonadIO m,- Typeable view) =>- View view m b -> FlowM view m b + :: (FormInput view) =>+ View view IO a -> FlowM view IO a ask w = do st1 <- get let env= mfEnv st1@@ -911,8 +938,8 @@ Nothing -> if not (inSync st') && not (onInit st') && hasParams (mfSequence st') (mfSeqCache st') ( mfEnv st') -- !> (show $ inSync st') !> (show $ onInit st') then do- put st'{mfSequence= head1 $ prevSeq st'- ,prevSeq= tail1 $ prevSeq st' }+ put st'{ mfSequence= head1 $ prevSeq st',+ prevSeq= tail1 $ prevSeq st' } fail "" else do reqs <- FlowM $ lift installAllRequirements@@ -981,12 +1008,33 @@ st <- get return $ not (inSync st) && not (onInit st) --- | Clears the environment-clearEnv :: MonadState (MFlowState view) m => m () -clearEnv= do- st <- get- put st{ mfEnv= []} +-- | Will prevent the backtrack beyond the point where 'preventGoingBack' is located.+-- If the user press the back button beyond that point, the flow parameter is executed, usually+-- it is an ask statement with a message. If the flow is not going back, it does nothing. It is a cut in backtracking+--+-- It is useful when an undoable transaction has been commited. For example, after a payment.+--+-- This example show a message when the user go back and press again to pay+--+-- > ask $ wlink () << b << "press here to pay 100000 $ "+-- > payIt+-- > preventGoingBack . ask $ b << "You paid 10000 $ one time"+-- > ++> wlink () << b << " Please press here to complete the proccess"+-- > ask $ wlink () << b << "OK, press here to go to the menu or press the back button to verify that you can not pay again"+-- > where+-- > payIt= liftIO $ print "paying"++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+ clearEnv+ msg+ breturn()+ + receiveWithTimeouts :: MonadIO m => WState view m () receiveWithTimeouts= do st <- get @@ -996,7 +1044,9 @@ req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t) put st{mfEnv= req} --- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget ++-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a+-- higuer level form of the latter wstateless :: (Typeable view, FormInput view) => View view IO a -> Flow@@ -1008,8 +1058,7 @@ put $ env{ mfSequence= 0,prevSeq=[]} loop ----- | it creates a stateless flow (see `stateless`) whose behaviour is defined as a widget -----+ ---- This version writes a log with all the values returned by ask --wstatelessLog -- :: (Typeable view, ToHttpData view, FormInput view,Serialize a,Typeable a) =>@@ -1131,7 +1180,7 @@ toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v getParam1 name env [toSend] --- | When some HTML return some response to the server, but it is not produced by+-- | When some user interface int return some response to the server, but it is not produced by -- a form or a link, but for example by an script, @returning@ notify the type checker. -- -- At runtime the parameter is read from the environment and validated.
src/MFlow/Forms/Admin.hs view
@@ -72,6 +72,7 @@ wait f= do mv <- newEmptyMVar forkIO (f1 >> putMVar mv True)+ putStrLn "wait: ready" takeMVar mv `E.catch` (\(e:: E.SomeException) ->do ssyncCache@@ -139,9 +140,8 @@ showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<-users] 0 10 showFormList- :: (Functor m, MonadIO m) =>- [[View Html m ()]]- -> Int -> Int -> FlowM Html m b+ :: [[View Html IO ()]]+ -> Int -> Int -> FlowM Html IO b showFormList ls n l= do nav <- ask $ updown n l <|> (list **> updown n l) showFormList ls nav l@@ -155,7 +155,8 @@ optionsUser us = do wfs <- liftIO $ return . M.keys =<< getMessageFlows- stats <- liftIO $ mapM (\wf -> getWFHistory wf Token{twfname= wf,tuser=us}) wfs+ stats <- let u= undefined+ in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us 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")
src/MFlow/Forms/Blaze/Html.hs view
@@ -24,6 +24,9 @@ import Data.Monoid import Unsafe.Coerce +-- | used to insert html elements within a tag with the appropriate infix priority for the+-- other operators used in MFlow+(<<) :: ToMarkup a => (Markup -> t) -> a -> t (<<) tag v= tag $ toMarkup v infixr 7 <<
src/MFlow/Forms/Internals.hs view
@@ -58,7 +58,7 @@ error1 s= error $ s ++ " undefined" -userPrefix= "User/" +userPrefix= "user/" instance Indexable User where key User{userName= user}= keyUserName user @@ -67,13 +67,11 @@ -- | Register an user/password userRegister :: MonadIO m => String -> String -> m (DBRef User) -userRegister user password = liftIO . atomically $ newDBRef $ User user password-- +userRegister user password = liftIO . atomically $ newDBRef $ User user password -- | Authentication against `userRegister`ed users. -- to be used with `validate` -userValidate :: MonadIO m => (UserStr,PasswdStr) -> m (Maybe String) +userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view) userValidate (u,p) = let user= eUser{userName=u} in liftIO $ atomically @@ -87,11 +85,11 @@ } where - err= Just "Username or password invalid" + err= Just . fromStr $ "Username or password invalid" data Config = Config UserStr deriving (Read, Show, Typeable) -keyConfig= "MFlow.Config"+keyConfig= "mflow.config" instance Indexable Config where key _= keyConfig rconf= getDBRef keyConfig @@ -104,7 +102,6 @@ getAdminName= liftIO $ atomically ( readDBRef rconf `onNothing` error "admin user not set" ) >>= \(Config u) -> return u - data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable) @@ -143,10 +140,14 @@ +fromFailBack (NoBack x) = x+fromFailBack (BackPoint x)= x +toFailBack x= NoBack x+ {-# NOINLINE breturn #-} --- | Use this instead of return to return from a computation with an ask statement+-- | Use this instead of return to return from a computation with ask statements -- -- This way when the user press the back button, the computation will execute back, to -- the returned code, according with the user navigation.@@ -282,28 +283,26 @@ type Lang= String data MFlowState view= MFlowState{ - mfSequence :: Int,- mfCached :: Bool,- prevSeq :: [Int],- onInit :: Bool,- inSync :: Bool, - - mfLang :: Lang, - mfEnv :: Params,- needForm :: Bool, - - mfToken :: Token, - mfkillTime :: Int, - mfSessionTime :: Integer, - mfCookies :: [Cookie],- mfHttpHeaders :: Params, - mfHeader :: view -> view,- mfDebug :: Bool,- mfRequirements :: [Requirement],- mfData :: M.Map TypeRep Void,- mfAjax :: Maybe (M.Map String Void),- mfSeqCache :: Int,- notSyncInAction :: Bool+ mfSequence :: Int,+ mfCached :: Bool,+ prevSeq :: [Int],+ onInit :: Bool,+ inSync :: Bool, + mfLang :: Lang, + mfEnv :: Params,+ needForm :: Bool, + mfToken :: Token, + mfkillTime :: Int, + mfSessionTime :: Integer, + mfCookies :: [Cookie],+ mfHttpHeaders :: Params, + mfHeader :: view -> view,+ mfDebug :: Bool,+ mfRequirements :: [Requirement],+ mfData :: M.Map TypeRep Void,+ mfAjax :: Maybe (M.Map String Void),+ mfSeqCache :: Int,+ notSyncInAction :: Bool } deriving Typeable @@ -312,7 +311,7 @@ mFlowState0 :: (FormInput view) => MFlowState view mFlowState0 = MFlowState 0 False [] True False "en" [] False (error "token of mFlowState0 used")- 0 0 [] [] stdHeader False [] M.empty Nothing 0 False + 0 0 [] [] stdHeader False [] M.empty Nothing 0 False -- | Set user-defined data in the context of the session.@@ -330,7 +329,7 @@ -- > setHistory $ html' `mappend` html setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m () -setSessionData x= do+setSessionData x= modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)} -- | Get the session data of the desired type if there is any.@@ -621,17 +620,29 @@ adminLoop @ -} -runFlow :: (FormInput view, Monad m) - => FlowM view m a -> Token -> m a -runFlow f = \t ->- evalStateT (runBackT . runFlowM $ breturn() >> loopf) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return ()+runFlow :: (FormInput view, Monad m) + => FlowM view m () -> Token -> m () +runFlow f t=+ loop (runFlowOnce1 f) t --evalStateT (runBackT . runFlowM $ breturn() >> f) mFlowState0{mfToken=t,mfEnv= tenv t} >> return () -- >> return () where- loopf= f >> loopf+ loop f t= f t >>= \t -> loop f t +-- | Clears the environment+clearEnv :: MonadState (MFlowState view) m => m () +clearEnv= do+ st <- get+ put st{ mfEnv= []}++runFlowOnce :: (FormInput view, Monad m) + => FlowM view m () -> Token -> m ()+runFlowOnce f t= runFlowOnce1 f t >> return ()+ +runFlowOnce1 f t =+ evalStateT (runBackT . runFlowM $ (clearEnv >> breturn ()) >> f >> getToken) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return ()++ -- to restart the flow in case of going back before the first page of the flow -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.@@ -645,10 +656,11 @@ -> FlowM view (Workflow IO) b -> FlowM view m b runFlowIn wf f= do- t <- gets mfToken- liftIO $ WF.exec1nc wf $ runFlow1 f t+ t <- gets mfToken+ FlowM . BackT $ liftIO $ WF.exec1nc wf $ runFlow1 f t+ where- runFlow1 f t= evalStateT (runBackT . runFlowM $ breturn() >> f) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return ()+ runFlow1 f t= evalStateT (runBackT . runFlowM $ f) mFlowState0{mfToken=t,mfEnv= tenv t} -- >>= return . fromFailBack -- >> return () @@ -660,15 +672,45 @@ Typeable a) => FlowM view m a -> FlowM view (Workflow m) a - step f= do s <- get flowM $ BackT $ do- (r,s') <- lift . WF.step $ runStateT (runBackT $ runFlowM f) s- -- when recovery of a workflow, the MFlow state is not considered- when( mfSequence s' >0) $ put s'- return r+ (r,s') <- lift . WF.step $ runStateT (runBackT $ runFlowM f) s+ -- when recovery of a workflow, the MFlow state is not considered+ when( mfSequence s' >0) $ put s'+ return r +--stepWFRef +-- :: (Serialize a,+-- Typeable view,+-- FormInput view, +-- MonadIO m, +-- Typeable a) => +-- FlowM view m a +-- -> FlowM view (Workflow m) (WFRef (FailBack a),a) +--stepWFRef f= do +-- s <- get+-- flowM $ BackT $ do+-- (r,s') <- lift . WF.stepWFRef $ runStateT (runBackT $ runFlowM f) s+-- -- when recovery of a workflow, the MFlow state is not considered+-- when( mfSequence s' >0) $ put s'+-- return r++--step f= do +-- s <- get+-- flowM $ BackT $ do+-- (r,s') <- do+-- (br,s') <- runStateT (runBackT $ runFlowM f) s+-- case br of+-- NoBack r -> WF.step $ return r+-- BackPoint r -> WF.step $ return r+-- GoBack -> undoStep+-- -- when recovery of a workflow, the MFlow state is not considered+-- when( mfSequence s' >0) $ put s'+-- return r+++ --stepDebug -- :: (Serialize a, -- Typeable view,@@ -679,8 +721,8 @@ -- FlowM view m a -- -> FlowM view (Workflow m) a --stepDebug f= BackT $ do--- s <- get--- (r, s') <- lift $ do+-- s <- get+-- (r, s') <- lift $ do -- (r',stat)<- do -- rec <- isInRecover -- case rec of@@ -715,7 +757,7 @@ _ -> do let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)- return $ FormElm (err:form) Nothing + return $ FormElm (form++[err]) Nothing ---- Requirements
src/MFlow/Forms/Test.hs view
@@ -15,14 +15,15 @@ -XOverlappingInstances -XFlexibleInstances -XUndecidableInstances - -XPatternGuards + -XPatternGuards -XRecordWildCards #-} -module MFlow.Forms.Test (Response(..),runTest,ask) where -import MFlow.Forms hiding(ask) -import qualified MFlow.Forms (ask) -import MFlow.Forms(FormInput(..)) +module MFlow.Forms.Test (Generate(..),runTest,runTest1,inject, ask, askt, userWidget, getUser, getUserSimple, verify) where +import MFlow.Forms hiding(ask,askt,getUser,userWidget,getUserSimple) +import qualified MFlow.Forms (ask)+import MFlow.Forms.Internals +import MFlow.Forms(FormInput(..)) import MFlow.Forms.Admin import Control.Workflow as WF import Control.Concurrent @@ -43,40 +44,46 @@ import Data.Maybe import Data.IORef import MFlow.Cookies(cookieuser) - ++import Data.Dynamic+import Data.TCache.Memoization++import Debug.Trace++(!>)= flip trace -class Response a where - response :: IO a +class Generate a where + generate :: IO a -instance Response a => Response (Maybe a) where - response= do +instance Generate a => Generate (Maybe a) where + generate= do b <- randomRIO(0,1 :: Int) - case b of 0 -> response >>= return . Just ; _ -> return Nothing + case b of 0 -> generate >>= return . Just ; _ -> return Nothing -instance Response String where - response= replicateM 5 $ randomRIO ('a','z') +instance Generate String where + generate= replicateM 5 $ randomRIO ('a','z') -instance Response Int where - response= randomRIO(1,1000) +instance Generate Int where + generate= randomRIO(1,1000) -instance Response Integer where - response= randomRIO(1,1000) +instance Generate Integer where + generate= randomRIO(1,1000) -instance (Response a, Response b) => Response (a,b) where - response= fmap (,) response `ap` response +instance (Generate a, Generate b) => Generate (a,b) where + generate= fmap (,) generate `ap` generate -instance (Response a, Response b) => Response (Maybe a,Maybe b) where - response= do - r <- response +instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where + generate= do + r <- generate case r of - (Nothing,Nothing) -> response + (Nothing,Nothing) -> generate other -> return other -instance (Bounded a, Enum a) => Response a where - response= mx +instance (Bounded a, Enum a) => Generate a where + generate= mx where mx= do let x= typeOfIO mx @@ -85,50 +92,134 @@ return $ toEnum n where typeOfIO :: IO a -> a - typeOfIO = error $ "typeOfIO not defined" + typeOfIO = undefined -- | run a list of flows with a number of simultaneous threads -runTest :: [(Int, Flow)] -> IO () -runTest ps=do - mapM_ (forkIO . run1) ps +++runTest :: [(Int, Flow)] -> IO () +runTest ps= do + mapM_ (forkIO . run1) ps putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads" - adminLoop - -run1 (nusers, proc) = replicateM_ nusers $ randomFlow proc + where - randomFlow f = do - name <- response - x <- response - y <- response - z <- response + run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc+ +runTest1 f = do+ atomicModifyIORef testNumber (\n -> (n+1,n+1)) + name <- generate + x <- generate + y <- generate + z <- generate r1<- liftIO newEmptyMVar - r2<- liftIO newEmptyMVar + r2<- liftIO newEmptyMVar let t = Token x y z [] r1 r2 - forkIO . WF.exec1 name $ f t + WF.start name f t++testNumber= unsafePerformIO $ newIORef 0++getTestNumber :: MonadIO m => m Int+getTestNumber= liftIO $ readIORef testNumber++-- | inject substitutes an expression by other. It may be used to override+-- ask interaction with the user. It should bee used infix for greater readability:+--+-- > ask something `inject` const someother+--+-- The parameter passed is the test number+-- if the flow has not been executed by runTest, inject return the original+inject :: MonadIO m => m b -> (Int -> b) -> m b+inject exp v= do+ n <- getTestNumber+ if n== 0 then exp else exp `seq` return $ v n --- | a simulated ask that generate simulated user responses of the type expected+-- | a simulated ask that generate simulated user input of the type expected. --+-- It forces the web page rendering, since it is monadic and can contain+-- side effects and load effects to be tested.+-- -- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes. -- execute 'runText' to initiate threads under different load conditions. -ask :: (Response a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a -ask w = do - w `MFlow.Forms.wmodify` (\v x -> consume v >> return (v,x)) - `seq` rest - where - consume= liftIO . B.writeFile "NULL" . B.concat . map toByteString - rest= do - bool <- liftIO $ response - case bool of - False -> fail "" - True -> do - b <- liftIO response - r <- liftIO $ response - case (b,r) of - (True,x) -> breturn x - _ -> ask w - +ask :: (Generate a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a +ask w = do+ FormElm forms mx <- FlowM . lift $ runView w+ r <- liftIO generate+ let n= B.length . toByteString $ mconcat forms+ breturn $ n `seq` mx `seq` r+-- let u= undefined+-- liftIO $ runStateT (runView mf) s +-- bool <- liftIO generate +-- case bool of +-- False -> fail "" +-- True -> do +-- b <- liftIO generate +-- r <- liftIO generate +-- case (b,r) of +-- (True,x) -> breturn x +-- _ -> ask w +++-- | instead of generating a result like `ask`, the result is given as the first parameter+-- so it does not need a Generate instance.+--+-- It forces the web page rendering, since it is monadic so it can contain+-- side effects and load effects to be tested. +askt :: (MonadIO m,FormInput v) => (Int -> a) -> View v m a -> FlowM v m a+askt v w = do+ FormElm forms mx <- FlowM . lift $ runView w+ n <- getTestNumber+ let l= B.length . toByteString $ mconcat forms+ breturn $ l `seq` mx `seq` v n++--mvtestopts :: MVar (M.Map String (Int,Dynamic))+--mvtestopts = unsafePerformIO $ newMVar M.empty++--asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a+--asktn xs w= do+-- v <- liftIO $ do+-- let k = addrStr xs+-- opts <- takeMVar mvtestopts+-- let r = M.lookup k opts+-- case r of+-- Nothing -> do+-- putMVar mvtestopts $ M.singleton k (0,toDyn xs)+-- return $ head xs+-- Just (i,d) -> do+-- putMVar mvtestopts $ M.insert k (i+1,d) opts+-- return $ (fromMaybe (error err1) $ fromDynamic d) !! i+--+-- askt v w+--+-- where+-- err1= "MFlow.Forms.Test: asktn: fromDynamic error"+++-- | verify a property. if not true, throw the error message.+--+-- It is intended to be used in a infix notation, on the right of the code,+-- in order to separate the code assertions from the application code and make clearly+-- visible them as a form of documentation.+-- separated from it:+--+-- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")+--+-- the expression is monadic to allow for complex verifications that may involve IO actions+verifyM :: Monad m => m b -> (m Bool, String) -> m b+verifyM f (mprop, msg)= do+ prop <- mprop+ case prop of+ True -> f+ False -> error msg++-- | a pure version of verifyM+verify :: a -> (Bool, String) -> a+verify f (prop, msg)= do+ case prop of+ True -> f+ False -> error msg+ -- --match form=do @@ -151,25 +242,57 @@ -- getPar= par $ search "name" -- in getPar form -- -{- -waction ::(Functor m, MonadIO m,Response a, FormInput view) + +waction ::(Functor m, MonadIO m,Generate a, FormInput view) => View view m a -> (a -> FlowM view m b) -> View view m b waction w f= do - x <- liftIO response + x <- liftIO generate MFlow.Forms.waction (return x) f ++userWidget :: ( MonadIO m, Functor m + , FormInput view) + => Maybe String+ -> View view m (Maybe (String,String), Maybe String)+ -> View view m String +userWidget muser formuser= do+ user <- getCurrentUser+ if muser== Just user then return user+ else if isJust muser then do+ let user= fromJust muser+ login user >> return user+ else liftIO generate >>= \u -> login u >> return u++ where+ login uname= do+ st <- get + let t = mfToken st+ t'= t{tuser= uname}+ put st{mfToken= t'} + return ()+ +getUserSimple :: ( FormInput view, Typeable view + , MonadIO m, Functor m)+ => FlowM view m String+getUserSimple= getUser Nothing userFormLine +getUser :: ( FormInput view, Typeable view + , MonadIO m, Functor m) + => Maybe String+ -> View view m (Maybe (String,String), Maybe String)+ -> FlowM view m String +getUser mu form= ask $ userWidget mu form+ --wmodify --- :: (Functor m, MonadIO m, FormInput v, Response (Maybe a)) => +-- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) => -- View v m a1 -- -> ([v] -> Maybe a -> WState v m ([v], Maybe b)) -- -> View v m b -wmodify formt act = do - x <- liftIO response - formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act --} +--wmodify formt act = do +-- x <- liftIO generate +-- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act {- type Var= String @@ -200,15 +323,15 @@ formAction _ _= id addAttributes _ _= id -generateResponse Test{..}= do - b <- response +generateGenerate Test{..}= do + b <- generate case b of True -> genLink False -> genForm where genForm= do - -- one on every response is incomplete + -- one on every generate is incomplete n <- randomRIO(0,10) :: IO Int case n of 0 -> do @@ -243,7 +366,7 @@ then return [] else mapM gen tfinput where gen(n,_)= do - str <- response + str <- generate return $ (n,str) genTextArea= do @@ -253,7 +376,7 @@ else mapM gen tftextarea where gen(n,_)= do - str <- response + str <- generate return $ (n,str) pwf= "pwf" @@ -261,7 +384,7 @@ instance Processable Params where pwfname = fromMaybe noScript . lookup pwf puser= fromMaybe anonymous . lookup cookieuser - pind = fromMaybe "0" . lookup ind + pind = fromMaybe "0" . lookup ind getParams = id @@ -271,17 +394,17 @@ replicateM nusers $ gen wfs where gen wfs = do - u <- response + u <- generate mapM (genTraffic u) $ M.toList wfs - genTraffic u (n,_)= forkIO $ iterateresponses [(pwf,n),(cookieuser,u)] [] + genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] [] - iterateresponses ident msg= iterate [] msg + iterategenerates ident msg= iterate [] msg where iterate cs msg= do (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks - resp <- generateResponse . read $ B.unpack test + resp <- generateGenerate . read $ B.unpack test iterate cs' resp -}
src/MFlow/Forms/Widgets.hs view
@@ -57,7 +57,7 @@ jqueryCSS= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css" -jqueryUi= "http://code.jquery.com/ui/1.9.1/jquery-ui.js"+jqueryUI= "http://code.jquery.com/ui/1.9.1/jquery-ui.js" ------- User Management ------ @@ -198,10 +198,10 @@ -- This example add or delete editable text boxes, with two initial boxes with -- /hi/, /how are you/ as values. Tt uses blaze-html: ----- > wlistEd= do+ -- > r <- ask $ addLink -- > ++> br--- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"])+-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid" -- > <++ br -- > <** submitButton "send" -- >@@ -209,7 +209,7 @@ -- > ++> wlink () (p << text " back to menu") -- > mainmenu -- > where--- > addLink = a ! At.id "wEditListAdd"+-- > addLink = a ! At.id "addid" -- > ! href "#" -- > $ text "add" -- > delBox = input ! type_ "checkbox"@@ -220,18 +220,19 @@ wEditList :: (Typeable a,Read a ,FormInput view ,Functor m,MonadIO m, Executable m)- => (view ->view) -- ^ the holder tag+ => (view ->view) -- ^ The holder tag -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string- -> [String] -- ^ the initial list of values.+ -> [String] -- ^ The initial list of values.+ -> String -- ^ The id of the button or link that will create a new list element when clicked -> View view m [a]-wEditList holderview w xs = do+wEditList holderview w xs addId = do let ws= map (w . Just) xs wn= w Nothing id1<- genNewId let sel= "$('#" <> B.pack id1 <> "')" callAjax <- ajax . const $ prependWidget sel wn let installevents= "$(document).ready(function(){\- \$('#wEditListAdd').click(function(){"++callAjax "''"++"});})"+ \$('#"++addId++"').click(function(){"++callAjax "''"++"});})" requires [JScriptFile jqueryScript [installevents] ] @@ -255,7 +256,7 @@ requires [JScriptFile jqueryScript [] -- [events] ,CSSFile jqueryCSS- ,JScriptFile jqueryUi []]+ ,JScriptFile jqueryUI []] getString mv <! [("type", "text")@@ -304,7 +305,7 @@ requires [JScriptFile jqueryScript [events ajaxc] -- [events] ,CSSFile jqueryCSS- ,JScriptFile jqueryUi []]+ ,JScriptFile jqueryUI []] ws' <- getEdited sel @@ -482,3 +483,21 @@ mField k= do lang <- getLang tField $ k ++ ('-':lang)++-- | present a calendar to choose a date+datePicker :: (Monad m, FormInput v) => Maybe String -> View v m (Int,Int,Int)+datePicker jd= do+ id <- genNewId+ let setit= "$(function() {\+ \$( '"++id++"' ).datepicker();\+ \});"++ requires+ [CSSFile jqueryCSS+ ,JScriptFile jqueryScript []+ ,JScriptFile jqueryUI [setit]]++ s <- getString jd <! [("id",id)]+ let (month,r) = span (/='/') s+ let (day,r2)= span(/='/') $ tail r+ return (read day,read month, read $ tail r2)
src/MFlow/Hack.hs view
@@ -59,26 +59,6 @@ -- getPath env= pathInfo env -- getPort env= serverPort env - -data NFlow= NFlow !Integer deriving (Read, Show, Typeable) --instance Serializable NFlow where- serialize= B.pack . show- deserialize= read . B.unpack - -instance Indexable NFlow where - key _= "NFlow" - --rflow= getDBRef . key $ NFlow undefined- -newFlow= do- TOD t _ <- getClockTime - atomically $ do - NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) - writeDBRef rflow . NFlow $ n+1- return . show $ t + n- ---------------------------------------------
src/MFlow/Wai.hs view
@@ -55,7 +55,7 @@ pwfname env= if SB.null sc then noScript else SB.unpack sc where sc= SB.tail $ rawPathInfo env - + puser env = fromMaybe anonymous $ fmap SB.unpack $ lookup ( mk $SB.pack cookieuser) $ requestHeaders env pind env= fromMaybe (error ": No FlowID") $ fmap SB.unpack $ lookup (mk $ SB.pack flow) $ requestHeaders env @@ -68,28 +68,10 @@ -- getPath env= pathInfo env -- getPort env= serverPort env -data NFlow= NFlow !Integer deriving (Read, Show, Typeable) -instance Serializable NFlow where - serialize= B.pack . show - deserialize= read . B.unpack -instance Indexable NFlow where - key _= "Flow" -rflow= getDBRef . key $ NFlow undefined - -newFlow= liftIO $ do - TOD t _ <- getClockTime - atomically $ do - NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) - writeDBRef rflow . NFlow $ n+1 - return . show $ t + n - - - - splitPath ""= ("","","") splitPath str= let @@ -108,7 +90,7 @@ (flowval , retcookies) <- case lookup flow cookies of Just fl -> return (fl, []) Nothing -> do - fl <- newFlow + fl <- liftIO $ newFlow return (fl, [(flow, fl, "/",Nothing)::Cookie]) {- for state persistence in cookies
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -26,6 +26,7 @@ ,module Text.Blaze.Internal ,module Text.Blaze.Html5 ,module Text.Blaze.Html5.Attributes+,module Control.Monad.IO.Class ) where import MFlow@@ -44,6 +45,7 @@ import Control.Applicative+import Control.Monad.IO.Class
src/MFlow/Wai/Response.hs view
@@ -54,6 +54,6 @@ instance ToResponse HttpData where toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs ++ cookieHeaders cookies)) x- toResponse (Error NotFound str)= responseLBS status404 [] $ getNotFoundResponse str + toResponse (Error NotFound str)= responseLBS status404 [] $ (unsafePerformIO getNotFoundResponse) str