MFlow 0.2.0.9 → 0.3.0.0
raw patch · 11 files changed
+3271/−2382 lines, 11 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- MFlow.Forms: instance [incoherent] (Monad m, Functor m, Monoid a) => Monoid (View v m a)
+ MFlow: pwfPath :: Processable a => a -> [String]
+ MFlow: sendToMF :: (Typeable a, Processable a) => Token -> a -> IO ()
+ MFlow: tpath :: Token -> [String]
+ MFlow.Forms: notValid :: Monad m => view -> View view m a
+ MFlow.Forms: page :: FormInput view => View view IO a -> FlowM view IO a
+ MFlow.Forms: pageFlow :: (Monad m, Functor m, FormInput view) => String -> View view m a -> View view m a
+ MFlow.Forms: wcallback :: Monad m => View view m a -> (a -> View view m b) -> View view m b
+ MFlow.Forms: wlabel :: (Monad m, FormInput view) => view -> View view m a -> View view m a
+ MFlow.Forms.Widgets: autoRefresh :: (MonadIO m, FormInput v) => View v m a -> View v m a
+ MFlow.Forms.Widgets: datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int, Int, Int)
+ MFlow.Forms.Widgets: getSpinner :: (MonadIO m, Read a, Show a, Typeable a, FormInput view) => String -> Maybe a -> View view m a
+ MFlow.Forms.Widgets: wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
+ MFlow.Wai.Blaze.Html.All: runServer :: FormInput view => FlowM view (Workflow IO) () -> IO Bool
+ MFlow.Wai.Blaze.Html.All: runServerTransient :: FormInput view => FlowM view IO () -> IO Bool
- MFlow: Token :: String -> String -> String -> Params -> MVar Req -> MVar Resp -> Token
+ MFlow: Token :: String -> String -> String -> [String] -> Params -> MVar Req -> MVar Resp -> Token
- MFlow: class Processable a
+ MFlow: class Processable a where pwfname = head . pwfPath
- MFlow: getNotFoundResponse :: IO (ByteString -> ByteString)
+ MFlow: getNotFoundResponse :: IO (String -> [Char] -> HttpData)
- MFlow: setNotFoundResponse :: MonadIO m => (ByteString -> ByteString) -> m ()
+ MFlow: setNotFoundResponse :: (String -> String -> HttpData) -> IO ()
- MFlow.Forms: getBool :: (FormInput view, Monad m) => Bool -> String -> String -> View view m Bool
+ MFlow.Forms: getBool :: (FormInput view, Monad m, Functor m) => Bool -> String -> String -> View view m Bool
- MFlow.Forms: goingBack :: MonadState (MFlowState view) m => m Bool
+ MFlow.Forms: goingBack :: (MonadIO m, MonadState (MFlowState view) m) => m Bool
- MFlow.Forms: runFlow :: (FormInput view, Monad m) => FlowM view m () -> Token -> m ()
+ MFlow.Forms: runFlow :: (FormInput view, MonadIO m) => FlowM view m () -> Token -> m ()
- MFlow.Forms: wlink :: (Typeable a, Read a, Show a, MonadIO m, Functor m, FormInput view) => a -> view -> View view m a
+ MFlow.Forms: wlink :: (Typeable a, Show a, MonadIO m, FormInput view) => a -> view -> View view m a
Files
- Demos/demos.blaze.hs +505/−323
- MFlow.cabal +91/−70
- src/MFlow.hs +403/−405
- src/MFlow/Forms.hs +419/−241
- src/MFlow/Forms/Admin.hs +169/−166
- src/MFlow/Forms/Internals.hs +1237/−938
- src/MFlow/Forms/Test.hs +125/−125
- src/MFlow/Forms/Widgets.hs +183/−19
- src/MFlow/Wai.hs +14/−7
- src/MFlow/Wai/Blaze/Html/All.hs +87/−50
- src/MFlow/Wai/Response.hs +38/−38
Demos/demos.blaze.hs view
@@ -1,325 +1,507 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Main where-import MFlow.Wai.Blaze.Html.All-import Text.Blaze.Html5 as El-import Text.Blaze.Html5.Attributes as At hiding (step)-import Data.String-import Data.List-import Data.TCache-import Data.Typeable-import Control.Monad.Trans-import Control.Concurrent-import Control.Exception as E-import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.Text as T-import qualified Data.Vector as V-import Data.Maybe-import Data.Monoid----test= runTest [(15,"shop")]--main= do- setAdminUser "admin" "admin"- syncWrite SyncManual- setFilesPath ""- addMessageFlows- [("" , transient $ runFlow mainmenu)- ,("shop", runFlow shopCart)]-- wait $ run 8081 waiMessageFlow---fstr= fromString--data Options= CountI | CountS | Radio- | Login | TextEdit |Grid | Autocomp | AutocompList- | ListEdit |Shop | Action | Ajax | Select- | CheckBoxes | PreventBack deriving (Bounded, Enum,Read, Show,Typeable)--mainmenu= do- setHeader stdheader- setTimeouts 100 0- 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 << "login/logout"- <|> br ++> wlink PreventBack << b << "Prevent going back after a transaction"--- case r of- CountI -> clickn 0- CountS -> clicks "1"- Action -> actions 1- Ajax -> ajaxsample- Select -> options- CheckBoxes -> checkBoxes- TextEdit -> textEdit- Grid -> grid- Autocomp -> autocomplete1- AutocompList -> autocompList- ListEdit -> wlistEd- Radio -> radio- 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 << "select a option") <|>- setOption "blue" (b << "blue") <|>- setOption "Red" (b << "red") ) <! dosummit- ask $ p << (r ++ " selected") ++> wlink () (p << " menu")-- mainmenu -- breturn() would do it as well- where- dosummit= [("onchange","this.form.submit()")]--checkBoxes= do- r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << "red")- <> (setCheckBox False "Green" <++ b << "green")- <> (setCheckBox False "blue" <++ b << "blue"))- <** submitButton "submit"-- ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu")- mainmenu--autocomplete1= do- 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 << " menu")- mainmenu- where- filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"]--autocompList= do- 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 << " 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 "")- <++ tdborder << delLink)- 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 ["",""] "wEditListAdd") <** submitButton "submit"- ask $ p << (show r ++ " returned")- ++> wlink () (p << " back to menu")-- mainmenu--wlistEd= do- r <- ask $ addLink- ++> br- ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd")- <++ br- <** submitButton "send"-- ask $ p << (show r ++ " returned")- ++> wlink () (p << " back to menu")- mainmenu- where- 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 << "increase an Int"- ++> wlink ("menu" :: String) (p << "menu")- |+| getInt (Just n) <* submitButton "submit"- case r of- (Just _,_) -> mainmenu- (_, Just n') -> clickn $ n'+1---clicks s= do- 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 (b << "length must be < 5") else Nothing )- clicks $ s'++ "1"--radio = do- r <- ask $ p << b << "Radio buttons"- ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]]- ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu")- mainmenu---ajaxsample= do- r <- ask $ p << b << "Ajax example that increment the value in a box"- ++> do- let elemval= "document.getElementById('text1').value"- ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'"- b << "click the box"- ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]<** submitButton "submit"- ask $ p << ( show r ++ " returned") ++> wlink () (p << " menu")- mainmenu------ recursive callbacks---actions n=do--- ask $ wlink () (p << "exit from action")--- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions )---actions n= do- 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 << " menu")- mainmenu- where- action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action"--data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum,Read, Show, Typeable)--shopCart = do- 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\- \The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events."- <> html)- setTimeouts 10 0- shopCart1 (V.fromList [0,0,0:: Int])- where- shopCart1 cart= do- o <- step . ask $- 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 (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- let newCart= cart V.// [(i, cart V.! i + 1 )]- shopCart1 newCart-- where- linkHome= a ! href (fstr noScript) << b << "home"---loginSample= do- ask $ p << "Please login with admin/admin"- ++> userWidget (Just "admin") userLogin- user <- getCurrentUser- ask $ b << ("user logged as " <> user) ++> wlink () (p << " logout and go to menu")- logout- mainmenu---textEdit= do-- let first= p << i <<- (El.span << "this is a page with"- <> b << " two " <> El.span << "paragraphs. this is the first")-- second= p << i << "This is the original of the second paragraph"---- ask $ p << b << "An example of content management"- ++> first- ++> second- ++> wlink () (p << "click here to edit it")--- ask $ p << "Please login with admin/admin to edit it"- ++> userWidget (Just "admin") userLogin-- 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 << "click here to see it as a normal user")-- logout-- ask $ p << "the user sees the edited content. He can not edit"- ++> tFieldEd "first" first- **> tFieldEd "second" second- **> wlink () (p << "click to continue")-- 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 << "End of edit field demo" ++> wlink () (p << "click here to go to menu")--+{-# LANGUAGE DeriveDataTypeable #-} +module Main where +import MFlow.Wai.Blaze.Html.All +import Text.Blaze.Html5 as El +import Text.Blaze.Html5.Attributes as At hiding (step) +import Data.String +import Data.List +import Data.TCache +import Data.Typeable +import Control.Monad.Trans +import Control.Concurrent +import Control.Exception as E +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Maybe +import Data.Monoid +import System.IO.Unsafe +import System.Environment +import Debug.Trace + +-- +--import Control.Monad.State +--import MFlow.Forms.Internals +(!>) = const -- flip trace + +--test= runTest [(15,"shop")] + +main= do + setAdminUser "admin" "admin" + syncWrite SyncManual + setFilesPath "" + addMessageFlows + [("" , transient $ runFlow mainmenu) + ,("shop", runFlow shopCart)] + env <- getEnvironment + let port = fromIntegral . read . fromMaybe "80" $ lookup "PORT" env + wait $ run port waiMessageFlow + + +attr= fromString +text = fromString + +data Options= CountI | CountS | Radio + | Login | TextEdit |Grid | Autocomp | AutocompList + | ListEdit |Shop | Action | Ajax | Select + | CheckBoxes | PreventBack | Multicounter + | Combination + | FViewMonad | Counter | WDialog + deriving (Bounded, Enum,Read, Show,Typeable) + + +mainmenu= do + setHeader stdheader + setTimeouts 100 0 + r <- ask $ do + requires[CSSFile "http://jqueryui.com/resources/demos/style.css"] + wcached "menu" 0 $ + b << "BASIC" + ++> br ++> wlink CountI << b << "increase an Int" + <|> br ++> wlink CountS << b << "increase a String" + <|> br ++> wlink Select << b << "select options" + <|> br ++> wlink CheckBoxes << b << "checkboxes" + <|> br ++> wlink Radio << b << "Radio buttons" + + <++ br <> br <> b << "WIDGET ACTIONS & CALLBACKS" + <|> br ++> wlink Action << b << "Example of action, executed when a widget is validated" + <|> br ++> wlink FViewMonad << b << "in page flow: sum of three numbers" + <|> br ++> wlink Counter << b << "Counter" + <|> br ++> wlink Multicounter << b << "Multicounter" + <|> br ++> wlink Combination << b << "combination of three active widgets" + <|> br ++> wlink WDialog << b << "modal dialog" + + <++ 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 (attr "/shop") << "shopping" -- ordinary Blaze.Html link + + <> br <> br <> b << "OTHERS" + <|> br ++> wlink Login << b << "login/logout" + <|> br ++> wlink PreventBack << b << "Prevent going back after a transaction" + + + + case r of + CountI -> clickn (0 :: Int) + CountS -> clicks "1" + Action -> actions 1 + Ajax -> ajaxsample + Select -> options + CheckBoxes -> checkBoxes + TextEdit -> textEdit + Grid -> grid + Autocomp -> autocomplete1 + AutocompList -> autocompList + ListEdit -> wlistEd + Radio -> radio + Login -> loginSample + PreventBack -> preventBack + Multicounter-> multicounter + FViewMonad -> sumInView + Counter -> counter + Combination -> combination + WDialog -> wdialog1 + +wdialog1= ask wdialogw -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"+wdialogw= pageFlow "diag" $ do + r <- wform $ p<< "please enter your name" ++> getString (Just "your name") <** submitButton "ok" + wdialog "({modal: true})" "question" $ + p << ("Do your name is \""++r++"\"?") ++> getBool True "yes" "no" <** submitButton "ok" - <> 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."- )+ `wcallback` \q -> if not q then wdialogw+ else wlink () << b << "thanks, press here to go to the menu" + + +sumInView= ask $ p << "ask for three numbers in the same page and display the result.\ + \It is possible to modify the inputs and the sum will reflect it" + ++> sumWidget + **> wlink () << text "exit" + +formWidget= wform $ do + (n,s) <- (,) <$> p << "Who are you?" + ++> getString Nothing <! hint "name" <++ br + <*> getString Nothing <! hint "surname" <++ br + <** submitButton "ok" <++ br + + flag <- b << "Do you " ++> getRadio[radiob "work?",radiob "study?"] <++ br + + r<- case flag of + "work?" -> pageFlow "l" + $ Left <$> b << "do you enjoy your work? " + ++> getBool True "yes" "no" + <** submitButton "ok" <++ br + + "study?"-> pageFlow "r" + $ Right <$> b << "do you study in " + ++> getRadio[radiob "University" + ,radiob "High School"] + u <- getCurrentUser + p << ("You are "++n++" "++s) + ++> p << ("And your user is: "++ u) + ++> case r of + Left fl -> p << ("You work and it is " ++ show fl ++ " that you enjoy your work") + ++> noWidget + + Right stu -> p << ("You study at the " ++ stu) + ++> noWidget + + +hint s= [("placeholder",s)] +onClickSubmit= [("onclick","if(window.jQuery){\n\ + \$(this).parent().submit();}\n\ + \else {this.form.submit()}")] +radiob s n= wlabel (text s) $ setRadio s n <! onClickSubmit + +sumWidget= do + n1 <- p << "Enter first number" ++> getInt Nothing <** submitButton "enter" <++ br + n2 <- p << "Enter second number" ++> getInt Nothing <** submitButton "enter" <++ br + n3 <- p << "Enter third number" ++> getInt Nothing <** submitButton "enter" <++ br + p << ("The result is: "++show (n1 + n2 + n3)) ++> wlink () << b << " menu" + <++ p << "you can change them to see the result" + + + +combination = ask $ + p << "Three active widgets in the same page with autoRefresh. Each widget refresh itself \ + \with Ajax. If Ajax is not active, they will refresh by sending a new page." + ++> hr + ++> p << "Login widget (use admin/admin)" ++> autoRefresh (pageFlow "r" wlogin) <++ hr + **> p << "Counter widget" ++> autoRefresh (pageFlow "c" (counterWidget 0)) <++ hr + **> p << "Dynamic form widget" ++> autoRefresh (pageFlow "f" formWidget) <++ hr + **> wlink () << b << "exit" + +wlogin :: View Html IO () +wlogin= wform (do + username <- getCurrentUser + if username /= anonymous + then return username + else do + name <- getString Nothing <! hint "username" <++ br + pass <- getPassword <! focus <** submitButton "login" <++ br + val <- userValidate (name,pass) + case val of + Just msg -> notValid msg + Nothing -> login name >> return name) + + `wcallback` (\name -> b << ("logged as " ++ name) + ++> p << ("navigate away of this page before logging out") + ++> wlink "logout" << b << " logout") + `wcallback` const (logout >> wlogin) + +focus = [("onload","this.focus()")] + + +multicounter= do + let explain= p << "This example emulates the" + <> a ! href (attr "http://www.seaside.st/about/examples/multicounter?_k=yBJEDEGp") + << " seaside example" + <> p << "It uses various copies of the " <> a ! href (attr "/noscript/counter") << "counter widget " + <> text "instantiated in the same page. This is an example of how it is possible to " + <> text "compose widgets with independent behaviours" + + ask $ explain ++> add (counterWidget 0) [1,2] <|> wlink () << p << "exit" + + +add widget list= firstOf [pageFlow (show i) widget <++ hr | i <- list] + +counter1= do + ask $ wlink "p" <<p<<"press here" + ask $ pageFlow "c" $ ex [ wlink i << text (show (i :: Int)) | i <- [1..] ] + where + + ex (a:as)= a >> ex as +counter= do + let explain= p <<"This example emulates the" + <> a ! href (attr "http://www.seaside.st/about/examples/counter") << "seaside counter example" + <> p << "This widget uses a callback to permit an independent" + <> p << "execution flow for each widget." <> a ! href (attr "/noscript/multicounter") << "Multicounter" <> (text " instantiate various counter widgets") + <> p << "But while the seaside case the callback update the widget object, in this case" + <> p << "the callback call generates a new copy of the counter with the value modified." + + ask $ explain ++> pageFlow "c" (counterWidget 0) <++ br <|> wlink () << p << "exit" + +counterWidget n= do + (h2 << show n !> show n + ++> wlink "i" << b << " ++ " + <|> wlink "d" << b << " -- ") + `wcallback` + \op -> case op of + "i" -> counterWidget (n + 1) !> "increment" + "d" -> counterWidget (n - 1) !> "decrement" + +rpaid= unsafePerformIO $ newMVar (0 :: Int) + + +preventBack= do + ask $ wlink () << b << "press here to pay 100000 $ " + payIt + paid <- liftIO $ readMVar rpaid + preventGoingBack . ask $ p << "You already paid 100000 before" + ++> p << "you can no go back until the end of the buy process" + ++> wlink () << p << "Please press here to continue" + ask $ p << ("you paid "++ show paid) + ++> wlink () << p << "Press here to go to the menu or press the back button to verify that you can not pay again" + where + payIt= liftIO $ do + print "paying" + paid <- takeMVar rpaid + putMVar rpaid $ paid + 100000 + +options= do + r <- ask $ getSelect (setSelectedOption "" (p << "select a option") <|> + setOption "red" (b << "red") <|> + setSelectedOption "blue" (b << "blue") <|> + setOption "Green" (b << "Green") ) + <! dosummit + ask $ p << (r ++ " selected") ++> wlink () (p << " menu") + + + where + dosummit= [("onchange","this.form.submit()")] + +checkBoxes= do + 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 << " menu") + + +autocomplete1= do + r <- ask $ p << "Autocomplete " + ++> p << "when su press submit, the box value is returned" + ++> wautocomplete Nothing filter1 <! hint "red,green or blue" + <** submitButton "submit" + ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") + + where + filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] + +autocompList= do + 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 << " menu") + + 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 "") + <++ tdborder << delLink) + addLink= a ! href (attr "#") + ! At.id (attr "wEditListAdd") + << "add" + delLink= a ! href (attr "#") + ! onclick (attr "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)") + << "delete" + tdborder= td ! At.style (attr "border: solid 1px") + + r <- ask $ addLink ++> ( wEditList table row ["",""] "wEditListAdd") <** submitButton "submit" + ask $ p << (show r ++ " returned") + ++> wlink () (p << " back to menu") + + + +wlistEd= do + r <- ask $ addLink + ++> br + ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd") + <++ br + <** submitButton "send" + + ask $ p << (show r ++ " returned") + ++> wlink () (p << " back to menu") + + + where + addLink = a ! At.id (attr "wEditListAdd") + ! href (attr "#") + $ b << "add" + delBox = input ! type_ (attr "checkbox") + ! checked (attr "") + ! onclick (attr "this.parentNode.parentNode.removeChild(this.parentNode)") + getString1 mx= El.div <<< delBox ++> getString mx <++ br + + +clickn n= do + r <- ask $ p << b << "increase an Int" + ++> wlink "menu" << p << "menu" + |+| getInt (Just n) <* submitButton "submit" + case r of + (Just _,_) -> return () -- ask $ wlink () << p << "thanks" + (_, Just n') -> clickn $ n'+1 + + +clicks s= do + 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 (b << "length must be < 5") else Nothing ) + clicks $ s'++ "1" + + +radio = do + r <- ask $ p << b << "Radio buttons" + ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] + + ask $ p << ( show r ++ " selected") ++> wlink () << p << " menu" + +ajaxsample= do + r <- ask $ p << b << "Ajax example that increment the value in a box" + ++> do + let elemval= "document.getElementById('text1').value" + ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'" + b << "click the box " + ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)] <** submitButton "submit" + ask $ p << ( show r ++ " returned") ++> wlink () << p << " menu" + + +---- recursive action +--actions n=do +-- ask $ wlink () (p << "exit from action") +-- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) + + +actions n= do + 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 << " menu" + where + action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action" + +data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum, Show,Read , Typeable) + +newtype Cart= Cart (V.Vector Int) deriving Typeable +emptyCart= Cart $ V.fromList [0,0,0] + +shopCart = do + + setHeader $ \html -> p << ( El.span << + "A persistent flow (uses step). The process is killed after 100 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\ + \The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events." + + <> html) + setTimeouts 100 (60 * 60) + shopCart1 + where + shopCart1 = do + o <- step . ask $ do + let moreexplain= p << "The second parameter of \"setTimeout\" is the time during which the cart is recorded" + Cart cart <- getSessionData `onNothing` return emptyCart + + moreexplain + ++> + (table ! At.style (attr "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 (attr "2") << td << linkHome + ++> (tr <<< td <<< wlink IPhone (b << "iphone") <++ td << ( b << show ( cart V.! 0)) + <|> tr <<< td <<< wlink IPod (b << "ipod") <++ td << ( b << show ( cart V.! 1)) + <|> tr <<< td <<< wlink IPad (b << "ipad") <++ td << ( b << show ( cart V.! 2))) + <++ tr << td << linkHome + )) + let i =fromEnum o + Cart cart <- getSessionData `onNothing` return emptyCart + setSessionData . Cart $ cart V.// [(i, cart V.! i + 1 )] + shopCart1 + + where + linkHome= a ! href (attr $ "/" ++ noScript) << b << "home" + + +loginSample= do + ask $ p << "Please login with admin/admin" + ++> userWidget (Just "admin") userLogin + user <- getCurrentUser + ask $ b << ("user logged as " <> user) ++> wlink () << p << " logout and go to menu" + logout + + + +textEdit= do + let first= p << i << + (El.span << "this is a page with" + <> b << " two " <> El.span << "paragraphs. this is the first") + + second= p << i << "This is the original of the second paragraph" + + + + ask $ p << b << "An example of content management" + ++> first + ++> second + ++> wlink () << p << "click here to edit it" + + + ask $ p << "Please login with admin/admin to edit it" + ++> userWidget (Just "admin") userLogin + + 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 << "click here to see it as a normal user" + + logout + + ask $ p << "the user sees the edited content. He can not edit" + ++> tFieldEd "first" first + **> tFieldEd "second" second + **> wlink () << p << "click to continue" + + 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 << "End of edit field demo" ++> wlink () << p << "click here to go to menu" + + + +stdheader= html . body + +stdheader1 c= docTypeHtml $ body $ + a ! At.style (attr "-align:center") ! href ( attr "/html/MFlow/index.html") << h1 << "MFlow" + <> br + <> hr + <> (El.div ! At.style (attr "position:fixed;top:40px;left:0%\ + \;width:50%\ + \;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 (attr "position:fixed;top:40px;left:50%;width:50%") $ + h2 << "Documentation" + <> br + <> p << a ! href (attr "/html/MFlow/index.html") << "MFlow package description and documentation" + <> p << a ! href (attr "demos.blaze.hs") << "download demo source code" + <> p << a ! href (attr "https://github.com/agocorona/MFlow/issues") << "bug tracker" + <> p << a ! href (attr "https://github.com/agocorona/MFlow") << "source repository" + <> p << a ! href (attr "http://hackage.haskell.org/package/MFlow") << "Hackage repository" + <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/11/mflow-now-widgets-can-express.html") << "MFlow: now the widgets can express requirements" + <> p << a ! href (attr "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 (attr "http://haskell-web.blogspot.com.es/2013/01/now-example-of-use-of-active-widget.html") << "MFlow active widgets example" + <> p << a ! href (attr "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 (attr "http://haskell-web.blogspot.com.es/2012/11/i-just-added-some-templatingcontent.html") << "Content Management and multilanguage in MFlow" + <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/10/testing-mflow-applications_9.html") << "Testing MFlow applications" + <> p << a ! href (attr "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 (attr "http://haskell-web.blogspot.com.es/2012/09/announce-mflow-015.html") << "ANNOUNCE MFlow 0.1.5 Web app server for stateful processes with safe, composable user interfaces." + )
MFlow.cabal view
@@ -1,84 +1,105 @@-name: MFlow-version: 0.2.0.9-cabal-version: >=1.6-build-type: Simple-license: BSD3-license-file: LICENSE-maintainer: agocorona@gmail.com-stability: experimental-Bug-reports: https://github.com/agocorona/MFlow/issues-synopsis: continuation-based Web framework without continuations.-description: 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. It is not continuation based. It uses a log for thread state persistence and backtracking forall- handling the back button. Because the serialized state is small and can be synchronized,- potentially that makes the MFlow architecture scalable.+name: MFlow +version: 0.3.0.0 +cabal-version: >=1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: agocorona@gmail.com +stability: experimental +Bug-reports: https://github.com/agocorona/MFlow/issues +synopsis: stateful, RESTful web framework +description: MFlow run stateful server processes. This version is the first stateful web framework+ that is as RESTful as a web framework can be. .- These processes are stopped and restarted by the- application server on demand, including the execution state (if the Wokflow monad is used.- Therefore session management is automatic. State consistence and transactions are given by the TCache package.+ The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links+ point to alternative routes within this monadic computation just like a textual menu+ in a console application. Any GET page is directly reachable by means of a RESTful URL. .- The processes interact trough widgets, that are an extension of formlets with- additional applicative combinators, formatting, link management, callbacks, modifiers, caching,- byteString conversion and AJAX. All is coded in pure haskell.+ All the flow of requests and responses are coded by the programmer in a single procedure. + Allthoug single request-response flows are possible. Therefore, the code is + more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for + handling the back button. Back button state syncronization is supported out-of-the-box .- The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString- , Hack and WAI but it can be extended to non Web based architectures.+ The MFlow architecture is scalable, since the state is serializable and small + . + The processes are stopped and restarted by the + application server on demand, including the execution state (if the Wokflow monad is used). + Therefore session management is automatic. State consistence and transactions are given by the TCache package. + . + The processes interact trough widgets, that are an extension of formlets with + additional applicative combinators, formatting, link management, callbacks, modifiers, caching, + byteString conversion and AJAX. All is coded in pure haskell. .- Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files.- To use them, add then to the exported modules and execute cabal install+ The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString + , Hack and WAI but it can be extended to non Web based architectures. + . + Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files. + To use them, add then to the exported modules and execute cabal install + . + It is designed for applications that can be run with no deployment with runghc in order + to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html> .- It is designed for applications that can be run with no deployment with runghc in order- to speed up the development process. see "Web application in a tweet": http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html+ This release includes: .- The previous release (0.1) add transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX,- and WAI integration.+ - /RESTful/ URLs .- This version (0.2) add better WAI integration, higher level dynamic Widgets, content management, multilanguage, blaze-html support,- stateful ajax for server-side control, user-defined data in sessions and widget requirements for automatic installation of scripts, CSS and server flows.+ - Automatic independent refreshing of widgets via Ajax. (see <http://haskell-web.blogspot.com.es/2013/06/and-finally-widget-auto-refreshing.html>) .- This version (0.2.0.9) add the runFlowConf primitive+ - Now each widget can be monadic so it can express his own behaviour and can run its own independent page flow. (see <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html>) .- See "MFlow.Forms" for details+ - Per-widget callbacks, used in page flows, that change the rendering of the widget (see <http://haskell-web.blogspot.com.es/2013/06/callbacks-in-mflow.html>) .- 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.+ - Widgets in modal and non modal dialogs (using jQuery dialog) .- To do:+ - Other jQuery widgets as MFlow widgets: spinner, datepicker + . + The version 0.2 added better WAI integration, higher level dynamic Widgets, content management, multilanguage, blaze-html support, + stateful ajax for server-side control, user-defined data in sessions and widget requirements for automatic installation of scripts, CSS and server flows. .+ The version 0.1 added transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX, + and WAI integration. + . + See "MFlow.Forms" for details + . . + To do: + . -Clustering .-category: Web, Application Server-author: Alberto Gómez Corona-data-dir: ""-extra-source-files: Demos/demos.blaze.hs- , src/MFlow/Hack.hs- , src/MFlow/Hack/Response.hs- , src/MFlow/Hack/XHtml.hs- , src/MFlow/Hack/XHtml/All.hs- , src/MFlow/Forms/HSP.hs--source-repository head- type: git- location: http://github.com/agocorona/MFlow--library- build-depends: Workflow -any, transformers -any, mtl -any,- extensible-exceptions -any, xhtml -any, base >4.0 && <5,- bytestring -any, containers -any, RefSerialize -any, TCache -any,- stm >2, 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,- random -any,- blaze-html -any, blaze-markup -any- exposed-modules: MFlow MFlow.Wai.Blaze.Html.All- MFlow.Forms MFlow.Forms.Admin- MFlow.Cookies MFlow.Wai- MFlow.Wai.XHtml.All MFlow.Forms.XHtml- MFlow.Forms.Blaze.Html MFlow.Forms.Test- MFlow.Forms.Widgets- other-modules: MFlow.Forms.Internals MFlow.Wai.Response- exposed: True- buildable: True- hs-source-dirs: src .-+ -Automatic error traces + . +category: Web, Application Server +author: Alberto Gómez Corona +data-dir: "" +extra-source-files: Demos/demos.blaze.hs + , src/MFlow/Hack.hs + , src/MFlow/Hack/Response.hs + , src/MFlow/Hack/XHtml.hs + , src/MFlow/Hack/XHtml/All.hs + , src/MFlow/Forms/HSP.hs + + +source-repository head + type: git + location: http://github.com/agocorona/MFlow + +library + build-depends: Workflow -any, transformers -any, mtl -any, + extensible-exceptions -any, xhtml -any, base >4.0 && <5, + bytestring -any, containers -any, RefSerialize -any, TCache -any, + stm >2, 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, + random -any, + blaze-html -any, blaze-markup -any + + exposed-modules: MFlow MFlow.Wai.Blaze.Html.All + MFlow.Forms MFlow.Forms.Admin + MFlow.Cookies MFlow.Wai + MFlow.Wai.XHtml.All MFlow.Forms.XHtml + MFlow.Forms.Blaze.Html MFlow.Forms.Test + MFlow.Forms.Widgets + other-modules: MFlow.Forms.Internals MFlow.Wai.Response + exposed: True + buildable: True + hs-source-dirs: src . +
src/MFlow.hs view
@@ -1,224 +1,228 @@-{- | Non monadic low level primitives that implement the MFlow application server.-See "MFlow.Form" for the higher level interface that you may use.--it implements an scheduler of 'Processable' messages that are served according with-the source identification and the verb invoked.-The scheduler executed the appropriate workflow (using the workflow package).-The workflow will send additional messages to the source and wait for the responses.-The diaglog is identified by a 'Token', which is associated to the flow.-. The computation state is optionally logged. On timeout, the process is killed. When invoked again,-the execution state is recovered as if no interruption took place.--There is no asumption about message codification, so instantiations-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 and applicative-combinator as well as an higher comunication interface.--"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format--"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html--"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format--There are some @*.All@ packages thant contain a mix of these instantiations.-For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with-Wai <http://hackage.haskell.org/package/wai> and-Blaze-html <http://hackage.haskell.org/package/blaze-html>---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 higher level interface.--Fragment based streaming: 'sendFragment' are provided only at this level.--'stateless' and 'transient' server processeses are also possible. the first are request-response- . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash.---}---{-# LANGUAGE DeriveDataTypeable, UndecidableInstances- ,ExistentialQuantification- ,MultiParamTypeClasses- ,FunctionalDependencies- ,TypeSynonymInstances- ,FlexibleInstances- ,FlexibleContexts- ,RecordWildCards- ,OverloadedStrings- ,ScopedTypeVariables+{- | Non monadic low level primitives that implement the MFlow application server. +See "MFlow.Form" for the higher level interface that you may use. + +it implements an scheduler of 'Processable' messages that are served according with +the source identification and the verb invoked. +The scheduler executed the appropriate workflow (using the workflow package). +The workflow will send additional messages to the source and wait for the responses. +The diaglog is identified by a 'Token', which is associated to the flow. +. The computation state is optionally logged. On timeout, the process is killed. When invoked again, +the execution state is recovered as if no interruption took place. + +There is no asumption about message codification, so instantiations +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 and applicative +combinator as well as an higher comunication interface. + +"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format + +"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html + +"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format + +There are some @*.All@ packages that contain a mix of these instantiations. +For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with +Wai <http://hackage.haskell.org/package/wai> and +Blaze-html <http://hackage.haskell.org/package/blaze-html> + + +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 higher level interface. + +Fragment based streaming: 'sendFragment' are provided only at this level. + +'stateless' and 'transient' server processeses are also possible. the first are request-response + . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash. + +-} + + +{-# LANGUAGE DeriveDataTypeable, UndecidableInstances + ,ExistentialQuantification + ,MultiParamTypeClasses + ,FunctionalDependencies + ,TypeSynonymInstances + ,FlexibleInstances + ,FlexibleContexts + ,RecordWildCards + ,OverloadedStrings + ,ScopedTypeVariables #-} -module MFlow (-Flow, Params, HttpData(..),Processable(..)-, Token(..), ProcList--- * low level comunication primitives. Use `ask` instead-,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment-, sendEndFragment--- * Flow configuration-,addMessageFlows,getMessageFlows, transient, stateless,anonymous-,noScript,hlog, setNotFoundResponse,getNotFoundResponse,--- * ByteString tags--- | very basic but efficient tag formatting-btag, bhtml, bbody,Attribs, addAttrs---- * static files-,setFilesPath--- * internal use-,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow-)+module MFlow ( +Flow, Params, HttpData(..),Processable(..) +, Token(..), ProcList +-- * low level comunication primitives. Use `ask` instead +,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment +, sendEndFragment, sendToMF +-- * Flow configuration +,addMessageFlows,getMessageFlows, transient, stateless,anonymous +,noScript,hlog, setNotFoundResponse,getNotFoundResponse, +-- * ByteString tags +-- | very basic but efficient tag formatting +btag, bhtml, bbody,Attribs, addAttrs + +-- * static files +,setFilesPath +-- * internal use +,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow +) where import Control.Concurrent.MVar import Data.IORef import GHC.Conc(unsafeIOToSTM) import Data.Typeable -import Data.Maybe(isJust, isNothing, fromMaybe, fromJust)+import Data.Maybe(isJust, isNothing, fromMaybe, fromJust) import Data.Char(isSeparator) import Data.List(isPrefixOf,isSuffixOf,isInfixOf, elem , span, (\\)) -import Control.Monad(when)+import Control.Monad(when) import Data.Monoid import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId) import Data.Char(toLower) -import Unsafe.Coerce-import System.IO.Unsafe-import Data.TCache+import Unsafe.Coerce +import System.IO.Unsafe +import Data.TCache import Data.TCache.DefaultPersistence hiding(Indexable(..)) -import Data.TCache.Memoization+import Data.TCache.Memoization import Data.ByteString.Lazy.Char8 as B (readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks) import Data.ByteString.Lazy.Internal (ByteString(Chunk)) import qualified Data.Map as M -import System.IO-import System.Time-import Control.Workflow-import MFlow.Cookies-import Control.Monad.Trans-import qualified Control.Exception as CE----import Debug.Trace---(!>)= flip trace--type Flow= (Token -> Workflow IO ())--data HttpData = HttpData Params [Cookie] ByteString | Error WFErrors ByteString deriving (Typeable, Show)----instance ToHttpData HttpData where--- toHttpData= id------instance ToHttpData ByteString where--- toHttpData bs= HttpData [] [] bs--instance Monoid HttpData where- mempty= HttpData [] [] empty- mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'---- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname-type ProcList = WorkflowList IO Token ()---data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable--type Params = [(String,String)]-+import System.IO +import System.Time +import Control.Workflow +import MFlow.Cookies +import Control.Monad.Trans +import qualified Control.Exception as CE + +import Debug.Trace +(!>) x y = x -- flip trace + +type Flow= (Token -> Workflow IO ()) + +data HttpData = HttpData Params [Cookie] ByteString | Error WFErrors ByteString deriving (Typeable, Show) + +--instance ToHttpData HttpData where +-- toHttpData= id +-- +--instance ToHttpData ByteString where +-- toHttpData bs= HttpData [] [] bs + +instance Monoid HttpData where + mempty= HttpData [] [] empty + mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s' + +-- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname +type ProcList = WorkflowList IO Token () + + +data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable + +type Params = [(String,String)] + class Processable a where - pwfname :: a -> String- puser :: a -> String- pind :: a -> String- getParams :: a -> Params--- getServer ::a -> String--- getPath :: a -> String--- getPort :: a -> Int--instance Processable Token where- pwfname = twfname- puser = tuser- pind = tind- getParams = tenv+ pwfname :: a -> String + pwfname= head . pwfPath + pwfPath :: a -> [String] + puser :: a -> String + pind :: a -> String + getParams :: a -> Params +-- getServer ::a -> String +-- getPath :: a -> String +-- getPort :: a -> Int +instance Processable Token where + pwfname = twfname + pwfPath = tpath + puser = tuser + pind = tind + getParams = tenv + instance Processable Req where - pwfname (Req x)= pwfname x- puser (Req x)= puser x+ pwfname (Req x)= pwfname x + pwfPath (Req x)= pwfPath x + puser (Req x)= puser x pind (Req x)= pind x - getParams (Req x)= getParams x--- getServer (Req x)= getServer x--- getPath (Req x)= getPath x+ getParams (Req x)= getParams x +-- getServer (Req x)= getServer x +-- getPath (Req x)= getPath x -- getPort (Req x)= getPort x -data Resp = Fragm HttpData- | EndFragm HttpData- | Resp HttpData----- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable`+data Resp = Fragm HttpData + | EndFragm HttpData + | Resp HttpData + + +-- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable` -- message that arrives and send the mesage to the appropriate flow. -data Token = Token{twfname,tuser, tind :: String , tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable -+data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable + instance Indexable Token where - key (Token w u i _ _ _ )=- if u== anonymous then u++ i -- ++ "@" ++ w- else u -- ++ "@" ++ w-+ key (Token w u i _ _ _ _ )= + if u== anonymous then u++ i -- ++ "@" ++ w + else u -- ++ "@" ++ w + instance Show Token where - show t = "Token " ++ key t-+ show t = "Token " ++ key t + instance Read Token where - readsPrec _ ('T':'o':'k':'e': 'n':' ':str1)- | anonymous `isPrefixOf` str1= [(Token w anonymous i [] (newVar 0) (newVar 0), tail str2)] - | otherwise = [(Token w ui "0" [] (newVar 0) (newVar 0), tail str2)] -- where-- (ui,str')= span(/='@') str1- i = drop (length anonymous) ui- (w,str2) = span (not . isSeparator) $ tail str'- newVar _= unsafePerformIO $ newEmptyMVar--- readsPrec _ str= error $ "parse error in Token read from: "++ str--instance Serializable Token where- serialize = pack . show- deserialize= read . unpack--iorefqmap= unsafePerformIO . newMVar $ M.empty--addTokenToList t@Token{..} =- modifyMVar_ iorefqmap $ \ map ->- return $ M.insert ( tind ++ twfname ++ tuser ) t map--deleteTokenInList t@Token{..} =- modifyMVar_ iorefqmap $ \ map ->- return $ M.delete (tind ++ twfname ++ tuser) map+ readsPrec _ ('T':'o':'k':'e': 'n':' ':str1) + | anonymous `isPrefixOf` str1= [(Token w anonymous i [] [] (newVar 0) (newVar 0), tail str2)] + | otherwise = [(Token w ui "0" [] [] (newVar 0) (newVar 0), tail str2)] -getToken msg= do- qmap <- readMVar iorefqmap- let u= puser msg ; w= pwfname msg ; i=pind msg; penv= getParams msg- let mqs = M.lookup ( i ++ w ++ u) qmap- case mqs of+ where + + (ui,str')= span(/='@') str1 + i = drop (length anonymous) ui + (w,str2) = span (not . isSeparator) $ tail str' + newVar _= unsafePerformIO $ newEmptyMVar + + + readsPrec _ str= error $ "parse error in Token read from: "++ str + +instance Serializable Token where + serialize = pack . show + deserialize= read . unpack + +iorefqmap= unsafePerformIO . newMVar $ M.empty + +addTokenToList t@Token{..} = + modifyMVar_ iorefqmap $ \ map -> + return $ M.insert ( tind ++ twfname ++ tuser ) t map + +deleteTokenInList t@Token{..} = + modifyMVar_ iorefqmap $ \ map -> + return $ M.delete (tind ++ twfname ++ tuser) map + +getToken msg= do + qmap <- readMVar iorefqmap + let u= puser msg ; w= pwfname msg ; i=pind msg; ppath=pwfPath msg;penv= getParams msg + let mqs = M.lookup ( i ++ w ++ u) qmap + case mqs of Nothing -> do - q <- newEmptyMVar -- `debug` (i++w++u)- qr <- newEmptyMVar- let token= Token w u i penv q qr- addTokenToList token- return token-- Just token-> return token+ q <- newEmptyMVar -- `debug` (i++w++u) + qr <- newEmptyMVar + let token= Token w u i ppath penv q qr + addTokenToList token + return token + Just token-> return token{tpath= ppath, tenv= penv} --- | The anonymous user-anonymous= "anon#"---- | It is the path of the root flow-noScript = "noscript" -{-+-- | The anonymous user +anonymous= "anon#" + +-- | It is the path of the root flow +noScript = "noscript" + +{- instance (Monad m, Show a) => Traceable (Workflow m a) where debugf iox str = do x <- iox @@ -226,293 +230,287 @@ -} -- | send a complete response --send :: Token -> HttpData -> IO() -send t@(Token _ _ _ _ _ qresp) msg= do +send t@(Token _ _ _ _ _ _ qresp) msg= do ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ thread t) --sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush " +sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush " + -- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' sendFragment :: Token -> HttpData -> IO() -sendFragment (Token _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg -+sendFragment (Token _ _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg + {-# DEPRECATED sendEndFragment "use send to end a fragmented response instead" #-} sendEndFragment :: Token -> HttpData -> IO() -sendEndFragment (Token _ _ _ _ _ qresp ) msg= putMVar qresp $ EndFragm msg +sendEndFragment (Token _ _ _ _ _ _ qresp ) msg= putMVar qresp $ EndFragm msg --emptyReceive (Token queue _ _)= emptyQueue queue receive :: Typeable a => Token -> IO a -receive t= receiveReq t >>= return . fromReq--flushRec t@(Token _ _ _ _ queue _)= do- empty <- isEmptyMVar queue- when (not empty) $ takeMVar queue >> return ()---receiveReq :: Token -> IO Req-receiveReq t@(Token _ _ _ _ queue _)= readMVar queue -- !> (">>>>>> receive "++ thread t)--fromReq :: Typeable a => Req -> a-fromReq (Req x) = x' where- x'= case cast x of+receive t= receiveReq t >>= return . fromReq + +flushRec t@(Token _ _ _ _ _ queue _)= do + empty <- isEmptyMVar queue + when (not empty) $ takeMVar queue >> return () + + +receiveReq :: Token -> IO Req +receiveReq t@(Token _ _ _ _ _ queue _)= readMVar queue -- !> (">>>>>> receive "++ thread t) + +fromReq :: Typeable a => Req -> a +fromReq (Req x) = x' where + x'= case cast x of Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x') - Just y -> y--+ Just y -> y -receiveReqTimeout :: Int- -> Integer+ + +receiveReqTimeout :: Int + -> Integer -> Token - -> IO Req-receiveReqTimeout 0 0 t= receiveReq t-receiveReqTimeout time time2 t=- let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t)-+ -> IO Req +receiveReqTimeout 0 0 t= receiveReq t +receiveReqTimeout time time2 t= + let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t) -delMsgHistory t = do+ +delMsgHistory t = do let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t delWFHistory1 statKey -- `debug` "delWFHistory" ----- | executes a simple monadic computation that receive the params and return a response------ It is used with `addMessageFlows`---+ + +-- | executes a simple monadic computation that receive the params and return a response +-- +-- It is used with `addMessageFlows` +-- -- There is a higuer level version @wstateless@ in "MFLow.Forms" stateless :: (Params -> IO HttpData) -> Flow -stateless f = transient proc- where- proc t@(Token _ _ _ _ queue qresp) = loop t queue qresp- loop t queue qresp=do- req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t)- resp <- f (getParams req)- (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t)- loop t queue qresp -- !> ("enviado stateless " ++ thread t)+stateless f = transient proc + where + proc t@(Token _ _ _ _ _ queue qresp) = loop t queue qresp + loop t queue qresp=do + req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t) + resp <- f (getParams req) + (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t) + loop t queue qresp -- !> ("enviado stateless " ++ thread t) -- ------ | Executes a monadic computation that send and receive messages, but does+ + + +-- | Executes a monadic computation that send and receive messages, but does -- not store its state in permanent storage. The process once stopped, will restart anew -------- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow`+-- +---- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow` transient :: (Token -> IO ()) -> Flow transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) ) - + _messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ())) -_messageFlows= unsafePerformIO $ newMVar emptyFList- where+_messageFlows= unsafePerformIO $ newMVar emptyFList + where emptyFList= M.empty :: WorkflowList IO Token () --- | 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 $ map flt wfs))- where flt ("",f)= (noScript,f)+-- | 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 $ map flt wfs)) + where flt ("",f)= (noScript,f) flt e= e -+ -- | return the list of the scheduler getMessageFlows = readMVar _messageFlows --class ToHttpData a where -- toHttpData :: a -> HttpData -+ thread t= show(unsafePerformIO myThreadId) ++ " "++ show (twfname t) ----tellToWF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c-tellToWF t@(Token _ _ _ _ queue qresp ) msg = do + +sendToMF Token{..} msg= putMVar tsendq $ Req msg + +--tellToWF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c +tellToWF t@(Token _ _ _ _ _ queue qresp ) msg = do putMVar queue (Req msg) -- !> (">>>>> telltowf"++ thread t) - m <- takeMVar qresp -- !> ("<<<<<< tellTowf"++ thread t)+ m <- takeMVar qresp -- !> ("<<<<<< tellTowf"++ thread t) case m of Resp r -> return r -- !> ("recibido tellTowf"++ thread t) - Fragm r -> do- result <- getStream r- return result+ Fragm r -> do + result <- getStream r + return result - where+ where getStream r = do mr <- takeMVar qresp case mr of - Fragm h -> do- rest <- unsafeInterleaveIO $ getStream h- let result= mappend r rest+ Fragm h -> do + rest <- unsafeInterleaveIO $ getStream h + let result= mappend r rest return result - EndFragm h -> do- let result= mappend r h+ EndFragm h -> do + let result= mappend r h return result -- Resp h -> do- let result= mappend r h- return result- ----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-------- | The scheduler creates a Token with every `Processable`--- message that arrives and send the mesage to the appropriate flow, then waht for the response--- and return it.------ It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it-msgScheduler- :: (Typeable a,Processable a)- => a -> IO (HttpData, ThreadId)+ Resp h -> do + let result= mappend r h + return result + + + + +-- | The scheduler creates a Token with every `Processable` +-- message that arrives and send the mesage to the appropriate flow, then waht for the response +-- and return it. +-- +-- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it +msgScheduler + :: (Typeable a,Processable a) + => a -> IO (HttpData, ThreadId) msgScheduler x = do - token <- getToken x- th <- startMessageFlow (pwfname x) token+ token <- getToken x + let wfname= takeWhile (/='/') $ pwfname x + th <- startMessageFlow wfname token r <- tellToWF token x -- !> let HttpData _ _ r1=r in unpack r1 - return (r,th)- where+ return (r,th) + where --start the flow if not started yet startMessageFlow wfname token = - forkIO $ do+ forkIO $ do wfs <- getMessageFlows r <- startWF wfname token wfs -- !>( "init wf " ++ wfname) case r of - Left NotFound -> do- sendFlush token =<< serveFile wfname--- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)+ Left NotFound -> do + (sendFlush token =<< serveFile (pwfname x)) + `CE.catch`\(e:: CE.SomeException) -> showError wfname token (show e) +-- sendFlush token (Error NotFound $ "Not found: " <> pack 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}- fresp<- getNotFoundResponse- sendFlush token $ HttpData [("Content-Type", "text/html")] [] $- fresp $- case user of- "admin" -> pack $ show e- _ -> mempty---- Right _ -> do--- let msg= "finished Flow "++ wfname++ " restarting"--- logError (key token) wfname msg--- startMessageFlow wfname token wfs-- delMsgHistory token; return () -- !> ("finished " ++ wfname)+ Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname) + Left Timeout -> do --logError u wf e= do- hSeek hlog SeekFromEnd 0- t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime+ hFlush stdout !> "TIMEOUT in msgScheduler" + return() + Left (WFException e)-> showError wfname token e + + + + Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname) + + + +showError wfname token@Token{..} e= do + let user= key token + let msg= e ++ ": "++twfname++ " "++tuser ++" "++ tind++" "++ show tpath ++ show tenv + putStrLn msg + logError user wfname e +-- moveState wfname token token{tuser= "error/"++tuser token} + fresp <- getNotFoundResponse + sendFlush token $ fresp (key token) msg + + + +logError u wf e= do + hSeek hlog SeekFromEnd 0 + t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime hPutStrLn hlog (","++show [u, t,wf,e]) >> hFlush hlog --logFileName= "errlog"------ | The handler of the error log+ +logFileName= "errlog" + + + +-- | 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 <>+ + +defNotFoundResponse user msg= + HttpData [("Content-Type", "text/html")] [] + $ fresp + $ case user of + "admin" -> pack msg + _ -> "The administrator has been notified" + where + fresp 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= liftIO $ readIORef notFoundResponse---- basic bytestring tags-type Attribs= [(String,String)]--- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For--- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP".-btag :: String -> Attribs -> ByteString -> ByteString-btag t rs v= "<" `append` pt `append` attrs rs `append` ">" `append` v `append`"</"`append` pt `append` ">"- where- pt= pack t- attrs []= B.empty- attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs---- |--- > bhtml ats v= btag "html" ats v-bhtml :: Attribs -> ByteString -> ByteString-bhtml ats v= btag "html" ats v----- |--- > bbody ats v= btag "body" ats v-bbody :: Attribs -> ByteString -> ByteString-bbody ats v= btag "body" ats v--addAttrs :: ByteString -> Attribs -> ByteString-addAttrs (Chunk "<" (Chunk tag rest)) rs=- Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest--addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other------ basic file server -------- | Set the path of the files in the web server. The links to the files are relative to it.+ + + 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.+--+-- The parameter is as follows:+-- (String The user identifier. The username when logged +-- -> String The error string +-- -> HttpData) The response. See `defNotFoundResponse` code for an example + +setNotFoundResponse :: + (String + -> String + -> HttpData) + -> IO () + +setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f +getNotFoundResponse= liftIO $ readIORef notFoundResponse + +-- basic bytestring tags +type Attribs= [(String,String)] +-- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For +-- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP". +btag :: String -> Attribs -> ByteString -> ByteString +btag t rs v= "<" `append` pt `append` attrs rs `append` ">" `append` v `append`"</"`append` pt `append` ">" + where + pt= pack t + attrs []= B.empty + attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs + +-- | +-- > bhtml ats v= btag "html" ats v +bhtml :: Attribs -> ByteString -> ByteString +bhtml ats v= btag "html" ats v + + +-- | +-- > bbody ats v= btag "body" ats v +bbody :: Attribs -> ByteString -> ByteString +bbody ats v= btag "body" ats v + +addAttrs :: ByteString -> Attribs -> ByteString +addAttrs (Chunk "<" (Chunk tag rest)) rs= + Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest + +addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other + + +--- basic file server ---- + +-- | Set the path of the files in the web server. The links to the files are relative to it. -- The files are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of -- the efficient GHC threads by frequent IO calls.So it enhances the performance -- in the context of heavy concurrence. -- It uses 'Data.TCache.Memoization'. -- The caching-uncaching follows the `setPersist` criteria setFilesPath :: String -> IO () -setFilesPath path= writeIORef rfilesPath path--rfilesPath= unsafePerformIO $ newIORef "files/"--serveFile path'= do+setFilesPath path= writeIORef rfilesPath path + +rfilesPath= unsafePerformIO $ newIORef "files/" + +serveFile path'= do when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm filesPath <- readIORef rfilesPath let path= filesPath ++ path' mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing) case mr of - Nothing -> return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible" + Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible" Just r -> let ext = reverse . takeWhile (/='.') $ reverse path mmime= lookup (map toLower ext) mimeTable mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r - where- noperm= "no permissions"+ where + noperm= "no permissions" ioerr x= \(e :: CE.IOException) -> x - setMime x= ("Content-Type",x)-+ setMime x= ("Content-Type",x) + data NFlow= NFlow !Integer deriving (Read, Show, Typeable) instance Serializable NFlow where @@ -531,13 +529,13 @@ NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) writeDBRef rflow . NFlow $ n+1 return . show $ t + n - + mimeTable=[ ("html", "text/html"), ("htm", "text/html"), - ("txt", "text/plain"),- ("hs", "text/plain"),+ ("txt", "text/plain"), + ("hs", "text/plain"), ("lhs", "text/plain"), ("jpeg", "image/jpeg"), ("pdf", "application/pdf"),
src/MFlow/Forms.hs view
@@ -15,13 +15,72 @@ #-} -{- | This module implement stateful processes (flows) that are optionally persistent.+{- |+MFlow run stateful server processes. This version is the first stateful web framework+that is as RESTful as a web framework can be.++The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links+point to alternative routes within this monadic computation just like a textual menu+in a console application. Any GET page is directly reachable by means of a RESTful URL.++At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar.+If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match+. From this position the execution goes forward until the rest of the path match. This way the+statelessness is optional. However, it is possible to store a session state, which may backtrack or+not when the navigation goes back and forth. It is upto the programmer.+++All the flow of requests and responses are coded by the programmer in a single procedure. +Allthoug single request-response flows are possible. Therefore, the code is +more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for +handling the back button. Back button state syncronization is supported out-of-the-box++The MFlow architecture is scalable, since the state is serializable and small + +The processes are stopped and restarted by the +application server on demand, including the execution state (if the Wokflow monad is used). +Therefore session management is automatic. State consistence and transactions are given by the TCache package. + +The processes interact trough widgets, that are an extension of formlets with +additional applicative combinators, formatting, link management, callbacks, modifiers, caching, +byteString conversion and AJAX. All is coded in pure haskell.++The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString +, Hack and WAI but it can be extended to non Web based architectures. + +Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files. +To use them, add then to the exported modules and execute cabal install+ +It is designed for applications that can be run with no deployment with runghc in order +to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>++This release (0.3) includes:++ - /RESTful/ URLs++ - Automatic independent refreshing of widgets via Ajax. (see <http://haskell-web.blogspot.com.es/2013/06/and-finally-widget-auto-refreshing.html>)++ - Now each widget can be monadic so it can express his own behaviour and can run its own independent page flow. (see <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html>)++ - Per-widget callbacks, used in page flows, that change the rendering of the widget (see <http://haskell-web.blogspot.com.es/2013/06/callbacks-in-mflow.html>)++ - Widgets in modal and non modal dialogs (using jQuery dialog)++ - Other wrappers for jQuery widgets as MFlow widgets: spinner, datepicker + +The version 0.2 added better WAI integration, higher level dynamic Widgets, content management, multilanguage, blaze-html support, +stateful ajax for server-side control, user-defined data in sessions and widget requirements for automatic installation of scripts, CSS and server flows. ++The version 0.1 added transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX, +and WAI integration. ++This module implement stateful processes (flows) that are optionally persistent. This means that they automatically store and recover his execution state. They are executed by the MFlow app server. defined in the "MFlow" module. These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to the calling process. Because flows are stateful, not request-response, the code is more understandable, because-all the flow of request and responses is coded by the programmer in a single function. Allthoug+all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug single request-response flows and callbacks are possible. This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an@@ -72,6 +131,20 @@ * NEW IN THIS RELEASE +[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession+of links clicked to reach such page and such point in the procedure. Just what you would expect.++[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can+refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a+subpage flow by adding a well know indetifier prefix for links and form parameters.+'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic+widget-formlet can add different form elements depending on the user responses, 'wcallback' can+substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples)++[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'++* IN PREVIOUS RELEASES+ [@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it. [@blaze-html support@] see <http://hackage.haskell.org/package/blaze-html> import "MFlow.Forms.Blaze.Html" or "MFlow.Wai.Blaze.Html.All" to use Blaze-Html@@ -85,7 +158,6 @@ [@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements' - [@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField' [@multilanguage@] see 'mField' and 'mFieldEd'@@ -94,7 +166,6 @@ an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users. Just like in the case of an ordinary stateless application. -* NEW IN PREVIOUS RELEASE: [@Back Button@] This is probably the first implementation in any language where the navigation can be expressed procedurally and still it works well with the back button, thanks@@ -103,7 +174,7 @@ [@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) , the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if-the widget content comes from a database and it is shared by all users.+the widget content comes from a database and it is shared by all users. [@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.@@ -144,7 +215,7 @@ ,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget,getLang, login, userName, -- * User interaction -ask, askt, clearEnv, wstateless, transfer, +ask, page, askt, clearEnv, wstateless, transfer, pageFlow, -- * formLets -- | They usually produce the HTML form elements (depending on the FormInput instance used) -- It is possible to modify their attributes with the `<!` operator.@@ -153,10 +224,10 @@ -- modifiers change their presentation and behaviour getString,getInt,getInteger, getTextBox ,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,-getRadio, setRadio, setRadioActive, getCheckBoxes, genCheckBoxes, setCheckBox,-submitButton,resetButton, whidden, wlink, returning, wform, firstOf, manyOf, wraw, wrender+getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,+submitButton,resetButton, whidden, wlink, returning, wform, firstOf, manyOf, wraw, wrender, notValid -- * FormLet modifiers-,validate, noWidget, waction, wmodify,+,validate, noWidget, waction, wcallback, wmodify, -- * Caching widgets cachedWidget, wcached, wfreeze,@@ -172,7 +243,7 @@ ,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.), -- * Formatting combinators-(<<<),(<++),(++>),(<!),+(<<<),(++>),(<++),(<!), -- * Normalized (convert to ByteString) formatting combinators -- | Some combinators that convert the formatting of their arguments to lazy byteString@@ -238,14 +309,10 @@ import Data.IORef import qualified Data.Map as M import System.IO.Unsafe-import Data.Char(isNumber)+import Data.Char(isNumber,toLower) import Network.HTTP.Types.Header - -import Debug.Trace-(!>)= flip trace - -- | Validates a form or widget result against a validating procedure -- @@ -268,7 +335,10 @@ _ -> return $ FormElm form mx -- | Actions are callbacks that are executed when a widget is validated.--- It is useful when the widget is inside widget containers that know nothing about his content.+-- A action may be a complete flow in the flowM monad. It takes complete control of the navigation+-- while it is executed. At the end it return the result to the caller and display the original+-- calling page.+-- It is useful when the widget is inside widget containers that may treat it as a black box. -- -- It returns a result that can be significative or, else, be ignored with '<**' and '**>'. -- An action may or may not initiate his own dialog with the user via `ask`@@ -282,7 +352,7 @@ s <- get let env = mfEnv s let seq = mfSequence s- put s{mfSequence=mfSequence s+ 100,mfEnv=[]}+ put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True{-,mfLinkSelected= False-}} r <- flowToView $ ac x modify $ \s-> s{mfSequence= seq, mfEnv= env} return r@@ -322,10 +392,13 @@ -- let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z) -- (,,) <$> digest x <*> digest y <*> digest z --- | Display a text box and return a String +-- | Display a text box and return a non empty String getString :: (FormInput view,Monad m) => Maybe String -> View view m String -getString = getTextBox +getString ms = getTextBox ms+ `validate`+ \s -> if null s then return (Just $ fromStr "")+ else return Nothing -- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation) getInteger :: (FormInput view, MonadIO m) => @@ -352,26 +425,35 @@ st <- get put st{needForm= True} let env = mfEnv st- FormElm form mn <- getParam1 n env []+ mn <- getParam1 n env return $ FormElm [finput n "radio" v - ( isJust mn && v== fromJust mn) (Just "this.form.submit()")]- (fmap Radio mn)+ ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()")]+ (fmap Radio $ valToMaybe mn) +valToMaybe (Validated x)= Just x+valToMaybe _= Nothing++isValidated (Validated x)= True+isValidated _= False++fromValidated (Validated x)= x+fromValidated NoParam= error $ "fromValidated : NoParam"+fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s -- | Implement a radio button -- the parameter is the name of the radio group-setRadio :: (FormInput view, MonadIO m) => +setRadio :: (FormInput view, MonadIO m) => String -> String -> View view m Radio setRadio v n= View $ do- st <- get- put st{needForm= True}- let env = mfEnv st- FormElm f mn <- getParam1 n env []- return $ FormElm- (f++[finput n "radio" v - ( isJust mn && v== fromJust mn) Nothing])- (fmap Radio mn)+ st <- get+ put st{needForm= True}+ let env = mfEnv st+ mn <- getParam1 n env+ return $ FormElm [finput n "radio" v + ( isValidated mn && v== fromValidated mn) Nothing]+ (fmap Radio $ valToMaybe mn) +-- | encloses a set of Radio boxes. Return the option selected getRadio :: (Monad m, Functor m, FormInput view) => [String -> View view m Radio] -> View view m String@@ -390,9 +472,6 @@ -- mappend x y= mappend <$> x <*> y -- mempty= return (CheckBoxes []) -instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where- mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum- mempty= return mempty -- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation) setCheckBox :: (FormInput view, MonadIO m) => @@ -404,10 +483,9 @@ let env = mfEnv st strs= map snd $ filter ((==) n . fst) env mn= if null strs then Nothing else Just $ head strs-- val <- gets inSync- let ret= case val of- True -> Just $ CheckBoxes strs+ val = inSync st+ let ret= case val of -- !> show val of+ True -> Just $ CheckBoxes strs -- !> show strs False -> Nothing return $ FormElm ( [ finput n "checkbox" v @@ -438,22 +516,25 @@ let showx= case cast x of Just x' -> x' Nothing -> show x- getParam1 n env [finput n "hidden" showx False Nothing]+ r <- getParam1 n env+ return $ FormElm [finput n "hidden" showx False Nothing] $ valToMaybe r -getCheckBoxes ::(FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]+getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String] getCheckBoxes boxes = View $ do- n <- genNewId- env <- gets mfEnv- FormElm form (mr :: Maybe String) <- getParam1 n env [finput n "hidden" "" False Nothing]+ n <- genNewId st <- get+ let env = mfEnv st+ let form= [finput n "hidden" "" False Nothing]+ mr <- getParam1 n env+ let env = mfEnv st- put st{needForm= True}+ modify $ \st -> st{needForm= True} FormElm form2 mr2 <- runView boxes return $ FormElm (form ++ form2) $- case (mr,mr2) of- (Nothing,_) -> Nothing- (Just _,Nothing) -> Just []- (Just _, Just (CheckBoxes rs)) -> Just rs+ case (mr `asTypeOf` Validated ("" :: String),mr2) of+ (NoParam,_) -> Nothing+ (Validated _,Nothing) -> Just []+ (Validated _, Just (CheckBoxes rs)) -> Just rs @@ -480,36 +561,21 @@ tolook <- case look of Nothing -> genNewId Just n -> return n - let nvalue= case mvalue of + let nvalue x= case x of Nothing -> "" Just v -> case cast v of Just v' -> v' Nothing -> show v--- let typev= typeOf v--- in if typev==typeOf (undefined :: String) then unsafeCoerce v--- else if typev==typeOf (undefined :: String) then unsafeCoerce v--- else if typev==typeOf (undefined :: ByteString) then unsafeCoerce v--- else show v - form= [finput tolook type1 nvalue False Nothing] st <- get let env = mfEnv st put st{needForm= True} - getParam1 tolook env form + r <- getParam1 tolook env+ case r of+ Validated x -> return $ FormElm [finput tolook type1 (nvalue $ Just x) False Nothing] $ Just x+ NotValidated s err -> return $ FormElm ([finput tolook type1 s False Nothing]++[err]) $ Nothing+ NoParam -> return $ FormElm [finput tolook type1 (nvalue mvalue) False Nothing] $ Nothing --- | Generate a new string. Useful for creating tag identifiers and other attributes -genNewId :: MonadState (MFlowState view) m => m String -genNewId= do - st <- get- case mfCached st of- False -> do - let n= mfSequence st - put $ st{mfSequence= n+1}- return $ 'p':(show n)- True -> do- let n = mfSeqCache st- put $ st{mfSeqCache=n+1} - return $ 'c' : (show n) getCurrentName :: MonadState (MFlowState view) m => m String@@ -526,8 +592,12 @@ getMultilineText nvalue = View $ do tolook <- genNewId env <- gets mfEnv- let form= [ftextarea tolook nvalue] - getParam1 tolook env form + r <- getParam1 tolook env+ case r of+ Validated x -> return $ FormElm [ftextarea tolook (show x) ] $ Just x+ NotValidated s err -> return $ FormElm [ftextarea tolook s ] $ Nothing+ NoParam -> return $ FormElm [ftextarea tolook nvalue ] $ Nothing + --instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where -- digest mv = getBool b "True" "False" @@ -541,21 +611,25 @@ -- | 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) => + Monad m, Functor m) => Bool -> String -> String -> View view m Bool -getBool mv truestr falsestr= View $ do - tolook <- genNewId- st <- get- let env = mfEnv st- put st{needForm= True}- 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 --- Just x -> return . FormElm f $ fromstr x - where - fromstr x= if x== truestr then True else False +getBool mv truestr falsestr= do+ r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])+ <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []+ if r == truestr then return True else return False +--View $ do +-- tolook <- genNewId+-- st <- get+-- let env = mfEnv st+-- put st{needForm= True}+-- r <- getParam1 tolook env+-- let flag = isValidated r && fromstr (fromValidated r) +-- let form = [fselect tolook (foption1 truestr flag `mappend` foption1 falsestr (not flag))]+-- return . FormElm form . fmap fromstr $ valToMaybe r +-- where +-- fromstr x = if x == truestr then True else False + -- | Display a dropdown box with the options in the first parameter is optionally selected -- . It returns the selected option. getSelect :: (FormInput view, @@ -567,7 +641,8 @@ let env = mfEnv st put st{needForm= True} FormElm form mr <- (runView opts) - getParam1 tolook env [fselect tolook $ mconcat form] + r <- getParam1 tolook env+ return $ FormElm [fselect tolook $ mconcat form] $ valToMaybe r data MFOption a= MFOption @@ -576,9 +651,15 @@ mempty = Control.Applicative.empty -- | Set the option for getSelect. Options are concatenated with `<|>`+setOption+ :: (Monad m, Show a, Typeable a, FormInput view) =>+ a -> view -> View view m (MFOption a) setOption n v = setOption1 n v False -- | Set the selected option for getSelect. Options are concatenated with `<|>`+setSelectedOption+ :: (Monad m, Show a, Typeable a, FormInput view) =>+ a -> view -> View view m (MFOption a) setSelectedOption n v= setOption1 n v True setOption1 :: (FormInput view, @@ -595,9 +676,11 @@ -- | Enclose Widgets within some formating. -- @view@ is intended to be instantiated to a particular format ----- This is a widget, which is a table with some links. it returns an Int+-- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,+-- unless the we want to enclose all the widgets in the right side.+-- Most of the type errors in the DSL are due to the low priority of this operator. ----- it has a infix priority : @infixr 5@ less than '++>' so use parenthesis when appropriate+-- This is a widget, which is a table with some links. it returns an Int -- -- > import MFlow.Forms.Blaze.Html -- >@@ -624,19 +707,8 @@ --- | Useful for the creation of pages using two or more views.--- For example 'HSP' and 'Html'.--- Because both have ConvertTo instances to ByteString, then it is possible--- to mix them via 'normalize':------ > normalize widget <+> normalize widget'------ is equivalent to------ > widget .<+>. widget' - -- | Append formatting code to a widget -- @@ -667,7 +739,7 @@ -- | Add attributes to the topmost tag of a widget -- -- it has a fixity @infix 8@-infix 8 <!+infixl 8 <! widget <! attribs= View $ do FormElm fs mx <- runView widget return $ FormElm (head fs `attrs` attribs:tail fs) mx@@ -723,6 +795,9 @@ wraw :: Monad m => view -> View view m () wraw x= View . return . FormElm [x] $ Just () +-- To display some rendering and return non valid+notValid :: Monad m => view -> View view m a+notValid x= View . return $ FormElm [x] Nothing -- | Wether the user is logged or is anonymous isLogged :: MonadState (MFlowState v) m => m Bool@@ -751,7 +826,7 @@ val mu (Just us, Nothing)= if isNothing mu || isJust mu && fromJust mu == fst us then userValidate us- else return . Just $ fromStr "wrong user for the operation"+ else return . Just $ fromStr "This user has no permissions for this task" val mu (Just us, Just p)= if isNothing mu || isJust mu && fromJust mu == fst us@@ -792,18 +867,19 @@ --- | logout. The user is resetted to the `anonymous` user+-- | logout. The user is reset to the `anonymous` user logout :: (MonadIO m, MonadState (MFlowState view) m) => m () logout= do st <- get let t = mfToken st t'= t{tuser= anonymous}- moveState (twfname t) t t'- put st{mfToken= t'}- liftIO $ deleteTokenInList t- liftIO $ addTokenToList t'+ if tuser t == anonymous then return () else do+ moveState (twfname t) t t'+ put st{mfToken= t'}+ liftIO $ deleteTokenInList t+ liftIO $ addTokenToList t' - setCookie cookieuser anonymous "/" (Just $ -1000)+ setCookie cookieuser anonymous "/" (Just $ -1000) -- | If not logged, perform login. otherwise return the user --@@ -889,7 +965,7 @@ FormElm form mx <- runView form return $ FormElm form $ Just undefined --- | for compatibility with the same procedure in 'MFLow.Forms.Text.askt'.+-- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'. -- This is the non testing version -- -- > askt v w= ask w@@ -900,151 +976,161 @@ -- | It is the way to interact with the user. --- It takes a widget and return the user result.+-- It takes a widget and return the input result. If the widget is not validated (return @Nothing@)+-- , the page is presented again ----- If the widget is not validated (return @Nothing@), the page is presented again+-- If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction,+-- it will not ask to the user and return the result.+-- To force asking in any case, add an `clearEnv` statement before.+-- It also handles ajax requests ----- If the environment has the parameters being looked at, as a result of a previous interaction,--- it will not ask to the user.--- To force asking in any case, put an `clearEnv` statement before +-- 'ask' also synchronizes the execution of the flow with the user page navigation by++-- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between get and post parameters and what is expected by the widgets +-- until a total or partial match is found.+--+-- * Advancing in the flow by mathing a single requests with one or more sucessive ask statements+--+-- Backtracking and advancing can occur in a single request, so the flow in any state can reach any+-- other state in the flow if the request satisfy the parameters required. ask :: (FormInput view) => View view IO a -> FlowM view IO a ask w = do st1 <- get++ -- AJAX let env= mfEnv st1- let mv1= lookup "ajax" env- let majax1= mfAjax st1+ mv1= lookup "ajax" env+ majax1= mfAjax st1 case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of (Just ajaxl,Just v1,Just f, Just v2) -> do FlowM . lift $ (unsafeCoerce f) v2- FlowM $ lift receiveWithTimeouts+ FlowM $ lift nextMessage ask w+ -- END AJAX _ -> do- let st= st1{needForm= False, inSync= False, mfRequirements= []} + let st= st1{needForm= False, inSync= False, mfRequirements= [],linkMatched=False} put st- FormElm forms mx <- FlowM . lift $ runView w- - st' <- get- if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w else- case mx of++ FormElm forms mx <- FlowM . lift $ runView w + st' <- get+ if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w+ else if mfAutorefresh st' then resetState st st' >> FlowM (lift nextMessage) >> ask w+ else+ case mx of Just x -> do- put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]}- breturn x -- !> "just x"++ put st'{newAsk= True , mfEnv=[]+ ,mfPageIndex=Nothing+ ,mfPIndex= length (mfPath st') -1+ }++ breturn x Nothing ->- if not (inSync st') && not (onInit st') && hasParams (mfSequence st') (mfSeqCache st') ( mfEnv st') -- !> (show $ inSync st') !> (show $ onInit st')+ if not (inSync st') && not (newAsk st')+ !> ("pageIndex="++ show (mfPageIndex st'))+ !> ("insinc="++show (inSync st'))+ !> ("newask="++show (newAsk st'))+ !> ("mfPIndex="++ show( mfPIndex st')) then do- put st'{ mfSequence= head1 $ prevSeq st',- prevSeq= tail1 $ prevSeq st' }- fail ""+ let index = mfPIndex st'+ nindex= if index== 0 then 1 else index - 1+ put st'{mfPIndex= nindex} !> "BACKTRACK"+ fail "" else do reqs <- FlowM $ lift installAllRequirements let header= mfHeader st' t= mfToken st'- cont = case (needForm st') of- True -> header $ reqs <> (formAction (twfname t ) $ mconcat forms)- _ -> header $ reqs <> mconcat forms+ cont <- case (needForm st') of+ True -> do+ frm <- formPrefix (mfPIndex st') (twfname t ) st' forms False+ return . header $ reqs <> frm+ _ -> return . header $ reqs <> mconcat forms - HttpData ctype c s= toHttpData cont + let HttpData ctype c s= toHttpData cont liftIO . sendFlush t $ HttpData (ctype++mfHttpHeaders st') (mfCookies st' ++ c) s- put st{mfCookies=[],mfHttpHeaders=[], onInit= False, mfToken= t, mfAjax= mfAjax st', mfSeqCache= mfSeqCache st' } -- !> ("after "++show ( mfSequence st')) - FlowM $ lift receiveWithTimeouts+++ resetState st st' ++ FlowM $ lift nextMessage ask w where- head1 []=0- head1 xs= head xs- tail1 []=[]- tail1 xs= tail xs+ resetState st st'=+ put st{mfCookies=[]+ ,mfHttpHeaders=[]+ ,newAsk= False+ ,mfToken= mfToken st'+ ,mfPageIndex= mfPageIndex st'+ ,mfAjax= mfAjax st'+ ,mfSeqCache= mfSeqCache st' } - hasParams seq cseq= not . null . filter (\(p,_) ->- let tailp = tail p- in and (map isNumber tailp) &&- let rt= read tailp- in case head p of- 'p' -> rt <= seq- 'c' -> rt <= cseq- _ -> False)--- (head p== 'p' || head p == 'c')--- && and (map isNumber tailp)--- && read tailp <= seq) --- | True if the flow is going back (as a result of the back button pressed in the web browser).--- Usually this chech is nos necessary unless conditional code make it necessary------ @menu= do--- mop <- getGoStraighTo--- case mop of--- Just goop -> goop--- Nothing -> do--- r \<- `ask` option1 \<|> option2--- case r of--- op1 -> setGoStraighTo (Just goop1) >> goop1--- op2 -> setGoStraighTo (Just goop2) >> goop2@------ This pseudocode below would execute the ask of the menu once. But the user will never have--- the possibility to see the menu again. To let him choose other option, the code--- has to be change to------ @menu= do--- mop <- getGoStraighTo--- back <- `goingBack`--- case (mop,back) of--- (Just goop,False) -> goop--- _ -> do--- r \<- `ask` option1 \<|> option2--- case r of--- op1 -> setGoStraighTo (Just goop1) >> goop1--- op2 -> setGoStraighTo (Just goop2) >> goop2@+-- | A synonym of ask. ----- However this is very specialized. Normally the back button detection is not necessary.--- In a persistent flow (with step) even this default entry option would be completely automatic,--- since the process would restar at the last page visited. No setting is necessary.-goingBack :: MonadState (MFlowState view) m => m Bool-goingBack = do- st <- get- return $ not (inSync st) && not (onInit st)+-- Maybe more appropiate for pages with long interactions with the user+-- while the result has little importance.+page+ :: (FormInput view) =>+ View view IO a -> FlowM view IO a+page= ask --- | 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() + +comparePaths _ n [] xs= n+comparePaths o n _ [] = o+comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath+ | otherwise= n -receiveWithTimeouts :: MonadIO m => WState view m () -receiveWithTimeouts= do - st <- get - let t= mfToken st - t1= mfkillTime st- t2= mfSessionTime st - req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t) - put st{mfEnv= req} +nextMessage :: MonadIO m => WState view m () +nextMessage= do + st <- get + let t= mfToken st + t1= mfkillTime st+ t2= mfSessionTime st+ msg <- liftIO ( receiveReqTimeout t1 t2 t)+ let req= getParams msg+ env= updateParams inPageFlow (mfEnv st) req -- !> show req+ npath= pwfPath msg + path= mfPath st+ inPageFlow= isJust $ mfPageIndex st + put st{ mfPath= npath+ , mfPIndex= case mfPageIndex st !> ("mfPageIndex=" ++ show (mfPageIndex st)) of+ Just n -> n+ Nothing ->+ comparePaths (mfPIndex st) 1 (tail path) (tail npath)+-- , mfPageIndex= Nothing+ , mfEnv= env } ++ where+ updateParams :: Bool -> Params -> Params -> Params+ updateParams False _ req= req !> "NOT IN PAGE FLOW"+ updateParams True env req=+ let params= takeWhile isparam env+ fs= fst $ head req+ parms= (case findIndex (\p -> fst p == fs) params of+ Nothing -> params+ Just i -> take i params)+ ++ req+ in parms !> "IN PAGE FLOW" !> ("parms=" ++ show parms )+ !> ("env=" ++ show env)+ !> ("req=" ++ show req)++ ++isparam ('p': r:_,_)= isNumber r+isparam ('c': r:_,_)= isNumber r+isparam _= False+ -- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a -- higuer level form of the latter wstateless@@ -1055,7 +1141,7 @@ loop= do ask w env <- get- put $ env{ mfSequence= 0,prevSeq=[]} + put $ env{ mfSequence= 0} loop @@ -1083,22 +1169,23 @@ sendFlush t r --- | Wrap a widget of form element within a form-action element.----- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad. +-- | Wrap a widget with form element within a form-action element.+-- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless+-- there are more than one form in the page. wform :: (Monad m, FormInput view) - => View view m b -> View view m b + => View view m b -> View view m b wform x = View $ do - FormElm form mr <- (runView $ x )- st <- get - let t = mfToken st- anchor <- genNewId- put st{needForm=False}- let anchorf= (ftag "a") mempty `attrs` [("name",anchor)] - let form1= formAction (twfname t {-++"#"++anchor-}) $ mconcat ( anchorf:form) -- !> anchor - - return $ FormElm [form1] mr + FormElm form mr <- (runView $ x )+ st <- get+ verb <- getWFName + form1 <- formPrefix (mfPIndex st) verb st form True+ put st{needForm=False} + return $ FormElm [form1] mr +++ resetButton :: (FormInput view, Monad m) => String -> View view m () resetButton label= View $ return $ FormElm [finput "reset" "reset" label False Nothing] $ Just () @@ -1152,7 +1239,7 @@ (Just id, Just _) -> do FormElm __ (Just str) <- runView cmd liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"- receiveWithTimeouts+ nextMessage env <- getEnv case (lookup "ajax" $ env,lookup "val" env) of (Nothing,_) -> return $ FormElm [] Nothing@@ -1166,20 +1253,65 @@ :: MonadIO m => View v m ByteString -> View v m () ajaxSend_ = ajaxSend -+wlabel+ :: (Monad m, FormInput view) => view -> View view m a -> View view m a+wlabel str w = do+ id <- genNewId+-- modify $ \s ->case mfCached s of+-- True -> s{mfSeqCache= mfSeqCache s -1}+-- False -> s{mfSequence= mfSequence s -1}+ ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)] -- | Creates a link wiget. A link can be composed with other widget elements, -wlink :: (Typeable a, Read a, Show a, MonadIO m, Functor m, FormInput view) +wlink :: (Typeable a, Show a, MonadIO m, FormInput view) => a -> view -> View view m a wlink x v= View $ do - verb <- getWFName - name <- genNewId- env <- gets mfEnv - let - showx= if typeOf x== typeOf (undefined :: String) then unsafeCoerce x else show x - toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v - getParam1 name env [toSend] + verb <- getWFName+ st <- get+ + let+ name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)+ then unsafeCoerce x+ else show x)+ index' = mfPIndex st + if linkMatched st then -1 else 0+ + if Just (mfPIndex st)== mfPageIndex st then 1 else 0+ index = if index'== 0 then 1 else index'+ lpath = mfPath st + back = True -- not $ inSync st || (inSync st && linkMatched st)++ let path= currentPath back index lpath verb ++ ('/':name)+ !> (show $ mfPath st) + toSend = flink path v+++ r <- if linkMatched st then return Nothing+ else+ if isJust $ mfPageIndex st !> (show $ mfPageIndex st)+ then+ case M.lookup name $ mfLinks st !> (show $ mfLinks st)of+ Just 0 -> do+ modify $ \st -> st{ inSync= True}+ return Nothing !> (name ++ " 0 Fail")++ Just n -> do+ modify $ \st -> st{ inSync= True,linkMatched= True,mfPIndex= index+1,mfLinks= M.insert name (n-1) $ mfLinks st}+ !> (name ++" "++ show n ++ " Match")+ return $ Just x+ Nothing -> return Nothing !> (name ++ " 0 Fail")+ else+ case index < length lpath && name== lpath !! index of+ True -> do+ modify $ \s -> s{inSync= True+ , linkMatched= True, mfPIndex= index+1 } !> (name ++ "<-" ++show index++ " MATCHED")+ return $ Just x+ False -> return Nothing !> (name++"<-" ++show index++ " "++(if index < length lpath then lpath !! index else ""))++ return $ FormElm [toSend] r ++++ -- | 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. --@@ -1188,7 +1320,7 @@ -- . The parameter is the visualization code, that accept a serialization function that generate -- the server invocation string, used by the visualization to return the value by means -- of a link or a @window.location@ statement in javasCript -returning ::(Typeable a, Read a, Show a,Monad m, FormInput view) +returning :: (Typeable a, Read a, Show a,Monad m, FormInput view) => ((a->String) ->view) -> View view m a returning expr=View $ do verb <- getWFName @@ -1200,7 +1332,8 @@ _ -> show x in (verb ++ "?" ++ name ++ "=" ++ showx) toSend= expr string - getParam1 name env [toSend]+ r <- getParam1 name env+ return $ FormElm [toSend] $ valToMaybe r @@ -1229,11 +1362,13 @@ forms <- mapM runView xs let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms - res1= catMaybes $ map (\(FormElm _ r) -> r) forms - return $ FormElm vs $ Just res1)+ res1= catMaybes $ map (\(FormElm _ r) -> r) forms + + return $ FormElm vs $ Just res1) -(>:>) ::(Monad m)=> View v m a -> View v m [a] -> View v m [a]++(>:>) :: (Monad m)=> View v m a -> View v m [a] -> View v m [a] (>:>) w ws= View $ do FormElm fs mxs <- runView $ ws FormElm f1 mx <- runView w@@ -1398,5 +1533,48 @@ flink v str = btag "a" [("href", v)] str +------ page Flows ---- +-- | prepares the state for a page flow. A page flow is a dynamic page which changes his rendering by executing+-- a monadic computation with widgets that are validated depending on the user responses.+-- It initiates the creation of a well known sequence of identifiers for the formlets and also+-- keep the state of the previous form submissions within the page.+-- If the computation has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier+--+-- See "http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html"+pageFlow+ :: (Monad m, Functor m, FormInput view) =>+ String -> View view m a -> View view m a+pageFlow str flow=do+ s <- get++ if isNothing $ mfPageIndex s+ then do+ put s{mfPrefix= str ++ mfPrefix s+ ,mfSequence=0+ ,mfLinks= acum M.empty $ drop (mfPIndex s) (mfPath s)+ ,mfPageIndex= Just $ mfPIndex s } !> ("PARENT pageflow. prefix="++ str)++ flow <** (modify (\s' -> s'{mfSequence= mfSequence s+ ,mfPrefix= mfPrefix s})+ !> ("END PARENT pageflow. prefix="++ str))+++ else do+ put s{mfPrefix= str++ mfPrefix s+ ,mfLinks= acum M.empty $ drop (fromJust $ mfPageIndex s) (mfPath s)+ ,mfSequence=0} !> ("CHILD pageflow. prefix="++ str)++ flow <** (modify (\s' -> s'{mfSequence= mfSequence s+ ,mfPrefix= mfPrefix s})+ !> ("END CHILD pageflow. prefix="++ str))++++acum map []= map+acum map (x:xs) =+ let map' = case M.lookup x map of+ Nothing -> M.insert x 1 map+ Just n -> M.insert x (n+1) map+ in acum map' xs
src/MFlow/Forms/Admin.hs view
@@ -1,166 +1,169 @@-{-# OPTIONS- -XScopedTypeVariables-- #-}-module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where-import MFlow.Forms-import MFlow.Forms.XHtml-import MFlow-import Text.XHtml.Strict hiding (widget)-import Control.Applicative-import Control.Workflow-import Control.Monad.Trans-import Data.TCache-import Data.TCache.IndexQuery-import System.Exit-import System.IO-import System.IO.Unsafe-import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)-import System.IO-import Data.RefSerialize hiding ((<|>))-import Data.Typeable-import Data.Monoid-import Data.Maybe-import Data.Map as M (keys)-import System.Exit-import Control.Exception as E-import Control.Concurrent-import Control.Concurrent.MVar----ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"---- | A small console interpreter with some commands:------ [@sync@] Synchronize the cache with persistent storage (see `syncCache`)------ [@flush@] Flush the cache------ [@end@] Synchronize and exit------ [@abort@] Exit. Do not synchronize------ on exception, for example Control-c, it sync and exits.--- 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- `E.catch` (\(e:: E.SomeException) ->do- ssyncCache- error $ "\nException: "++ show e)--adminLoop1= do- putStr ">"; hFlush stdout- op <- getLine- case op of- "sync" -> ssyncCache- "flush" -> atomically flushAll >> putStrLn "flushed cache"- "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess- "abort" -> exitWith ExitSuccess- _ -> return()- adminLoop1---- | execute the process and wait for its finalization.--- then it synchronizes the cache-wait f= do- mv <- newEmptyMVar- forkIO (f1 >> putMVar mv True)- putStrLn "wait: ready"- takeMVar mv- `E.catch` (\(e:: E.SomeException) ->do- ssyncCache- error $ "Signal: "++ show e)- where- f1= f--- do--- n <- getNumProcessors--- setNumCapabilities n--- f---- | Install the admin flow in the list of flows handled by `HackMessageFlow`--- this gives access to an administrator page. It is necessary to--- create an admin user with `setAdminUser`.------ The administration page is reached with the path \"adminserv\"-addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)]---adminMFlow :: FlowM Html IO ()-adminMFlow= do- admin <- getAdminName- u <- getUser (Just admin) $ p << bold << "Please login as Administrator" ++> userLogin- op <- ask $ p <<< wlink "sync" (bold << "sync")- <|> p <<< wlink "flush" (bold << "flush")- <|> p <<< wlink "errors"(bold << "errors")- <|> p <<< wlink "users" (bold << "users")- <|> p <<< wlink "end" (bold << "end")- <|> wlink "abort" (bold << "abort")-- case op of- "users" -> users- "sync" -> liftIO $ syncCache >> print "syncronized cache"- "flush" -> liftIO $ atomically flushAll >> print "flushed cache"-- "errors" -> errors- "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)- "abort" -> liftIO $ exitWith(ExitSuccess)- _ -> return()- adminMFlow---errors= do- size <- liftIO $ hFileSize hlog- if size == 0- then ask $ wlink () (bold << "no error log")- else do- liftIO $ hSeek hlog AbsoluteSeek 0- log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)-- let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]"- let rows= [wlink (head e) (bold << head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls]- showFormList rows 0 10- breturn()--------users= do- users <- liftIO $ atomically $ return . map fst =<< indexOf userName-- showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<-users] 0 10--showFormList- :: [[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-- where- list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])-- cols e= firstOf[td <<< c | c <- e]- span1 n l = take l . drop n- updown n l= wlink ( n +l) (bold << "up ") <|> wlink ( n -l) (bold << "down ") <++ br--optionsUser us = do- wfs <- liftIO $ return . M.keys =<< getMessageFlows- 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")- else do- wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss]- ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")-+{-# OPTIONS + -XScopedTypeVariables + + #-} +module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where +import MFlow.Forms +import MFlow.Forms.XHtml +import MFlow +import Text.XHtml.Strict hiding (widget) +import Control.Applicative +import Control.Workflow +import Control.Monad.Trans +import Data.TCache +import Data.TCache.IndexQuery +import System.Exit +import System.IO +import System.IO.Unsafe +import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack) +import System.IO +import Data.RefSerialize hiding ((<|>)) +import Data.Typeable +import Data.Monoid +import Data.Maybe +import Data.Map as M (keys) +import System.Exit +import Control.Exception as E +import Control.Concurrent +import Control.Concurrent.MVar +import GHC.Conc + + +ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done" + +-- | A small console interpreter with some commands: +-- +-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`) +-- +-- [@flush@] Flush the cache +-- +-- [@end@] Synchronize and exit +-- +-- [@abort@] Exit. Do not synchronize +-- +-- on exception, for example Control-c, it sync and exits. +-- 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 + `E.catch` (\(e:: E.SomeException) ->do + ssyncCache + error $ "\nException: "++ show e) + +adminLoop1= do + putStr ">"; hFlush stdout + op <- getLine + case op of + "sync" -> ssyncCache + "flush" -> atomically flushAll >> putStrLn "flushed cache" + "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess + "abort" -> exitWith ExitSuccess + _ -> return() + adminLoop1 + +-- | execute the process and wait for its finalization. +-- then it synchronizes the cache +wait f= do + mv <- newEmptyMVar + forkIO (f1 >> putMVar mv True) + putStrLn "wait: ready" + takeMVar mv + `E.catch` (\(e:: E.SomeException) ->do + ssyncCache + error $ "Signal: "++ show e) + where + f1= do + mv <- newEmptyMVar + n <- getNumProcessors + putStr "Running in " + putStr $ show n + putStrLn " core(s)" + hFlush stdout + f + +-- | Install the admin flow in the list of flows handled by `HackMessageFlow` +-- this gives access to an administrator page. It is necessary to +-- create an admin user with `setAdminUser`. +-- +-- The administration page is reached with the path \"adminserv\" +addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)] + + +adminMFlow :: FlowM Html IO () +adminMFlow= do + admin <- getAdminName + u <- getUser (Just admin) $ p << bold << "Please login as Administrator" ++> userLogin + op <- ask $ p <<< wlink "sync" (bold << "sync") + <|> p <<< wlink "flush" (bold << "flush") + <|> p <<< wlink "errors"(bold << "errors") + <|> p <<< wlink "users" (bold << "users") + <|> p <<< wlink "end" (bold << "end") + <|> wlink "abort" (bold << "abort") + + case op of + "users" -> users + "sync" -> liftIO $ syncCache >> print "syncronized cache" + "flush" -> liftIO $ atomically flushAll >> print "flushed cache" + + "errors" -> errors + "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess) + "abort" -> liftIO $ exitWith(ExitSuccess) + _ -> return() + adminMFlow + + +errors= do + size <- liftIO $ hFileSize hlog + if size == 0 + then ask $ wlink () (bold << "no error log") + else do + liftIO $ hSeek hlog AbsoluteSeek 0 + log <- liftIO $ hGetNonBlocking hlog (fromIntegral size) + + let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]" + let rows= [wlink (head e) (bold << head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls] + showFormList rows 0 10 + breturn() + + + + + + + +users= do + users <- liftIO $ atomically $ return . map fst =<< indexOf userName + + showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<-users] 0 10 + +showFormList + :: [[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 + + where + list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ]) + + cols e= firstOf[td <<< c | c <- e] + span1 n l = take l . drop n + updown n l= wlink ( n +l) (bold << "up ") <|> wlink ( n -l) (bold << "down ") <++ br + +optionsUser us = do + wfs <- liftIO $ return . M.keys =<< getMessageFlows + stats <- let u= undefined + in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us u 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") + else do + wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss] + ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu") +
src/MFlow/Forms/Internals.hs view
@@ -1,938 +1,1237 @@------------------------------------------------------------------------------------ Module : MFlow.Forms.Internals--- Copyright :--- License : BSD3------ Maintainer : agocorona@gmail.com--- Stability : experimental--- Portability :------ |----------------------------------------------------------------------------------{-# OPTIONS -XDeriveDataTypeable - -XExistentialQuantification- -XScopedTypeVariables- -XFlexibleInstances- -XUndecidableInstances- -XMultiParamTypeClasses- -XGeneralizedNewtypeDeriving- -XFlexibleContexts- -XOverlappingInstances -#-} --module MFlow.Forms.Internals where-import MFlow-import MFlow.Cookies-import Control.Applicative-import Data.Monoid-import Control.Monad.Trans-import Control.Monad.State-import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks)-import Data.Typeable-import Data.RefSerialize hiding((<|>))-import Data.TCache-import Data.TCache.Memoization-import Data.TCache.DefaultPersistence-import Data.Dynamic-import qualified Data.Map as M-import Unsafe.Coerce-import Control.Workflow as WF-import Control.Monad.Identity-import Data.List-import System.IO.Unsafe-import Control.Concurrent.MVar---instance Serialize a => Serializable a where- serialize= runW . showp- deserialize= runR readp--type UserStr= String-type PasswdStr= String- -data User= User - { userName :: String - , upassword :: String - } deriving (Read, Show, Typeable) - -eUser= User (error1 "username") (error1 "password") - -error1 s= error $ s ++ " undefined" - -userPrefix= "user/" -instance Indexable User where - key User{userName= user}= keyUserName user---- | Return the key name of an user -keyUserName n= userPrefix++n - --- | Register an user/password -userRegister :: MonadIO m => String -> String -> m (DBRef User) -userRegister user password = liftIO . atomically $ newDBRef $ User user password - --- | Authentication against `userRegister`ed users. --- to be used with `validate` -userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view) -userValidate (u,p) =- let user= eUser{userName=u}- in liftIO $ atomically - $ withSTMResources [user] - $ \ mu -> case mu of - [Nothing] -> resources{toReturn= err } - [Just (User _ pass )] -> resources{toReturn= - case pass==p of - True -> Nothing - False -> err - } - - where - err= Just . fromStr $ "Username or password invalid" --data Config = Config UserStr deriving (Read, Show, Typeable)--keyConfig= "mflow.config"-instance Indexable Config where key _= keyConfig-rconf= getDBRef keyConfig--setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()-setAdminUser user password= liftIO $ atomically $ do- newDBRef $ User user password- writeDBRef rconf $ Config user--getAdminName :: MonadIO m => m UserStr-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)---instance (Serialize a) => Serialize (FailBack a ) where- showp (BackPoint x)= insertString (pack iCanFailBack) >> showp x- showp (NoBack x)= insertString (pack noFailBack) >> showp x- showp GoBack = insertString (pack repeatPlease)-- readp = choice [icanFailBackp,repeatPleasep,noFailBackp]- where- noFailBackp = {-# SCC "deserialNoBack" #-} symbol noFailBack >> readp >>= return . NoBack- icanFailBackp = {-# SCC "deserialBackPoint" #-} symbol iCanFailBack >> readp >>= return . BackPoint- repeatPleasep = {-# SCC "deserialbackPlease" #-} symbol repeatPlease >> return GoBack--iCanFailBack= "B"-repeatPlease= "G"-noFailBack= "N"--newtype BackT m a = BackT { runBackT :: m (FailBack a ) }--instance Monad m => Monad (BackT m) where- fail _ = BackT . return $ GoBack- return x = BackT . return $ NoBack x- x >>= f = BackT $ loop- where- loop = do- v <- runBackT x -- !> "loop"- case v of- NoBack y -> runBackT (f y) -- !> "runback"- BackPoint y -> do- z <- runBackT (f y) -- !> "BACK"- case z of- GoBack -> loop -- !> "GoBack"- other -> return other- GoBack -> return $ GoBack----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 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.-breturn :: (Monad m) => a -> FlowM v m a-breturn = flowM . BackT . return . BackPoint -- !> "breturn"---instance (MonadIO m) => MonadIO (BackT m) where- liftIO f= BackT $ liftIO f >>= \ x -> return $ NoBack x--instance (Monad m,Functor m) => Functor (BackT m) where- fmap f g= BackT $ do- mr <- runBackT g- case mr of- BackPoint x -> return . BackPoint $ f x- NoBack x -> return . NoBack $ f x- GoBack -> return $ GoBack---liftBackT f = BackT $ f >>= \x -> return $ NoBack x-instance MonadTrans BackT where- lift f = BackT $ f >>= \x -> return $ NoBack x---instance MonadState s m => MonadState s (BackT m) where- get= lift get -- !> "get"- put= lift . put--type WState view m = StateT (MFlowState view) m -type FlowMM view m= BackT (WState view m)- -data FormElm view a = FormElm [view] (Maybe a) deriving Typeable--instance Serialize a => Serialize (FormElm view a) where- showp (FormElm _ x)= showp x- readp= readp >>= \x -> return $ FormElm [] x-- -newtype View v m a = View { runView :: WState v m (FormElm v a)}---newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,MonadState(MFlowState v))-flowM= FlowM---runFlowM= runView---instance (FormInput v,Serialize a)- => Serialize (a,MFlowState v) where- showp (x,s)= case mfDebug s of- False -> showp x- True -> showp(x, mfEnv s)- readp= choice[nodebug, debug]- where- nodebug= readp >>= \x -> return (x, mFlowState0)- debug= do- (x,env) <- readp- return (x,mFlowState0{mfEnv= env})- - -instance Functor (FormElm view ) where - fmap f (FormElm form x)= FormElm form (fmap f x) - -instance (Monad m,Functor m) => Functor (View view m) where - fmap f x= View $ fmap (fmap f) $ runView x-- -instance (Functor m, Monad m) => Applicative (View view m) where - pure a = View $ return (FormElm [] $ Just a) - View f <*> View g= View $ - f >>= \(FormElm form1 k) -> - g >>= \(FormElm form2 x) -> - return $ FormElm (form1 ++ form2) (k <*> x) --instance (Functor m, Monad m) => Alternative (View view m) where - empty= View $ return $ FormElm [] Nothing- View f <|> View g= View $ - f >>= \(FormElm form1 k) -> - g >>= \(FormElm form2 x) ->- return $ FormElm (form1 ++ form2) (k <|> x) -- -instance (Monad m) => Monad (View view m) where - View x >>= f = View $ do - FormElm form1 mk <- x- case mk of- Just k -> do- FormElm form2 mk <- runView $ f k- return $ FormElm (form1++ form2) mk- Nothing -> return $ FormElm form1 Nothing- - return= View . return . FormElm [] . Just ----instance (Monad m) => Monad (FlowM view m) where--- --View view m a-> (a -> View view m b) -> View view m b --- FlowM x >>= f = FlowM $ do --- FormElm _ mk <- x--- case mk of--- Just k -> do--- FormElm _ mk <- runFlowM $ f k--- return $ FormElm [] mk--- Nothing -> return $ FormElm [] Nothing--- --- return= FlowM . return . FormElm [] . Just--instance MonadTrans (View view) where- lift f = View $ (lift f) >>= \x -> return $ FormElm [] $ Just x--instance MonadTrans (FlowM view) where- lift f = FlowM $ lift (lift f) >>= \x -> return x----instance (Monad m)=> MonadState (MFlowState view) (View view m) where- get = View $ get >>= \x -> return $ FormElm [] $ Just x- put st = View $ put st >>= \x -> return $ FormElm [] $ Just x----instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where--- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x--- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x---instance (MonadIO m) => MonadIO (View view m) where- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad---- | Execute the widget in a monad and return the result in another.-changeMonad :: (Monad m, Executable m1)- => View v m1 a -> View v m a-changeMonad w= View . StateT $ \s ->- let (r,s')= execute $ runStateT ( runView w) s- in mfSequence s' `seq` return (r,s')-- -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- }- deriving Typeable--type Void = Char--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 ----- | Set user-defined data in the context of the session.------ The data is indexed by type in a map. So the user can insert-retrieve different kinds of data--- in the session context.------ This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:------ > newtype History = History ( Html) deriving Typeable--- > setHistory html= setSessionData $ History html--- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h--- > addHistory html= do--- > html' <- getHistory--- > setHistory $ html' `mappend` html--setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m () -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.-getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a)-getSessionData = resp where- resp= gets mfData >>= \list ->- case M.lookup ( typeOf $ typeResp resp ) list of- Just x -> return . Just $ unsafeCoerce x- Nothing -> return $ Nothing- typeResp :: m (Maybe x) -> x- typeResp= undefined---- | Return the user language. Now it is fixed to "en"-getLang :: MonadState (MFlowState view) m => m String-getLang= gets mfLang--getToken :: MonadState (MFlowState view) m => m Token-getToken= gets mfToken----- get a parameter form the las received response-getEnv :: MonadState (MFlowState view) m => m Params-getEnv = gets mfEnv- -stdHeader v = v - ---- | Set the header-footer that will enclose the widgets. It must be provided in the--- same formatting than them, altrough with normalization to byteStrings any formatting can be used------ This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)------ @--- setHeader $ \c ->--- \<html\>--- \<head\>--- \<title\> my title \</title\>--- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)--- \</head\>--- \<body style= \"margin-left:5%;margin-right:5%\"\>--- \<% c %\>--- \</body\>--- \</html\>--- @------ This header uses "Text.XHtml"------ @--- setHeader $ \c ->--- `thehtml`--- << (`header`--- << (`thetitle` << title +++--- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++--- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c--- @------ This header uses both. It uses byteString tags------ @--- setHeader $ \c ->--- `bhtml` [] $--- `btag` "head" [] $--- (`toByteString` (thetitle << title) `append`--- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append`--- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c--- @- -setHeader :: MonadState (MFlowState view) m => (view -> view) -> m () -setHeader header= do - fs <- get - put fs{mfHeader= header}------ | Return the current header-getHeader :: (Monad m) => FlowM view m (view -> view) -getHeader= gets mfHeader- --- | Set an HTTP cookie -setCookie :: MonadState (MFlowState view) m - => String -- ^ name - -> String -- ^ value - -> String -- ^ path - -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie - -> m () -setCookie n v p me= do - modify $ \st -> st{mfCookies= (n,v,p,fmap show me):mfCookies st } ---- | Set an HTTP Response header -setHttpHeader :: MonadState (MFlowState view) m - => String -- ^ name - -> String -- ^ value - -> m () -setHttpHeader n v = do - modify $ \st -> st{mfHttpHeaders= (n,v):mfHttpHeaders st } ----- | Set 1) the timeout of the flow execution since the last user interaction.--- Once passed, the flow executes from the begining. 2). In persistent flows--- it set the session state timeout for the flow, that is persistent. If the--- flow is not persistent, it has no effect.------ `transient` flows restart anew.--- persistent flows (that use `step`) restart at the las saved execution point, unless--- the session time has expired for the user. -setTimeouts :: Monad m => Int -> Integer -> FlowM view m () -setTimeouts kt st= do - fs <- get - put fs{ mfkillTime= kt, mfSessionTime= st} - - -getWFName :: MonadState (MFlowState view) m => m String -getWFName = do - fs <- get - return . twfname $ mfToken fs - -getCurrentUser :: MonadState (MFlowState view) m=> m String -getCurrentUser = return . tuser =<< gets mfToken- -type Name= String -type Type= String -type Value= String -type Checked= Bool -type OnClick= Maybe String - -normalize ::(Monad m, FormInput v) => View v m a -> View ByteString m a-normalize f= View . StateT $ \s ->do- (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s- return (FormElm (map toByteString fs ) mx,unsafeCoerce s')------class ToByteString a where--- toByteString :: a -> ByteString------instance ToByteString a => ToHttpData a where--- toHttpData = toHttpData . toByteString------instance ToByteString ByteString where--- toByteString= id------instance ToByteString String where--- toByteString = pack- --- | 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 (Monoid view,Typeable view) => FormInput view where- toByteString :: view -> ByteString- toHttpData :: view -> HttpData- fromStr :: String -> view- fromStrNoEncode :: String -> view- ftag :: String -> view -> view - inred :: view -> view - flink :: String -> view -> view - flink1:: String -> view - flink1 verb = flink verb (fromStr verb) - finput :: Name -> Type -> Value -> Checked -> OnClick -> view - ftextarea :: String -> String -> view- fselect :: String -> view -> view- foption :: String -> view -> Bool -> view - foption1 :: String -> Bool -> view - foption1 val msel= foption val (fromStr val) msel - formAction :: String -> view -> view- attrs :: view -> Attribs -> view- -----instance (MonadIO m) => MonadIO (FlowM view m) where--- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad----instance Executable (View v m) where--- execute f = execute $ evalStateT f mFlowState0-----instance (Monad m, Executable m, Monoid view, FormInput view)--- => Executable (StateT (MFlowState view) m) where--- execute f= execute $ evalStateT f mFlowState0---- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance--- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose--- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his--- own instance for his monad.------ With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)---, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases.------ @--- import MFlow.Wai.XHtm.All--- import Some.Time.Library--- addMessageFlows [(noscript, time)]--- main= run 80 waiMessageFlow--- time=do ask $ cachedWidget \"time\" 5--- $ wlink () bold << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\"--- time--- @------ this pseudocode would update the time every 5 seconds. The execution of the IO computation--- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions.------ NOTE: cached widgets are shared by all users-cachedWidget ::(MonadIO m,Typeable view- , FormInput view, Typeable a, Executable m )- => String -- ^ The key of the cached object for the retrieval- -> Int -- ^ Timeout of the caching. Zero means sessionwide- -> View view Identity a -- ^ The cached widget, in the Identity monad- -> View view m a -- ^ The cached result-cachedWidget key t mf = View . StateT $ \s -> do-- let((FormElm form _), sec)= execute $ cachedByKey key t $ proc mf s{mfCached=True}- let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True}- let s''= s{inSync = inSync s2- ,mfRequirements=mfRequirements s2- ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec}- return $ (mfSeqCache s'') `seq` ((FormElm form mx2), s'')- -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))- where- proc mf s= runStateT (runView mf) s >>= \(r,_) ->mfSeqCache s `seq` return (r,mfSeqCache s )---- | A shorter name for `cachedWidget`-wcached ::(MonadIO m,Typeable view- , FormInput view, Typeable a, Executable m )- => String -- ^ The key of the cached object for the retrieval- -> Int -- ^ Timeout of the caching. Zero means sessionwide- -> View view Identity a -- ^ The cached widget, in the Identity monad- -> View view m a -- ^ The cached result-wcached= cachedWidget---- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@--- cache also the user response. This is useful for pseudo-widgets which just show information--- while the controls are in other non freezed widgets. A freezed widget ever return the first user response--- It is faster than `cachedWidget`.--- It is not restricted to the Identity monad.------ NOTE: cached widgets are shared by all users-wfreeze ::(MonadIO m,Typeable view- , FormInput view, Typeable a, Executable m )- => String -- ^ The key of the cached object for the retrieval- -> Int -- ^ Timeout of the caching. Zero means sessionwide- -> View view m a -- ^ The cached widget- -> View view m a -- ^ The cached result-wfreeze key t mf = View . StateT $ \s -> do- ((FormElm f mx), req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True}- return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq,mfAjax=ajax})- where- proc mf s= do- (r,s) <- runStateT (runView mf) s- return (r,mfRequirements s, mfSeqCache s,mfAjax s)---- ----- | FormLet class ---class (Functor m, MonadIO m) => FormLet a m view where --- digest :: Maybe a --- -> View view m a ----wrender--- :: Widget a1 a m v => a1 -> StateT (MFlowState v) m ([v], Maybe a)--- ---wrender x =do--- (FormElm frm x) <- runView (widget x)--- return (frm, x) - --- Minimal definition: either (wrender and wget) or widget ---class (Functor m, MonadIO m) => Widget a b m view | a -> b view where --- wrender :: a -> WState view m [view] --- wrender x =do--- (FormElm frm (_ :: Maybe b)) <- runView (widget x)--- return frm --- wget :: a -> WState view m (Maybe b) --- wget x= runView (widget x) >>= \(FormElm _ mx) -> return mx - --- widget :: a -> View view m b --- widget x = View $ do --- form <- wrender x --- got <- wget x --- return $ FormElm form got - - ---instance FormLet a m view => Widget (Maybe a) a m view where --- widget = digest --{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`-`waiMessageFlow` or `addMessageFlows`--The flow is executed in a loop. When the flow is finished, it is started again--@main= do- addMessageFlows [(\"noscript\",transient $ runFlow mainf)]- forkIO . run 80 $ waiMessageFlow- adminLoop-@--} -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- 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----- | Run a persistent flow inside the current flow. It is identified by the procedure and--- the string identifier.--- unlike the normal flows, that are infinite loops, runFlowIn executes a finite flow--- once executed, in subsequent executions the flow will return the stored result--- without asking again. This is useful for asking/storing/retrieving user defined configurations.-runFlowIn- :: (MonadIO m,- FormInput view)- => String- -> FlowM view (Workflow IO) b- -> FlowM view m b-runFlowIn wf f= do- t <- gets mfToken- FlowM . BackT $ liftIO $ WF.exec1nc wf $ runFlow1 f t-- where- runFlow1 f t= evalStateT (runBackT . runFlowM $ f) mFlowState0{mfToken=t,mfEnv= tenv t} -- >>= return . fromFailBack -- >> return ()---- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn--- outside of a web application-runFlowConf :: (FormInput view, MonadIO m) - => FlowM view m a -> m a -runFlowConf f = do- q <- liftIO newEmptyMVar -- `debug` (i++w++u)- qr <- liftIO newEmptyMVar- let t= Token "" "" "" [] q qr- evalStateT (runBackT . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()----step - :: (Serialize a,- Typeable view,- FormInput view, - MonadIO m, - 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----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,--- FormInput view,--- Monoid view, --- MonadIO m, --- Typeable a) => --- FlowM view m a --- -> FlowM view (Workflow m) a---stepDebug f= BackT $ do--- s <- get--- (r, s') <- lift $ do--- (r',stat)<- do--- rec <- isInRecover--- case rec of--- True ->do (r', s'') <- getStep 0--- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)})--- False -> return (undefined,s)--- (r'', s''') <- WF.stepDebug $ runStateT (runBackT f) stat >>= \(r,s)-> return (r, s)--- return $ (r'' `asTypeOf` r', s''' )--- put s'--- return r----getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)- => String -> Params -> [v] -> m (FormElm v a)-getParam1 par req form= r- where- r= case lookup par req of- Just x -> do- modify $ \s -> s{inSync= True}- maybeRead x -- !> x- Nothing -> return $ FormElm form Nothing- getType :: m (FormElm v a) -> a- getType= undefined- x= getType r- maybeRead str= do-- if typeOf x == (typeOf ( undefined :: String))- then return . FormElm form . Just $ unsafeCoerce str- else case readsPrec 0 $ str of- [(x,"")] -> return . FormElm form $ Just x- _ -> do-- let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)- return $ FormElm (form++[err]) Nothing ------- Requirements----- | Requirements are javascripts, Stylesheets or server processes (or any instance of the 'Requirement' class) that are included in the--- Web page or in the server when a widget specifies this. @requires@ is the--- procedure to be called with the list of requirements.--- Varios widgets in the page can require the same element, MFlow will install it once.-requires rs =do- st <- get- let l = mfRequirements st--- let rs'= map Requirement rs \\ l- put st {mfRequirements= l ++ map Requirement rs}----data Requirement= forall a.(Typeable a,Requirements a) => Requirement a deriving Typeable--class Requirements a where- installRequirements :: (Monad m,FormInput view) => [a] -> m view----installAllRequirements ::( Monad m, FormInput view) => WState view m view-installAllRequirements= do- rs <- gets mfRequirements- installAllRequirements1 mempty rs- where-- installAllRequirements1 v []= return v- installAllRequirements1 v rs= do- let typehead= case head rs of {Requirement r -> typeOf r}- (rs',rs'')= partition1 typehead rs- v' <- installRequirements2 rs'- installAllRequirements1 (v `mappend` v') rs''- where- installRequirements2 []= return $ fromStrNoEncode ""- installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs- unmap []=[]- unmap (Requirement r:rs)= unsafeCoerce r:unmap rs- partition1 typehead xs = foldr select ([],[]) xs- where- select x ~(ts,fs)=- let typer= case x of Requirement r -> typeOf r- in if typer== typehead then ( x:ts,fs)- else (ts, x:fs)---- Web requirements ----loadjsfile filename lcallbacks=- "var fileref=document.createElement('script');\- \fileref.setAttribute('type','text/javascript');\- \fileref.setAttribute('src',\'" ++ filename ++ "\');\- \document.getElementsByTagName('head')[0].appendChild(fileref);"- ++ onload- where- onload= case lcallbacks of- [] -> ""- cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};"---loadjs content= content---loadcssfile filename=- "var fileref=document.createElement('link');\- \fileref.setAttribute('rel', 'stylesheet');\- \fileref.setAttribute('type', 'text/css');\- \fileref.setAttribute('href', \'"++filename++"\');\- \document.getElementsByTagName('head')[0].appendChild(fileref);"---loadcss content=- "var fileref=document.createElement('link');\- \fileref.setAttribute('rel', 'stylesheet');\- \fileref.setAttribute('type', 'text/css');\- \fileref.innerText=\""++content++"\";\- \document.getElementsByTagName('head')[0].appendChild(fileref);"-------data WebRequirement= JScriptFile- String- [String] -- ^ Script URL and the list of scripts to be executed when loaded- | CSSFile String -- ^ a CSS file URL- | CSS String -- ^ a String with a CSS description- | JScript String -- ^ a string with a valid JavaScript- | ServerProc (String, Flow) -- ^ a server procedure- deriving(Typeable,Eq,Ord,Show)--instance Eq (String, Flow) where- (x,_) == (y,_)= x == y--instance Ord (String, Flow) where- compare(x,_) (y,_)= compare x y-instance Show (String, Flow) where- show (x,_)= show x--instance Requirements WebRequirement where- installRequirements= installWebRequirements----installWebRequirements :: (Monad m,FormInput view) =>[WebRequirement] -> m view-installWebRequirements rs= do- let s = aggregate $ sort rs-- return $ ftag "script" (fromStrNoEncode s)- where- aggregate []= ""--- aggregate (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs)- | f==f'= aggregate $ JScriptFile f (nub c++c'):rs- | otherwise= strRequirement r++aggregate (r':rs)-- aggregate (r:r':rs)- | r== r' = aggregate $ r:rs- | otherwise= strRequirement r ++ aggregate (r':rs)-- aggregate (r:rs)= strRequirement r++aggregate rs-- strRequirement (CSSFile s') = loadcssfile s'- strRequirement (CSS s') = loadcss s'- strRequirement (JScriptFile s' call) = loadjsfile s' call- strRequirement (JScript s') = loadjs s'- strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` ""------ AJAX -----ajaxScript=- "function loadXMLObj()" ++- "{" ++- "var xmlhttp;" ++- "if (window.XMLHttpRequest)" ++- "{"++- " xmlhttp=new XMLHttpRequest();" ++- " }" ++- "else" ++- "{"++- " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++- " }" ++- "return xmlhttp" ++- "};" ++-- " xmlhttp= loadXMLObj();" ++- " noparam= '';"++- ""++- "function doServer (servproc,param,param2){" ++- " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++- " xmlhttp.send();};" ++- ""++- "xmlhttp.onreadystatechange=function()" ++- " {" ++- " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++- " {" ++- " eval(xmlhttp.responseText);" ++- " }" ++- " };" ++- ""-+----------------------------------------------------------------------------- +-- +-- Module : MFlow.Forms.Internals +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- +{-# OPTIONS -XDeriveDataTypeable + -XExistentialQuantification + -XScopedTypeVariables + -XFlexibleInstances + -XUndecidableInstances + -XMultiParamTypeClasses + -XGeneralizedNewtypeDeriving + -XFlexibleContexts + -XOverlappingInstances + -XRecordWildCards +#-} + +module MFlow.Forms.Internals where +import MFlow +import MFlow.Cookies +import Control.Applicative +import Data.Monoid +import Control.Monad.Trans +import Control.Monad.State +import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) +import Data.Typeable +import Data.RefSerialize hiding((<|>)) +import Data.TCache +import Data.TCache.Memoization +import Data.TCache.DefaultPersistence +import Data.TCache.Memoization +import Data.Dynamic +import qualified Data.Map as M +import Unsafe.Coerce +import Control.Workflow as WF +import Control.Monad.Identity +import Data.List +import System.IO.Unsafe +import Control.Concurrent.MVar + +-- for traces +--import Language.Haskell.TH.Syntax(qLocation, Loc(..), Q, Exp, Quasi) +--import Text.Printf + + +import Debug.Trace +(!>) = const -- flip trace + +instance Serialize a => Serializable a where + serialize= runW . showp + deserialize= runR readp + +type UserStr= String +type PasswdStr= String + +data User= User + { userName :: String + , upassword :: String + } deriving (Read, Show, Typeable) + +eUser= User (error1 "username") (error1 "password") + +error1 s= error $ s ++ " undefined" + +userPrefix= "user/" +instance Indexable User where + key User{userName= user}= keyUserName user + +-- | Return the key name of an user +keyUserName n= userPrefix++n + +-- | Register an user/password +userRegister :: MonadIO m => String -> String -> m (DBRef User) +userRegister user password = liftIO . atomically $ newDBRef $ User user password + +-- | Authentication against `userRegister`ed users. +-- to be used with `validate` +userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view) +userValidate (u,p) = + let user= eUser{userName=u} + in liftIO $ atomically + $ withSTMResources [user] + $ \ mu -> case mu of + [Nothing] -> resources{toReturn= err } + [Just (User _ pass )] -> resources{toReturn= + case pass==p of + True -> Nothing + False -> err + } + + where + err= Just . fromStr $ "Username or password invalid" + +data Config = Config UserStr deriving (Read, Show, Typeable) + +keyConfig= "mflow.config" +instance Indexable Config where key _= keyConfig +rconf= getDBRef keyConfig + +setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m () +setAdminUser user password= liftIO $ atomically $ do + newDBRef $ User user password + writeDBRef rconf $ Config user + +getAdminName :: MonadIO m => m UserStr +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) + + +instance (Serialize a) => Serialize (FailBack a ) where + showp (BackPoint x)= insertString (pack iCanFailBack) >> showp x + showp (NoBack x)= insertString (pack noFailBack) >> showp x + showp GoBack = insertString (pack repeatPlease) + + readp = choice [icanFailBackp,repeatPleasep,noFailBackp] + where + noFailBackp = {-# SCC "deserialNoBack" #-} symbol noFailBack >> readp >>= return . NoBack + icanFailBackp = {-# SCC "deserialBackPoint" #-} symbol iCanFailBack >> readp >>= return . BackPoint + repeatPleasep = {-# SCC "deserialbackPlease" #-} symbol repeatPlease >> return GoBack + +iCanFailBack= "B" +repeatPlease= "G" +noFailBack= "N" + +newtype BackT m a = BackT { runBackT :: m (FailBack a ) } + +instance (Monad m, HandleBacktracking s m)=> Monad (BackT m) where + fail _ = BackT . return $ GoBack + return x = BackT . return $ NoBack x + x >>= f = BackT $ loop + where + loop = do + s <- get + v <- runBackT x -- !> "loop" + case v of + NoBack y -> runBackT (f y) -- !> "runback" + BackPoint y -> do + z <- runBackT (f y) -- !> "BACK" + case z of + GoBack -> handle s >> loop -- !> "BACKTRACKING" + other -> return other + GoBack -> return $ GoBack + +class MonadState s m => HandleBacktracking s m where + handle :: s -> m () +-- supervise :: m (FailBack a) -> m (FailBack a) + +--instance Monad m => HandleBacktracking () m where +-- handle= const $ return () + +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 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. +breturn :: (Monad m) => a -> FlowM v m a +breturn = flowM . BackT . return . BackPoint -- !> "breturn" + + +instance (HandleBacktracking s m,MonadIO m) => MonadIO (BackT m) where + liftIO f= BackT $ liftIO f >>= \ x -> return $ NoBack x + +instance (Monad m,Functor m) => Functor (BackT m) where + fmap f g= BackT $ do + mr <- runBackT g + case mr of + BackPoint x -> return . BackPoint $ f x + NoBack x -> return . NoBack $ f x + GoBack -> return $ GoBack + + +liftBackT f = BackT $ f >>= \x -> return $ NoBack x +instance MonadTrans BackT where + lift f = BackT $ f >>= \x -> return $ NoBack x + + +instance (HandleBacktracking s m,MonadState s m) => MonadState s (BackT m) where + get= lift get -- !> "get" + put= lift . put + +type WState view m = StateT (MFlowState view) m +type FlowMM view m= BackT (WState view m) + +data FormElm view a = FormElm [view] (Maybe a) deriving Typeable + +instance Serialize a => Serialize (FormElm view a) where + showp (FormElm _ x)= showp x + readp= readp >>= \x -> return $ FormElm [] x + +-- | @View v m a@ is a widget (formlet) with formatting `v` running the monad `m` (usually `IO`) and which return a value of type `a` +--+-- It has 'Applicative', 'Alternative' and 'Monad' instances.+--+-- Things to know about these instances:+--+-- If the View expression does not validate, ask will present the page again.+--+-- /Alternative instance/: Both alternatives are executed. The rest is as usual+--+-- /Monad Instance/:+--+-- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'+--+-- The execution is stopped when the statement has a formlet-widget that does not validate.+--+-- The monadic code is executed from the beginning each time the page is presented or refreshed+--+-- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour+--+-- use 'pageFlow' to identify each subflow branch of a conditional+--+-- For example:+--+-- > pageFlow "myid" $ do+-- > r <- formlet1+-- > liftIO $ ioaction1 r+-- > s <- formlet2+-- > liftIO $ ioaction2 s+-- > case s of+-- > True -> pageFlow "idtrue" $ do ....+-- > False -> paeFlow "idfalse" $ do ...+-- > ...+--+-- Here if @formlet2@ do not validate, @ioaction2@ is not executed. But if @formLet1@ validates and the+-- page is refreshed two times (because @formlet2@ has failed, see above),then @ioaction1@ is executed two times.++newtype View v m a = View { runView :: WState v m (FormElm v a)} + +instance Monad m => HandleBacktracking (MFlowState v) (WState v m) where + handle st= do + MFlowState{..} <- get + case mfTrace of + Nothing -> + put st{mfEnv= mfEnv,mfToken=mfToken, mfPath=mfPath,mfPIndex= mfPIndex, mfData=mfData,inSync=False,newAsk=False} +-- Just trace -> do +-- -- inspired by Pepe Iborra withLocTH +-- loc <- qLocation +-- let loc_msg = showLoc loc +-- put st{mfTrace= Just(loc_msg:trace)} + + +-- supervise f= f `WF.catch` handler +-- where +-- handler e= do +-- loc <- qLocation +-- let loc_msg = showLoc loc +-- modify $ \st -> st{mfTrace= Just [loc_msg++" exception: " ++show e]} +-- return GoBack + +--showLoc :: Loc -> String +--showLoc Loc{loc_module=mod, loc_filename=filename, loc_start=start} = +-- {- text package <> char '.' <> -} +-- printf "%s (%s). %s" mod filename (show start) + +--instance (MonadIO m, Functor m) => Quasi (StateT (MFlowState v) m) where +-- qLocation = badIO "currentLocation" + + +badIO :: MonadIO m => String -> StateT (MFlowState v) m a +badIO op = do + liftIO $ putStrLn $ "Template Haskell error: " ++"Can't do `" ++ op ++ "' in the IO monad" + fail "Template Haskell failure" + +-- | the FlowM monad executes the page navigation. It perform backtracking when necessary to syncronize+-- when the user press the back button or when the user enter an arbitrary URL. The instruction pointer+-- is moved to the right position within the procedure to handle the request.+--+-- However this is transparent to the programmer, who codify in the style of a console application. +newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,MonadState(MFlowState v)) +flowM= FlowM +--runFlowM= runView + + + +instance (FormInput v,Serialize a) + => Serialize (a,MFlowState v) where + showp (x,s)= case mfDebug s of + False -> showp x + True -> showp(x, mfEnv s) + readp= choice[nodebug, debug] + where + nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= -1}) + debug= do + (x,env) <- readp + return (x,mFlowState0{mfEnv= env,mfSequence= -1}) + + +instance Functor (FormElm view ) where + fmap f (FormElm form x)= FormElm form (fmap f x) + +instance (Monad m,Functor m) => Functor (View view m) where + fmap f x= View $ fmap (fmap f) $ runView x + + +instance (Functor m, Monad m) => Applicative (View view m) where + pure a = View $ return (FormElm [] $ Just a) + View f <*> View g= View $ + f >>= \(FormElm form1 k) -> + g >>= \(FormElm form2 x) -> + return $ FormElm (form1 ++ form2) (k <*> x) + +instance (Functor m, Monad m) => Alternative (View view m) where + empty= View $ return $ FormElm [] Nothing + View f <|> View g= View $ do + FormElm form1 k <- f + FormElm form2 x <- g + + return $ FormElm (form1 ++ form2) (k <|> x) + + +instance (Monad m) => Monad (View view m) where + View x >>= f = View $ do + FormElm form1 mk <- x + case mk of + Just k -> do + modify $ \st -> st{linkMatched= False} !> "------M--------" + FormElm form2 mk <- runView $ f k + return $ FormElm (form1 ++ form2) mk + + Nothing -> + return $ FormElm form1 Nothing + + + return = View . return . FormElm [] . Just +-- fail msg= View . return $ FormElm [fromStr msg] Nothing + + + +instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where + mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum + mempty= return mempty + + +-- | It is a callback in the view monad. The callback rendering substitutes the widget rendering +-- when the latter is validated, without afecting the rendering of other widgets. This allow +-- the simultaneous execution of different behaviours in different widgets simultaneously in the +-- same page. The inspiration is the callback primitive in the Seaside Web Framework +-- that allows similar functionality (See <http://www.seaside.st>) +-- +-- This is the visible difference with 'waction' callbacks, which execute a +-- a flow in the FlowM monad that takes complete control of the navigation, while wactions are +-- executed whithin the same ask statement. +wcallback + :: Monad m => + View view m a -> (a -> View view m b) -> View view m b +wcallback (View x) f = View $ do + FormElm form1 mk <- x + case mk of + Just k -> do + modify $ \st -> st{linkMatched= False} !> "-------C-------" + runView (f k) + Nothing -> return $ FormElm form1 Nothing + +--incLink :: MonadState (MFlowState view) m => m() +--incLink= modify $ \st -> st{mfPIndex= if linkMatched st then mfPIndex st + 1 else mfPIndex st +-- ,linkMatched= False} -- !> "<-inc" +--incLinkDepth +-- :: MFlowState v -> Int +--incLinkDepth s= +-- +-- let depth= mfLinkDepth s +-- in if mfLinkSelected s +-- then +-- depth +1 +-- else +-- depth + + + +--instance (Monad m) => Monad (FlowM view m) where +-- --View view m a-> (a -> View view m b) -> View view m b +-- FlowM x >>= f = FlowM $ do +-- FormElm _ mk <- x +-- case mk of +-- Just k -> do +-- FormElm _ mk <- runFlowM $ f k +-- return $ FormElm [] mk +-- Nothing -> return $ FormElm [] Nothing +-- +-- return= FlowM . return . FormElm [] . Just + +instance MonadTrans (View view) where + lift f = View $ (lift f) >>= \x -> return $ FormElm [] $ Just x + +instance MonadTrans (FlowM view) where + lift f = FlowM $ lift (lift f) >>= \x -> return x + +instance (Monad m)=> MonadState (MFlowState view) (View view m) where + get = View $ get >>= \x -> return $ FormElm [] $ Just x + put st = View $ put st >>= \x -> return $ FormElm [] $ Just x + +--instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where +-- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x +-- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x + + +instance (MonadIO m) => MonadIO (View view m) where + liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad + +-- | Execute the widget in a monad and return the result in another. +changeMonad :: (Monad m, Executable m1) + => View v m1 a -> View v m a +changeMonad w= View . StateT $ \s -> + let (r,s')= execute $ runStateT ( runView w) s + in mfSequence s' `seq` return (r,s') + +-- | True if the flow is going back (as a result of the back button pressed in the web browser). +-- Usually this check is nos necessary unless conditional code make it necessary +-- +-- @menu= do +-- mop <- getGoStraighTo +-- case mop of +-- Just goop -> goop +-- Nothing -> do +-- r \<- `ask` option1 \<|> option2 +-- case r of +-- op1 -> setGoStraighTo (Just goop1) >> goop1 +-- op2 -> setGoStraighTo (Just goop2) >> goop2@ +-- +-- This pseudocode below would execute the ask of the menu once. But the user will never have +-- the possibility to see the menu again. To let him choose other option, the code +-- has to be change to +-- +-- @menu= do +-- mop <- getGoStraighTo +-- back <- `goingBack` +-- case (mop,back) of +-- (Just goop,False) -> goop +-- _ -> do +-- r \<- `ask` option1 \<|> option2 +-- case r of +-- op1 -> setGoStraighTo (Just goop1) >> goop1 +-- op2 -> setGoStraighTo (Just goop2) >> goop2@ +-- +-- However this is very specialized. Normally the back button detection is not necessary. +-- In a persistent flow (with step) even this default entry option would be completely automatic, +-- since the process would restar at the last page visited. No setting is necessary. +goingBack :: (MonadIO m,MonadState (MFlowState view) m) => m Bool +goingBack = do + st <- get + liftIO $ do + print $"Insync=" ++ show (inSync st) + print $ "newAsk st=" ++ show (newAsk st) + return $ not (inSync st) && not (newAsk st) + +-- | 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 + liftIO $ putStr "BACK= ">> print back + if not back then breturn() else do + breturn() -- will not go back bellond this + clearEnv + modify $ \s -> s{newAsk= True} + msg + + + +type Lang= String + +data MFlowState view= MFlowState{ + mfSequence :: Int, + mfCached :: Bool, + newAsk :: 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, + + -- Link management + mfPath :: [String], + + mfPrefix :: String, + mfPIndex :: Int, + mfPageIndex :: Maybe Int, + linkMatched :: Bool, + mfLinks :: M.Map String Int, + + mfAutorefresh :: Bool, + mfTrace :: Maybe [String] + } + deriving Typeable + +type Void = Char + +mFlowState0 :: (FormInput view) => MFlowState view +mFlowState0 = MFlowState 0 False True True "en" + [] False (error "token of mFlowState0 used") + 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] "" 1 Nothing False M.empty False Nothing + + +-- | Set user-defined data in the context of the session. +-- +-- The data is indexed by type in a map. So the user can insert-retrieve different kinds of data +-- in the session context. +-- +-- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow: +-- +-- > newtype History = History ( Html) deriving Typeable +-- > setHistory html= setSessionData $ History html +-- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h +-- > addHistory html= do +-- > html' <- getHistory +-- > setHistory $ html' `mappend` html + +setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m () +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. +getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a) +getSessionData = resp where + resp= gets mfData >>= \list -> + case M.lookup ( typeOf $ typeResp resp ) list of + Just x -> return . Just $ unsafeCoerce x + Nothing -> return $ Nothing + typeResp :: m (Maybe x) -> x + typeResp= undefined + +-- | Return the user language. Now it is fixed to "en" +getLang :: MonadState (MFlowState view) m => m String +getLang= gets mfLang + +getToken :: MonadState (MFlowState view) m => m Token +getToken= gets mfToken + + +-- get a parameter form the las received response +getEnv :: MonadState (MFlowState view) m => m Params +getEnv = gets mfEnv + +stdHeader v = v + + +-- | Set the header-footer that will enclose the widgets. It must be provided in the +-- same formatting than them, altrough with normalization to byteStrings any formatting can be used +-- +-- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>) +-- +-- @ +-- setHeader $ \c -> +-- \<html\> +-- \<head\> +-- \<title\> my title \</title\> +-- \<meta name= \"Keywords\" content= \"sci-fi\" /\>) +-- \</head\> +-- \<body style= \"margin-left:5%;margin-right:5%\"\> +-- \<% c %\> +-- \</body\> +-- \</html\> +-- @ +-- +-- This header uses "Text.XHtml" +-- +-- @ +-- setHeader $ \c -> +-- `thehtml` +-- << (`header` +-- << (`thetitle` << title +++ +-- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++ +-- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c +-- @ +-- +-- This header uses both. It uses byteString tags +-- +-- @ +-- setHeader $ \c -> +-- `bhtml` [] $ +-- `btag` "head" [] $ +-- (`toByteString` (thetitle << title) `append` +-- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append` +-- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c +-- @ + +setHeader :: MonadState (MFlowState view) m => (view -> view) -> m () +setHeader header= do + fs <- get + put fs{mfHeader= header} + +----addHeader added= do +---- h <- gets mfHeader +---- let h' added html = h $ added <> html +---- setHeader $ h' added +---- +----addFooter added= do +---- h <- gets mfHeader +---- let h' added html = h $ html <> added +---- setHeader $ h' added + + +-- | Return the current header +getHeader :: (Monad m) => FlowM view m (view -> view) +getHeader= gets mfHeader + +-- | Set an HTTP cookie +setCookie :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> String -- ^ path + -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie + -> m () +setCookie n v p me= do + modify $ \st -> st{mfCookies= (n,v,p,fmap show me):mfCookies st } + +-- | Set an HTTP Response header +setHttpHeader :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> m () +setHttpHeader n v = do + modify $ \st -> st{mfHttpHeaders= (n,v):mfHttpHeaders st } + + +-- | Set 1) the timeout of the flow execution since the last user interaction. +-- Once passed, the flow executes from the begining. 2). In persistent flows +-- it set the session state timeout for the flow, that is persistent. If the +-- flow is not persistent, it has no effect. +-- +-- `transient` flows restart anew. +-- persistent flows (that use `step`) restart at the las saved execution point, unless +-- the session time has expired for the user. +setTimeouts :: Monad m => Int -> Integer -> FlowM view m () +setTimeouts kt st= do + fs <- get + put fs{ mfkillTime= kt, mfSessionTime= st} + + +getWFName :: MonadState (MFlowState view) m => m String +getWFName = do + fs <- get + return . twfname $ mfToken fs + +getCurrentUser :: MonadState (MFlowState view) m => m String +getCurrentUser = do + st<- gets mfToken + return $ tuser st + +type Name= String +type Type= String +type Value= String +type Checked= Bool +type OnClick= Maybe String + +normalize :: (Monad m, FormInput v) => View v m a -> View ByteString m a +normalize f= View . StateT $ \s ->do + (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s + return (FormElm (map toByteString fs ) mx,unsafeCoerce s') + +--class ToByteString a where +-- toByteString :: a -> ByteString +-- +--instance ToByteString a => ToHttpData a where +-- toHttpData = toHttpData . toByteString +-- +--instance ToByteString ByteString where +-- toByteString= id +-- +--instance ToByteString String where +-- toByteString = pack + +-- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic +-- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an +-- instance of this class +-- +-- See "MFlow.Forms.Blaze.Html for the instance for blaze-html. "MFlow.Forms.XHtml" for the instance +-- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages. +class (Monoid view,Typeable view) => FormInput view where + toByteString :: view -> ByteString + toHttpData :: view -> HttpData + fromStr :: String -> view + fromStrNoEncode :: String -> view + ftag :: String -> view -> view + inred :: view -> view + flink :: String -> view -> view + flink1:: String -> view + flink1 verb = flink verb (fromStr verb) + finput :: Name -> Type -> Value -> Checked -> OnClick -> view + ftextarea :: String -> String -> view + fselect :: String -> view -> view + foption :: String -> view -> Bool -> view + foption1 :: String -> Bool -> view + foption1 val msel= foption val (fromStr val) msel + formAction :: String -> view -> view + attrs :: view -> Attribs -> view + + + +--instance (MonadIO m) => MonadIO (FlowM view m) where +-- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad + +--instance Executable (View v m) where +-- execute f = execute $ evalStateT f mFlowState0 + + +--instance (Monad m, Executable m, Monoid view, FormInput view) +-- => Executable (StateT (MFlowState view) m) where +-- execute f= execute $ evalStateT f mFlowState0 + +-- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance +-- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose +-- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his +-- own instance for his monad. +-- +-- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) +--, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases. +-- +-- @ +-- import MFlow.Wai.XHtm.All +-- import Some.Time.Library +-- addMessageFlows [(noscript, time)] +-- main= run 80 waiMessageFlow +-- time=do ask $ cachedWidget \"time\" 5 +-- $ wlink () bold << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\" +-- time +-- @ +-- +-- this pseudocode would update the time every 5 seconds. The execution of the IO computation +-- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions. +-- +-- NOTE: cached widgets are shared by all users +cachedWidget :: (MonadIO m,Typeable view + , FormInput view, Typeable a, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> View view Identity a -- ^ The cached widget, in the Identity monad + -> View view m a -- ^ The cached result +cachedWidget key t mf = View . StateT $ \s -> do + let((FormElm form _), sec)= execute $ cachedByKey key t $ proc mf s{mfCached=True} + let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True} + let s''= s{inSync = inSync s2 + ,mfRequirements=mfRequirements s2 + ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec} + return $ (mfSeqCache s'') `seq` ((FormElm form mx2), s'') + -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2)) + where + proc mf s= runStateT (runView mf) s >>= \(r,_) ->mfSeqCache s `seq` return (r,mfSeqCache s ) + +-- | A shorter name for `cachedWidget` +wcached :: (MonadIO m,Typeable view + , FormInput view, Typeable a, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> View view Identity a -- ^ The cached widget, in the Identity monad + -> View view m a -- ^ The cached result +wcached= cachedWidget + +-- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@ +-- cache also the user response. This is useful for pseudo-widgets which just show information +-- while the controls are in other non freezed widgets. A freezed widget ever return the first user response +-- It is faster than `cachedWidget`. +-- It is not restricted to the Identity monad. +-- +-- NOTE: cached widgets are shared by all users +wfreeze :: (MonadIO m,Typeable view + , FormInput view, Typeable a, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> View view m a -- ^ The cached widget + -> View view m a -- ^ The cached result +wfreeze key t mf = View . StateT $ \s -> do + ((FormElm f mx), req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True} + return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq,mfAjax=ajax}) + where + proc mf s= do + (r,s) <- runStateT (runView mf) s + return (r,mfRequirements s, mfSeqCache s,mfAjax s) + +-- +---- | FormLet class +--class (Functor m, MonadIO m) => FormLet a m view where +-- digest :: Maybe a +-- -> View view m a + +--wrender +-- :: Widget a1 a m v => a1 -> StateT (MFlowState v) m ([v], Maybe a) +-- +--wrender x =do +-- (FormElm frm x) <- runView (widget x) +-- return (frm, x) + +-- Minimal definition: either (wrender and wget) or widget +--class (Functor m, MonadIO m) => Widget a b m view | a -> b view where +-- wrender :: a -> WState view m [view] +-- wrender x =do +-- (FormElm frm (_ :: Maybe b)) <- runView (widget x) +-- return frm +-- wget :: a -> WState view m (Maybe b) +-- wget x= runView (widget x) >>= \(FormElm _ mx) -> return mx + +-- widget :: a -> View view m b +-- widget x = View $ do +-- form <- wrender x +-- got <- wget x +-- return $ FormElm form got + + +--instance FormLet a m view => Widget (Maybe a) a m view where +-- widget = digest + +{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow` +`waiMessageFlow` or `addMessageFlows` + +The flow is executed in a loop. When the flow is finished, it is started again + +@main= do + addMessageFlows [(\"noscript\",transient $ runFlow mainf)] + forkIO . run 80 $ waiMessageFlow + adminLoop +@ +-} +runFlow :: (FormInput view, MonadIO 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 + loop f t = do + t' <- f t + let t''= t'{tpath=[twfname t']} + liftIO $ do + flushRec t'' + sendToMF t'' t'' -- !> "SEND" + loop f t'' -- !> "LOOPAGAIN" + + + +runFlowOnce :: (FormInput view, Monad m) + => FlowM view m () -> Token -> m () +runFlowOnce f t= runFlowOnce1 f t >> return () + +runFlowOnce1 f t = + evalStateT (runBackT . runFlowM $ do + backInit + f + getToken) + mFlowState0{mfToken=t + ,mfPath= tpath t + ,mfEnv= tenv t} >>= return . fromFailBack + + where + backInit= do + modify $ \s -> s{mfEnv=[], newAsk= True} + breturn () + -- to restart the flow in case of going back before the first page of the flow + + +-- | Run a persistent flow inside the current flow. It is identified by the procedure and +-- the string identifier. +-- unlike the normal flows, that are infinite loops, runFlowIn executes a finite flow +-- once executed, in subsequent executions the flow will return the stored result +-- without asking again. This is useful for asking/storing/retrieving user defined configurations. +runFlowIn + :: (MonadIO m, + FormInput view) + => String + -> FlowM view (Workflow IO) b + -> FlowM view m b +runFlowIn wf f= do + t <- gets mfToken + FlowM . BackT $ liftIO $ WF.exec1nc wf $ runFlow1 f t + + where + runFlow1 f t= evalStateT (runBackT . runFlowM $ f) mFlowState0{mfToken=t,mfEnv= tenv t} -- >>= return . fromFailBack -- >> return () + +-- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn +-- outside of a web application +runFlowConf :: (FormInput view, MonadIO m) + => FlowM view m a -> m a +runFlowConf f = do + q <- liftIO newEmptyMVar -- `debug` (i++w++u) + qr <- liftIO newEmptyMVar + let t= Token "" "" "" [] [] q qr + evalStateT (runBackT . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return () + + + +-- | Clears the environment +clearEnv :: MonadState (MFlowState view) m => m () +clearEnv= do + st <- get + put st{ mfEnv= []} + +step + :: (Serialize a, + Typeable view, + FormInput view, + MonadIO m, + 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' /= -1) $ put s' !> (show $ mfSequence s') -- else put s{newAsk=True} + 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, +-- FormInput view, +-- Monoid view, +-- MonadIO m, +-- Typeable a) => +-- FlowM view m a +-- -> FlowM view (Workflow m) a +--stepDebug f= BackT $ do +-- s <- get +-- (r, s') <- lift $ do +-- (r',stat)<- do +-- rec <- isInRecover +-- case rec of +-- True ->do (r', s'') <- getStep 0 +-- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)}) +-- False -> return (undefined,s) +-- (r'', s''') <- WF.stepDebug $ runStateT (runBackT f) stat >>= \(r,s)-> return (r, s) +-- return $ (r'' `asTypeOf` r', s''' ) +-- put s' +-- return r + + + +--getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) +-- => String -> Params -> [v] -> m (FormElm v a) +--getParam1 par req form= r +-- where +-- r= case lookup par req of +-- Just x -> do +-- modify $ \s -> s{inSync= True} +-- maybeRead x -- !> x +-- Nothing -> return $ FormElm form Nothing +-- getType :: m (FormElm v a) -> a +-- getType= undefined +-- x= getType r +-- maybeRead str= do +-- if typeOf x == (typeOf ( undefined :: String)) +-- then return . FormElm form . Just $ unsafeCoerce str +-- else case readsPrec 0 $ str of +-- [(x,"")] -> return . FormElm form $ Just x +-- _ -> do +-- +-- let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) +-- return $ FormElm (form++[err]) Nothing + +data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show) + +getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) + => String -> Params -> m (ParamResult v a) +getParam1 par req = r + where + r= case lookup par req of + Just x -> do + modify $ \s -> s{inSync= True} + maybeRead x -- !> x + Nothing -> return NoParam + getType :: m (ParamResult v a) -> a + getType= undefined + x= getType r + maybeRead str= do + if typeOf x == (typeOf ( undefined :: String)) + then return . Validated $ unsafeCoerce str + else case readsPrec 0 $ str of + [(x,"")] -> return $ Validated x + _ -> do + + let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) + return $ NotValidated str err + + +---- Requirements + + +-- | Requirements are javascripts, Stylesheets or server processes (or any instance of the 'Requirement' class) that are included in the +-- Web page or in the server when a widget specifies this. @requires@ is the +-- procedure to be called with the list of requirements. +-- Varios widgets in the page can require the same element, MFlow will install it once. +requires rs =do + st <- get + let l = mfRequirements st +-- let rs'= map Requirement rs \\ l + put st {mfRequirements= l ++ map Requirement rs} + + + +data Requirement= forall a.(Typeable a,Requirements a) => Requirement a deriving Typeable + +class Requirements a where + installRequirements :: (Monad m,FormInput view) => [a] -> m view + + + +installAllRequirements :: ( Monad m, FormInput view) => WState view m view +installAllRequirements= do + rs <- gets mfRequirements + installAllRequirements1 mempty rs + where + + installAllRequirements1 v []= return v + installAllRequirements1 v rs= do + let typehead= case head rs of {Requirement r -> typeOf r} + (rs',rs'')= partition1 typehead rs + v' <- installRequirements2 rs' + installAllRequirements1 (v `mappend` v') rs'' + where + installRequirements2 []= return $ fromStrNoEncode "" + installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs + unmap []=[] + unmap (Requirement r:rs)= unsafeCoerce r:unmap rs + partition1 typehead xs = foldr select ([],[]) xs + where + select x ~(ts,fs)= + let typer= case x of Requirement r -> typeOf r + in if typer== typehead then ( x:ts,fs) + else (ts, x:fs) + +-- Web requirements --- +loadjsfile filename lcallbacks= + "var fileref=document.createElement('script');\ + \fileref.setAttribute('type','text/javascript');\ + \fileref.setAttribute('src',\'" ++ filename ++ "\');\ + \document.getElementsByTagName('head')[0].appendChild(fileref);" + ++ onload + where + onload= case lcallbacks of + [] -> "" + cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};" + + +loadjs content= content + + +loadcssfile filename= + "var fileref=document.createElement('link');\ + \fileref.setAttribute('rel', 'stylesheet');\ + \fileref.setAttribute('type', 'text/css');\ + \fileref.setAttribute('href', \'"++filename++"\');\ + \document.getElementsByTagName('head')[0].appendChild(fileref);" + + +loadcss content= + "var fileref=document.createElement('link');\ + \fileref.setAttribute('rel', 'stylesheet');\ + \fileref.setAttribute('type', 'text/css');\ + \fileref.innerText=\""++content++"\";\ + \document.getElementsByTagName('head')[0].appendChild(fileref);" + + + + + + +data WebRequirement= JScriptFile + String + [String] -- ^ Script URL and the list of scripts to be executed when loaded + | CSSFile String -- ^ a CSS file URL + | CSS String -- ^ a String with a CSS description + | JScript String -- ^ a string with a valid JavaScript + | ServerProc (String, Flow) -- ^ a server procedure + deriving(Typeable,Eq,Ord,Show) + +instance Eq (String, Flow) where + (x,_) == (y,_)= x == y + +instance Ord (String, Flow) where + compare(x,_) (y,_)= compare x y +instance Show (String, Flow) where + show (x,_)= show x + +instance Requirements WebRequirement where + installRequirements= installWebRequirements + + + +installWebRequirements :: (Monad m,FormInput view) =>[WebRequirement] -> m view +installWebRequirements rs= do + let s = aggregate $ sort rs + + return $ ftag "script" (fromStrNoEncode s) + where + aggregate []= "" + + + aggregate (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs) + | f==f'= aggregate $ JScriptFile f (nub c++c'):rs + | otherwise= strRequirement r++aggregate (r':rs) + + aggregate (r:r':rs) + | r== r' = aggregate $ r:rs + | otherwise= strRequirement r ++ aggregate (r':rs) + + aggregate (r:rs)= strRequirement r++aggregate rs + + strRequirement (CSSFile s') = loadcssfile s' + strRequirement (CSS s') = loadcss s' + strRequirement (JScriptFile s' call) = loadjsfile s' call + strRequirement (JScript s') = loadjs s' + strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` "" + + +--- AJAX ---- +ajaxScript= + "function loadXMLObj()" ++ + "{" ++ + "var xmlhttp;" ++ + "if (window.XMLHttpRequest)" ++ + "{"++ + " xmlhttp=new XMLHttpRequest();" ++ + " }" ++ + "else" ++ + "{"++ + " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++ + " }" ++ + "return xmlhttp" ++ + "};" ++ + + " xmlhttp= loadXMLObj();" ++ + " noparam= '';"++ + ""++ + "function doServer (servproc,param,param2){" ++ + " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++ + " xmlhttp.send();};" ++ + ""++ + "xmlhttp.onreadystatechange=function()" ++ + " {" ++ + " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++ + " {" ++ + " eval(xmlhttp.responseText);" ++ + " }" ++ + " };" ++ + "" + +formPrefix index verb st form anchored= do + let path = currentPath False index (mfPath st) verb + (anchor,anchorf) + <- case anchored of + True -> do + anchor <- genNewId + return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)]) + False -> return (mempty,mempty) + return $ formAction (path ++ anchor ) $ mconcat ( anchorf:form) -- !> anchor + +currentPath isInBackTracking index lpath verb = + (if null lpath then verb + else case isInBackTracking of + True -> concat $ take index ['/':v | v <- lpath] !> ("index= " ++ show index) + False -> concat ['/':v| v <- lpath]) + +-- | Generate a new string. Useful for creating tag identifiers and other attributes +genNewId :: MonadState (MFlowState view) m => m String +genNewId= do + st <- get + case mfCached st of + False -> do + let n= mfSequence st + prefseq= mfPrefix st + put $ st{mfSequence= n+1} + + return $ 'p':show n++prefseq + True -> do + let n = mfSeqCache st + put $ st{mfSeqCache=n+1} + return $ 'c' : (show n)
src/MFlow/Forms/Test.hs view
@@ -21,7 +21,7 @@ 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 qualified MFlow.Forms (ask) import MFlow.Forms.Internals import MFlow.Forms(FormInput(..)) import MFlow.Forms.Admin @@ -44,12 +44,12 @@ import Data.Maybe import Data.IORef import MFlow.Cookies(cookieuser) --import Data.Dynamic-import Data.TCache.Memoization--import Debug.Trace-+ +import Data.Dynamic +import Data.TCache.Memoization + +import Debug.Trace + (!>)= flip trace class Generate a where @@ -96,17 +96,17 @@ -- | run a list of flows with a number of simultaneous threads --+ + runTest :: [(Int, Flow)] -> IO () runTest ps= do mapM_ (forkIO . run1) ps putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads" where - run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc+ run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc -runTest1 f = do+runTest1 f = do atomicModifyIORef testNumber (\n -> (n+1,n+1)) name <- generate x <- generate @@ -114,41 +114,41 @@ z <- generate r1<- liftIO newEmptyMVar r2<- liftIO newEmptyMVar - let t = Token x y z [] r1 r2 - 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+ let t = Token x y z [] [] r1 r2 + WF.start name f t --- | 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.-+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 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 :: (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+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 @@ -159,69 +159,69 @@ -- 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+ + +-- | 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-+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 -- marches <- readIORef matches -- return $ head map (m s) matches @@ -250,40 +250,40 @@ waction w f= do 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)+ => 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+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}+ let t = mfToken st + t'= t{tuser= uname} put st{mfToken= t'} - return ()+ return () getUserSimple :: ( FormInput view, Typeable view - , MonadIO m, Functor m)- => FlowM view m String-getUserSimple= getUser Nothing userFormLine+ , 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)+ => Maybe String + -> View view m (Maybe (String,String), Maybe String) -> FlowM view m String -getUser mu form= ask $ userWidget mu form+getUser mu form= ask $ userWidget mu form --wmodify -- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
src/MFlow/Forms/Widgets.hs view
@@ -7,16 +7,18 @@ {-# LANGUAGE UndecidableInstances,ExistentialQuantification , FlexibleInstances, OverlappingInstances, FlexibleContexts- , OverloadedStrings, DeriveDataTypeable #-}+ , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables #-} module MFlow.Forms.Widgets (+-- * JQueryUi widgets+datePicker, getSpinner, wautocomplete, wdialog, -- * User Management userFormOrName,maybeLogout, -- * Active widgets-wEditList,wautocomplete,wautocompleteList+wEditList,wautocompleteList , wautocompleteEdit, -- * Editing widgets@@ -28,6 +30,8 @@ -- * Multilanguage ,mFieldEd, mField +,autoRefresh+ ) where import MFlow import MFlow.Forms@@ -53,11 +57,14 @@ readyJQuery="ready=function(){if(!window.jQuery){return setTimeout(ready,100)}};" -jqueryScript= "http://ajax.googleapis.com/ajax/libs/jquery/1.8.3/jquery.min.js"+jqueryScript1= "http://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"+jqueryScript="http://code.jquery.com/jquery-1.9.1.js" -jqueryCSS= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"+jqueryCSS1= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"+jqueryCSS= "http://code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css" -jqueryUI= "http://code.jquery.com/ui/1.9.1/jquery-ui.js"+jqueryUI1= "http://code.jquery.com/ui/1.9.1/jquery-ui.js"+jqueryUI= "http://code.jquery.com/ui/1.10.3/jquery-ui.js" ------- User Management ------ @@ -154,7 +161,7 @@ -- The resulting string can be executed in the browser. 'ajax' will return the code to -- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler. ----- This example code will insert a widget in the div when the element with identifier+-- This example will insert a widget in the div when the element with identifier -- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned -- and the list of edited widgets are deleted. --@@ -166,7 +173,7 @@ -- > -- > requires [JScriptFile jqueryScript [installevents] ] -- > ws <- getEdited sel--- > r <- (div <<< manyOf ws) <! [("id",id1)]+-- > r <- (div <<< manyOf ws) <! [("id",id1)] -- > delEdited sel ws' -- > return r @@ -242,14 +249,14 @@ delEdited sel ws' return r --- | Present an autocompletion list, from a procedure defined by the programmer, to a text box.+-- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box. wautocomplete :: (Show a, MonadIO m, FormInput v)- => Maybe String -- ^ Initial value+ => Maybe String -- ^ Initial value -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings -> View v m String wautocomplete mv autocomplete = do- ajaxc <- ajax $ \(u) -> do+ ajaxc <- ajax $ \u -> do r <- liftIO $ autocomplete u return $ jaddtoautocomp r @@ -309,7 +316,7 @@ ws' <- getEdited sel - r<-(ftag "div" mempty `attrs` [("id", id1)]+ r<- (ftag "div" mempty `attrs` [("id", id1)] ++> manyOf (ws' ++ (map (changeMonad . elem . Just) values))) <++ ftag "input" mempty `attrs` [("type", "text")@@ -440,10 +447,10 @@ -> (Key ->v -> IO()) -- ^ the write procedure, user defiend -> View v m () tFieldGen k getcontent create = wfreeze k 0 $ do- content <- liftIO $ getcontent k+ content <- liftIO $ getcontent k admin <- getAdminName- ajaxjs <- ajax $ \str -> do- let (k,s)= break (==',') str+ ajaxjs <- ajax $ \str -> do+ let (k,s)= break (==',') str !> str liftIO . create k $ fromStrNoEncode (tail s) liftIO $ flushCached k return "alert('saved')"@@ -484,12 +491,14 @@ lang <- getLang tField $ k ++ ('-':lang) --- | present a calendar to choose a date-datePicker :: (Monad m, FormInput v) => Maybe String -> View v m (Int,Int,Int)-datePicker jd= do+-- | present the JQuery datepicker calendar to choose a date.+-- The second parameter is the configuration. Use \"()\" by default.+-- See http://jqueryui.com/datepicker/+datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)+datePicker conf jd= do id <- genNewId- let setit= "$(function() {\- \$( '"++id++"' ).datepicker();\+ let setit= "$(document).ready(function() {\+ \$( '#"++id++"' ).datepicker "++ conf ++";\ \});" requires@@ -501,3 +510,158 @@ let (month,r) = span (/='/') s let (day,r2)= span(/='/') $ tail r return (read day,read month, read $ tail r2)++-- | present a jQuery dialog with a widget. When a button is pressed it return the result.+-- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see "http://jqueryui.com/dialog/" for+-- the available configurations.+--+-- As in the case of 'autoRefresh' the enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.++wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a+wdialog conf title w= do+ id <- genNewId+ let setit= "$(document).ready(function() {\n\+ \$('#"++id++"').dialog "++ conf ++";\n\+ \var idform= $('#"++id++" form');\n\+ \idform.submit(function(){$(this).dialog(\"close\")})\n\+ \});"++ modify $ \st -> st{needForm= False}+ requires+ [CSSFile jqueryCSS+ ,JScriptFile jqueryScript []+ ,JScriptFile jqueryUI [setit]]++ (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]++++insertForm w=View $ do+ FormElm forms mx <- runView w+ st <- get+++ cont <- case needForm st of+ True -> do+ frm <- formPrefix (mfPIndex st) (twfname $ mfToken st ) st forms False+ return frm+ _ -> return $ mconcat forms+ put st{needForm= False}+ return $ FormElm [cont] mx++++-- | Capture the form submissions and the links of the enclosed widget and send them via AJAX.+-- The response is the new presentation of the widget, that is updated. No navigation occur.+-- So a widget with autoRefresh can be used in heavyweight pages.+-- If AJAX or javascript is not available, the widget is refresh normally, via a new page.+-- The enclosed widget if has form elements, must include the form action tag, not a part of it.+-- For this purpose, autoRefresh encloses the widget in a form tag if there are form elements on it+-- and the programmer has not enclosed them in a 'wform' element.+autoRefresh+ :: (MonadIO m,+ FormInput v)+ => View v m a+ -> View v m a+autoRefresh w= do+ id <- genNewId++ let installscript=+ "$(document).ready(function(){\n"+ ++ "ajaxGetLink('"++id++"');"+ ++ "ajaxPostForm('"++id++"');"+ ++ "})\n"++ st <- get++ r <- getParam1 ("auto"++id) $ mfEnv st+ case r of+ NoParam -> do+ requires [JScript ajaxGetLink+ ,JScript ajaxPostForm+ ,JScriptFile jqueryScript [installscript]]+ (ftag "div" <<< insertForm w) <! [("id",id)] ++ Validated (x :: String) -> View $ do+ let t= mfToken st+ FormElm form mr <- runView w+ st <- get+ let HttpData ctype c s= toHttpData $ mconcat form+ liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st) (mfCookies st ++ c) s+ put st{mfAutorefresh=True}+ return $ FormElm [] mr++ where+ -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal++ ajaxGetLink = "function ajaxGetLink(id){\n\+ \var id1= $('#'+id);\n\+ \var ida= $('#'+id+' a');\n\+ \ida.click(function () {\n\+ \ var pdata = $(this).attr('data-value');\n\+ \ var actionurl = $(this).attr('href');\n\+ \ var dialogOpts = {\n\+ \ type: 'GET',\n\+ \ url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\+ \ data: pdata,\n\+ \ success: function (resp) {\n\+ \ id1.html(resp);\n\+ \ ajaxGetLink(id)\n\+ \ },\n\+ \ error: function (xhr, status, error) {\n\+ \ var msg = $('<div>' + xhr + '</div>');\n\+ \ id1.html(msg);\n\+ \ }\n\+ \ };\n\+ \ $.ajax(dialogOpts);\n\+ \ return false;\n\+ \});\n\+ \}"++ ajaxPostForm = "function ajaxPostForm(id) {\n\+ \var id1= $('#'+id);\n\+ \var idform= $('#'+id+' form');\n\+ \idform.submit(function (event) {\n\+ \event.preventDefault();\n\+ \var $form = $(this);\n\+ \var url = $form.attr('action');\n\+ \var pdata = $form.serialize();\n\+ \$.ajax({\n\+ \type: 'GET',\n\+ \url: url,\n\+ \data: 'auto'+id+'=true&'+pdata,\n\+ \success: function (resp) {\n\+ \id1.html(resp);\n\+ \ajaxPostForm(id)\n\+ \},\n\+ \error: function (xhr, status, error) {\n\+ \var msg = $('<div>' + xhr + '</div>');\n\+ \id1.html(msg);\n\+ \}\n\+ \});\n\+ \});\n\+ \return false;\n\+ \}"+++-- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.+-- See http://jqueryui.com/spinner+getSpinner+ :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>+ String -> Maybe a -> View view m a+getSpinner conf mv= do+ id <- genNewId+ let setit= "$(document).ready(function() {\n\+ \var spinner = $( '#"++id++"' ).spinner "++conf++";\n\+ \spinner.spinner( \"enable\" );\n\+ \});"+ requires+ [CSSFile jqueryCSS+ ,JScriptFile jqueryScript []+ ,JScriptFile jqueryUI [setit]]++ getTextBox mv <! [("id",id)]++++
src/MFlow/Wai.hs view
@@ -44,17 +44,21 @@ import qualified Data.Conduit.List as CList import Data.CaseInsensitive import System.Time +import qualified Data.Text as T ---import Debug.Trace ---(!>)= flip trace flow= "flow" instance Processable Request where - pwfname env= if SB.null sc then noScript else SB.unpack sc + pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc where - sc= SB.tail $ rawPathInfo env + sc= let p= pathInfo env + p'= reverse p + in case p' of + [] -> [] + p' -> if T.null $ head p' then reverse(tail p') else p + puser env = fromMaybe anonymous $ fmap SB.unpack $ lookup ( mk $SB.pack cookieuser) $ requestHeaders env @@ -91,7 +95,7 @@ Just fl -> return (fl, []) Nothing -> do fl <- liftIO $ newFlow - return (fl, [(flow, fl, "/",Nothing)::Cookie]) + return (fl, [(flow, fl, "/",Nothing):: Cookie]) {- for state persistence in cookies putStateCookie req1 cookies @@ -110,7 +114,7 @@ Right GET -> let tail1 s | s==SB.empty =s tail1 xs= SB.tail xs in return . urlDecode $ SB.unpack . tail1 $ rawQueryString req1 -- !> (SB.unpack $ rawQueryString req1) - x -> return []+ x -> return [] let req = case retcookies of [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" @@ -150,7 +154,10 @@ Just str -> do swapMVar tvresources Nothing return $ Just (statCookieName, str , "/") - ++++ {- persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} where
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -1,57 +1,94 @@------------------------------------------------------------------------------------ Module : MFlow.Wai.Blaze.Html.All--- Copyright :--- License : BSD3------ Maintainer : agocorona@gmail.com--- Stability : experimental--- Portability :------ |-----------------------------------------------------------------------------------module MFlow.Wai.Blaze.Html.All (- module Data.TCache-,module MFlow-,module MFlow.Wai-,module MFlow.Forms-,module MFlow.Forms.Widgets-,module MFlow.Forms.Blaze.Html-,module MFlow.Forms.Admin-,module Network.Wai-,module Network.Wai.Handler.Warp-,module Control.Applicative-,module Text.Blaze.Internal-,module Text.Blaze.Html5-,module Text.Blaze.Html5.Attributes+----------------------------------------------------------------------------- +-- +-- Module : MFlow.Wai.Blaze.Html.All +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module MFlow.Wai.Blaze.Html.All ( + module Data.TCache +,module MFlow +,module MFlow.Wai +,module MFlow.Forms +,module MFlow.Forms.Widgets +,module MFlow.Forms.Blaze.Html +,module MFlow.Forms.Admin +,module Network.Wai +,module Network.Wai.Handler.Warp +,module Control.Applicative +--,module Text.Blaze.Internal +,module Text.Blaze.Html5 +,module Text.Blaze.Html5.Attributes ,module Control.Monad.IO.Class-) where--import MFlow-import MFlow.Wai-import MFlow.Forms-import MFlow.Forms.Widgets-import MFlow.Forms.XHtml-import MFlow.Forms.Admin-import MFlow.Forms.Blaze.Html-import Text.Blaze.Html5 hiding (map)-import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)-import Network.Wai-import Network.Wai.Handler.Warp-import Data.TCache+,runServerTransient+,runServer +) where + +import MFlow +import MFlow.Wai +import MFlow.Forms +import MFlow.Forms.Widgets +import MFlow.Forms.XHtml +import MFlow.Forms.Admin +import MFlow.Forms.Blaze.Html +import Text.Blaze.Html5 hiding (map) +import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form) +import Network.Wai +import Network.Wai.Handler.Warp +import Data.TCache import Text.Blaze.Internal(text) --import Control.Applicative-import Control.Monad.IO.Class-----+import Control.Workflow (Workflow) + + +import Control.Applicative +import Control.Monad.IO.Class +import System.Environment +import Data.Maybe(fromMaybe) +import Data.Char(isNumber) +-- | run a transient flow (see 'transient'). The port is read from the first exectution parameter+-- if no parameter, it is read from the PORT environment variable.+-- if this does not exist, the port 80 is used. +runServerTransient :: FormInput view => FlowM view IO () -> IO Bool+runServerTransient f= do + addMessageFlows[("", transient $ runFlow f)]+ porti <- getPort+ wait $ run porti waiMessageFlow +-- The port is read from the first exectution parameter+-- if no parameter, it is read from the PORT environment variable.+-- if this does not exist, the port 80 is used.+getPort= do+ args <- getArgs+ port <- case args of+ port:xs -> return port+ _ -> do+ env <- getEnvironment+ return $ fromMaybe "80" $ lookup "PORT" env+ let porti= if and $ map isNumber port then fromIntegral $ read port+ else 80+ putStr "using port "+ print porti+ return porti +-- | run a persistent flow. The port is read from the first exectution parameter+-- if no parameter, it is read from the PORT environment variable.+-- if this does not exist, the port 80 is used.+runServer :: FormInput view => FlowM view (Workflow IO) () -> IO Bool+runServer f= do+ addMessageFlows[("", runFlow f)] + porti <- getPort+ wait $ run porti waiMessageFlow + + + +
src/MFlow/Wai/Response.hs view
@@ -1,59 +1,59 @@-{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances+{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-} module MFlow.Wai.Response where -import Network.Wai+import Network.Wai import MFlow.Cookies -import Data.ByteString.Char8 as SB-import Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Char8 as SB +import Data.ByteString.Lazy.Char8 as B import MFlow import Data.Typeable -import Data.Monoid-import System.IO.Unsafe-import Data.Map as M---import Data.CaseInsensitive-import Network.HTTP.Types-import Control.Workflow(WFErrors(..))-import Data.String---import Debug.Trace------(!>)= flip trace--+import Data.Monoid +import System.IO.Unsafe +import Data.Map as M +--import Data.CaseInsensitive +import Network.HTTP.Types +import Control.Workflow(WFErrors(..)) +import Data.String +--import Debug.Trace +-- +--(!>)= flip trace + + class ToResponse a where toResponse :: a -> Response ----data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable--instance Monoid TResp where- mempty = TRempty- mappend (TResp x) (TResp y)=- case cast y of- Just y' -> TResp $ mappend x y'+ + + +data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable + +instance Monoid TResp where + mempty = TRempty + mappend (TResp x) (TResp y)= + case cast y of + Just y' -> TResp $ mappend x y' Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) --contentHtml1= [mkparam contentHtml] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")]-mkParams = Prelude.map mkparam-mkparam (x,y)= (fromString x, fromString y)-instance ToResponse TResp where+ +contentHtml1= [mkparam contentHtml] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")] +mkParams = Prelude.map mkparam +mkparam (x,y)= (fromString x, fromString y) +instance ToResponse TResp where toResponse (TResp x)= toResponse x - toResponse (TRespR r)= toResponse r+ toResponse (TRespR r)= toResponse r instance ToResponse Response where toResponse = id instance ToResponse B.ByteString where - toResponse x= responseLBS status200 contentHtml1 {-,("Content-Length",show $ B.length x) -} x+ toResponse x= responseLBS status200 contentHtml1 {-,("Content-Length",show $ B.length x) -} x instance ToResponse String where - toResponse x= responseLBS status200 contentHtml1 {-,("Content-Length",show $ B.length x) -} $ B.pack x--instance ToResponse HttpData where- toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs ++ cookieHeaders cookies)) x- toResponse (Error NotFound str)= responseLBS status404 [] $ (unsafePerformIO getNotFoundResponse) str + toResponse x= responseLBS status200 contentHtml1 {-,("Content-Length",show $ B.length x) -} $ B.pack x + +instance ToResponse HttpData where + toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs ++ cookieHeaders cookies)) x + toResponse (Error NotFound str)= error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs " -- responseLBS status404 [] $ (unsafePerformIO getNotFoundResponse) str