MFlow 0.0.5.3 → 0.1.5.0
raw patch · 13 files changed
+228/−152 lines, 13 filesdep −hsp
Dependencies removed: hsp
Files
- Demos/ShoppingCart.Wai.hs +3/−6
- Demos/ShoppingCart.hs +3/−5
- Demos/demos.hs +36/−16
- MFlow.cabal +5/−6
- src/MFlow.hs +44/−14
- src/MFlow/Forms.hs +99/−44
- src/MFlow/Forms/Admin.hs +12/−1
- src/MFlow/Forms/HSP.hs +6/−10
- src/MFlow/Forms/XHtml.hs +3/−4
- src/MFlow/Hack.hs +8/−8
- src/MFlow/Hack/Response.hs +1/−15
- src/MFlow/Wai.hs +7/−7
- src/MFlow/Wai/Response.hs +1/−16
Demos/ShoppingCart.Wai.hs view
@@ -21,15 +21,12 @@ main= do -- syncWrite SyncManual- putStrLn $ options messageFlows- forkIO $ run 80 $ waiMessageFlow messageFlows+ addMessageFlows messageFlows+ forkIO $ run 80 waiMessageFlow adminLoop -options msgs= "in the browser navigate to\n\n" ++- concat [ "http://localhost/"++ i ++ "\n" | (i,_) <- msgs]--messageFlows= [("noscript", runFlow shopCart )+messageFlows= [("", runFlow shopCart ) ,("stateless", stateless st)] st _ = return "hi"
Demos/ShoppingCart.hs view
@@ -17,15 +17,13 @@ main= do -- syncWrite SyncManual- putStrLn $ options messageFlows- forkIO $ run 80 $ hackMessageFlow messageFlows+ addMessageFlows messageFlows+ forkIO $ run 80 hackMessageFlow adminLoop -options msgs= "in the browser navigate to\n\n" ++- concat [ "http://localhost/"++ i ++ "\n" | (i,_) <- msgs] -messageFlows= [("noscript", runFlow shopCart )]+messageFlows= [("", runFlow shopCart )] --shopCart1 :: V.Vector Int -> FlowM (Workflow IO) b
Demos/demos.hs view
@@ -7,18 +7,18 @@ import Control.Concurrent import Control.Exception as E import qualified Data.ByteString.Char8 as SB+import qualified Data.Vector as V+import Data.Maybe -import Debug.Trace-(!>)= flip trace -data Ops= Ints | Strings | Actions | Ajax | Shop deriving(Typeable,Read, Show)+data Ops= Ints | Strings | Actions | Ajax | Opt deriving(Typeable,Read, Show) main= do- syncWrite SyncManual setFilesPath "" addFileServerWF- forkIO $ run 80 $ waiMessageFlow [("noscript",transient $ runFlow mainf)- ("shop" ,runFlow shopCart)]+ addMessageFlows [("" ,transient $ runFlow mainf)+ ,("shop" ,runFlow shopCart)]+ forkIO $ run 80 waiMessageFlow adminLoop @@ -26,21 +26,34 @@ stdheader c= p << "you can press the back button to go to the menu"+++ c mainf= do setHeader stdheader- r <- ask $ wlink Ints (bold << "Ints") <|>- br ++> wlink Strings (bold << "Strings") <|>- br ++> wlink Actions (bold << "Example of a string widget with an action") <|>- br ++> wlink Ajax (bold << "Simple AJAX example")+ r <- ask $ wlink Ints (bold << "increase an Int")+ <|> br ++> wlink Strings (bold << "increase a String")+ <|> br ++> wlink Actions (bold << "Example of a string widget with an action")+ <|> br ++> wlink Ajax (bold << "Simple AJAX example")+ <|> br ++> wlink Opt (bold << "select options")+ <++ (br +++ linkShop) -- this is an ordinary XHtml link+ case r of Ints -> clickn 0 Strings -> clicks "1" Actions -> actions 1 Ajax -> ajaxsample- Shop -> shopCart+ Opt -> options mainf+ where+ linkShop= toHtml $ hotlink "shop" << "shopping" +options= do+ r <- ask $ getSelect (setOption "blue" (bold << "blue") <|>+ setSelectedOption "Red" (bold << "red") ) <! dosummit+ ask $ p << (r ++ " selected") ++> wlink () (p<< " menu")+ breturn()+ where+ dosummit= [("onchange","this.form.submit()")]+ clickn (n :: Int)= do setHeader stdheader- r <- ask $ wlink "menu" (p << "back")+ r <- ask $ wlink "menu" (p << "menu") |+| getInt (Just n) <* submitButton "submit" case r of (Just _,_) -> breturn ()@@ -69,20 +82,27 @@ <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) breturn () -+-- A persistent flow (uses step). The process is killed after 10 seconds of inactivity+-- but it is restarted automatically. if you restart the program, it remember the shopping cart+-- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow. shopCart = do setTimeouts 10 0 shopCart1 (V.fromList [0,0,0:: Int]) where shopCart1 cart= do- i <- step . ask- $ table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]+ i <- step . ask $+ table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] <<< caption << "choose an item" ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] ++> (tbody- <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0))+ <<< tr ! [rowspan 2] << td << linkHome+ ++> (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2)))+ <++ tr << td << linkHome )+ let newCart= cart V.// [(i, cart V.! i + 1 )] shopCart1 newCart+ where+ linkHome= (toHtml $ hotlink noScript << bold << "home")
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow-version: 0.0.5.3+version: 0.1.5.0 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -25,7 +25,7 @@ This release add transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting AJAX, and WAI integration. .- It is designed for coding an entire application can be run with no deployment with runghc in order+ It is designed for applications that can be run with no deployment with runghc in order to speed up the development process. . See "MFlow.Forms" for details@@ -41,25 +41,24 @@ category: Web, Application Server author: Alberto Gómez Corona data-dir: ""-extra-source-files: Demos/ShoppingCart.hs, Demos/ShoppingCart.Wai.hs, Demos/demos.hs+extra-source-files: src/MFlow/Forms/HSP.hs, Demos/ShoppingCart.hs, Demos/ShoppingCart.Wai.hs, Demos/demos.hs library build-depends: Workflow -any, transformers -any, mtl -any, extensible-exceptions -any, xhtml -any, base >4.0 && < 5, hack -any, hack-handler-simpleserver -any, bytestring -any, containers -any, RefSerialize -any, TCache -any, stm >2,- old-time -any, vector -any, hsp -any, directory -any,+ old-time -any, vector -any, directory -any, utf8-string -any, wai -any, case-insensitive -any, http-types -any, conduit -any ,text -any, parsec -any,warp -any exposed-modules: MFlow.Forms- MFlow.Forms.Admin MFlow MFlow.FileServer MFlow.Forms.Ajax MFlow.Cookies MFlow.Hack.Response, MFlow.Hack MFlow.Hack.XHtml MFlow.Hack.XHtml.All MFlow.Wai.Response, MFlow.Wai, MFlow.Wai.XHtml.All MFlow.Forms.XHtml- MFlow.Forms.HSP+ exposed: True buildable: True hs-source-dirs: src .
src/MFlow.hs view
@@ -1,25 +1,34 @@ {- | Non monadic low level support stuff for the MFlow application server.+(See "MFlow.Form" for the higher level interfaces) it implements an scheduler of queued 'Processable' messages that are served according with the source identification and the verb invoked.-Ths scheduler executed the appropriate workflow (using the workflow package)-the workflow may send additional messages to the source, identified by a 'Token'-. The computation state is logged and can be recovered.+The scheduler executed the appropriate workflow (using the workflow package).+The workflow may send additional messages to the source, identified by a 'Token'+. The computation state is optionally logged and recovered. The message communication is trough polimorphic, monoidal queues. There is no asumption about message codification, so instantiations-of this scheduler for many different infrastructures is possible.+of this scheduler for different infrastructures is possible,+including non-Web based ones as long as they support or emulate cookies.+ "MFlow.Hack" is an instantiation for the Hack interface in a Web context. "MFlow.Wai" is a instantiation for the WAI interface. +"MFlow.Forms" implements a monadic type safe interface with composabe widgets and a+higher comunication interface.++"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format++"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format+ In order to manage resources, there are primitives that kill the process and its state after a timeout. -All these details are hidden in the monad of "MFlow.Forms" that provides-an higuer level interface.+All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface. Fragment based streaming 'sendFragment' 'sendEndFragment' are provided only at this level. -'stateless' and 'transient' serving processes are possible. `stateless` are request-response+'stateless' and 'transient' server processeses are also possible. `stateless` are request-response with no intermediate messaging dialog. `transient` processes have no persistent state, so they restart anew after a timeout or a crash. @@ -38,13 +47,17 @@ module MFlow ( Params, Workflow, HttpData(..),Processable(..), ToHttpData(..) , Token(..), ProcList+-- * low level comunication primitives. Use `ask` instead ,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment , sendEndFragment-,msgScheduler, addMessageFlows,getMessageFlows, transient, stateless,anonymous-,noScript,hlog,addTokenToList,deleteTokenInList,+-- * Flow configuration+,addMessageFlows,getMessageFlows, transient, stateless,anonymous+,noScript,hlog, setNotFoundResponse,getNotFoundResponse, -- * ByteString tags--- | basic but efficient tag formatting-btag, bhtml, bbody,Attribs)+-- | very basic but efficient tag formatting+btag, bhtml, bbody,Attribs+-- * internal use+,addTokenToList,deleteTokenInList, msgScheduler) where import Control.Concurrent.MVar @@ -64,14 +77,14 @@ import System.IO.Unsafe import Data.TCache.DefaultPersistence hiding(Indexable(..)) -import Data.ByteString.Lazy.Char8 as B(ByteString, pack, unpack,empty,append,cons,fromChunks) +import Data.ByteString.Lazy.Char8 as B (ByteString, concat,pack, unpack,empty,append,cons,fromChunks) import qualified Data.Map as M import System.IO import System.Time import Control.Workflow import MFlow.Cookies-+import Control.Monad.Trans --import Debug.Trace --(!>)= flip trace @@ -259,7 +272,9 @@ _messageFlows= unsafePerformIO $ newMVar M.empty -- [(String,Token -> Workflow IO ())]) -- | add a list of flows to be scheduled. Each entry in the list is a pair @(path, flow)@-addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union ms (M.fromList wfs)) +addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union ms (M.fromList $ map flt wfs))+ where flt ("",f)= (noScript,f)+ flt e= e -- | return the list of the scheduler getMessageFlows = readMVar _messageFlows @@ -354,6 +369,21 @@ -- | The handler of the error log hlog= unsafePerformIO $ openFile logFileName ReadWriteMode ++defNotFoundResponse msg=+ "<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 + paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows+ opts= "options: " <> B.concat (Prelude.map (\s ->+ "<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)++notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse++-- | set the 404 "not found" response+setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f+getNotFoundResponse= unsafePerformIO $ readIORef notFoundResponse -- basic bytestring XML tags type Attribs= [(String,String)]
src/MFlow/Forms.hs view
@@ -119,34 +119,47 @@ > import Control.Monad.Trans > import Data.Typeable > import Control.Concurrent+> import Control.Exception as E+> import qualified Data.ByteString.Char8 as SB+> import qualified Data.Vector as V+> import Data.Maybe > >-> data Ops= Ints | Strings | Actions | Ajax deriving(Typeable,Read, Show) >+> data Ops= Ints | Strings | Actions | Ajax | Shop deriving(Typeable,Read, Show)+> > main= do-> syncWrite SyncManual-> forkIO $ run 80 $ waiMessageFlow [("noscript",transient $ runFlow mainf)]+> setFilesPath ""+> addFileServerWF+> addMessageFlows [("" ,transient $ runFlow mainf)+> ,("shop" ,runFlow shopCart)]+> forkIO $ run 80 waiMessageFlow > adminLoop > >-> stdheader c= p << "you can press the back button to go to the menu"+++ c >+> stdheader c= p << "you can press the back button to go to the menu"+++ c > mainf= do > setHeader stdheader-> r <- ask $ wlink Ints (bold << "Ints") <|>-> br ++> wlink Strings (bold << "Strings") <|>-> br ++> wlink Actions (bold << "Example of a string widget with an action") <|>-> br ++> wlink Ajax (bold << "Simple AJAX example")+> r <- ask $ wlink Ints (bold << "increase an Int")+> <|> br ++> wlink Strings (bold << "increase a String")+> <|> br ++> wlink Actions (bold << "Example of a string widget with an action")+> <|> br ++> wlink Ajax (bold << "Simple AJAX example")+> <++ (br +++ linkShop) -- this is an ordinary XHtml link+> > case r of-> Ints -> clickn 0+> Ints -> clickn 0 > Strings -> clicks "1" > Actions -> actions 1 > Ajax -> ajaxsample+> > mainf+> where+> linkShop= toHtml $ hotlink "shop" << "shopping" > > clickn (n :: Int)= do > setHeader stdheader-> r <- ask $ wlink "menu" (p << "back")+> r <- ask $ wlink "menu" (p << "menu") > |+| getInt (Just n) <* submitButton "submit" > case r of > (Just _,_) -> breturn ()@@ -165,8 +178,8 @@ > > ajaxsample= do > setHeader ajaxheader-> ajaxc <- ajaxCommand "document.getTextBoxentById('text1').value"-> (\n -> return $ "document.getTextBoxentById('text1').value='"++show(read n +1)++"'")+> ajaxc <- ajaxCommand "document.getElementById('text1').value"+> (\n -> return $ "document.getElementById('text1').value='"++show(read n +1)++"'") > ask $ (getInt (Just 0) <! [("id","text1"),("onclick", ajaxc)]) > breturn() >@@ -175,6 +188,30 @@ > <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) > breturn () >+> -- A persistent flow (uses step). The process is killed after 10 seconds of inactivity+> -- but it is restarted automatically. if you restart the program, it remember the shopping cart+> -- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.+> shopCart = do+> setTimeouts 10 0+> shopCart1 (V.fromList [0,0,0:: Int])+> where+> shopCart1 cart= do+> i <- step . ask $+> table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]+> <<< caption << "choose an item"+> ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"]+> ++> (tbody+> <<< tr ! [rowspan 2] << td << linkHome+> ++> (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0))+> <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1))+> <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2)))+> <++ tr << td << linkHome+> )+>+> let newCart= cart V.// [(i, cart V.! i + 1 )]+> shopCart1 newCart+> where+> linkHome= (toHtml $ hotlink noScript << bold << "home") -} @@ -197,10 +234,10 @@ -- formatting can be added with the formatting combinators. -- modifiers change their presentation and behaviour getString,getInt,getInteger, getTextBox -,getMultilineText,getBool,getOption, getPassword,+,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword, getRadio, getRadioActive, getCheckBox, submitButton,resetButton, wlink, wform,-+getCurrentName, -- * FormLet modifiers validate, noWidget, wrender, waction, wmodify, @@ -291,7 +328,7 @@ userPrefix= "User#" instance Indexable User where - key User{userName= user}= keyUserName user+ key User{userName= user}= keyUserName user -- | return the key name of an user keyUserName n= userPrefix++n @@ -883,26 +920,26 @@ let form= [ftextarea tolook nvalue] getParam1 tolook env form -instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where - digest mv = getBool b "True" "False" - where - b= case mv of - Nothing -> Nothing - Just bool -> Just $ case bool of- True -> "True"- False -> "False"+--instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where +-- digest mv = getBool b "True" "False" +-- where +-- b= case mv of +-- Nothing -> Nothing +-- Just bool -> Just $ case bool of+-- True -> "True"+-- False -> "False" --- | display an dropdown box with the two values (second (true) and third parameter(false))+-- | display a dropdown box with the two values (second (true) and third parameter(false)) -- . With the value of the first parameter selected. getBool :: (FormInput view, Monad m) => - Maybe String -> String -> String -> View view m Bool + Bool -> String -> String -> View view m Bool getBool mv truestr falsestr= View $ do tolook <- getNewName st <- get let env = mfEnv st put st{needForm= True}- r <- getParam1 tolook env $ [foption1 tolook [truestr,falsestr] mv] + r <- getParam1 tolook env $ [fselect tolook(foption1 truestr mv `mappend` foption1 falsestr (not mv))] return $ fmap fromstr r -- case mx of -- Nothing -> return $ FormElm f Nothing @@ -910,20 +947,37 @@ where fromstr x= if x== truestr then True else False --- | display a dropdown box with the options. the value of the first parameter is optionally selected+-- | display a dropdown box with the options in the first parameter is optionally selected -- . It returns the selected option. -getOption :: (FormInput view, - Monad m) => - Maybe String ->[(String, view)] -> View view m String -getOption mv strings = View $ do +getSelect :: (FormInput view, + Monad m,Typeable a, Read a) => + View view m (MFOption a) -> View view m a +getSelect opts = View $ do tolook <- getNewName st <- get let env = mfEnv st- put st{needForm= True} - getParam1 tolook env [foption tolook strings mv] - - + put st{needForm= True}+ FormElm form mr <- (runView opts) + getParam1 tolook env [fselect tolook $ mconcat form] +data MFOption a= MFOption++-- | set the option for getSelect. Options are concatenated with `<|>`+setOption n v = setOption1 n v False++-- | set the selected option for getSelect. Options are concatenated with `<|>`+setSelectedOption n v= setOption1 n v True+ +setOption1 :: (FormInput view, + Monad m, Typeable a, Show a) => + a -> view -> Bool -> View view m (MFOption a) +setOption1 nam val check= View $ do+ st <- get+ let env = mfEnv st+ put st{needForm= True}+ let n= if typeOf nam== typeOf(undefined :: String) then unsafeCoerce nam else show nam + return . FormElm [foption n val check] $ Just MFOption + -- | Enclose Widgets in some formating. -- @view@ is intended to be instantiated to a particular format@@ -1019,17 +1073,18 @@ -- | Minimal interface for defining the basic form combinators in a concrete rendering. -- defined in this module. see "MFlow.Forms.XHtml" for the instance for @Text.XHtml@ and MFlow.Forms.HSP for an instance -- form Haskell Server Pages. -class FormInput view where +class Monoid view => FormInput view where inred :: view -> view fromString :: String -> view flink :: String -> view -> view flink1:: String -> view - flink1 verb = flink verb (fromString verb) + flink1 verb = flink verb (fromString verb) finput :: Name -> Type -> Value -> Checked -> OnClick -> view - ftextarea :: String -> String -> view - foption :: String -> [(String, view)] -> Maybe String -> view - foption1 :: String -> [String] -> Maybe String -> view - foption1 name list msel= foption name (zip list (map fromString list)) msel + ftextarea :: String -> String -> view+ fselect :: String -> view -> view+ foption :: String -> view -> Bool -> view + foption1 :: String -> Bool -> view + foption1 val msel= foption val (fromString val) msel formAction :: String -> view -> view addAttributes :: view -> Attribs -> view @@ -1643,11 +1698,11 @@ ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) "" ftextarea name text= btag "textarea" [("name", name)] $ pack text - foption name list msel= btag "select" [("name", name)] (mconcat- $ map (\(n,v) -> btag "option" ([("value", n)] ++ selected msel n) v) list)+ fselect name options= btag "select" [("name", name)] options + foption value content msel= btag "option" ([("value", value)] ++ selected msel) content where- selected msel n= if Just n == msel then [("selected","true")] else []+ selected msel = if msel then [("selected","true")] else [] addAttributes tag attrs = error "addAttributes not implemented for ByteString"
src/MFlow/Forms/Admin.hs view
@@ -28,6 +28,7 @@ import Control.Exception as E + ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done" -- | A small console interpreter with some commands:@@ -44,6 +45,16 @@ -- It must be used as the last statement of the main procedure. adminLoop :: IO () adminLoop= do+ msgs <- getMessageFlows+ putStrLn ""+ putStrLn $ "Served:"+ mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]+ putStrLn ""+ putStrLn "Commands: sync, flush, end, abort"+ adminLoop1++adminLoop1= do+ putStr ">"; hFlush stdout op <- getLine case op of "sync" -> ssyncCache@@ -51,7 +62,7 @@ "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess "abort" -> exitWith ExitSuccess _ -> return()- adminLoop+ adminLoop1 `E.catch` (\(e:: E.SomeException) ->do ssyncCache
src/MFlow/Forms/HSP.hs view
@@ -38,18 +38,14 @@ ftextarea name text= <textarea name=(name) > <% text %> </textarea> -- foption name list msel=- <select name=(name)>- <% map (\(n,v) ->- <option value=(n) selected=(selected msel n) >+ fselect name list= <select name=(name)> <%list%> </select>+ foption n v msel=+ <option value=(n) selected=(selected msel ) > <% v %>- </option> )- list- %>- </select>+ </option>+ where- selected msel n= if Just n == msel then "true" else "false"+ selected msel = if msel then "true" else "false" flink v str = <a href=(v)> <% str %> </a>
src/MFlow/Forms/XHtml.hs view
@@ -49,11 +49,10 @@ ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] ) ftextarea name text= X.textarea ! [X.name name] << text - foption name list msel= select ![ X.name name] << (concatHtml- $ map (\(n,v) -> X.option ! ([value n] ++ selected msel n) << v ) list)-+ fselect name list = select ![ X.name name] << list+ foption name v msel= X.option ! ([value name] ++ selected msel) << v where- selected msel n= if Just n == msel then [X.selected] else []+ selected msel = if msel then [X.selected] else [] addAttributes tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
src/MFlow/Hack.hs view
@@ -108,7 +108,7 @@ --theDir= unsafePerformIO getCurrentDirectory wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) -wFMiddleware filter f = \ env -> if filter env then hackWorkflow env else f env -- !> "new message" +wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message" -- | An instance of the abstract "MFlow" scheduler to the Hack interface -- it accept the list of processes being scheduled and return a hack handler @@ -126,11 +126,11 @@ -- options msgs= \"in the browser choose\\n\\n\" ++ -- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] -- @-hackMessageFlow :: [(String, (Token -> Workflow IO ()))]- -> (Env -> IO Response) -hackMessageFlow messageFlows = - unsafePerformIO (addMessageFlows messageFlows) `seq` - hackWorkflow -- wFMiddleware f other +--hackMessageFlow :: [(String, (Token -> Workflow IO ()))]+-- -> (Env -> IO Response) +--hackMessageFlow messageFlows = +-- unsafePerformIO (addMessageFlows messageFlows) `seq` +-- hackWorkflow -- wFMiddleware f other -- where -- f env = unsafePerformIO $ do -- paths <- getMessageFlows >>=@@ -151,8 +151,8 @@ -hackWorkflow :: Env -> IO Response -hackWorkflow req1= do +hackMessageFlow :: Env -> IO Response +hackMessageFlow req1= do let httpreq1= http req1 let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
src/MFlow/Hack/Response.hs view
@@ -33,21 +33,7 @@ Just y' -> TResp $ mappend x y' Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) -defaultResponse :: String -> IO Response -defaultResponse msg= return . toResponse $ "<p>Page not found or error ocurred:<br/>" ++ msg ++ "<br/><a href=\"/\" >home</a> </p>" -errorResponse msg=- "<h4>Page not found or error ocurred:</h4><h3>" <> msg <>- "</h3><br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a>" -- where - paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows-- opts= "options: " <> B.concat (Prelude.map (\s ->-- "<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)-- instance ToResponse TResp where toResponse (TResp x)= toResponse x toResponse (TRespR r)= toResponse r@@ -63,7 +49,7 @@ instance ToResponse HttpData where toResponse (HttpData hs cookies x)= (toResponse x) {headers= hs++ cookieHeaders cookies}- toResponse (Error NotFound str)= Response{status=404, headers=[], body= errorResponse str} + toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str} instance Typeable Env where typeOf = \_-> mkTyConApp (mkTyCon "Hack.Env") []
src/MFlow/Wai.hs view
@@ -138,11 +138,11 @@ -- options msgs= \"in the browser choose\\n\\n\" ++ -- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] -- @-waiMessageFlow :: [(String, (Token -> Workflow IO ()))]- -> (Request -> ResourceT IO Response) -waiMessageFlow messageFlows = - unsafePerformIO (addMessageFlows messageFlows) `seq` - waiWorkflow -- wFMiddleware f other+--waiMessageFlow :: [(String, (Token -> Workflow IO ()))]+-- -> (Request -> ResourceT IO Response) +--waiMessageFlow messageFlows = +-- unsafePerformIO (addMessageFlows messageFlows) `seq` +-- waiWorkflow -- wFMiddleware f other -- where -- f env = unsafePerformIO $ do@@ -164,8 +164,8 @@ -waiWorkflow :: Request -> ResourceT IO Response -waiWorkflow req1= do +waiMessageFlow :: Request -> ResourceT IO Response +waiMessageFlow req1= do let httpreq1= getParams req1 let cookies=getCookies httpreq1
src/MFlow/Wai/Response.hs view
@@ -34,22 +34,7 @@ Just y' -> TResp $ mappend x y' Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) -defaultResponse :: String -> IO Response -defaultResponse msg= return . toResponse $ "<p>Page not found or error ocurred:<br/>" ++ msg ++ "<br/><a href=\"/\" >home</a> </p>" --errorResponse msg=- "<h4>Page not found or error ocurred:</h4><h3>" <> msg <>- "</h3><br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a>" -- where - paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows-- opts= "options: " <> B.concat (Prelude.map (\s ->-- "<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)-- ctype1= [mkparam ctype] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")] mkParams = Prelude.map mkparam mkparam (x,y)= (mk $ SB.pack x, SB.pack y)@@ -70,6 +55,6 @@ instance ToResponse HttpData where toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams $ hs ++ cookieHeaders cookies) x- toResponse (Error NotFound str)= responseLBS status404 [] $ errorResponse str + toResponse (Error NotFound str)= responseLBS status404 [] $ getNotFoundResponse str