diff --git a/Demos/ShoppingCart.Wai.hs b/Demos/ShoppingCart.Wai.hs
--- a/Demos/ShoppingCart.Wai.hs
+++ b/Demos/ShoppingCart.Wai.hs
@@ -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"
diff --git a/Demos/ShoppingCart.hs b/Demos/ShoppingCart.hs
--- a/Demos/ShoppingCart.hs
+++ b/Demos/ShoppingCart.hs
@@ -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
diff --git a/Demos/demos.hs b/Demos/demos.hs
--- a/Demos/demos.hs
+++ b/Demos/demos.hs
@@ -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") ) 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")
diff --git a/MFlow.cabal b/MFlow.cabal
--- a/MFlow.cabal
+++ b/MFlow.cabal
@@ -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 .
diff --git a/src/MFlow.hs b/src/MFlow.hs
--- a/src/MFlow.hs
+++ b/src/MFlow.hs
@@ -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=
+ "
Error 404: Page not found or error ocurred:
" <> msg <>
+ "
" <> opts <> " press here to go home"
+
+ where
+ paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
+ opts= "options: " <> B.concat (Prelude.map (\s ->
+ " s <>"\">"<> s <>", ") 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)]
diff --git a/src/MFlow/Forms.hs b/src/MFlow/Forms.hs
--- a/src/MFlow/Forms.hs
+++ b/src/MFlow/Forms.hs
@@ -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) 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"
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
@@ -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
diff --git a/src/MFlow/Forms/HSP.hs b/src/MFlow/Forms/HSP.hs
--- a/src/MFlow/Forms/HSP.hs
+++ b/src/MFlow/Forms/HSP.hs
@@ -38,18 +38,14 @@
ftextarea name text=
-
- foption name list msel=
-
+
+
where
- selected msel n= if Just n == msel then "true" else "false"
+ selected msel = if msel then "true" else "false"
flink v str = <% str %>
diff --git a/src/MFlow/Forms/XHtml.hs b/src/MFlow/Forms/XHtml.hs
--- a/src/MFlow/Forms/XHtml.hs
+++ b/src/MFlow/Forms/XHtml.hs
@@ -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)
diff --git a/src/MFlow/Hack.hs b/src/MFlow/Hack.hs
--- a/src/MFlow/Hack.hs
+++ b/src/MFlow/Hack.hs
@@ -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
diff --git a/src/MFlow/Hack/Response.hs b/src/MFlow/Hack/Response.hs
--- a/src/MFlow/Hack/Response.hs
+++ b/src/MFlow/Hack/Response.hs
@@ -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 $ "
Page not found or error ocurred: " ++ msg ++ " home
"
-errorResponse msg=
- "
Page not found or error ocurred:
" <> msg <>
- "
" <> opts <> " press here to go home"
-
- where
- paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
-
- opts= "options: " <> B.concat (Prelude.map (\s ->
-
- " s <>"\">"<> s <>", ") 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") []
diff --git a/src/MFlow/Wai.hs b/src/MFlow/Wai.hs
--- a/src/MFlow/Wai.hs
+++ b/src/MFlow/Wai.hs
@@ -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
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
@@ -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 $ "
Page not found or error ocurred: " ++ msg ++ " home