diff --git a/Demos/demos.blaze.hs b/Demos/demos.blaze.hs --- a/Demos/demos.blaze.hs +++ b/Demos/demos.blaze.hs @@ -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") ) wlink () (p << text " menu") + r <- ask $ getSelect (setSelectedOption ("" :: String) (p << "select a option") <|> + setOption "blue" (b << "blue") <|> + setOption "Red" (b << "red") ) 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) wlink () (p << text " menu") + ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'" + b << "click the box" + ++> getInt (Just 0) 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." + ) diff --git a/MFlow.cabal b/MFlow.cabal --- a/MFlow.cabal +++ b/MFlow.cabal @@ -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: . diff --git a/src/MFlow.hs b/src/MFlow.hs --- a/src/MFlow.hs +++ b/src/MFlow.hs @@ -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 @@ "

Error 404: Page not found or error ocurred:

" <> msg <> "


" <> opts <> "
press here to go home" - where + where paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows opts= "options: " <> B.concat (Prelude.map (\s -> " s <>"\">"<> s <>", ") 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=[ diff --git a/src/MFlow/Forms.hs b/src/MFlow/Forms.hs --- a/src/MFlow/Forms.hs +++ b/src/MFlow/Forms.hs @@ -123,7 +123,8 @@ [@attributes for formLet elements@] to add atributes to widgets. See the ')= 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 return $ FormElm [hfs `attrs` attribs] mx +-- _ -> error $ "operator View view m (Maybe (UserStr,PasswdStr), Maybe String) + => View view m (Maybe (UserStr,PasswdStr), Maybe String) userLogin= ((,) <$> fromStr "Enter User: " ++> getString Nothing fromStr " Enter Pass: " ++> getPassword 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. diff --git a/src/MFlow/Forms/Admin.hs b/src/MFlow/Forms/Admin.hs --- a/src/MFlow/Forms/Admin.hs +++ b/src/MFlow/Forms/Admin.hs @@ -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") diff --git a/src/MFlow/Forms/Blaze/Html.hs b/src/MFlow/Forms/Blaze/Html.hs --- a/src/MFlow/Forms/Blaze/Html.hs +++ b/src/MFlow/Forms/Blaze/Html.hs @@ -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 << diff --git a/src/MFlow/Forms/Internals.hs b/src/MFlow/Forms/Internals.hs --- a/src/MFlow/Forms/Internals.hs +++ b/src/MFlow/Forms/Internals.hs @@ -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 diff --git a/src/MFlow/Forms/Test.hs b/src/MFlow/Forms/Test.hs --- a/src/MFlow/Forms/Test.hs +++ b/src/MFlow/Forms/Test.hs @@ -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 -} diff --git a/src/MFlow/Forms/Widgets.hs b/src/MFlow/Forms/Widgets.hs --- a/src/MFlow/Forms/Widgets.hs +++ b/src/MFlow/Forms/Widgets.hs @@ -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 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 return (fl, []) Nothing -> do - fl <- newFlow + fl <- liftIO $ newFlow return (fl, [(flow, fl, "/",Nothing)::Cookie]) {- for state persistence in cookies diff --git a/src/MFlow/Wai/Blaze/Html/All.hs b/src/MFlow/Wai/Blaze/Html/All.hs --- a/src/MFlow/Wai/Blaze/Html/All.hs +++ b/src/MFlow/Wai/Blaze/Html/All.hs @@ -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 diff --git a/src/MFlow/Wai/Response.hs b/src/MFlow/Wai/Response.hs --- a/src/MFlow/Wai/Response.hs +++ b/src/MFlow/Wai/Response.hs @@ -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