MFlow 0.1.5.5 → 0.2.0.0
raw patch · 22 files changed
+4317/−2619 lines, 22 filesdep +blaze-htmldep +blaze-markupdep +fay
Dependencies added: blaze-html, blaze-markup, fay, hack, hack-handler-simpleserver, hsp, random
Files
- Demos/demos.blaze.hs +290/−0
- Demos/demos.hs +185/−111
- MFlow.cabal +24/−27
- src/MFlow.hs +102/−67
- src/MFlow/Cookies.hs +6/−5
- src/MFlow/FileServer.hs +334/−331
- src/MFlow/Forms.hs +1327/−1765
- src/MFlow/Forms/Admin.hs +27/−11
- src/MFlow/Forms/Ajax.hs +0/−108
- src/MFlow/Forms/Blaze/Html.hs +69/−0
- src/MFlow/Forms/HSP.hs +18/−8
- src/MFlow/Forms/Internals.hs +942/−0
- src/MFlow/Forms/Test.hs +287/−0
- src/MFlow/Forms/Widgets.hs +483/−0
- src/MFlow/Forms/XHtml.hs +9/−13
- src/MFlow/Hack.hs +27/−27
- src/MFlow/Hack/Response.hs +6/−6
- src/MFlow/Hack/XHtml/All.hs +2/−2
- src/MFlow/Wai.hs +113/−127
- src/MFlow/Wai/Blaze/Html/All.hs +56/−0
- src/MFlow/Wai/Response.hs +7/−8
- src/MFlow/Wai/XHtml/All.hs +3/−3
+ Demos/demos.blaze.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, NoMonomorphismRestriction #-}+module Main where+import MFlow.Wai.Blaze.Html.All+import MFlow.Forms.Internals+import Text.Blaze.Html5 as El+import Text.Blaze.Html5.Attributes as At hiding (step)+import Data.String+import Data.List+import MFlow+import MFlow.FileServer+import Data.TCache+import Data.TCache.Memoization+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 ""+ addFileServerWF+ addMessageFlows [("" ,transient $ runFlow mainmenu)+ ,("shop" ,runFlow shopCart)]+ wait $ run 80 waiMessageFlow++-- adminLoop++stdheader c= html << El.head << body << (p << text "You can press the back button" <> c)++data Options= CountI | CountS | Radio+ | Login | TextEdit |Grid | Autocomp | AutocompList+ | ListEdit |Shop | Action | Ajax | Select+ | CheckBoxes deriving (Bounded, Enum,Read, Show,Typeable)++mainmenu= do+ setHeader stdheader+ r <- ask $ br ++> wlink CountI (b << text "increase an Int")+ <|> br ++> wlink CountS (b << text "increase a String")+ <|> br ++> wlink Action (b << text "Example of action, executed when a widget is validated")+ <|> br ++> wlink Select (b << text "select options")+ <|> br ++> wlink CheckBoxes (b << text "checkboxes")+ <|> br ++> wlink Radio (b << text "Radio buttons")+ <++ br <> br <> b << text "DYNAMIC WIDGETS"+ <|> br ++> wlink Ajax (b << text "AJAX example")+ <|> br ++> wlink Autocomp (b << text "autocomplete")+ <|> br ++> wlink AutocompList (b << text "autocomplete List")+ <|> br ++> wlink ListEdit (b << text "list edition")+ <|> br ++> wlink Grid (b << text "grid")+ <|> br ++> wlink TextEdit (b << text "Content Management")++ <++ br <> br <> b << text "OTHERS"+ <|> br ++> wlink Shop (b << text "example of transfer to another flow (shopping)")+ <|> br ++> wlink Login (b << text "login/logout")+ <++ (br <> a ! href "shop" << text "shopping") -- ordinary Blaze.Html link+++ 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 -> login+ Shop -> transfer "shop"++++options= do+ r <- ask $ getSelect (setSelectedOption ("" :: String) (p << text "select a option") <|>+ setOption "blue" (b << text "blue") <|>+ setOption "Red" (b << text "red") ) <! dosummit+ ask $ p << (r ++ " selected") ++> wlink () (p << text " menu")++ mainmenu -- breturn() would do it as well+ where+ dosummit= [("onchange","this.form.submit()")]++checkBoxes= do+ r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << text "red")+ <> (setCheckBox False "Green" <++ b << text "green")+ <> (setCheckBox False "blue" <++ b << text "blue"))+ <** submitButton "submit"++ ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ mainmenu++autocomplete1= do+ r <- ask $ wautocomplete (Just "red,green,blue") filter1+ <** submitButton "submit"+ ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ mainmenu+ where+ filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"]++autocompList= do+ r <- ask $ wautocompleteList "red,green,blue" filter1 ["red"]+ <** submitButton "submit"+ ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ mainmenu+ where+ filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"]++grid = do+ let row _= tr <<< ( (,) <$> tdborder <<< getInt (Just 0)+ <*> tdborder <<< getString (Just "text")+ <++ tdborder << delLink)+ addLink= a ! href "#"+ ! At.id "wEditListAdd"+ << text "add"+ delLink= a ! href "#"+ ! onclick "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)"+ << text "delete"+ tdborder= td ! At.style "border: solid 1px"++ r <- ask $ addLink ++> ( wEditList table row ["",""]) <** submitButton "submit"+ ask $ p << (show r ++ " returned")+ ++> wlink () (p << text " back to menu")++ mainmenu++wlistEd= do+ r <- ask $ addLink+ ++> br+ ++> (El.div `wEditList` getString1 $ ["hi", "how are you"])+ <++ br+ <** submitButton "send"++ ask $ p << (show r ++ " returned")+ ++> wlink () (p << text " back to menu")+ mainmenu+ where+ addLink = a ! At.id "wEditListAdd"+ ! href "#"+ $ text "add"+ delBox = input ! type_ "checkbox"+ ! checked ""+ ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"+ getString1 mx= El.div <<< delBox ++> getString mx <++ br++clickn (n :: Int)= do+ setHeader stdheader+ r <- ask $ wlink ("menu" :: String) (p << text "menu")+ |+| getInt (Just n) <* submitButton "submit"+ case r of+ (Just _,_) -> mainmenu+ (_, Just n') -> clickn $ n'+1+++clicks s= do+ setHeader stdheader+ s' <- ask $ (getString (Just s)+ <* submitButton "submit")+ `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing )+ clicks $ s'++ "1"++radio = do+ r <- ask $ getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]]+ ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu")+ mainmenu+++--+--askr :: (Read a,Show a,FormInput v,MonadIO m)+-- => String -> a -> (a -> View v m b) -> FlowM v m b+--askr id param w = do+-- let key= addrStr w+-- w'= do+-- env <- getEnv+-- let link= "param="++show param+-- requires[JScript $ "document.getElementById('"++id++"').outerHtml=<a href='"++link++"'></a>"]+-- let par = fromMaybe param $ fmap read $ lookup "param" env+-- w par+--+---- liftIO $ addMessageFlows [(key, wstateless w')]+-- ask w'+++ajaxsample= do+ r <- ask $ do+ let elemval= "document.getElementById('text1').value"+ ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"+ b << text "click the box"+ ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]<** submitButton "submit"+ ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu")+ mainmenu+++--actions n=do+-- ask $ wlink () (p << text "exit from action")+-- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions )+++actions n= do+ r<- ask $ (getString $ Just "widget1") `waction` action+ <+> (getString $ Just "widget2") `waction` action+ <** submitButton "submit"+ ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu")+ mainmenu+ where+ action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action"++data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum,Read, Show, Typeable)++-- A persistent flow (uses step). The process is killed after 10 seconds of inactivity+-- but it is restarted automatically. if you restart the program, it remember the shopping cart+-- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.+shopCart = do+ setTimeouts 10 0+ shopCart1 (V.fromList [0,0,0:: Int])+ where+ shopCart1 cart= do+ o <- step . ask $+ table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"+ <<< caption << text "choose an item"+ ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")+ ++> (tbody+ <<< tr ! rowspan "2" << td << linkHome+ ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))+ <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))+ <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))+ <++ tr << td << linkHome+ )+ let i =fromEnum o+ let newCart= cart V.// [(i, cart V.! i + 1 )]+ shopCart1 newCart++ where+ linkHome= a ! href (fromString noScript) << b << text "home"+++login= do+ ask $ p << text "Please login with admin/admin"+ ++> userWidget (Just "admin") userLogin+ user <- getCurrentUser+ ask $ b << text ("user logged as " <> T.pack user) ++> wlink () (p << text " logout and go to menu")+ logout+ mainmenu++-- an example of content management+textEdit= do+ setHeader $ \t -> html << body << t++ let first= p << i <<+ (El.span << text "this is a page with"+ <> b << text " two " <> El.span << text "paragraphs")++ second= p << i << text "This is the original text of the second paragraph"++ pageEditable = (tFieldEd "first" first)+ **> (tFieldEd "second" second)++ ask $ first+ ++> second+ ++> wlink () (p << text "click here to edit it")+++ ask $ p << text "Please login with admin/admin to edit it"+ ++> userWidget (Just "admin") userLogin++ ask $ p << text "now you can click the field and edit them"+ ++> p << b << text "to save the edited field, double click on it"+ ++> pageEditable+ **> wlink () (p << text "click here to see it as a normal user")++ logout++ ask $ p << text "the user sees the edited content. He can not edit"+ ++> pageEditable+ **> wlink () (p << text "click to continue")++ ask $ p << text "When text are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key"+ ++> tField "first"+ **> tField "second"+ **> p << text "End of edit field demo" ++> wlink () (p << text "click here to go to menu")+
Demos/demos.hs view
@@ -1,111 +1,185 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}-module Main where-import MFlow.Wai.XHtml.All-import Data.TCache-import Control.Monad.Trans-import Data.Typeable-import Control.Concurrent-import Control.Exception as E-import qualified Data.ByteString.Char8 as SB-import qualified Data.Vector as V-import Data.Maybe----data Ops= Ints | Strings | Actions | Ajax | Opt deriving(Typeable,Read, Show)-main= do- setFilesPath ""- addFileServerWF- addMessageFlows [("" ,transient $ runFlow mainf)- ,("shop" ,runFlow shopCart)]- forkIO $ run 80 waiMessageFlow- adminLoop--stdheader c= p << "you can press the back button to go to the menu"+++ c--mainf= do- setHeader stdheader- r <- ask $ wlink Ints (bold << "increase an Int")- <|> br ++> wlink Strings (bold << "increase a String")- <|> br ++> wlink Actions (bold << "Example of a string widget with an action")- <|> br ++> wlink Ajax (bold << "Simple AJAX example")- <|> br ++> wlink Opt (bold << "select options")- <++ (br +++ linkShop) -- this is an ordinary XHtml link-- case r of- Ints -> clickn 0- Strings -> clicks "1"- Actions -> actions 1- Ajax -> ajaxsample- Opt -> options- mainf- where- linkShop= toHtml $ hotlink "shop" << "shopping"--options= do- r <- ask $ getSelect (setSelectedOption "" (p <<"select a option") <|>- setOption "blue" (bold << "blue") <|>- setOption "Red" (bold << "red") ) <! dosummit- ask $ p << (r ++ " selected") ++> wlink () (p<< " menu")- breturn()- where- dosummit= [("onchange","this.form.submit()")]--clickn (n :: Int)= do- setHeader stdheader- r <- ask $ wlink "menu" (p << "menu")- |+| getInt (Just n) <* submitButton "submit"- case r of- (Just _,_) -> breturn ()- (_, Just n') -> clickn $ n'+1---clicks s= do- setHeader stdheader- s' <- ask $ (getString (Just s)- <* submitButton "submit")- `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing )- clicks $ s'++ "1"---ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html----ajaxsample= do- setHeader ajaxheader- let ajaxf n= return $ "document.getElementById('text1').value='"++show(read n +1)++"'"- ajaxc <- ajaxCommand "document.getElementById('text1').value" ajaxf-- ask $ (getInt (Just 0) <! [("id","text1"),("onclick", ajaxc)])- breturn()--actions n=do- ask $ wlink () (p << "exit from action")- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions )- breturn ()---- A persistent flow (uses step). The process is killed after 10 seconds of inactivity--- but it is restarted automatically. if you restart the program, it remember the shopping cart--- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.-shopCart = do- setTimeouts 10 0- shopCart1 (V.fromList [0,0,0:: Int])- where- shopCart1 cart= do- i <- step . ask $- table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]- <<< caption << "choose an item"- ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"]- ++> (tbody- <<< tr ! [rowspan 2] << td << linkHome- ++> (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0))- <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1))- <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2)))- <++ tr << td << linkHome- )-- let newCart= cart V.// [(i, cart V.! i + 1 )]- shopCart1 newCart- where- linkHome= (toHtml $ hotlink noScript << bold << "home")+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, NoMonomorphismRestriction #-} +module Main where +<<<<<<< HEAD +import MFlow.Wai.XHtml.All -- hiding (ask) +======= +import MFlow.Hack.XHtml.All -- hiding (ask) +>>>>>>> 393fb07bfb3f14b6557dff6fb36fedfcbb786ac6 +--import MFlow.Forms.Test +import MFlow +import MFlow.FileServer +import MFlow.Forms.Ajax +import MFlow.Forms.Admin +import MFlow.Forms +<<<<<<< HEAD +import Text.XHtml +======= +>>>>>>> 393fb07bfb3f14b6557dff6fb36fedfcbb786ac6 +import Data.TCache +import Control.Monad.Trans +import Data.Typeable + +import Control.Concurrent +import Control.Exception as E +import qualified Data.ByteString.Char8 as SB +import qualified Data.Vector as V +import Data.Maybe + +--test= runTest [(15,"shop")] + +main= do + syncWrite SyncManual + setFilesPath "" + addFileServerWF + addMessageFlows [("" ,transient $ runFlow mainf), + ("shop" ,runFlow shopCart)] +<<<<<<< HEAD + wait $ run 80 waiMessageFlow +-- adminLoop -- for debug + +stdheader c= thehtml << body << (p << "you can press the back button to go to the menu"+++ c) +======= + run 80 hackMessageFlow + + adminLoop + +stdheader c= thehtml << body << (p << "you can press the back button"+++ c) +>>>>>>> 393fb07bfb3f14b6557dff6fb36fedfcbb786ac6 + +data Options= CountI | CountS | TextEdit |Shop | Action | Ajax | Select deriving (Bounded, Enum,Read, Show,Typeable) + +mainf= do + setHeader stdheader + r <- ask $ br ++> wlink TextEdit (bold << "Content Management") + <|> br ++> wlink Shop (bold << "example of transfer to another flow (shopping)") + <|> br ++> wlink CountI (bold << "increase an Int") + <|> br ++> wlink CountS (bold << "increase a String") + <|> br ++> wlink Action (bold << "Example of a string widget with an action") + <|> br ++> wlink Ajax (bold << "Simple AJAX example") + <|> br ++> wlink Select (bold << "select options") + <++ (br +++ linkShop) -- this is an ordinary XHtml link + + + case r of + CountI -> clickn 0 + CountS -> clicks "1" + Action -> actions 1 + Ajax -> ajaxsample + Select -> options + TextEdit -> textEdit + Shop -> transfer "shop" + mainf + + where + linkShop= toHtml $ hotlink "shop" << "shopping" + +options= do + r <- ask $ getSelect (setSelectedOption "" (p <<"select a option") <|> + setOption "blue" (bold << "blue") <|> + setOption "Red" (bold << "red") ) <! dosummit + ask $ p << (r ++ " selected") ++> wlink () (p<< " menu") + breturn() + where + dosummit= [("onchange","this.form.submit()")] + +clickn (n :: Int)= do + setHeader stdheader + r <- ask $ wlink "menu" (p << "menu") + |+| getInt (Just n) <* submitButton "submit" + case r of + (Just _,_) -> breturn () + (_, Just n') -> clickn $ n'+1 + + +clicks s= do + setHeader stdheader + s' <- ask $ (getString (Just s) + <* submitButton "submit") + `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) + clicks $ s'++ "1" + + + +ajaxsample= do + let ajaxf n= return $ "document.getElementById('text1').value='"++show(read n +1)++"'" + ajaxc <- ajaxCommand "document.getElementById('text1').value" ajaxf + + ask $ requires[JScript ajaxScript] + >> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc)] + breturn() + + +actions n=do + ask $ wlink () (p << "exit from action") + <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) + breturn () + +data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum,Read, Show, Typeable) + +-- A persistent flow (uses step). The process is killed after 10 seconds of inactivity +-- but it is restarted automatically. if you restart the program, it remember the shopping cart +-- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow. +shopCart = do + setTimeouts 10 0 + shopCart1 (V.fromList [0,0,0:: Int]) + where + shopCart1 cart= do + o <- step . ask $ + table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] + <<< caption << "choose an item" + ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] + ++> (tbody + <<< tr ! [rowspan 2] << td << linkHome + ++> (tr <<< td <<< wlink IPhone (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) + <|> tr <<< td <<< wlink IPad (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) + <|> tr <<< td <<< wlink IPod (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2))) + <++ tr << td << linkHome + ) + let i =fromEnum o + let newCart= cart V.// [(i, cart V.! i + 1 )] + shopCart1 newCart + + where + linkHome= (toHtml $ hotlink noScript << bold << "home") + + + + +-- an example of content management +textEdit= do + setHeader $ \html -> thehtml << body << html + + let first= p << italics << + (thespan << "this is a page with" + +++ bold << " two " +++ thespan << "paragraphs") + + second= p << italics << "This is the original text of the second paragraph" + + pageEditable = (tFieldEd "first" first) + **> (tFieldEd "second" second) + + ask $ first + ++> second + ++> wlink () (p << "click here to edit it") + + setAdminUser "admin" "admin" + + ask $ p << "Please login with admin/admin to edit it" + ++> userWidget (Just "admin") userLogin + + ask $ p << "now you can click the field and edit them" + ++> p << bold << "to save the edited field, double click on it" + ++> pageEditable + **> wlink () (p << "click here to see it as a normal user") + + logout + + ask $ p << "the user sees the edited content. He can not edit" + ++> pageEditable + **> wlink () (p << "click to continue") + + ask $ p << "When text 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") + breturn ()
MFlow.cabal view
@@ -1,17 +1,16 @@ name: MFlow-version: 0.1.5.5-cabal-version: >= 1.6+version: 0.2.0.0+cabal-version: >=1.6 build-type: Simple license: BSD3 license-file: LICENSE maintainer: agocorona@gmail.com stability: experimental synopsis: Web app server for stateful processes with safe, composable user interfaces.- description: A Web framework with some unique features thanks to the power of the Haskell language. MFlow run stateful server processes; All the flow of request and responses are coded by the programmer in a single function. Allthoug single request-response flows and callbacks are possible. Therefore, the code is- more understandable.+ more understandable.f . These processes are stopped and restarted by the application server on demand, including its execution state. Therefore session management@@ -42,36 +41,34 @@ . -Clustering .- category: Web, Application Server author: Alberto Gómez Corona data-dir: ""-extra-source-files: src/MFlow/Forms/HSP.hs- , src/MFlow/Hack/Response.hs, src/MFlow/Hack.hs- , src/MFlow/Hack/XHtml.hs, src/MFlow/Hack/XHtml/All.hs- , Demos/ShoppingCart.hs, Demos/ShoppingCart.Wai.hs- , Demos/demos.hs+extra-source-files: Demos/ShoppingCart.hs Demos/ShoppingCart.Wai.hs+ Demos/demos.hs Demos/demos.blaze.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-- exposed-modules: MFlow.Forms- MFlow.Forms.Admin MFlow MFlow.FileServer- MFlow.Forms.Ajax MFlow.Cookies- MFlow.Wai.Response, MFlow.Wai, MFlow.Wai.XHtml.All- MFlow.Forms.XHtml-+ 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, fay -any,+ random -any, hsp == 0.7.1, hack -any, hack-handler-simpleserver -any,+ blaze-html -any, blaze-markup -any+ exposed-modules: MFlow.Wai.Blaze.Html.All+ MFlow.Forms MFlow.Forms.Admin MFlow MFlow.FileServer+ MFlow.Cookies MFlow.Wai+ MFlow.Wai.XHtml.All MFlow.Forms.XHtml MFlow.Forms.HSP+ MFlow.Hack MFlow.Hack.XHtml+ MFlow.Hack.XHtml.All MFlow.Forms.Blaze.Html MFlow.Forms.Test+ MFlow.Forms.Widgets+ other-modules: MFlow.Forms.Internals MFlow.Wai.Response MFlow.Hack.Response exposed: True buildable: True hs-source-dirs: src .- other-modules: -source-repository head- type: git- location: http://github.com/agocorona/MFlow
src/MFlow.hs view
@@ -4,7 +4,8 @@ the source identification and the verb invoked. The scheduler executed the appropriate workflow (using the workflow package). The workflow may send additional messages to the source, identified by a 'Token'-. The computation state is optionally logged and recovered.+. The 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. The message communication is trough polimorphic, monoidal queues. There is no asumption about message codification, so instantiations@@ -20,17 +21,24 @@ "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' 'sendEndFragment' are provided only at this level.+Fragment based streaming 'sendFragment' are provided only at this level. -'stateless' and 'transient' server processeses are also possible. `stateless` are request-response- with no intermediate messaging dialog. `transient` processes have no persistent- state, so they restart anew after a timeout or a crash.+'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. -} @@ -43,9 +51,10 @@ ,FlexibleContexts ,RecordWildCards ,OverloadedStrings+ ,ScopedTypeVariables #-} module MFlow (-Params, Workflow, HttpData(..),Processable(..), ToHttpData(..)+Flow, Params, HttpData(..),Processable(..) , Token(..), ProcList -- * low level comunication primitives. Use `ask` instead ,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment@@ -55,7 +64,7 @@ ,noScript,hlog, setNotFoundResponse,getNotFoundResponse, -- * ByteString tags -- | very basic but efficient tag formatting-btag, bhtml, bbody,Attribs+btag, bhtml, bbody,Attribs, addAttrs -- * internal use ,addTokenToList,deleteTokenInList, msgScheduler) @@ -78,25 +87,27 @@ import Data.TCache.DefaultPersistence hiding(Indexable(..)) import Data.ByteString.Lazy.Char8 as B (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 ()) ---type Header= (String,String) 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 ToHttpData HttpData where+-- toHttpData= id+--+--instance ToHttpData ByteString where+-- toHttpData bs= HttpData [] [] bs instance Monoid HttpData where mempty= HttpData [] [] empty@@ -106,7 +117,7 @@ type ProcList = WorkflowList IO Token () -data Req = forall a.( Processable a,Typeable a)=> Req a deriving Typeable+data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable type Params = [(String,String)] @@ -119,6 +130,11 @@ -- getPath :: a -> String -- getPort :: a -> Int +instance Processable Token where+ pwfname = twfname+ puser = tuser+ pind = tind+ getParams = tenv instance Processable Req where pwfname (Req x)= pwfname x@@ -141,10 +157,10 @@ -- | 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 , q :: MVar Req, qr :: MVar Resp} deriving Typeable +data Token = Token{twfname,tuser, tind :: String , tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable instance Indexable Token where - key (Token w u i _ _ )=+ key (Token w u i _ _ _ )= if u== anonymous then u++ i -- ++ "@" ++ w else u -- ++ "@" ++ w @@ -153,8 +169,8 @@ 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)] + | 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 @@ -182,13 +198,13 @@ getToken msg= do qmap <- readMVar iorefqmap- let u= puser msg ; w= pwfname msg ; i=pind msg+ let u= puser msg ; w= pwfname msg ; i=pind 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 q qr+ let token= Token w u i penv q qr addTokenToList token return token @@ -202,30 +218,31 @@ return $ debug x (str++" => Workflow "++ show x) -} -- | send a complete response -send :: ToHttpData a => Token -> a -> IO() -send (Token _ _ _ queue qresp) msg= do - putMVar qresp . Resp $ toHttpData msg +send :: Token -> HttpData -> IO() +send t@(Token _ _ _ _ _ qresp) msg= do + ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ thread t) sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush " -- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' -sendFragment :: ToHttpData a => Token -> a -> IO() -sendFragment (Token _ _ _ _ qresp) msg= putMVar qresp . Fragm $ toHttpData msg - -sendEndFragment :: ToHttpData a => Token -> a -> IO() -sendEndFragment (Token _ _ _ _ qresp ) msg= putMVar qresp . EndFragm $ toHttpData msg +sendFragment :: Token -> HttpData -> IO() +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 --emptyReceive (Token queue _ _)= emptyQueue queue receive :: Typeable a => Token -> IO a receive t= receiveReq t >>= return . fromReq -flushRec t@(Token _ _ _ queue _)= do+flushRec t@(Token _ _ _ _ queue _)= do empty <- isEmptyMVar queue when (not empty) $ takeMVar queue >> return () receiveReq :: Token -> IO Req-receiveReq (Token _ _ _ queue _)= readMVar queue -- !> "receiveReqSTM"+receiveReq t@(Token _ _ _ _ queue _)= readMVar queue -- !> (">>>>>> receive "++ thread t) fromReq :: Typeable a => Req -> a fromReq (Req x) = x' where@@ -244,32 +261,40 @@ 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" + delWFHistory1 statKey -- `debug` "delWFHistory" -- | executes a simple monadic computation that receive the params and return a response ----- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow` -stateless :: (ToHttpData b) => (Params -> IO b) -> (Token -> Workflow IO ()) -stateless f = transient $ \tk ->do- req <- receiveReq tk+-- 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)- sendFlush tk resp + (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 -- not store its state in permanent storage. The process once stopped, will restart anew -- ---- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow`-transient :: (Token -> IO ()) -> (Token -> Workflow IO ()) +transient :: (Token -> IO ()) -> Flow transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) ) -_messageFlows :: MVar (M.Map String (Token-> Workflow IO ())) -_messageFlows= unsafePerformIO $ newMVar M.empty -- [(String,Token -> Workflow IO ())]) +_messageFlows :: MVar (M.Map String Flow) +_messageFlows= unsafePerformIO $ newMVar M.empty -- | 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))@@ -279,28 +304,25 @@ -- | return the list of the scheduler getMessageFlows = readMVar _messageFlows -class ToHttpData a where - toHttpData :: a -> HttpData +--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 (Token _ _ _ queue qresp ) msg = do - putMVar queue $ Req msg - m <- takeMVar qresp -- !> ("********antes de recibir" ++ show(unsafePerformIO myThreadId))+tellToWF t@(Token _ _ _ _ queue qresp ) msg = do + putMVar queue (Req msg) -- !> (">>>>> telltowf"++ thread t) + m <- takeMVar qresp -- !> ("<<<<<< tellTowf"++ thread t) case m of - Resp r -> return r -- !> ("*********** RECIBIDO"++ show(unsafePerformIO myThreadId)) + Resp r -> return r -- !> ("recibido tellTowf"++ thread t) Fragm r -> do result <- getStream r return result-- + where- getStream r = do mr <- takeMVar qresp - case mr of- Resp _ -> error "\"send\" used instead of \"sendFragment\" or \"sendEndFragment\"" + case mr of Fragm h -> do rest <- unsafeInterleaveIO $ getStream h let result= mappend r rest@@ -309,15 +331,17 @@ let result= mappend r h return result -+ Resp h -> do+ let result= mappend r h+ return result --data Error= Error String deriving (Read, Show, Typeable) -instance ToHttpData String where- toHttpData= HttpData [] [] . pack+--instance ToHttpData String where+-- toHttpData= HttpData [] [] . pack -- | The scheduler creates a Token with every `Processable` -- message that arrives and send the mesage to the appropriate flow, get the response@@ -326,19 +350,21 @@ :: (Typeable a,Processable a) => a -> IO (HttpData, ThreadId) msgScheduler x = do - token <- getToken x -+ token <- getToken x th <- startMessageFlow (pwfname x) token- r<- tellToWF token x + r <- tellToWF token x+-- liftIO $ print $ let HttpData _ _ r1=r in unpack r1 return (r,th) where- + --start the flow if not started yet startMessageFlow wfname token = forkIO $ do wfs <- getMessageFlows r <- startWF wfname token wfs -- !>( "init wf " ++ wfname) case r of - Left NotFound -> sendFlush token (Error NotFound $ "Not found: " <> pack wfname) + Left NotFound -> do+ 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@@ -347,9 +373,10 @@ logError user wfname e moveState wfname token token{tuser= "error/"++tuser token} - case user of- "admin" -> sendFlush token (show e) -- !> ("WF error: "++ show e)- _ -> sendFlush token ("An Error has ocurred." :: ByteString)+ sendFlush token $ HttpData [("Content-Type", "text/plain")] [] $+ case user of+ "admin" -> pack $ show e+ _ -> "An Error has ocurred." Right _ -> do -- let msg= "finished Flow "++ wfname++ " restarting"@@ -385,7 +412,7 @@ setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f getNotFoundResponse= unsafePerformIO $ readIORef notFoundResponse --- basic bytestring XML tags+-- 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".@@ -394,13 +421,21 @@ where pt= pack t attrs []= B.empty- attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs+ 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(Chunk ">" rest))) rs=+ Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> ">" <> rest++addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ unpack other
src/MFlow/Cookies.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-} module MFlow.Cookies-(Cookie,ctype,urlDecode,cookieuser,cookieHeaders,getCookies)+(Cookie,contentHtml,urlDecode,cookieuser,cookieHeaders,getCookies) where import Control.Monad(MonadPlus(..), guard, replicateM_, when) import Data.Char@@ -19,7 +19,7 @@ import Control.Monad.Identity --import Text.Parsec.Token -ctype= ("Content-Type", "text/html")+contentHtml= ("Content-Type", "text/html") type Cookie= (String,String,String,Maybe String) @@ -35,12 +35,13 @@ cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs showCookie :: Cookie -> String-showCookie (n,v,p,me) = n <> "=" <> v <> "; path=" - <> p <> showMaxAge me <> "\n"+showCookie (n,v,p,me) = n <> "=" <> v <>+ ";path=" <> p <>+ showMaxAge me where showMaxAge Nothing = "" - showMaxAge (Just e) = "; Max-age=" <> e+ showMaxAge (Just e) = ";Max-age=" <> e --showCookie :: Cookie -> String
src/MFlow/FileServer.hs view
@@ -1,331 +1,334 @@-{- | A file server for frequently accessed files, such are static web pages and image decorations, icons etc-that 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.--}------------------------------------------------------------------------------------ Module : FileServer--- Copyright :--- License : BSD3------ Maintainer : agocorona@gmail.com--- Stability : experimental--- Portability :----------------------------------------------------------------------------------------{-# OPTIONS -XScopedTypeVariables #-}-module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath--) where--import MFlow-import Control.Monad.State-import Data.TCache.Memoization-import MFlow.Forms.XHtml-import System.Directory-import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty)--import Control.Exception as CE-import Data.Char-import Data.List-import System.IO.Unsafe-import Data.IORef-import Data.Monoid----import Debug.Trace---(!>)= flip trace--rfilesPath= unsafePerformIO $ newIORef "files/"---- | Set the path of the files in the web server. The links to the files are relative to it-setFilesPath :: String -> IO ()-setFilesPath path= writeIORef rfilesPath path--pathPrm= "path"-fileServe ::(Token -> Workflow IO ())-fileServe = stateless $ \env -> do- case lookup pathPrm env of- Nothing -> error " no file specified"- Just 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'- isDirectory <- doesDirectoryExist path -- !> path- case isDirectory of- True -> directory1 $ path ++ "/"- False -> do- isFile <- doesFileExist path- case isFile of- True -> servefile path- False -> return . pack $ "path not found"-- where- dropBack ".."= ".."-- dropBack path-- | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath- | otherwise= path- where- revpath= reverse path--- maybetail ""= "."- maybetail xs= tail xs- noperm= "no permissions"- ioerr x= \(e :: CE.IOException) -> x- servefile path= do- mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing)- case mr of- Nothing -> return . pack $ "no permissions"- Just r -> return r--- let ext = reverse . takeWhile (/='.') $ reverse path--- mmime= lookup (map toLower ext) mimeTable--- mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream"--- mimet= [("Content-Type",mime)]--- in return r -- $ HttpData mimet [] r---- | Is the flow to be added to the list in order to stream any file from the filesystem--- for example, images------ This app includes the fileServe flow:------ @--- main= do--- addFileServerWF--- addMessageFlows messageFlows--- run 80 hackMessageFlow--- adminLoop--- where--- messageFlows= [(\"noscript\" , transient $ runFlow showStories)--- ,("\admin\" , transient $ runFlow admin)--- ,("\mail\" , transient $ runFlow mail)]@------ Add the fileServer to the list of server flows-addFileServerWF= addMessageFlows [("file", fileServe)]------ | Creates the url of file path. To be used in ordinary links to files.--- in Text.XHtml, a image would be embeded as------ > image ![src $ linkFile imagepath]------ in HSP:------ > <img src=(linkFile imagepath)\>---- | Given the relative path of a file, it return the content of the @href@ element in a html link-linkFile :: String -> String-linkFile path= "file?path=" <> path--directory :: Token -> Workflow IO ()-directory = stateless $ \_ -> do- path <- readIORef rfilesPath- directory1 path--directory1 path = do- fs <- getDirectoryContents path- return $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs]--{--mimeTable=[- ("html", "text/html"),- ("htm", "text/html"),- ("txt", "text/plain"),- ("jpeg", "image/jpeg"),- ("pdf", "application/pdf"),- ("js", "application/x-javascript"),- ("gif", "image/gif"),- ("bmp", "image/bmp"),- ("ico", "image/x-icon"),- ("doc", "application/msword"),- ("jpg", "image/jpeg"),- ("eps", "application/postscript"),- ("zip", "application/zip"),- ("exe", "application/octet-stream"),- ("tif", "image/tiff"),- ("tiff", "image/tiff"),- ("mov", "video/quicktime"),- ("movie", "video/x-sgi-movie"),- ("mp2", "video/mpeg"),- ("mp3", "audio/mpeg"),- ("mpa", "video/mpeg"),- ("mpe", "video/mpeg"),- ("mpeg", "video/mpeg"),- ("mpg", "video/mpeg"),- ("mpp", "application/vnd.ms-project"),- ("323", "text/h323"),- ("*", "application/octet-stream"),- ("acx", "application/internet-property-stream"),- ("ai", "application/postscript"),- ("aif", "audio/x-aiff"),- ("aifc", "audio/x-aiff"),- ("aiff", "audio/x-aiff"),- ("asf", "video/x-ms-asf"),- ("asr", "video/x-ms-asf"),- ("asx", "video/x-ms-asf"),- ("au", "audio/basic"),- ("avi", "video/x-msvideo"),- ("axs", "application/olescript"),- ("bas", "text/plain"),- ("bcpio", "application/x-bcpio"),- ("bin", "application/octet-stream"),- ("c", "text/plain"),- ("cat", "application/vnd.ms-pkiseccat"),- ("cdf", "application/x-cdf"),- ("cdf", "application/x-netcdf"),- ("cer", "application/x-x509-ca-cert"),- ("class", "application/octet-stream"),- ("clp", "application/x-msclip"),- ("cmx", "image/x-cmx"),- ("cod", "image/cis-cod"),- ("cpio", "application/x-cpio"),- ("crd", "application/x-mscardfile"),- ("crl", "application/pkix-crl"),- ("crt", "application/x-x509-ca-cert"),- ("csh", "application/x-csh"),- ("css", "text/css"),- ("dcr", "application/x-director"),- ("der", "application/x-x509-ca-cert"),- ("dir", "application/x-director"),- ("dll", "application/x-msdownload"),- ("dms", "application/octet-stream"),- ("dot", "application/msword"),- ("dvi", "application/x-dvi"),- ("dxr", "application/x-director"),- ("eps", "application/postscript"),- ("etx", "text/x-setext"),- ("evy", "application/envoy"),- ("fif", "application/fractals"),- ("flr", "x-world/x-vrml"),- ("gtar", "application/x-gtar"),- ("gz", "application/x-gzip"),- ("h", "text/plain"),- ("hdf", "application/x-hdf"),- ("hlp", "application/winhlp"),- ("hqx", "application/mac-binhex40"),- ("hta", "application/hta"),- ("htc", "text/x-component"),- ("htt", "text/webviewhtml"),- ("ief", "image/ief"),- ("iii", "application/x-iphone"),- ("ins", "application/x-internet-signup"),- ("isp", "application/x-internet-signup"),- ("jfif", "image/pipeg"),- ("jpe", "image/jpeg"),- ("latex", "application/x-latex"),- ("lha", "application/octet-stream"),- ("lsf", "video/x-la-asf"),- ("lsx", "video/x-la-asf"),- ("lzh", "application/octet-stream"),- ("m13", "application/x-msmediaview"),- ("m14", "application/x-msmediaview"),- ("m3u", "audio/x-mpegurl"),- ("man", "application/x-troff-man"),- ("mdb", "application/x-msaccess"),- ("me", "application/x-troff-me"),- ("mht", "message/rfc822"),- ("mhtml", "message/rfc822"),- ("mid", "audio/mid"),- ("mny", "application/x-msmoney"),- ("mpv2", "video/mpeg"),- ("ms", "application/x-troff-ms"),- ("msg", "application/vnd.ms-outlook"),- ("mvb", "application/x-msmediaview"),- ("nc", "application/x-netcdf"),- ("nws", "message/rfc822"),- ("oda", "application/oda"),- ("p10", "application/pkcs10"),- ("p12", "application/x-pkcs12"),- ("p7b", "application/x-pkcs7-certificates"),- ("p7c", "application/x-pkcs7-mime"),- ("p7m", "application/x-pkcs7-mime"),- ("p7r", "application/x-pkcs7-certreqresp"),- ("p7s", "application/x-pkcs7-signature"),- ("pbm", "image/x-portable-bitmap"),- ("pfx", "application/x-pkcs12"),- ("pgm", "image/x-portable-graymap"),- ("pko", "application/ynd.ms-pkipko"),- ("pma", "application/x-perfmon"),- ("pmc", "application/x-perfmon"),- ("pml", "application/x-perfmon"),- ("pmr", "application/x-perfmon"),- ("pmw", "application/x-perfmon"),- ("pnm", "image/x-portable-anymap"),- ("pot", "application/vnd.ms-powerpoint"),- ("ppm", "image/x-portable-pixmap"),- ("pps", "application/vnd.ms-powerpoint"),- ("ppt", "application/vnd.ms-powerpoint"),- ("prf", "application/pics-rules"),- ("ps", "application/postscript"),- ("pub", "application/x-mspublisher"),- ("qt", "video/quicktime"),- ("ra", "audio/x-pn-realaudio"),- ("ram", "audio/x-pn-realaudio"),- ("ras", "image/x-cmu-raster"),- ("rgb", "image/x-rgb"),- ("rmi", "audio/mid"),- ("roff", "application/x-troff"),- ("rtf", "application/rtf"),- ("rtx", "text/richtext"),- ("scd", "application/x-msschedule"),- ("sct", "text/scriptlet"),- ("setpay", "application/set-payment-initiation"),- ("setreg", "application/set-registration-initiation"),- ("sh", "application/x-sh"),- ("shar", "application/x-shar"),- ("sit", "application/x-stuffit"),- ("snd", "audio/basic"),- ("spc", "application/x-pkcs7-certificates"),- ("spl", "application/futuresplash"),- ("src", "application/x-wais-source"),- ("sst", "application/vnd.ms-pkicertstore"),- ("stl", "application/vnd.ms-pkistl"),- ("stm", "text/html"),- ("sv4cpio", "application/x-sv4cpio"),- ("sv4crc", "application/x-sv4crc"),- ("svg", "image/svg+xml"),- ("swf", "application/x-shockwave-flash"),- ("t", "application/x-troff"),- ("tar", "application/x-tar"),- ("tcl", "application/x-tcl"),- ("tex", "application/x-tex"),- ("texi", "application/x-texinfo"),- ("texinfo", "application/x-texinfo"),- ("tgz", "application/x-compressed"),- ("tr", "application/x-troff"),- ("trm", "application/x-msterminal"),- ("tsv", "text/tab-separated-values"),- ("uls", "text/iuls"),- ("ustar", "application/x-ustar"),- ("vcf", "text/x-vcard"),- ("vrml", "x-world/x-vrml"),- ("wav", "audio/x-wav"),- ("wcm", "application/vnd.ms-works"),- ("wdb", "application/vnd.ms-works"),- ("wks", "application/vnd.ms-works"),- ("wmf", "application/x-msmetafile"),- ("wps", "application/vnd.ms-works"),- ("wri", "application/x-mswrite"),- ("wrl", "x-world/x-vrml"),- ("wrz", "x-world/x-vrml"),- ("xaf", "x-world/x-vrml"),- ("xbm", "image/x-xbitmap"),- ("xla", "application/vnd.ms-excel"),- ("xlc", "application/vnd.ms-excel"),- ("xlm", "application/vnd.ms-excel"),- ("xls", "application/vnd.ms-excel"),- ("xlt", "application/vnd.ms-excel"),- ("xlw", "application/vnd.ms-excel"),- ("xof", "x-world/x-vrml"),- ("xpm", "image/x-xpixmap"),- ("xwd", "image/x-xwindowdump"),- ("z", "application/x-compress")-- ]--}+{- | A file server for frequently accessed files, such are static web pages and image decorations, icons etc +that 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. +-} +----------------------------------------------------------------------------- +-- +-- Module : FileServer +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- +-- +----------------------------------------------------------------------------- +{-# OPTIONS -XScopedTypeVariables #-} +module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath + +) where + +import MFlow +import MFlow.Cookies(contentHtml) +import Control.Monad.State +import Data.TCache.Memoization +import MFlow.Forms.XHtml +import System.Directory +import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty) + +import Control.Exception as CE +import Data.Char +import Data.List +import System.IO.Unsafe +import Data.IORef +import Data.Monoid + + +rfilesPath= unsafePerformIO $ newIORef "files/" + +-- | Set the path of the files in the web server. The links to the files are relative to it +setFilesPath :: String -> IO () +setFilesPath path= writeIORef rfilesPath path + +pathPrm= "path" +fileServe :: Flow +fileServe = stateless $ \env -> do + case lookup pathPrm env of + Nothing -> error " no file specified" + Just 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' + servefile path + -- isDirectory <- doesDirectoryExist path -- !> path + +-- case isDirectory of +-- True -> do +-- dir <- directory1 $ path ++ "/" +-- return $ HttpData (setMime "text/html") [] dir +-- False -> servefile path + + + where + setMime x= ("Content-Type",x) + + dropBack ".."= ".." + dropBack path + | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath + | otherwise= path + where + revpath= reverse path +-- maybetail ""= "." + maybetail xs= tail xs + noperm= "no permissions" + ioerr x= \(e :: CE.IOException) -> x + servefile path= do + 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" + 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 + +stringServer mime str= stateless +-- | Is the flow to be added to the list in order to stream any file from the filesystem +-- for example, images +-- +-- This app includes the fileServe flow: +-- +-- @ +-- main= do +-- addFileServerWF +-- addMessageFlows messageFlows +-- run 80 hackMessageFlow +-- adminLoop +-- where +-- messageFlows= [(\"noscript\" , transient $ runFlow showStories) +-- ,("\admin\" , transient $ runFlow admin) +-- ,("\mail\" , transient $ runFlow mail)]@ +-- +-- | Add the fileServer to the list of server flows +-- it is mandatory if you want to use the file service +addFileServerWF= addMessageFlows [("file", fileServe)] + + + +-- | Creates the url of file path. To be used in ordinary links to files. +-- in Text.XHtml, a image would be embeded as +-- +-- > image ![src $ linkFile imagepath] +-- +-- in HSP: +-- +-- > <img src=(linkFile imagepath)\> + +-- | Given the relative path of a file, it return the content of the @href@ element in a html link +linkFile :: String -> String +linkFile path= "file?path=" <> path + +directory :: Flow +directory = stateless $ \_ -> do + path <- readIORef rfilesPath + directory1 path + +directory1 path = do + fs <- getDirectoryContents path + return $ HttpData [contentHtml][] $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs] + + +mimeTable=[ + ("html", "text/html"), + ("htm", "text/html"), + ("txt", "text/plain"), + ("jpeg", "image/jpeg"), + ("pdf", "application/pdf"), + ("js", "application/x-javascript"), + ("gif", "image/gif"), + ("bmp", "image/bmp"), + ("ico", "image/x-icon"), + ("doc", "application/msword"), + ("jpg", "image/jpeg"), + ("eps", "application/postscript"), + ("zip", "application/zip"), + ("exe", "application/octet-stream"), + ("tif", "image/tiff"), + ("tiff", "image/tiff"), + ("mov", "video/quicktime"), + ("movie", "video/x-sgi-movie"), + ("mp2", "video/mpeg"), + ("mp3", "audio/mpeg"), + ("mpa", "video/mpeg"), + ("mpe", "video/mpeg"), + ("mpeg", "video/mpeg"), + ("mpg", "video/mpeg"), + ("mpp", "application/vnd.ms-project"), + ("323", "text/h323"), + ("*", "application/octet-stream"), + ("acx", "application/internet-property-stream"), + ("ai", "application/postscript"), + ("aif", "audio/x-aiff"), + ("aifc", "audio/x-aiff"), + ("aiff", "audio/x-aiff"), + ("asf", "video/x-ms-asf"), + ("asr", "video/x-ms-asf"), + ("asx", "video/x-ms-asf"), + ("au", "audio/basic"), + ("avi", "video/x-msvideo"), + ("axs", "application/olescript"), + ("bas", "text/plain"), + ("bcpio", "application/x-bcpio"), + ("bin", "application/octet-stream"), + ("c", "text/plain"), + ("cat", "application/vnd.ms-pkiseccat"), + ("cdf", "application/x-cdf"), + ("cdf", "application/x-netcdf"), + ("cer", "application/x-x509-ca-cert"), + ("class", "application/octet-stream"), + ("clp", "application/x-msclip"), + ("cmx", "image/x-cmx"), + ("cod", "image/cis-cod"), + ("cpio", "application/x-cpio"), + ("crd", "application/x-mscardfile"), + ("crl", "application/pkix-crl"), + ("crt", "application/x-x509-ca-cert"), + ("csh", "application/x-csh"), + ("css", "text/css"), + ("dcr", "application/x-director"), + ("der", "application/x-x509-ca-cert"), + ("dir", "application/x-director"), + ("dll", "application/x-msdownload"), + ("dms", "application/octet-stream"), + ("dot", "application/msword"), + ("dvi", "application/x-dvi"), + ("dxr", "application/x-director"), + ("eps", "application/postscript"), + ("etx", "text/x-setext"), + ("evy", "application/envoy"), + ("fif", "application/fractals"), + ("flr", "x-world/x-vrml"), + ("gtar", "application/x-gtar"), + ("gz", "application/x-gzip"), + ("h", "text/plain"), + ("hdf", "application/x-hdf"), + ("hlp", "application/winhlp"), + ("hqx", "application/mac-binhex40"), + ("hta", "application/hta"), + ("htc", "text/x-component"), + ("htt", "text/webviewhtml"), + ("ief", "image/ief"), + ("iii", "application/x-iphone"), + ("ins", "application/x-internet-signup"), + ("isp", "application/x-internet-signup"), + ("jfif", "image/pipeg"), + ("jpe", "image/jpeg"), + ("latex", "application/x-latex"), + ("lha", "application/octet-stream"), + ("lsf", "video/x-la-asf"), + ("lsx", "video/x-la-asf"), + ("lzh", "application/octet-stream"), + ("m13", "application/x-msmediaview"), + ("m14", "application/x-msmediaview"), + ("m3u", "audio/x-mpegurl"), + ("man", "application/x-troff-man"), + ("mdb", "application/x-msaccess"), + ("me", "application/x-troff-me"), + ("mht", "message/rfc822"), + ("mhtml", "message/rfc822"), + ("mid", "audio/mid"), + ("mny", "application/x-msmoney"), + ("mpv2", "video/mpeg"), + ("ms", "application/x-troff-ms"), + ("msg", "application/vnd.ms-outlook"), + ("mvb", "application/x-msmediaview"), + ("nc", "application/x-netcdf"), + ("nws", "message/rfc822"), + ("oda", "application/oda"), + ("p10", "application/pkcs10"), + ("p12", "application/x-pkcs12"), + ("p7b", "application/x-pkcs7-certificates"), + ("p7c", "application/x-pkcs7-mime"), + ("p7m", "application/x-pkcs7-mime"), + ("p7r", "application/x-pkcs7-certreqresp"), + ("p7s", "application/x-pkcs7-signature"), + ("png", "image/png"), + ("pbm", "image/x-portable-bitmap"), + ("pfx", "application/x-pkcs12"), + ("pgm", "image/x-portable-graymap"), + ("pko", "application/ynd.ms-pkipko"), + ("pma", "application/x-perfmon"), + ("pmc", "application/x-perfmon"), + ("pml", "application/x-perfmon"), + ("pmr", "application/x-perfmon"), + ("pmw", "application/x-perfmon"), + ("pnm", "image/x-portable-anymap"), + ("pot", "application/vnd.ms-powerpoint"), + ("ppm", "image/x-portable-pixmap"), + ("pps", "application/vnd.ms-powerpoint"), + ("ppt", "application/vnd.ms-powerpoint"), + ("prf", "application/pics-rules"), + ("ps", "application/postscript"), + ("pub", "application/x-mspublisher"), + ("qt", "video/quicktime"), + ("ra", "audio/x-pn-realaudio"), + ("ram", "audio/x-pn-realaudio"), + ("ras", "image/x-cmu-raster"), + ("rgb", "image/x-rgb"), + ("rmi", "audio/mid"), + ("roff", "application/x-troff"), + ("rtf", "application/rtf"), + ("rtx", "text/richtext"), + ("scd", "application/x-msschedule"), + ("sct", "text/scriptlet"), + ("setpay", "application/set-payment-initiation"), + ("setreg", "application/set-registration-initiation"), + ("sh", "application/x-sh"), + ("shar", "application/x-shar"), + ("sit", "application/x-stuffit"), + ("snd", "audio/basic"), + ("spc", "application/x-pkcs7-certificates"), + ("spl", "application/futuresplash"), + ("src", "application/x-wais-source"), + ("sst", "application/vnd.ms-pkicertstore"), + ("stl", "application/vnd.ms-pkistl"), + ("stm", "text/html"), + ("sv4cpio", "application/x-sv4cpio"), + ("sv4crc", "application/x-sv4crc"), + ("svg", "image/svg+xml"), + ("swf", "application/x-shockwave-flash"), + ("t", "application/x-troff"), + ("tar", "application/x-tar"), + ("tcl", "application/x-tcl"), + ("tex", "application/x-tex"), + ("texi", "application/x-texinfo"), + ("texinfo", "application/x-texinfo"), + ("tgz", "application/x-compressed"), + ("tr", "application/x-troff"), + ("trm", "application/x-msterminal"), + ("tsv", "text/tab-separated-values"), + ("uls", "text/iuls"), + ("ustar", "application/x-ustar"), + ("vcf", "text/x-vcard"), + ("vrml", "x-world/x-vrml"), + ("wav", "audio/x-wav"), + ("wcm", "application/vnd.ms-works"), + ("wdb", "application/vnd.ms-works"), + ("wks", "application/vnd.ms-works"), + ("wmf", "application/x-msmetafile"), + ("wps", "application/vnd.ms-works"), + ("wri", "application/x-mswrite"), + ("wrl", "x-world/x-vrml"), + ("wrz", "x-world/x-vrml"), + ("xaf", "x-world/x-vrml"), + ("xbm", "image/x-xbitmap"), + ("xla", "application/vnd.ms-excel"), + ("xlc", "application/vnd.ms-excel"), + ("xlm", "application/vnd.ms-excel"), + ("xls", "application/vnd.ms-excel"), + ("xlt", "application/vnd.ms-excel"), + ("xlw", "application/vnd.ms-excel"), + ("xof", "x-world/x-vrml"), + ("xpm", "image/x-xpixmap"), + ("xwd", "image/x-xwindowdump"), + ("z", "application/x-compress") + + ] +
src/MFlow/Forms.hs view
@@ -11,1771 +11,1333 @@ -XIncoherentInstances -XTypeFamilies -XTypeOperators- -XOverloadedStrings -#-} - -{- | 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-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-instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .-To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.--`ask` is the only method for user interaction. It run in the @MFlow view m@ monad, with @m@ the monad chosen by the user, usually IO.-It send user interfaces (in the @View view m@ monad) and return statically -typed responses. The user interface definitions are based on a extension of-formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,- extra combinators, callbaks and modifiers.-The interaction with the user is stateful. In the same computation there may be many-request-response interactions, in the same way than in the case of a console applications. --* APPLICATION SERVER--Therefore, session and state management is simple and transparent: it is in the haskell-structures in the scope of the computation. `transient` (normal) procedures have no persistent session state-and `stateless` procedures accept a single request and return a single response.--`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that-remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.-This state management is transparent. There is no programer interface for session management.--The programmer set the process timeout and the session timeout with `setTimeouts`. -If the procedure has been stopped due to the process timeout or due to a system shutdowm,-the procedure restart in the last state when a request for this procedure arrives-(if the procedure uses the `step` monad transformer)--* WIDGETS--The correctness of the web responses is assured by the use of formLets.-But unlike formLets in its current form, it permits the definition of widgets.-/A widget is a combination of formLets and links within its own formatting template/, all in-the same definition in the same source file, in plain declarative Haskell style.--The formatting is abstract. It has to implement the 'FormInput' class.-There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")-and ByteString. So widgets-can use any formatting that is instance of FormInput.-It is possible to use more than one format in the same widget.--Links defined with `wlink` are treated the same way than forms. They are type safe and return values- to the same flow of execution.-It is posssible to combine links and forms in the same widget by using applicative combinators but also-additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can-be combined as such.--* NEW IN THIS RELEASE:--[@Back Button@] This is probably the first implementation of an stateful Web framework that works well with the back button thanks-to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)--[@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.--[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.-The callback may initate a flow of interactions with the user or simply execute an internal computation.-Callbacks are necessary for the creation of abstract container-widgets that may not know the behaviour of its content. The widget manages its content as black boxes.--[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a-login form and substitute it by the username if already logged.--Example:--@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@---[@attributes for formLet elements@] it is not only possible to add Html formatting, but also to add atributes to a formlet element.-This example has three formLet elements with the attribute "size" added, and a string prepended to the second password box.--> userFormLine=-> (User <$> getString (Just "enter user") <! [("size","5")]-> <*> getPassword <! [("size","5")]-> <+> submitButton "login")-> <+> fromString " password again" ++> getPassword <! [("size","5")]-> <* submitButton "register"---[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the ByteString level, and to permit many formatring styles-in the same page, there are operators that combine different formats which are converted to ByteStrings.-For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.---[@AJAX@] See "MFlow.Forms.Ajax"---[@File Server@] With file caching. See "MFlow.FileServer"--This is a complete example, that can be run with runghc, which show some of these features:--> {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}-> module Main where-> import MFlow.Wai.XHtml.All-> import Data.TCache-> import Control.Monad.Trans-> import Data.Typeable-> import Control.Concurrent-> import Control.Exception as E-> import qualified Data.ByteString.Char8 as SB-> import qualified Data.Vector as V-> import Data.Maybe->-> data Ops= Ints | Strings | Actions | Ajax | Opt deriving(Typeable,Read, Show)-> main= do-> setFilesPath ""-> addFileServerWF-> addMessageFlows [("" ,transient $ runFlow mainf)-> ,("shop" ,runFlow shopCart)]-> forkIO $ run 80 waiMessageFlow-> adminLoop->-> stdheader c= p << "you can press the back button to go to the menu"+++ c->-> mainf= do-> setHeader stdheader-> r <- ask $ wlink Ints (bold << "increase an Int")-> <|> br ++> wlink Strings (bold << "increase a String")-> <|> br ++> wlink Actions (bold << "Example of a string widget with an action")-> <|> br ++> wlink Ajax (bold << "Simple AJAX example")-> <|> br ++> wlink Opt (bold << "select options")-> <++ (br +++ linkShop) -- this is an ordinary XHtml link->-> case r of-> Ints -> clickn 0-> Strings -> clicks "1"-> Actions -> actions 1-> Ajax -> ajaxsample-> Opt -> options-> mainf-> where-> linkShop= toHtml $ hotlink "shop" << "shopping"->-> options= do-> r <- ask $ getSelect (setOption "blue" (bold << "blue") <|>-> setSelectedOption "Red" (bold << "red") ) <! dosummit-> ask $ p << (r ++ " selected") ++> wlink () (p<< " menu")-> breturn()-> where-> dosummit= [("onchange","this.form.submit()")]->-> clickn (n :: Int)= do-> setHeader stdheader-> r <- ask $ wlink "menu" (p << "menu")-> |+| getInt (Just n) <* submitButton "submit"-> case r of-> (Just _,_) -> breturn ()-> (_, Just n') -> clickn $ n'+1->->-> clicks s= do-> setHeader stdheader-> s' <- ask $ (getString (Just s)-> <* submitButton "submit")-> `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing )-> clicks $ s'++ "1"->->-> ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html->-> ajaxsample= do-> setHeader ajaxheader-> ajaxc <- ajaxCommand "document.getElementById('text1').value"-> (\n -> return $ "document.getElementById('text1').value='"++show(read n +1)++"'")-> ask $ (getInt (Just 0) <! [("id","text1"),("onclick", ajaxc)])-> breturn()->-> actions n=do-> ask $ wlink () (p << "exit from action")-> <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions )-> breturn ()->-> -- A persistent flow (uses step). The process is killed after 10 seconds of inactivity-> -- but it is restarted automatically. if you restart the program, it remember the shopping cart-> -- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.-> shopCart = do-> setTimeouts 10 0-> shopCart1 (V.fromList [0,0,0:: Int])-> where-> shopCart1 cart= do-> i <- step . ask $-> table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]-> <<< caption << "choose an item"-> ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"]-> ++> (tbody-> <<< tr ! [rowspan 2] << td << linkHome-> ++> (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0))-> <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1))-> <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2)))-> <++ tr << td << linkHome-> )->-> let newCart= cart V.// [(i, cart V.! i + 1 )]-> shopCart1 newCart-> where-> linkHome= (toHtml $ hotlink noScript << bold << "home")- --} - -module MFlow.Forms(- --- * Basic definitions -FormLet(..), -FlowM,View, FormInput(..)- --- * Users -,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName -,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin, userWidget, --- * User interaction -ask, clearEnv, --- * formLets --- | they mimic the HTML form elements.--- It is possible to modify their attributes with the `<!` operator.--- They are combined with the widget combinators.--- formatting can be added with the formatting combinators.--- modifiers change their presentation and behaviour -getString,getInt,getInteger, getTextBox -,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,-getRadio, getRadioActive, getCheckBoxes, setCheckBox,-submitButton,resetButton, wlink, wform,- firstOf,--- * FormLet modifiers-validate, noWidget, wrender, waction, wmodify,---- * Caching widgets-cachedWidget, --- * Widget combinators -(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),---- * Normalized (convert to ByteString) widget combinators--- | these dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings------ The purpose is to combine heterogeneous formats into byteString-formatted widgets that--- can be cached with `cachedWidget`-(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),---- * Formatting combinators-(<<<),(<++),(++>),(<!),---- * Normalized (convert to ByteString) formatting combinators--- | some combinators that convert the formatting of their arguments to lazy byteString-(.<<.),(.<++.),(.++>.)---- * ByteString tags-,btag,bhtml,bbody---- * Normalization-, flatten, normalize, ToByteString(..)- --- * Running the flow monad -,runFlow,runFlowIn,MFlow.Forms.step, goingBack,breturn- --- * Setting parameters -,setHeader-,getHeader -,setTimeouts- --- * Cookies -,setCookie- -) -where -import Data.TCache-import Data.TCache.DefaultPersistence-import Data.TCache.Memoization -import MFlow -import MFlow.Cookies -import Data.RefSerialize hiding((<|>))-import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) --import qualified Data.CaseInsensitive as CI -import Data.Typeable -import Data.Monoid -import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import Data.Maybe -import Control.Applicative -import Control.Exception- -import Control.Workflow as WF -import Control.Monad.Identity-import Unsafe.Coerce-import Data.List(intersperse) -import Data.IORef --import System.IO.Unsafe-import Data.Char(isNumber)-import Network.HTTP.Types.Header - ---import Debug.Trace---import System.IO (hFlush,stdout)---(!>)= flip trace ---instance Serialize a => Serializable a where- serialize= runW . showp- deserialize= runR readp - -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 :: MonadIO m => (UserStr,PasswdStr) -> m (Maybe String) -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 "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-- ---test= runBackT $ do--- liftRepeat $ print "hola"--- n2 <- lift $ getLine--- lift $ print "n3"------ n3 <- lift $ getLine--- if n3 == "back"--- then fail ""--- else lift $ print $ n2++n3---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--- res<- do--- v <- runBackT x -- !> "loop"--- case v of--- NoBack y -> runBackT (f y) >>= return . Right -- !> "runback"--- BackPoint y -> do--- z <- runBackT (f y) -- !> "BACK"--- case z of--- GoBack -> return $ Left () -- !> "GoBack"--- other -> return $ Right other--- GoBack -> return $ Right GoBack--- case res of--- Left _ -> loop--- Right r -> return r--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----instance Monad m => Monad (BackT m) where--- fail _ = BackT $ return GoBack--- return x = BackT . return $ NoBack x--- x >>= f = BackT $ do--- v <- runBackT x--- case v of--- NoBack y -> runBackT (f y)--- BackPoint y -> loop--- where--- loop= do--- z <- runBackT (f y)--- case z of--- GoBack -> loop--- other -> return other--- GoBack -> return GoBack---{-# NOINLINE breturn #-}---- | Use this instead of return to return from a computation with an ask statement------ This way when the user press the back button, the computation will execute back, to--- the returned code, according with the user navigation.-breturn x= BackT . return $ BackPoint x -- !> "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--{-# NOINLINE liftBackT #-}-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 FlowM view m= BackT (WState view m)- -data FormElm view a = FormElm [view] (Maybe a) deriving Typeable- -newtype View v m a = View { runView :: WState v m (FormElm v a) }---instance (FormInput v, Monoid 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, Functor m) => Monad (View view m) where- --View view m a-> (a -> View view m b) -> View view m b - 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 MonadTrans (View view) where- lift f = View $ lift f >>= \x -> return $ FormElm [] $ Just x--instance (Functor m, 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 (MonadIO m, Functor m) => MonadIO (View view m) where- liftIO= lift . liftIO----instance Executable (View v m) where--- execute = runView-----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 user 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.--cachedWidget ::(Show a,MonadIO m,Typeable view, Monoid view- , FormInput view, Typeable a, Functor m, 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 _, seq)= execute $ cachedByKey key 0 $ proc mf s{mfCached=True}- let(FormElm _ mx2, s2) = execute $ runStateT (runView mf) s{mfSequence= seq,mfCached=True} -- !> ("mfSequence s1="++ show(mfSequence s1)) !> ("mfSequence s="++ show(mfSequence s)) !> ("mfSequence s'="++ show(mfSequence s'))- let s''= s{validated = validated s2}- return (FormElm form mx2, s'')- where- proc mf s= runStateT (runView mf) s>>= \(r,_) -> return (r,mfSequence s)-- --- | A FormLet instance -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 @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`-`waiMessageFlow` or `addMessageFlows`--@main= do- addMessageFlows [(\"noscript\",transient $ runFlow mainf)]- forkIO . run 80 $ waiMessageFlow- adminLoop-@--} -runFlow :: (FormInput view, Monoid view, Monad m) - => FlowM view m a -> Token -> m a -runFlow f = \ t -> evalStateT (runBackT $ backp >> f) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()- where- -- to restart the flow in case of going back before the first page of the flow- backp = breturn()- fromFailBack (NoBack x)= x- fromFailBack (BackPoint x)= x---- | run a persistent flow inside the current flow. It is identified by the procedure and--- the string identifier.--- unlike the normal flows, that are infinite loops, runFlowIn executes finite flows--- 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- liftIO $ WF.exec1nc wf $ runFlow f t---step - :: (Serialize a,- Typeable view,- FormInput view,- Monoid view, - MonadIO m, - Typeable a) => - FlowM view m a - -> FlowM view (Workflow m) a --step f= do - s <- get- BackT $ do- (r,s') <- lift . WF.step $ runStateT (runBackT f) s- -- 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{validated= 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 . fromString $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)- return $ FormElm (err:form) Nothing - --- | Validates a form or widget result against a validating procedure --- --- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@ -validate- :: (FormInput view, Monad m) =>- View view m a- -> (a -> WState view m (Maybe String))- -> View view m a -validate formt val= View $ do - FormElm form mx <- (runView formt) - case mx of - Just x -> do - me <- val x- modify (\s -> s{validated= True}) - case me of - Just str -> - --FormElm form mx' <- generateForm [] (Just x) noValidate - return $ FormElm ( inred (fromString str) : form) Nothing - Nothing -> return $ FormElm [] mx - _ -> 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.--- 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`-waction- :: (FormInput view, Monad m) =>- View view m a- -> (a -> FlowM view m b)- -> View view m b-waction formt act= View $ do - FormElm form mx <- (runView formt) - case mx of - Just x -> do- modify (\s -> s{validated= True})- clearEnv - br <- runBackT $ act x- case br of- GoBack -> do- modify (\s -> s{validated= False})- return $ FormElm form Nothing- NoBack r -> return . FormElm form $ Just r- BackPoint r -> return . FormElm form $ Just r -- bad. no backpoints- - _ -> return $ FormElm form Nothing---- | A modifier get the result and the rendering of a widget and change them. ------ This modifier, when logged, changes a login-password-register widget with a display username.------ @userFormOrName= `userWidget` Nothing `userFormLine` \`wmodify\` f--- where--- f _ justu\@(Just u) = return ([`fromString` u], justu) -- user validated, display and return user--- f felem Nothing = do--- us <- `getCurrentUser`--- if us == `anonymous`--- then return (felem, Nothing) -- user not logged, present the form--- else return([`fromString` us], Just us) -- already logged, display and return user@-wmodify :: (Monad m, FormInput v)- => View v m a- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))- -> View v m b-wmodify formt act = View $ do- FormElm f mx <- runView formt - (f',mx') <- act f mx- return $ FormElm f' mx'- - - -instance (FormInput view, FormLet a m view , FormLet b m view ) - => FormLet (a,b) m view where - digest mxy = do - let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y) - (,) <$> digest x <*> digest y - -instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view ) - => FormLet (a,b,c) m view where - digest mxy = do - 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 -getString :: (FormInput view,Monad m) => - Maybe String -> View view m String -getString = getTextBox ---- | display a text box and return an Integer (if the value entered is not an Integer, fails the validation) -getInteger :: (FormInput view, Functor m, MonadIO m) => - Maybe Integer -> View view m Integer -getInteger = getTextBox ---- | display a text box and return a Int (if the value entered is not an Int, fails the validation) -getInt :: (FormInput view, Functor m, MonadIO m) => - Maybe Int -> View view m Int -getInt = getTextBox ---- | display a password box -getPassword :: (FormInput view, - Monad m) => - View view m String -getPassword = getParam Nothing "password" Nothing ---- | implement a radio button that perform a submit when pressed.--- the parameter is the name of the radio group-getRadioActive :: (FormInput view, Functor m, MonadIO m) => - String -> String -> View view m String-getRadioActive n v= View $ do- st <- get- put st{needForm= True}- let env = mfEnv st- FormElm form mn <- getParam1 n env []- return $ FormElm [finput n "radio" v - ( isJust mn && v== fromJust mn) (Just "this.form.submit()")]- mn-- - --- | implement a radio button--- the parameter is the name of the radio group-getRadio :: (FormInput view, Functor m, MonadIO m) => - String -> String -> View view m String-getRadio n v= 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])- mn--data CheckBoxes = CheckBoxes [String]--instance Monoid CheckBoxes where- mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys- mempty= CheckBoxes []--instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where- 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- mempty= return mempty---- | display a text box and return the value entered if it is readable( Otherwise, fail the validation)-setCheckBox :: (FormInput view, Functor m, MonadIO m) => - String -> Bool -> View view m CheckBoxes-setCheckBox v checked= View $ do- n <- getNewName- st <- get- put st{needForm= True}- let env = mfEnv st- FormElm f mn <- getParam1 n env []- val <- gets validated- let ret= case val of- True -> Just . CheckBoxes $ maybeToList mn- False -> Nothing- return $ FormElm- (f ++ [ finput n "checkbox" v - ( checked || (isJust mn && v== fromJust mn)) Nothing])- ret--getCheckBoxes ::(FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]-getCheckBoxes boxes = View $ do- n <- getNewName- env <- gets mfEnv- FormElm form (mr :: Maybe String) <- getParam1 n env [finput n "hidden" "" False Nothing]- st <- get- let env = mfEnv st- put 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- - ----- get a parameter form the las received response-getEnv :: MonadState (MFlowState view) m => String -> m(Maybe String)-getEnv n= gets mfEnv >>= return . lookup n- -getTextBox - :: (FormInput view, - Monad m, - Typeable a, - Show a, - Read a) => - Maybe a -> View view m a -getTextBox ms = getParam Nothing "text" ms -- -getParam - :: (FormInput view, - Monad m, - Typeable a, - Show a, - Read a) => - Maybe String -> String -> Maybe a -> View view m a -getParam look type1 mvalue = View $ do - tolook <- case look of - Nothing -> getNewName - Just n -> return n - let nvalue= case mvalue of - Nothing -> "" - Just 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 - - -getNewName :: MonadState (MFlowState view) m => m String -getNewName= do - st <- get - let n= mfSequence st - put $ st{mfSequence= n+1}- let pref= if mfCached st then 'c' else 'p' - return $ pref : (show n)--getCurrentName :: MonadState (MFlowState view) m => m String-getCurrentName= do- st <- get- let parm = mfSequence st- return $ if mfCached st then "c" else "p"++show parm----- | display a multiline text box and return its content-getMultilineText :: (FormInput view, - Monad m) => - String -> View view m String -getMultilineText nvalue = View $ do - tolook <- getNewName- env <- gets mfEnv- let form= [ftextarea tolook nvalue] - getParam1 tolook env form - ---instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where --- digest mv = getBool b "True" "False" --- where --- b= case mv of --- Nothing -> Nothing --- Just bool -> Just $ case bool of--- True -> "True"--- False -> "False"---- | 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) => - Bool -> String -> String -> View view m Bool -getBool mv truestr falsestr= View $ do - tolook <- getNewName- st <- get- let env = mfEnv st- put st{needForm= True}- r <- getParam1 tolook env $ [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 ---- | display a dropdown box with the options in the first parameter is optionally selected--- . It returns the selected option. -getSelect :: (FormInput view, - Monad m,Typeable a, Read a) => - View view m (MFOption a) -> View view m a -getSelect opts = View $ do - tolook <- getNewName- st <- get- let env = mfEnv st- put st{needForm= True}- FormElm form mr <- (runView opts) - getParam1 tolook env [fselect tolook $ mconcat form] --data MFOption a= MFOption--instance (Monad m, Functor m) => Monoid (View view m (MFOption a)) where- mappend = (<|>)- mempty = Control.Applicative.empty---- | set the option for getSelect. Options are concatenated with `<|>`-setOption n v = setOption1 n v False---- | set the selected option for getSelect. Options are concatenated with `<|>`-setSelectedOption n v= setOption1 n v True- -setOption1 :: (FormInput view, - Monad m, Typeable a, Show a) => - a -> view -> Bool -> View view m (MFOption a) -setOption1 nam val check= View $ do- st <- get- let env = mfEnv st- put st{needForm= True}- let n= if typeOf nam== typeOf(undefined :: String) then unsafeCoerce nam else show nam - return . FormElm [foption n val check] $ Just MFOption -- --- | Enclose Widgets in some formating. --- @view@ is intended to be instantiated to a particular format------ This is a widget, which is table with some links. it returns an Int------ > import MFlow.Forms.XHtml--- >--- > tableLinks :: View Html Int--- > tableLinks= table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]--- > <<< caption << "choose an item"--- > ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"]--- > ++> (tbody--- > <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << "One")--- > <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << "Two")--- > <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << "Three"))--- > ) -(<<<) :: (Monad m, Monoid view) - => (view ->view) - -> View view m a - -> View view m a -(<<<) v form= View $ do - FormElm f mx <- runView form - return $ FormElm [v $ mconcat f] mx - - -infixr 5 <<< - ----- | 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'--normalize ::(Monad m, ToByteString v) => View v m a -> View ByteString m a-normalize f= View $ StateT $ \s ->do- (FormElm fs mx, s') <- runStateT (runView f) $ unsafeCoerce s- -- the only diference between the states of the two views is mfHeader- -- which don't affect to runState - 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--- --- | Append formatting code to a widget --- --- @ getString "hi" <++ H1 << "hi there"@ -(<++) :: (Monad m) - => View v m a - -> v - -> View v m a -(<++) form v= View $ do - FormElm f mx <- runView form - return $ FormElm ( f ++ [ v]) mx - -infixr 6 <++ , .<++. - - -infixr 6 ++> , .++>. --- | Prepend formatting code to a widget --- --- @bold << "enter name" ++> getString Nothing @ - -(++>) :: (Monad m, Monoid view) - => view -> View view m a -> View view m a -html ++> digest = (html `mappend`) <<< digest - - - - -type Name= String -type Type= String -type Value= String -type Checked= Bool -type OnClick= Maybe String - - --- | 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 => FormInput view where - inred :: view -> view - fromString :: String -> view - flink :: String -> view -> view - flink1:: String -> view - flink1 verb = flink verb (fromString 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 (fromString val) msel - formAction :: String -> view -> view- addAttributes :: view -> Attribs -> view ---- | add attributes to the form element--- if the view has more than one element, it is applied to the first-infix 8 <!-widget <! atrs= View $ do- FormElm fs mx <- runView widget- return $ FormElm [addAttributes (head fs) atrs] mx---------------------------------- - --- --- ---instance (MonadIO m, Functor m, FormInput view) --- => FormLet User m view where --- digest muser= --- (User <$> getString ( userName <$> muser) --- <*> getPassword) --- `validate` userValidate - - -newtype Lang= Lang String - -data MFlowState view= MFlowState{ - mfSequence :: Int,- mfCached :: Bool,- prevSeq :: [Int],- onInit :: Bool,- validated :: Bool, --- mfUser :: String, - mfLang :: Lang, - mfEnv :: Params,- needForm :: Bool,- hasForm :: Bool, --- mfServer :: String, --- mfPath :: String, --- mfPort :: Int, - - mfToken :: Token, - mfkillTime :: Int, - mfSessionTime :: Integer, - mfCookies :: [Cookie], - mfHeader :: view -> view,- mfDebug :: Bool- }- deriving Typeable - -stdHeader v = v- - -mFlowState0 :: (FormInput view, Monoid view) => MFlowState view -mFlowState0= MFlowState 0 False [] True False (Lang "en") [] False False (error "token of mFlowState0 used") 0 0 [] stdHeader False ---- | Set the header-footer that will enclose the widgets. It must be provided in the--- same formatting than them, altrough with normalization to byteStrings can be used any formatting------ 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 :: Monad m => (view -> view) -> FlowM 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 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 UserStr= String-type PasswdStr= String --- | Is an example of login\/register validation form needed by 'userWidget'. In this case--- the form field appears in a single line. it shows, in sequence, entries for the username,--- password, a button for loging, a entry to repeat password necesary for registering--- and a button for registering.--- The user can build its own user login\/validation forms by modifying this example------ @ userFormLine=--- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")--- \<\+\> fromString \" password again\" \+\> getPassword \<\* submitButton \"register\"--- @-userFormLine :: (FormInput view, Monoid view, Functor m, Monad m)- => View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) -userFormLine=- ((,) <$> getString (Just "enter user") <! [("size","5")]- <*> getPassword <! [("size","5")]- <+> submitButton "login")- <+> fromString " password again" ++> getPassword <! [("size","5")]- <* submitButton "register"---- | Example of user\/password form (no validation) to be used with 'userWidget'-userLogin :: (FormInput view, Monoid view, Functor m, Monad m)- => View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String)-userLogin=- ((,) <$> fromString "Enter User: " ++> getString Nothing <! [("size","4")]- <*> fromString " Enter Pass: " ++> getPassword <! [("size","4")]- <+> submitButton "login")- <+> noWidget- <* noWidget------ | empty widget that return Nothing. May be used as \"empty boxes\" inside larger widgets-noWidget :: (FormInput view, - Monad m) => - View view m a-noWidget= View . return $ FormElm [] Nothing---- | render the Show instance of the parameter and return it. It is useful--- for displaying information-wrender :: (Monad m, Show a, FormInput view) => a -> View view m a-wrender x= View . return $ FormElm [fromString $ show x] (Just x)---- | Wether the user is logged or is anonymous-isLogged :: MonadState (MFlowState v) m => m Bool-isLogged= do- rus <- return . tuser =<< gets mfToken - return . not $ rus == anonymous---- | It creates a widget for user login\/registering. If a user name is specified--- in the first parameter, it is forced to login\/password as this specific user.--- Otherwise, if the user is already logged, the widget does not appear--- If the user press the register button, the user/password is registered and the--- user-userWidget :: ( MonadIO m, Functor m - , FormInput view, Monoid view ) - => Maybe String- -> View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String)- -> View view m String -userWidget muser formuser= wform formuser `validate` val muser `waction` login - where- val _ (Nothing,_) = return $ Just "Plese fill in the user/passwd to login, or user/passwd/passwd to register"- val mu (Just (Just us , Just _), Nothing)=- if isNothing mu || isJust mu && fromJust mu == fst us- then userValidate us- else return $ Just "wrong user for the operation"- val mu (Just (Just us , Just _), Just p)=- if isNothing mu || isJust mu && fromJust mu == fst us- then if length p > 0 && snd us== p- then return Nothing- else return $ Just "The passwords do not match"- else return $ Just "wrong user for the operation"-- val _ _ = return $ Just "Please fill in the fields for login or register"-- login (Just (Just (u,p) , Just _), Nothing)= do-- let uname= u- st <- get - let t = mfToken st- t'= t{tuser= uname}- moveState (twfname t) t t'- put st{mfToken= t'}- liftIO $ deleteTokenInList t- liftIO $ addTokenToList t'- setCookie cookieuser uname "/" Nothing -- !> "setcookie" - return uname-- login (Just (Just us@(u,p) , Just _), Just _)= do- userRegister u p- login (Just (Just us , Just p), Nothing)- - --- | If not logged, perform login. otherwise return the user------ @getUserSimple= getUser Nothing userFormLine@-getUserSimple :: ( FormInput view, Monoid view, Typeable view - , ToHttpData view - , MonadIO m, Functor m)- => FlowM view m String-getUserSimple= getUser Nothing userFormLine- --- | Very basic user authentication. The user is stored in a cookie. --- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed --- user-password combination.--- The user-password combination is only asked if the user has not logged already--- otherwise, the stored username is returned.------ @getUser mu form= ask $ userWidget mu form@ -getUser :: ( FormInput view, Monoid view, Typeable view - , ToHttpData view - , MonadIO m, Functor m) - => Maybe String- -> View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String)- -> FlowM view m String -getUser mu form= ask $ userWidget mu form - - ---instance (MonadIO m, Functor m, m1 ~ m, b ~ a) --- => Widget(View view m1 b) a m view where --- widget = id - --- | Join two widgets in the same page --- the resulting widget, when `ask`ed with it, returns a either one or the other --- --- > r <- ask widget widget1 <+> widget widget2 --- > case r of (Just x, Nothing) -> ..-(<+>) , mix :: Monad m - => View view m a - -> View view m b - -> View view m (Maybe a, Maybe b) -mix digest1 digest2= View $ do - FormElm f1 mx' <- runView digest1 - FormElm f2 my' <- runView digest2 - return $ FormElm (f1++f2) - $ case (mx',my') of - (Nothing, Nothing) -> Nothing- other -> Just other --infixr 2 <+>, .<+>. - -(<+>) = mix---infixr 3 <**, **>, .**>., .<**.--- | The first elem result (even if it is not validated) is discarded, and the secod is returned--- . This contrast with the applicative operator '*>' which fails the whole validation if--- the validation of the first elem fails.--- . The first element is displayed however, as in the case of '*>'-(**>) :: (Functor m, Monad m)- => View view m a -> View view m b -> View view m b-(**>) form1 form2 = valid form1 *> form2----- | The second elem result (even if it is not validated) is discarded, and the first is returned--- . This contrast with the applicative operator '<*' which fails the whole validation if--- the validation of the second elem fails.--- . The first element is displayed however, as in the case of '<*'-(<**)- :: (Functor m, Monad m) =>- View view m a -> View view m b -> View view m a-(<**) form1 form2 = form1 <* valid form2---valid form= View $ do- FormElm form mx <- runView form- return $ FormElm form $ Just undefined--- --- | It is the way to interact with the user. --- It takes a widget and return the user result.--- If the environment has the result, ask don't ask to the user.--- To force asking in any case, put an `clearEnv` statement before -ask- :: (- ToHttpData view,- FormInput view,- Monoid view,- MonadIO m,- Typeable view) =>- View view m b -> FlowM view m b -ask x = do- st1 <- get- let st= st1{hasForm= False, needForm= False,validated= False} - put st- FormElm forms mx <- lift $ runView x -- !> "runWidget" - st' <- get- case mx of - Just x -> do- put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]}- breturn x -- !> "just x"- - _ ->- if not (validated st') && not (onInit st') && hasParams (mfSequence st') ( mfEnv st') -- !> (show $ validated st') !> (show $ onInit st')- then do- put st'{mfSequence= head1 $ prevSeq st'- ,prevSeq= tail1 $ prevSeq st' }- fail "" -- !> "repeatPlease"- else do- let header= mfHeader st'- t= mfToken st'- cont = case (needForm st', hasForm st') of- (True, False) -> header $ formAction (twfname t) $ mconcat forms- _ -> header $ mconcat forms-- let HttpData ctype c s= toHttpData cont - liftIO . sendFlush t $ HttpData ctype (mfCookies st' ++ c) s- put st{mfCookies=[], onInit= False, mfToken= t } -- !> ("after "++show ( mfSequence st')) - receiveWithTimeouts- ask x- where- head1 []=0- head1 xs= head xs- tail1 []=[]- tail1 xs= tail xs-- hasParams seq= not . null . filter (\(p,_) ->-- let tailp = tail p in- (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@------ 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 (validated st) && not (onInit st)---- | Clears the environment-clearEnv :: MonadState (MFlowState view) m => m () -clearEnv= do- st <- get- put st{ mfEnv= []} - -receiveWithTimeouts :: MonadIO m => FlowM 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} - - - - --- | wrap a widget of form element within a form-action element.----- Usually it is done automatically by the @Wiew@ monad. -wform :: (Monad m, FormInput view, Monoid view) - => View view m b -> View view m b - -wform x = View $ do - FormElm form mr <- (runView $ x )- st <- get - let t = mfToken st- put st{hasForm= True} - let form1= formAction ( twfname t) $ mconcat form - - 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 () --submitButton :: (FormInput view, Monad m) => String -> View view m String-submitButton label= getParam Nothing "submit" $ Just label -----insertView view= View $ return $ FormElm [view] $ Just ()------infix 3 +> ---view +> widget= (insertView view) *> widget------infix 3 <+---widget <+ view = widget <* insertView view-- - --- | 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) - => a -> view -> View view m a -wlink x v= View $ do - verb <- getWFName - name <- getNewName- 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] - - - - ---instance (Widget a b m view, Monoid view) => Widget [a] b m view where --- widget xs = View $ do --- forms <- mapM(\x -> (runView $ widget x )) xs --- let vs = concatMap (\(FormElm v _) -> v) forms --- res = filter isJust $ map (\(FormElm _ r) -> r) forms --- res1= if null res then Nothing else head res --- return $ FormElm [mconcat vs] res1---- | Concat a list of widgets of the same type, return a the first validated result -firstOf :: (Monoid view, MonadIO m, Functor m)=> [View view m a] -> View view m a -firstOf xs= View $ do - forms <- mapM(\x -> (runView x )) xs - let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms - res = filter isJust $ map (\(FormElm _ r) -> r) forms - res1= if null res then Nothing else head res - return $ FormElm vs res1 ------ | intersperse a widget in a list of widgets. the results is a 2-tuple of both types-(|*>) :: (MonadIO m, Functor m,Monoid view)- => View view m r- -> [View view m r']- -> View view m (Maybe r,Maybe r')-(|*>) x xs= View $ do- FormElm fxs rxs <- runView $ firstOf xs- FormElm fx rx <- runView $ x-- return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx)- $ case (rx,rxs) of- (Nothing, Nothing) -> Nothing- other -> Just other----infixr 5 |*>, .|*>.---- | Put a widget above and below other. Useful for navigation links in a page.-(|+|) :: (Functor m, Monoid view, MonadIO m)- => View view m r- -> View view m r'- -> View view m (Maybe r, Maybe r')-(|+|) w w'= w |*> [w']--infixr 1 |+|, .|+|.----- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator--- into a single tuple with the same elements in the same order.--- This is useful for easing matching. For example:------ @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@------ @res@ has type:------ @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@------ but @flatten res@ has type:------ @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@--flatten :: Flatten (Maybe tree) list => tree -> list-flatten res= doflat $ Just res--class Flatten tree list where- doflat :: tree -> list---type Tuple2 a b= Maybe (Maybe a, Maybe b)-type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)-type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)-type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)-type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)--instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where- doflat (Just(ma,mb))= (ma,mb)- doflat Nothing= (Nothing,Nothing)--instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where- doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)- doflat Nothing= (Nothing,Nothing,Nothing)--instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where- doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)- doflat Nothing= (Nothing,Nothing,Nothing,Nothing)--instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where- doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)--instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where- doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)----- | > (.<<.) w x = w $ toByteString x-(.<<.) :: (ToByteString view) => (ByteString -> ByteString) -> view -> ByteString-(.<<.) w x = w $ toByteString x---- | > (.<+>.) x y = normalize x <+> normalize y-(.<+>.)- :: (Monad m, ToByteString v, ToByteString v1) =>- View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)-(.<+>.) x y = normalize x <+> normalize y---- | > (.|*>.) x y = normalize x |*> map normalize y-(.|*>.)- :: (Functor m, MonadIO m, ToByteString v, ToByteString v1) =>- View v m r- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')-(.|*>.) x y = normalize x |*> map normalize y---- | > (.|+|.) x y = normalize x |+| normalize y-(.|+|.)- :: (Functor m, MonadIO m, ToByteString v, ToByteString v1) =>- View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')-(.|+|.) x y = normalize x |+| normalize y---- | > (.**>.) x y = normalize x **> normalize y-(.**>.)- :: (Monad m, Functor m, ToByteString v, ToByteString v1) =>- View v m a -> View v1 m b -> View ByteString m b-(.**>.) x y = normalize x **> normalize y---- | > (.<**.) x y = normalize x <** normalize y-(.<**.)- :: (Monad m, Functor m, ToByteString v, ToByteString v1) =>- View v m a -> View v1 m b -> View ByteString m a-(.<**.) x y = normalize x <** normalize y---- | > (.<|>.) x y= normalize x <|> normalize y-(.<|>.)- :: (Monad m, Functor m, ToByteString v, ToByteString v1) =>- View v m a -> View v1 m a -> View ByteString m a-(.<|>.) x y= normalize x <|> normalize y---- | > (.<++.) x v= normalize x <++ toByteString v-(.<++.) :: (Monad m, ToByteString v, ToByteString v') => View v m a -> v' -> View ByteString m a-(.<++.) x v= normalize x <++ toByteString v---- | > (.++>.) v x= toByteString v ++> normalize x-(.++>.) :: (Monad m, ToByteString v, ToByteString v') => v -> View v' m a -> View ByteString m a-(.++>.) v x= toByteString v ++> normalize x---instance FormInput ByteString where-- inred = btag "b" [("style", "color:red")]- finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []- ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""- ftextarea name text= btag "textarea" [("name", name)] $ pack text-- fselect name options= btag "select" [("name", name)] options-- foption value content msel= btag "option" ([("value", value)] ++ selected msel) content- where- selected msel = if msel then [("selected","true")] else []-- addAttributes tag attrs = error "addAttributes not implemented for ByteString"--- formAction action form = btag "form" [("action", action),("method", "post")] form- fromString = pack-+ -XOverloadedStrings+ +#-} + +{- | 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+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+instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .+To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.++`ask` is the only method for user interaction. It run in the @MFlow view m@ monad, with @m@ the monad chosen by the user, usually IO.+It send user interfaces (in the @View view m@ monad) and return statically +typed responses. The user interface definitions are based on a extension of+formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,+ extra combinators, callbaks and modifiers.+The interaction with the user is stateful. In the same computation there may be many+request-response interactions, in the same way than in the case of a console applications. ++* APPLICATION SERVER++Therefore, session and state management is simple and transparent: it is in the haskell+structures in the scope of the computation. `transient` (normal) procedures have no persistent session state+and `stateless` procedures accept a single request and return a single response.++`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that+remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.+This state management is transparent. There is no programer interface for session management.++The programmer set the process timeout and the session timeout with `setTimeouts`. +If the procedure has been stopped due to the process timeout or due to a system shutdowm,+the procedure restart in the last state when a request for this procedure arrives+(if the procedure uses the `step` monad transformer)++* WIDGETS++The correctness of the web responses is assured by the use of formLets.+But unlike formLets in its current form, it permits the definition of widgets.+/A widget is a combination of formLets and links within its own formatting template/, all in+the same definition in the same source file, in plain declarative Haskell style.++The formatting is abstract. It has to implement the 'FormInput' class.+There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")+and ByteString. So widgets+can use any formatting that is instance of `FormInput`.+It is possible to use more than one format in the same widget.++Links defined with `wlink` are treated the same way than forms. They are type safe and return values+ to the same flow of execution.+It is posssible to combine links and forms in the same widget by using applicative combinators but also+additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can+be combined as such.++* NEW IN THIS RELEASE++[@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++[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead+of a single request-response (see 'ajaxSend').++[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the+server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others.++[@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'++[@URLs to internal states@] if the web navigation is trough GET forms or links,+ 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+to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)+++[@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.+++[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.+The callback may initate a flow of interactions with the user or simply executes an internal computation.+Callbacks are necessary for the creation of abstract container+widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes.+++[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a+login form and substitute it by the username if already logged.++Example:++@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@+++[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator+++[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the ByteString level, and to permit many formatring styles+in the same page, there are operators that combine different formats which are converted to ByteStrings.+For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.++[@File Server@] With file caching. See "MFlow.FileServer"++ +-} + +module MFlow.Forms(+ +-- * Basic definitions +-- FormLet(..), +FlowM, View(..), FormElm(..), FormInput(..)+ +-- * Users +,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName +,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget,getLang, +-- * User interaction +ask, clearEnv, wstateless, transfer, +-- * formLets +-- | They usually produce the HTML form elements (depending on the FormInput instance used)+-- It is possible to modify their attributes with the `<!` operator.+-- They are combined with applicative ombinators and some additional ones+-- formatting can be added with the formatting combinators.+-- 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+-- * FormLet modifiers+,validate, noWidget, waction, wmodify,++-- * Caching widgets+cachedWidget, wcached, wfreeze, +-- * Widget combinators +(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)++-- * Normalized (convert to ByteString) widget combinators+-- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings+--+-- The purpose is to combine heterogeneous formats into byteString-formatted widgets that+-- can be cached with `cachedWidget`+,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),++-- * Formatting combinators+(<<<),(<++),(++>),(<!),++-- * Normalized (convert to ByteString) formatting combinators+-- | Some combinators that convert the formatting of their arguments to lazy byteString+(.<<.),(.<++.),(.++>.)++-- * ByteString tags+,btag,bhtml,bbody++-- * Normalization+, flatten, normalize+ +-- * Running the flow monad +,runFlow,runFlowIn,MFlow.Forms.Internals.step, goingBack,breturn+ +-- * Setting parameters +,setHeader+,setSessionData+,getSessionData+,getHeader +,setTimeouts+ +-- * Cookies +,setCookie+-- * Ajax+,ajax+,ajaxSend+,ajaxSend_+-- * Requirements+,Requirements(..)+,WebRequirement(..)+,requires+-- * Utility+,genNewId+,changeMonad +) +where ++import Data.RefSerialize hiding ((<|>))+import Data.TCache+import Data.TCache.Memoization +import MFlow+import MFlow.Forms.Internals +import MFlow.Cookies+import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) +import Data.List+import qualified Data.CaseInsensitive as CI +import Data.Typeable +import Data.Monoid +import Control.Monad.State.Strict +import Data.Maybe +import Control.Applicative +import Control.Exception+import Control.Concurrent +import Control.Workflow as WF +import Control.Monad.Identity+import Unsafe.Coerce+import Data.List(intersperse) +import Data.IORef +import qualified Data.Map as M+import System.IO.Unsafe+import Data.Char(isNumber)+import Network.HTTP.Types.Header ++ +import Debug.Trace+(!>)= flip trace +++ +-- | Validates a form or widget result against a validating procedure +-- +-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@ +validate+ :: (FormInput view, Monad m) =>+ View view m a+ -> (a -> WState view m (Maybe String))+ -> View view m a +validate formt val= View $ do + FormElm form mx <- (runView formt) + case mx of + Just x -> do + me <- val x+ modify (\s -> s{inSync= True}) + case me of + Just str -> + --FormElm form mx' <- generateForm [] (Just x) noValidate + return $ FormElm ( inred (fromStr str) : form) Nothing + Nothing -> return $ FormElm [] mx + _ -> return $ FormElm form 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.+--+-- 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`+waction+ :: (FormInput view, Monad m)+ => View view m a+ -> (a -> FlowM view m b)+ -> View view m b+waction f ac = do+ x <- f+ s <- get+ let env = mfEnv s+ let seq = mfSequence s+ put s{mfSequence=mfSequence s+ 100,mfEnv=[]}+ r <- flowToView $ ac x !> "ACTION"+ modify $ \s-> s{mfSequence= seq, mfEnv= env}+ return r+ where+ flowToView x=+ View $ do+ r <- runBackT $ runFlowM x+ case r of+ NoBack x ->+ return (FormElm [] $ Just x)+ BackPoint x->+ return (FormElm [] $ Just x)+ GoBack-> do+ modify $ \s ->s{notSyncInAction= True}+ return (FormElm [] Nothing)++wmodify :: (Monad m, FormInput v)+ => View v m a+ -> ([v] -> Maybe a -> WState v m ([v], Maybe b))+ -> View v m b+wmodify formt act = View $ do+ FormElm f mx <- runView formt + (f',mx') <- act f mx+ return $ FormElm f' mx'+ + +-- +--instance (FormInput view, FormLet a m view , FormLet b m view ) +-- => FormLet (a,b) m view where +-- digest mxy = do +-- let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y) +-- (,) <$> digest x <*> digest y +-- +--instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view ) +-- => FormLet (a,b,c) m view where +-- digest mxy = do +-- 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 +getString :: (FormInput view,Monad m) => + Maybe String -> View view m String +getString = getTextBox ++-- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation) +getInteger :: (FormInput view, MonadIO m) => + Maybe Integer -> View view m Integer +getInteger = getTextBox ++-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation) +getInt :: (FormInput view, MonadIO m) => + Maybe Int -> View view m Int +getInt = getTextBox ++-- | Display a password box +getPassword :: (FormInput view, + Monad m) => + View view m String +getPassword = getParam Nothing "password" Nothing ++data Radio= Radio String+-- | Implement a radio button that perform a submit when pressed.+-- the parameter is the name of the radio group+setRadioActive :: (FormInput view, MonadIO m) => + String -> String -> View view m Radio+setRadioActive v n = View $ do+ st <- get+ put st{needForm= True}+ let env = mfEnv st+ FormElm form mn <- getParam1 n env []+ return $ FormElm [finput n "radio" v + ( isJust mn && v== fromJust mn) (Just "this.form.submit()")]+ (fmap Radio mn)++ +-- | Implement a radio button+-- the parameter is the name of the radio group+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)++getRadio+ :: (Monad m, Functor m, FormInput view) =>+ [String -> View view m Radio] -> View view m String+getRadio rs= do+ id <- genNewId+ Radio r <- firstOf $ map (\r -> r id) rs+ return r++data CheckBoxes = CheckBoxes [String]++instance Monoid CheckBoxes where+ mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys+ mempty= CheckBoxes []++--instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where+-- 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) => + Bool -> String -> View view m CheckBoxes+setCheckBox checked v= View $ do+ n <- genNewId+ st <- get+ put st{needForm= True}+ 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+ False -> Nothing+ return $ FormElm+ ( [ finput n "checkbox" v + ( checked || (isJust mn && v== fromJust mn)) Nothing])+ ret++-- | Read the checkboxes dinamically created by JavaScript within the view parameter+-- see for example `selectAutocomplete` in "MFlow.Forms.Widgets"+genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes+genCheckBoxes v= View $ do+ n <- genNewId+ st <- get+ put st{needForm= True}+ 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+ False -> Nothing+ return $ FormElm [ftag "span" v `attrs`[("id",n)]] ret++whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a+whidden x= View $ do+ n <- genNewId+ env <- gets mfEnv+ let showx= case cast x of+ Just x' -> x'+ Nothing -> show x+ getParam1 n env [finput n "hidden" showx False Nothing]++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]+ st <- get+ let env = mfEnv st+ put 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+ ++++ +getTextBox + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe a -> View view m a +getTextBox ms = getParam Nothing "text" ms ++ +getParam + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe String -> String -> Maybe a -> View view m a +getParam look type1 mvalue = View $ do + tolook <- case look of + Nothing -> genNewId + Just n -> return n + let nvalue= case mvalue 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 + +-- | 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+getCurrentName= do+ st <- get+ let parm = mfSequence st+ return $ "p"++show parm+++-- | Display a multiline text box and return its content+getMultilineText :: (FormInput view, + Monad m) => + String -> View view m String +getMultilineText nvalue = View $ do + tolook <- genNewId+ env <- gets mfEnv+ let form= [ftextarea tolook nvalue] + getParam1 tolook env form + +--instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where +-- digest mv = getBool b "True" "False" +-- where +-- b= case mv of +-- Nothing -> Nothing +-- Just bool -> Just $ case bool of+-- True -> "True"+-- False -> "False"++-- | 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) => + 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 ++-- | Display a dropdown box with the options in the first parameter is optionally selected+-- . It returns the selected option. +getSelect :: (FormInput view, + Monad m,Typeable a, Read a) => + View view m (MFOption a) -> View view m a +getSelect opts = View $ do + tolook <- genNewId+ st <- get+ let env = mfEnv st+ put st{needForm= True}+ FormElm form mr <- (runView opts) + getParam1 tolook env [fselect tolook $ mconcat form] ++data MFOption a= MFOption++instance (Monad m, Functor m) => Monoid (View view m (MFOption a)) where+ mappend = (<|>)+ mempty = Control.Applicative.empty++-- | Set the option for getSelect. Options are concatenated with `<|>`+setOption n v = setOption1 n v False++-- | Set the selected option for getSelect. Options are concatenated with `<|>`+setSelectedOption n v= setOption1 n v True+ +setOption1 :: (FormInput view, + Monad m, Typeable a, Show a) => + a -> view -> Bool -> View view m (MFOption a) +setOption1 nam val check= View $ do+ st <- get+ let env = mfEnv st+ put st{needForm= True}+ let n= if typeOf nam== typeOf(undefined :: String) then unsafeCoerce nam else show nam + return . FormElm [foption n val check] $ Just MFOption ++ +-- | Enclose Widgets in some formating. +-- @view@ is intended to be instantiated to a particular format+--+-- This is a widget, which is table with some links. it returns an Int+--+-- > import MFlow.Forms.XHtml+-- >+-- > tableLinks :: View Html Int+-- > tableLinks= table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"]+-- > <<< caption << "choose an item"+-- > ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"]+-- > ++> (tbody+-- > <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << "One")+-- > <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << "Two")+-- > <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << "Three"))+-- > ) +(<<<) :: (Monad m, Monoid view) + => (view ->view) + -> View view m a + -> View view m a +(<<<) v form= View $ do + FormElm f mx <- runView form + return $ FormElm [v $ mconcat f] mx + + +infixr 5 <<< + +++-- | 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 +-- +-- @ getString "hi" <++ H1 << "hi there"@ +(<++) :: (Monad m) + => View v m a + -> v + -> View v m a +(<++) form v= View $ do + FormElm f mx <- runView form + return $ FormElm ( f ++ [ v]) mx + +infixr 6 <++ , .<++. , ++> , .++>. +-- | Prepend formatting code to a widget +-- +-- @bold << "enter name" ++> getString Nothing @ + +(++>) :: (Monad m, Monoid view) + => view -> View view m a -> View view m a +html ++> digest = (html `mappend`) <<< digest + + + ++-- | Add attributes to the form element+-- if the view has more than one element, it is applied to the first+infix 8 <!+widget <! atrs= View $ do+ FormElm fs mx <- runView widget+ return $ FormElm [attrs (head fs) atrs] mx+++------------------------------- + +-- +-- +--instance (MonadIO m, Functor m, FormInput view) +-- => FormLet User m view where +-- digest muser= +-- (User <$> getString ( userName <$> muser) +-- <*> getPassword) +-- `validate` userValidate + ++++ + +-- | Is an example of login\/register validation form needed by 'userWidget'. In this case+-- the form field appears in a single line. it shows, in sequence, entries for the username,+-- password, a button for loging, a entry to repeat password necesary for registering+-- and a button for registering.+-- The user can build its own user login\/validation forms by modifying this example+--+-- @ userFormLine=+-- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")+-- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"+-- @+userFormLine :: (FormInput view, Functor m, Monad m)+ => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr) +userFormLine=+ ((,) <$> getString (Just "enter user") <! [("size","5")]+ <*> getPassword <! [("size","5")]+ <** submitButton "login")+ <+> (fromStr " password again" ++> getPassword <! [("size","5")]+ <* submitButton "register")++-- | Example of user\/password form (no validation) to be used with 'userWidget'+userLogin :: (FormInput view, Functor m, Monad m)+ => View view m (Maybe (UserStr,PasswdStr), Maybe String)+userLogin=+ ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]+ <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]+ <** submitButton "login")+ <+> (noWidget+ <* noWidget)++++-- | Empty widget that return Nothing. May be used as \"empty boxes\" inside larger widgets+noWidget :: (FormInput view, + Monad m) => + View view m a+noWidget= View . return $ FormElm [] Nothing++-- | Render a value and return it+wrender+ :: (Monad m, Functor m, Show a, FormInput view) =>+ a -> View view m a+wrender x = (wraw . fromStr $ show x) **> return x++-- | Render raw view formatting. It is useful for displaying information+wraw :: Monad m => view -> View view m ()+wraw x= View . return . FormElm [x] $ Just ()+++-- | Wether the user is logged or is anonymous+isLogged :: MonadState (MFlowState v) m => m Bool+isLogged= do+ rus <- return . tuser =<< gets mfToken + return . not $ rus == anonymous++-- | It creates a widget for user login\/registering. If a user name is specified+-- in the first parameter, it is forced to login\/password as this specific user.+-- If this user was already logged, the widget return the user without asking.+-- If the user press the register button, the new user-password is registered and the+-- user logged.+userWidget :: ( MonadIO m, Functor m + , FormInput view) + => Maybe String+ -> View view m (Maybe (UserStr,PasswdStr), Maybe String)+ -> View view m String +userWidget muser formuser= do+ user <- getCurrentUser+ if muser== Just user+ then return user+ else formuser `validate` val muser `waction` login + where+ val _ (Nothing,_) = return $ Just "Plese fill in the user/passwd to login, or user/passwd/passwd to register"++ val mu (Just us, Nothing)=+ if isNothing mu || isJust mu && fromJust mu == fst us+ then userValidate us+ else return $ Just "wrong user for the operation"++ val mu (Just us, Just p)=+ if isNothing mu || isJust mu && fromJust mu == fst us+ then if length p > 0 && snd us== p+ then return Nothing+ else return $ Just "The passwords do not match"+ else return $ Just "wrong user for the operation"++-- val _ _ = return $ Just "Please fill in the fields for login or register"++ login (Just (u,p), Nothing)= do+ let uname= u+ st <- get + let t = mfToken st+ t'= t{tuser= uname}+ moveState (twfname t) t t'+ put st{mfToken= t'}+ liftIO $ deleteTokenInList t+ liftIO $ addTokenToList t'+ setCookie cookieuser uname "/" (Just $ 365*24*60*60) + return uname++ login (Just us@(u,p), Just _)= do+ userRegister u p+ login (Just us , Nothing)++-- | logout. The user is resetted 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'++ setCookie cookieuser anonymous "/" (Just $ -1000)+ +-- | If not logged, perform login. otherwise return the user+--+-- @getUserSimple= getUser Nothing userFormLine@+getUserSimple :: ( FormInput view, Typeable view + , MonadIO m, Functor m)+ => FlowM view m String+getUserSimple= getUser Nothing userFormLine+ +-- | Very basic user authentication. The user is stored in a cookie. +-- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed +-- user-password combination.+-- The user-password combination is only asked if the user has not logged already+-- otherwise, the stored username is returned.+--+-- @getUser mu form= ask $ userWidget mu form@ +getUser :: ( FormInput view, Typeable view + , MonadIO m, Functor m) + => Maybe String+ -> View view m (Maybe (UserStr,PasswdStr), Maybe String)+ -> FlowM view m String +getUser mu form= ask $ userWidget mu form + + +--instance (MonadIO m, Functor m, m1 ~ m, b ~ a) +-- => Widget(View view m1 b) a m view where +-- widget = id + +-- | Join two widgets in the same page +-- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results +-- +-- > r <- ask widget1 <+> widget2 +-- > case r of (Just x, Nothing) -> ..+(<+>) , mix :: Monad m + => View view m a + -> View view m b + -> View view m (Maybe a, Maybe b) +mix digest1 digest2= View $ do + FormElm f1 mx' <- runView digest1 + FormElm f2 my' <- runView digest2 + return $ FormElm (f1++f2) + $ case (mx',my') of + (Nothing, Nothing) -> Nothing+ other -> Just other ++infixr 2 <+>, .<+>. + +(<+>) = mix+++infixr 1 **> , .**>. , <** , .<**.+-- | The first elem result (even if it is not validated) is discarded, and the secod is returned+-- . This contrast with the applicative operator '*>' which fails the whole validation if+-- the validation of the first elem fails.+--+-- The first element is displayed however, as happens in the case of '*>' .+--+-- Here @w\'s@ are widgets and @r\'s@ are returned values+--+-- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated+--+-- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated+--+++(**>) :: (Functor m, Monad m)+ => View view m a -> View view m b -> View view m b+(**>) form1 form2 = valid form1 *> form2+++-- | The second elem result (even if it is not validated) is discarded, and the first is returned+-- . This contrast with the applicative operator '*>' which fails the whole validation if+-- the validation of the second elem fails.+-- The second element is displayed however, as in the case of '<*'.+-- see the `<**` examples+(<**)+ :: (Functor m, Monad m) =>+ View view m a -> View view m b -> View view m a+(<**) form1 form2 = form1 <* valid form2+++valid form= View $ do+ FormElm form mx <- runView form+ return $ FormElm form $ Just undefined++ +-- | It is the way to interact with the user. +-- It takes a widget and return the user result.+-- If the environment has the result, ask don't ask to the user.+-- To force asking in any case, put an `clearEnv` statement before +ask+ :: (+ FormInput view,+ MonadIO m,+ Typeable view) =>+ View view m b -> FlowM view m b +ask w = do+ st1 <- get+ let env= mfEnv st1+ case (mfAjax st1,lookup "ajax" env, lookup "val" env) of+ ( Just ajaxl,Just v1, Just v2) -> do+ let f = fromMaybe (error $ "not found Ajax handler for: "++ v1) $ M.lookup v1 ajaxl+ FlowM . lift $ (unsafeCoerce f) v2+ FlowM $ lift receiveWithTimeouts+ ask w++ _ -> do+ let st= st1{needForm= False, inSync= False, mfRequirements= []} + 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+ + Just x -> do+ put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]}+ breturn x -- BackT . return $ BackPoint x -- !> "just x"+ + Nothing ->+ if not (inSync st') && not (onInit st') && hasParams (mfSequence st') (mfSeqCache st') ( mfEnv st') -- !> (show $ inSync st') !> (show $ onInit st')+ then do+ put st'{mfSequence= head1 $ prevSeq st'+ ,prevSeq= tail1 $ prevSeq st' }+ 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++ 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+ ask w+ where+ head1 []=0+ head1 xs= head xs+ tail1 []=[]+ tail1 xs= tail xs++ 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@+--+-- 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)++-- | Clears the environment+clearEnv :: MonadState (MFlowState view) m => m () +clearEnv= do+ st <- get+ put st{ mfEnv= []} + +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} ++-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget +wstateless+ :: (Typeable view, FormInput view) =>+ View view IO a -> Flow+wstateless w = transient $ runFlow loop+ where+ loop= do+ ask w+ env <- get+ put $ env{ mfSequence= 0,prevSeq=[]} + loop++---- | it creates a stateless flow (see `stateless`) whose behaviour is defined as a widget +----+---- This version writes a log with all the values returned by ask+--wstatelessLog+-- :: (Typeable view, ToHttpData view, FormInput view,Serialize a,Typeable a) =>+-- View view IO a -> (Token -> Workflow IO ())+--wstatelessLog w = runFlow loop+-- where+-- loop= do+-- MFlow.Forms.step $ do+-- r <- ask w+-- env <- get+-- put $ env{ mfSequence= 0,prevSeq=[]}+-- return r +-- loop+ +-- | transfer control to another flow.+transfer :: MonadIO m => String -> FlowM v m ()+transfer flowname =do+ t <- gets mfToken+ let t'= t{twfname= flowname}+ liftIO $ do+ (r,_) <- msgScheduler t'+ 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. +wform :: (Monad m, FormInput view) + => 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 ++resetButton :: (FormInput view, Monad m) => String -> View view m () +resetButton label= View $ return $ FormElm [finput "reset" "reset" label False Nothing] $ Just () ++submitButton :: (FormInput view, Monad m) => String -> View view m String+submitButton label= getParam Nothing "submit" $ Just label ++newtype AjaxSessionId= AjaxSessionId String deriving Typeable++-- | Install the server code and return the client code for an AJAX interaction.+--+-- This example increases the value of a text box each time the box is clicked+--+-- > ask $ do+-- > let elemval= "document.getElementById('text1').value"+-- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"+-- > b << text "click the box"+-- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]+ajax :: (MonadIO m)+ => (String -> View v m ByteString) -- ^ user defined procedure, executed in the server.Receives the value of the javascript expression and must return another javascript expression that will be executed in the web browser+ -> View v m (String -> String) -- ^ returns a function that accept a javascript expression and return a javascript event handler expression that invoques the ajax server procedure+ajax f = do+ requires[JScript ajaxScript]+ t <- gets mfToken+ id <- genNewId+ installServerControl id $ \x-> do+ setSessionData $ AjaxSessionId id+ r <- f x+ liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )+ return ()++installServerControl :: MonadIO m => String -> (String -> View v m ()) -> View v m (String -> String)+installServerControl id f= do+ t <- gets mfToken+ st <- get+ let ajxl = fromMaybe M.empty $ mfAjax st+ let ajxl'= M.insert id (unsafeCoerce f ) ajxl+ put st{mfAjax=Just ajxl'}+ return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")" ++-- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back+--+-- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced+ajaxSend+ :: (Read a,MonadIO m) => View v m ByteString -> View v m a+ajaxSend cmd= View $ do+ AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"+ env <- getEnv+ t <- getToken+ case (lookup "ajax" $ env, lookup "val" env) of+ (Nothing,_) -> return $ FormElm [] Nothing+ (Just id, Just _) -> do+ FormElm __ (Just str) <- runView cmd+ liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"+ receiveWithTimeouts+ env <- getEnv+ case (lookup "ajax" $ env,lookup "val" env) of+ (Nothing,_) -> return $ FormElm [] Nothing+ (Just id, Just v2) -> do+ return $ FormElm [] . Just $ read v2+ where+ readEvalLoop t id v = "doServer('"<> pack (twfname t)<>"','"<> pack id<>"',"<>v<>");" :: ByteString++-- | Like @ajaxSend@ but the result is ignored+ajaxSend_+ :: MonadIO m => View v m ByteString -> View v m ()+ajaxSend_ = ajaxSend+++ +-- | 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) + => 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] ++-- | When some HTML produces a parameter in response, but it is not produced by+-- a form or a link, but for example by an script, returning notify the type checker+-- and the parameter extractor about this fact.+--+-- . 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) + => ((a->String) ->view) -> View view m a+returning expr=View $ do+ verb <- getWFName + name <- genNewId+ env <- gets mfEnv+ let string x= + let showx= case cast x of+ Just x' -> x'+ _ -> show x + in (verb ++ "?" ++ name ++ "=" ++ showx)+ toSend= expr string + getParam1 name env [toSend]+ +++ + +--instance (Widget a b m view, Monoid view) => Widget [a] b m view where +-- widget xs = View $ do +-- forms <- mapM(\x -> (runView $ widget x )) xs +-- let vs = concatMap (\(FormElm v _) -> v) forms +-- res = filter isJust $ map (\(FormElm _ r) -> r) forms +-- res1= if null res then Nothing else head res +-- return $ FormElm [mconcat vs] res1++-- | Concat a list of widgets of the same type, return a the first validated result +firstOf :: (Monoid view, Monad m, Functor m)=> [View view m a] -> View view m a +firstOf xs= View $ do + forms <- mapM runView xs + let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms + res = filter isJust $ map (\(FormElm _ r) -> r) forms + res1= if null res then Nothing else head res + return $ FormElm vs res1 ++manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a] +manyOf xs= whidden () *> (View $ do + forms <- mapM runView xs + let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms+ + 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]+(>:>) w ws= View $ do+ FormElm fs mxs <- runView $ ws+ FormElm f1 mx <- runView w+ return $ FormElm (f1++ fs)+ $ case( mx,mxs) of+ (Just x, Just xs) -> Just $ x:xs+ (Nothing, mxs) -> mxs+ (Just x, _) -> Just [x]++-- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types+(|*>) :: (MonadIO m, Functor m,Monoid view)+ => View view m r+ -> [View view m r']+ -> View view m (Maybe r,Maybe r')+(|*>) x xs= View $ do+ FormElm fxs rxs <- runView $ firstOf xs+ FormElm fx rx <- runView $ x++ return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx)+ $ case (rx,rxs) of+ (Nothing, Nothing) -> Nothing+ other -> Just other++++infixr 5 |*>, .|*>.++-- | Put a widget above and below other. Useful for navigation links in a page.+(|+|) :: (Functor m, Monoid view, MonadIO m)+ => View view m r+ -> View view m r'+ -> View view m (Maybe r, Maybe r')+(|+|) w w'= w |*> [w']++infixr 1 |+|, .|+|.+++-- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator+-- into a single tuple with the same elements in the same order.+-- This is useful for easing matching. For example:+--+-- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@+--+-- @res@ has type:+--+-- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@+--+-- but @flatten res@ has type:+--+-- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@++flatten :: Flatten (Maybe tree) list => tree -> list+flatten res= doflat $ Just res++class Flatten tree list where+ doflat :: tree -> list+++type Tuple2 a b= Maybe (Maybe a, Maybe b)+type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)+type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)+type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)+type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)++instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where+ doflat (Just(ma,mb))= (ma,mb)+ doflat Nothing= (Nothing,Nothing)++instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where+ doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)+ doflat Nothing= (Nothing,Nothing,Nothing)++instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where+ doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)+ doflat Nothing= (Nothing,Nothing,Nothing,Nothing)++instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where+ doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)+ doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)++instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where+ doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)+ doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)++infixr 7 .<<.+-- | > (.<<.) w x = w $ toByteString x+(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString+(.<<.) w x = w ( toByteString x)++-- | > (.<+>.) x y = normalize x <+> normalize y+(.<+>.)+ :: (Monad m, FormInput v, FormInput v1) =>+ View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)+(.<+>.) x y = normalize x <+> normalize y++-- | > (.|*>.) x y = normalize x |*> map normalize y+(.|*>.)+ :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>+ View v m r+ -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')+(.|*>.) x y = normalize x |*> map normalize y++-- | > (.|+|.) x y = normalize x |+| normalize y+(.|+|.)+ :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>+ View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')+(.|+|.) x y = normalize x |+| normalize y++-- | > (.**>.) x y = normalize x **> normalize y+(.**>.)+ :: (Monad m, Functor m, FormInput v, FormInput v1) =>+ View v m a -> View v1 m b -> View ByteString m b+(.**>.) x y = normalize x **> normalize y++-- | > (.<**.) x y = normalize x <** normalize y+(.<**.)+ :: (Monad m, Functor m, FormInput v, FormInput v1) =>+ View v m a -> View v1 m b -> View ByteString m a+(.<**.) x y = normalize x <** normalize y++-- | > (.<|>.) x y= normalize x <|> normalize y+(.<|>.)+ :: (Monad m, Functor m, FormInput v, FormInput v1) =>+ View v m a -> View v1 m a -> View ByteString m a+(.<|>.) x y= normalize x <|> normalize y++-- | > (.<++.) x v= normalize x <++ toByteString v+(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a+(.<++.) x v= normalize x <++ toByteString v++-- | > (.++>.) v x= toByteString v ++> normalize x+(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a+(.++>.) v x= toByteString v ++> normalize x+++instance FormInput ByteString where+ toByteString= id+ toHttpData = HttpData [contentHtml ] []+ ftag x= btag x []+ inred = btag "b" [("style", "color:red")]+ finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []+ ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""+ ftextarea name text= btag "textarea" [("name", name)] $ pack text++ fselect name options= btag "select" [("name", name)] options++ foption value content msel= btag "option" ([("value", value)] ++ selected msel) content+ where+ selected msel = if msel then [("selected","true")] else []++ attrs = addAttrs+++ formAction action form = btag "form" [("action", action),("method", "post")] form+ fromStr = pack+ fromStrNoEncode= pack flink v str = btag "a" [("href", v)] str
src/MFlow/Forms/Admin.hs view
@@ -2,7 +2,7 @@ -XScopedTypeVariables #-}-module MFlow.Forms.Admin(adminLoop,addAdminWF) where+module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where import MFlow.Forms import MFlow.Forms.XHtml import MFlow@@ -24,6 +24,8 @@ import Data.Map as M (keys) import System.Exit import Control.Exception as E+import Control.Concurrent+import Control.Concurrent.MVar @@ -50,27 +52,42 @@ 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+ "sync" -> ssyncCache "flush" -> atomically flushAll >> putStrLn "flushed cache"- "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess+ "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess "abort" -> exitWith ExitSuccess- _ -> return()+ _ -> return() adminLoop1 - `E.catch` (\(e:: E.SomeException) ->do- ssyncCache- error $ "\nException: "++ show e)+-- | execute the process and wait for its finalization.+-- then it synchronizes the cache+wait f= do+ mv <- newEmptyMVar+ forkIO (f1 >> putMVar mv True)+ 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"\+-- The administration page is reached with the path \"adminserv\" addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)] @@ -106,7 +123,7 @@ 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 <++ fromString x) (Prelude.tail e) | e <- ls]+ 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() @@ -138,8 +155,7 @@ optionsUser us = do wfs <- liftIO $ return . M.keys =<< getMessageFlows-- stats <- liftIO $ mapM (\wf -> getWFHistory wf Token{twfname= wf,tuser=us}) wfs+ stats <- liftIO $ mapM (\wf -> getWFHistory wf Token{twfname= wf,tuser=us}) wfs let wfss= filter (isJust . snd) $ zip wfs stats if null wfss then ask $ bold << " not logs for this user" ++> wlink () (bold << "Press here")
− src/MFlow/Forms/Ajax.hs
@@ -1,108 +0,0 @@-{-# OPTIONS -XFlexibleContexts #-}---- | A very simple (but effective) support for AJAX.--- The value of a javaScript variable is sent to the server.--- The server must return a valid sequence of javaScript statements--- that are evaluated in the client.------ This example increase the value, from 0 on, in a text box trough AJAX:------ @--- import Text.XHtml--- import MFlow.Forms--- import MFlow.Forms.Ajax--- ajaxsample= do--- ajaxheader html= thehtml << `ajaxHead` << html--- setHeader ajaxheader--- ajaxc \<- `ajaxCommand` \"document.getElementById(\'text1\').value\"--- (\n -> return $ \"document.getElementById(\'text1\').value='\"++show(read n +1)++\"'\")--- ask $ (getInt (Just 0) \<! [(\"id\",\"text1\"),(\"onclick\",ajaxc)])--- breturn()@--module MFlow.Forms.Ajax (ajaxCommand,ajaxHead) where-import MFlow-import MFlow.Forms-import Text.XHtml-import Control.Monad.Trans---import Data.ByteString.Lazy.Char8-import Data.RefSerialize (newContext,addrHash)-import Data.IORef-import System.IO.Unsafe-import Data.Maybe-import Control.Monad.State-import Data.Map (keys)-import qualified Data.CaseInsensitive as CI----import Debug.Trace---(!>)= flip trace--context= unsafePerformIO newContext---- | Install the server code and return the client code for an AJAX interaction.-ajaxCommand :: MonadIO m- => String -- ^ The javScript variable whose value will be sent to the server- -> (String -> IO String) -- ^ The server procedure to be executed with the- -- variable value as parameter. It must return a string with valid- -- javaScript code to be executed in the client- -> m (String) -- ^ return the javascript of the event handler, to be inserted in- -- the HTML to be sent to the client-ajaxCommand jsparam serverProc = do- r <- liftIO $ addrHash context serverProc- servname <- case r of- Left h -> do- let servname= "ajax"++ show h- liftIO $ addMessageFlows [( servname, serverp)]- return servname- Right h -> return $ "ajax"++ show h--- liftIO $ getMessageFlows >>= return . keys >>= print- return $ "doServer("++"'" ++ servname++"',"++jsparam++")"- where- serverp = stateless $ \env -> do- let c = lookup "ajax" env `justify` (error "not found ajax command") -- :: String- serverProc c- justify = flip fromMaybe------- | @ajaxHead@ must be used instead of `header` when using ajax(see example).------ Although it produces code form "Text.XHtml" rendering (package xhtml),--- it can be converted to byteString, so that any rendering can be used trough normalization--- . see `setHeader`-ajaxHead :: Html -> Html-ajaxHead html=- (header << (script ![thetype "text/javascript"] << (- "function loadXMLObj()\n" ++- "{\n" ++- "var xmlhttp;\n" ++- "if (window.XMLHttpRequest)\n" ++- " {\n// code for IE7+, Firefox, Chrome, Opera, Safari\n" ++- " xmlhttp=new XMLHttpRequest();\n" ++- " }\n" ++- "else\n" ++- " {\n// code for IE6, IE5\n\n" ++- " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');\n" ++- " }\n" ++- "return xmlhttp\n" ++- "}\n" ++-- " xmlhttp= loadXMLObj()\n" ++- " noparam= ''\n"++- "\n"++- "function doServer (servproc,param){\n" ++- " xmlhttp.open('GET',servproc+'?ajax='+param,true);\n" ++- " xmlhttp.send();}\n" ++- "\n"++- "xmlhttp.onreadystatechange=function()\n" ++- " {\n" ++- " if (xmlhttp.readyState + xmlhttp.status==204)\n" ++- " { \n" ++- " eval(xmlhttp.responseText);\n" ++- " }\n" ++- " }\n" ++- "\n" )))- +++ body << html---
+ src/MFlow/Forms/Blaze/Html.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS -XOverloadedStrings -XFlexibleInstances -XTypeSynonymInstances+ #-}+{- |+Instantiation of the 'FormInput' class for blaze-html <http://hackage.haskell.org/package/blaze-html>++This package is included in "MFlow.Wai.Blaze.Hml.All".++Use it to create applicaitons with this kind of formatting.+-}+module MFlow.Forms.Blaze.Html where+import MFlow+import MFlow.Forms+import MFlow.Cookies(contentHtml)+import Data.ByteString.Lazy.Char8++import Text.Blaze.Html+import qualified Text.Blaze.Internal as I+import Text.Blaze.Html5 as St+import Text.Blaze.Html5.Attributes as At+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Control.Monad.Trans+import Data.Typeable+import Data.String+import Data.Monoid+import Unsafe.Coerce++(<<) tag v= tag $ toMarkup v++infixr 7 <<++instance FormInput Html where+ toByteString = renderHtml+ toHttpData = HttpData [contentHtml ] [] . toByteString+ ftag x= I.Parent (fromString x) (fromString $ "<"++x) (fromString $ "</"++ x ++">")+ -- (mempty :: I.MarkupM () )++ inred = b ! At.style (fromString "color:red")++ finput n t v f c=+ let+ tag= input ! type_ (fromString t) ! name (fromString n) !value (fromString v)+ tag1= if f then tag ! checked (fromString "") else tag+ in case c of Just s -> tag1 ! onclick (fromString s) ; _ -> tag1++ ftextarea nam text= textarea ! name (fromString nam) << text++ fselect nam list = select ! name (fromString nam) << list+ foption name v msel=+ let tag= option ! value (fromString name) << v+ in if msel then tag ! selected (fromString "") else tag+++ formAction action form = St.form ! At.action (fromString action) ! method (fromString "post") $ form++ fromStr= toMarkup+ fromStrNoEncode = preEscapedToMarkup+ flink v str = a ! href (fromString v) << str++ attrs tag [] = tag+ attrs tag ((n,v):attribs) =+ let tag'= tag ! (customAttribute $ stringTag n) (fromString v)+ in attrs tag' attribs+++++++
src/MFlow/Forms/HSP.hs view
@@ -1,21 +1,24 @@ {-# OPTIONS -F -pgmFtrhsx -XUndecidableInstances -XOverlappingInstances -XTypeSynonymInstances -XFlexibleInstances #-} -{- | Instantiation of "MFlow.Forms" for the hsp package-it includes additional features for embedding widgets within HTML formatting+{- |+Instantiation of the 'FormInput' class for the HSP package <http://hackage.haskell.org/package/hsp>+ for embedding widgets within HTML-XML formatting -} module MFlow.Forms.HSP where -+import MFlow+import MFlow.Cookies(contentHtml) import MFlow.Forms import Control.Monad.Trans import Data.Typeable import HSP import Data.Monoid import Control.Monad(when)-import Data.ByteString.Lazy.Char8(unpack)+import Data.ByteString.Lazy.Char8(unpack,pack)+import System.IO.Unsafe @@ -24,11 +27,18 @@ mappend x y= <span> <% x %> <% y %> </span> mconcat xs= <span> <% [<% x %> | x <- xs] %> </span> -instance FormInput (HSP XML) where-- fromString s = <span><% s %></span>+instance Typeable (HSP XML) where+ typeOf= \_ -> mkTyConApp(mkTyCon "HSP XML") [] +instance FormInput (HSP XML) where+ toByteString x= unsafePerformIO $ do+ (_,r) <- evalHSP Nothing x+ return . pack $ renderXML r+ toHttpData = HttpData [contentHtml ] [] . toByteString+ ftag t = \e -> genElement (toName t) [] [asChild e] + fromStr s = <span><% s %></span>+ fromStrNoEncode s= <pcdata> pcdataToChild s </pcdata> finput typ name value checked onclick= <input type= (typ) name=(name)@@ -54,4 +64,4 @@ formAction action form = <form action=(action) method="post" > <% form %> </form> - addAttributes tag attrs= tag <<@ map (\(n,v)-> n:=v) attrs+ attrs tag attrs= tag <<@ map (\(n,v)-> n:=v) attrs
+ src/MFlow/Forms/Internals.hs view
@@ -0,0 +1,942 @@+-----------------------------------------------------------------------------+--+-- 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+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 :: MonadIO m => (UserStr,PasswdStr) -> m (Maybe String) +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 "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 Action m a= Backward Dynamic | Forward (Maybe (Handle m a)) a | Abort String++data Handle m a= forall b.Typeable b => Handle(b -> m(Action m a))++data Sup m a= Sup {runSup :: m (Action m a)}++instance Monad m => Monad(Sup m) where+ fail msg = Sup . return $ Backward $ toDyn msg+ return x = Sup . return $ Forward Nothing x+ x >>= f = Sup $ loop Nothing+ where+ loop mmsg= do+ v <- runSup x -- !> "loop"+ case v of+ Forward Nothing y -> runSup (f y)+ Forward (Just (Handle h)) y ->+ case mmsg of+ Just dmsg ->+ case fromDynamic dmsg of+ Just msg -> do+ r <- h msg+ case r of+ Forward _ y -> continueWith y+ Backward msg -> loop $ Just msg+ Abort text-> return $ Abort text+ Nothing -> loop mmsg+ Nothing -> continueWith y+++ Backward msg -> return $ Backward msg++ continueWith y=do+ z <- runSup (f y)+ case z of+ Backward msg -> loop $ Just msg -- !> "GoBack"+ other -> return other++instance MonadTrans Sup where+ lift mx= Sup $ mx >>= return . Forward Nothing++returnSup :: Monad m => Handle m a -> a -> Sup m a+returnSup hand x= Sup . return $ Forward (Just hand) x++liftSup :: Monad m => Handle m a -> m a -> Sup m a+liftSup h mx= Sup $ do+ x <- mx+ return $ Forward (Just h) x++++instance MonadState s m => MonadState s (Sup m) where+ get= lift get -- !> "get"+ put= lift . put++--handleString = Handle $ \(s ::String) -> do+-- putStrLn $"repeat "++s+-- return $ Forward Nothing ()+-- +--test= runSup $ do+-- liftSup handleString $ print "hola"+-- n2 <- lift $ getLine+-- lift $ print "n3"+-- n3 <- lift $ getLine+-- if n3 == "back"+-- then fail "again"+-- else lift $ print $ n2++n3+--++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+++++{-# NOINLINE breturn #-}++-- | Use this instead of return to return from a computation with an ask statement+--+-- 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= do+ 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) <- cachedByKey key t $ proc mf s{mfCached=True}+ return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq})+ where+ proc mf s= do+ (r,s) <- runStateT (runView mf) s+ return (r,mfRequirements s, mfSeqCache 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 @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`+`waiMessageFlow` or `addMessageFlows`++@main= do+ addMessageFlows [(\"noscript\",transient $ runFlow mainf)]+ forkIO . run 80 $ waiMessageFlow+ adminLoop+@+-} +runFlow :: (FormInput view, Monad m) + => FlowM view m a -> Token -> m a +runFlow f = \t -> evalStateT (runBackT . runFlowM $ breturn() >> f) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return ()+ where+ -- to restart the flow in case of going back before the first page of the flow++ fromFailBack (NoBack x) = x+ fromFailBack (BackPoint x)= x++-- | Run a persistent flow inside the current flow. It is identified by the procedure and+-- the string identifier.+-- 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+ liftIO $ WF.exec1nc wf $ runFlow f t++++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++--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 (err:form) 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 + xmlhttp.status==204)" +++ " { " +++ " eval(xmlhttp.responseText);" +++ " }" +++ " };" +++ ""+
+ src/MFlow/Forms/Test.hs view
@@ -0,0 +1,287 @@+----------------------------------------------------------------------------- +-- +-- Module : MFlow.Forms.Test +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- +{-# OPTIONS + -XOverlappingInstances + -XFlexibleInstances + -XUndecidableInstances + -XPatternGuards + -XRecordWildCards + #-} + +module MFlow.Forms.Test (Response(..),runTest,ask) where +import MFlow.Forms hiding(ask) +import qualified MFlow.Forms (ask) +import MFlow.Forms(FormInput(..)) +import MFlow.Forms.Admin +import Control.Workflow as WF +import Control.Concurrent +import Control.Monad +import MFlow +import qualified Data.Map as M +import Control.Monad.Trans +import System.IO.Unsafe +import System.Random +import Data.Char(chr, ord) +import Data.List +import Data.Typeable +import qualified Data.ByteString.Lazy.Char8 as B +import Control.Concurrent.MVar +import Data.TCache.Memoization +import Control.Monad.State +import Data.Monoid +import Data.Maybe +import Data.IORef +import MFlow.Cookies(cookieuser) + + +class Response a where + response :: IO a + +instance Response a => Response (Maybe a) where + response= do + b <- randomRIO(0,1 :: Int) + case b of 0 -> response >>= return . Just ; _ -> return Nothing + +instance Response String where + response= replicateM 5 $ randomRIO ('a','z') + +instance Response Int where + response= randomRIO(1,1000) + +instance Response Integer where + response= randomRIO(1,1000) + + +instance (Response a, Response b) => Response (a,b) where + response= fmap (,) response `ap` response + + +instance (Response a, Response b) => Response (Maybe a,Maybe b) where + response= do + r <- response + case r of + (Nothing,Nothing) -> response + other -> return other + + +instance (Bounded a, Enum a) => Response a where + response= mx + where + mx= do + let x= typeOfIO mx + n <- randomRIO ( fromEnum $ minBound `asTypeOf` x + , fromEnum $ maxBound `asTypeOf` x) + return $ toEnum n + where + typeOfIO :: IO a -> a + typeOfIO = error $ "typeOfIO not defined" + +-- | 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" + adminLoop + +run1 (nusers, proc) = replicateM_ nusers $ randomFlow proc + where + randomFlow f = do + name <- response + x <- response + y <- response + z <- response + r1<- liftIO newEmptyMVar + r2<- liftIO newEmptyMVar + let t = Token x y z [] r1 r2 + forkIO . WF.exec1 name $ f t + +-- | a simulated ask that generate simulated user responses of the type expected+--+-- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.++-- execute 'runText' to initiate threads under different load conditions. +ask :: (Response a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a +ask w = do + w `MFlow.Forms.wmodify` (\v x -> consume v >> return (v,x)) + `seq` rest + where + consume= liftIO . B.writeFile "NULL" . B.concat . map toByteString + rest= do + bool <- liftIO $ response + case bool of + False -> fail "" + True -> do + b <- liftIO response + r <- liftIO $ response + case (b,r) of + (True,x) -> breturn x + _ -> ask w + + +-- +--match form=do +-- marches <- readIORef matches +-- return $ head map (m s) matches +-- where +-- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of +-- True -> Just ps +-- False -> Nothing +-- +--composeParams (Gen ps) form= zip (getParams form) ps +-- where +-- getParams form= +-- let search name form +-- | null form = mempty +-- | isPrefix name form = drop (length name) form +-- | otherwise= search name $ tail form +-- +-- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s +-- getPar= par $ search "name" +-- in getPar form +-- +{- +waction ::(Functor m, MonadIO m,Response a, FormInput view) + => View view m a + -> (a -> FlowM view m b) + -> View view m b +waction w f= do + x <- liftIO response + MFlow.Forms.waction (return x) f + + +--wmodify +-- :: (Functor m, MonadIO m, FormInput v, Response (Maybe a)) => +-- View v m a1 +-- -> ([v] -> Maybe a -> WState v m ([v], Maybe b)) +-- -> View v m b +wmodify formt act = do + x <- liftIO response + formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act +-} + +{- +type Var= String +data Test= Test{tflink:: [(Var,String)] + ,selectOptions :: [(Var,[String])] + ,tfinput :: [(Var, String)] + ,tftextarea :: [(Var, String)] + } + deriving(Read,Show) + +type TestM = Test -> Test + +instance Monoid TestM where + mempty= id + mappend= (.) + +instance FormInput TestM where + ftag = const id + inred = const id + fromStr = const id + flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t} + finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t} + ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t} + fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t} + foption o _ _= \t -> + let (n,opts)= head $ selectOptions t + in t{selectOptions=(n,o:opts):tail (selectOptions t)} + formAction _ _= id + addAttributes _ _= id + +generateResponse Test{..}= do + b <- response + case b of + True -> genLink + False -> genForm + + where + genForm= do + -- one on every response is incomplete + n <- randomRIO(0,10) :: IO Int + case n of + 0 -> do + genInput + + _ -> do + r1 <- genInput + r2 <- genSelect + r3 <- genTextArea + return $ r1++r2++r3 + genLink= do + let n = length tflink + if n == 0 then genForm + else do + r <- randomRIO(0,n ) + return [tflink !! r] + + genSelect=do + let n = length selectOptions + if n== 0 + then return [] + else mapM gen selectOptions + where + gen(s,os)= do + let m = length os + j <- randomRIO(0,m) + return (s, os !! j) + + genInput= do + let n = length tftextarea + if n==0 + then return [] + else mapM gen tfinput + where gen(n,_)= do + str <- response + return $ (n,str) + + genTextArea= do + let n = length tfinput + if n==0 + then return [] + else mapM gen tftextarea + where + gen(n,_)= do + str <- response + return $ (n,str) + +pwf= "pwf" +ind= "ind" +instance Processable Params where + pwfname = fromMaybe noScript . lookup pwf + puser= fromMaybe anonymous . lookup cookieuser + pind = fromMaybe "0" . lookup ind + getParams = id + + + +runTest nusers = do + wfs <- getMessageFlows + replicateM nusers $ gen wfs + where + gen wfs = do + u <- response + mapM (genTraffic u) $ M.toList wfs + + genTraffic u (n,_)= forkIO $ iterateresponses [(pwf,n),(cookieuser,u)] [] + + iterateresponses ident msg= iterate [] msg + where + iterate cs msg= do + (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg + let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks + resp <- generateResponse . read $ B.unpack test + iterate cs' resp + + -}
+ src/MFlow/Forms/Widgets.hs view
@@ -0,0 +1,483 @@++{- |+Some dynamic widgets, widgets that dynamically edit content in other widgets,+widgets for templating, content management and multilanguage. And some primitives+to create other active widgets.+-}++{-# LANGUAGE UndecidableInstances,ExistentialQuantification+ , FlexibleInstances, OverlappingInstances, FlexibleContexts+ , OverloadedStrings, DeriveDataTypeable #-}+++++module MFlow.Forms.Widgets (+-- * User Management+userFormOrName,maybeLogout,+-- * Active widgets+wEditList,wautocomplete,wautocompleteList+, wautocompleteEdit,++-- * Editing widgets+delEdited, getEdited+,prependWidget,appendWidget,setWidget+-- * Content Management+,tField, tFieldEd, tFieldGen++-- * Multilanguage+,mFieldEd, mField++) where+import MFlow+import MFlow.Forms+import MFlow.Forms.Internals+import Data.Monoid+import qualified Data.ByteString.Lazy.Char8 as B+import Control.Monad.Trans+import Data.Typeable+import Data.List+import System.IO.Unsafe++import Control.Monad.State+import Data.TCache+import Data.TCache.Defs+import Data.TCache.Memoization+import Data.RefSerialize hiding ((<|>))+import qualified Data.Map as M+import Data.IORef+import MFlow.Cookies+import Data.Maybe+import Control.Monad.Identity+++readyJQuery="ready=function(){if(!window.jQuery){return setTimeout(ready,100)}};"++jqueryScript= "http://ajax.googleapis.com/ajax/libs/jquery/1.8.0/jquery.min.js"++jqueryCSS= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"++jqueryUi= "http://code.jquery.com/ui/1.9.1/jquery-ui.js"++------- User Management ------++-- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.+-- The paremeters and the behaviour are the same as 'userWidget'.+-- Only the display is different+userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout+ where+ f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"+ f felem Nothing = do+ us <- getCurrentUser -- getEnv cookieuser+ if us == anonymous+ then return (felem, Nothing)+ else return([fromStr us], Just us)++-- | Display a logout link if the user is logged. Nothing otherwise+maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()+maybeLogout= do+ us <- getCurrentUser+ if us/= anonymous+ then fromStr " " ++> wlink () (fromStr "logout") `waction` const logout+ else noWidget++--- active widgets++data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])+instance (Typeable view, Typeable a)+ =>Typeable (Medit view m a) where+ typeOf= \v -> mkTyConApp (mkTyCon "Medit" )+ [typeOf (tview v)+ ,typeOf (ta v)]+ where+ tview :: Medit v m a -> v+ tview= undefined+ tm :: Medit v m a -> m a+ tm= undefined+ ta :: Medit v m a -> a+ ta= undefined++getEdited1 id= do+ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))+ return $ fromMaybe [] $ M.lookup id stored++-- | Return the list of edited widgets (added by the active widgets) for a given identifier+getEdited+ :: (Typeable v, Typeable a, MonadState (MFlowState view) m) =>+ B.ByteString -> m [View v m1 a]+getEdited id= do+ r <- getEdited1 id+ let (k,ws)= unzip r+ return ws++-- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter+delEdited+ :: (Typeable v, Typeable a, MonadIO m,+ MonadState (MFlowState view) m)+ => B.ByteString -- ^ identifier+ -> [View v m1 a] -> m () -- ^ withess+delEdited id witness=do+ (ks,ws) <- return . unzip =<< getEdited1 id+ return $ ws `asTypeOf` witness+ mapM (liftIO . flushCached) ks+ setEdited id ([] `asTypeOf` (zip (repeat "") witness))++setEdited id ws= do+ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))+ let stored'= M.insert id ws stored+ setSessionData . Medit $ stored'+++addEdited id w= do+ ws <- getEdited1 id+ setEdited id (w:ws)+++modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)+ => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString+modifyWidget selector modifier w = View $ do+ ws <- getEdited selector+ let n = length (ws `asTypeOf` [w])+ let key= "widget"++ show selector ++ show n+ let cw = wcached key 0 w+ addEdited selector (key,cw)+ FormElm form _ <- runView cw+ let elem= toByteString $ mconcat form+ return . FormElm [] . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"++-- | Return the javascript to be executed on the browser to prepend a widget to the location+-- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression+-- . It stores the added widgets in the edited list, that is accessed with 'getEdited'+--+-- 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+-- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned+-- and the list of edited widgets are deleted.+--+-- > id1<- genNewId+-- > let sel= "$('#" <> B.pack id1 <> "')"+-- > callAjax <- ajax . const $ prependWidget sel wn+-- > let installevents= "$(document).ready(function(){\+-- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"+-- >+-- > requires [JScriptFile jqueryScript [installevents] ]+-- > ws <- getEdited sel+-- > r <- (div <<< manyOf ws) <! [("id",id1)]+-- > delEdited sel ws'+-- > return r++prependWidget+ :: (Typeable a, MonadIO m, Executable m, FormInput v)+ => B.ByteString -- ^ jquery selector+ -> View v Identity a -- ^ widget to prepend+ -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser+prependWidget sel w= modifyWidget sel "prepend" w++-- | Like 'prependWidget' but append the widget instead of prepend.+appendWidget+ :: (Typeable a, MonadIO m, Executable m, FormInput v) =>+ B.ByteString -> View v Identity a -> View v m B.ByteString+appendWidget sel w= modifyWidget sel "append" w++-- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element+setWidget+ :: (Typeable a, MonadIO m, Executable m, FormInput v) =>+ B.ByteString -> View v Identity a -> View v m B.ByteString+setWidget sel w= modifyWidget sel "html" w+++-- | Inside a tag, it add and delete widgets of the same type. When the form is submitted+-- or a wlink is pressed, this widget return the list of validated widgets.+-- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/+-- that the user will choose.+--+-- This example add or delete editable text boxes, with two initial boxes with+-- /hi/, /how are you/ as values. Tt uses blaze-html:+--+-- > wlistEd= do+-- > r <- ask $ addLink+-- > ++> br+-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"])+-- > <++ br+-- > <** submitButton "send"+-- >+-- > ask $ p << (show r ++ " returned")+-- > ++> wlink () (p << text " back to menu")+-- > mainmenu+-- > where+-- > addLink = a ! At.id "wEditListAdd"+-- > ! href "#"+-- > $ text "add"+-- > delBox = input ! type_ "checkbox"+-- > ! checked ""+-- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"+-- > getString1 mx= El.div <<< delBox ++> getString mx <++ br++wEditList :: (Typeable a,Read a+ ,FormInput view+ ,Functor m,MonadIO m, Executable m)+ => (view ->view) -- ^ the holder tag+ -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string+ -> [String] -- ^ the initial list of values.+ -> View view m [a]+wEditList holderview w xs = do+ let ws= map (w . Just) xs+ wn= w Nothing+ id1<- genNewId+ let sel= "$('#" <> B.pack id1 <> "')"+ callAjax <- ajax . const $ prependWidget sel wn+ let installevents= "$(document).ready(function(){\+ \$('#wEditListAdd').click(function(){"++callAjax "''"++"});})"++ requires [JScriptFile jqueryScript [installevents] ]++ ws' <- getEdited sel++ r <- (holderview <<< (manyOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]+ delEdited sel ws'+ return r++-- | Present an autocompletion list, from a procedure defined by the programmer, to a text box.+wautocomplete+ :: (Show a, MonadIO m, FormInput v)+ => 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+ r <- liftIO $ autocomplete u+ return $ jaddtoautocomp r+++ requires [JScriptFile jqueryScript [] -- [events]+ ,CSSFile jqueryCSS+ ,JScriptFile jqueryUi []]+++ getString mv <! [("type", "text")+ ,("id", "text1")+ ,("oninput",ajaxc "$('#text1').attr('value')" )+ ,("autocomplete", "off")]+++ where+ jaddtoautocomp us= "$('#text1').autocomplete({ source: " <> B.pack( show us) <> " });"+++-- | Produces a text box. It gives a autocompletion list to the textbox. When return+-- is pressed in the textbox, the box content is used to create a widget of a kind defined+-- by the user, which will be situated above of the textbox. When submitted, the result of this widget is the content+-- of the created widgets (the validated ones).+--+-- 'wautocompleteList' is an specialization of this widget, where+-- the widget parameter is fixed, with a checkbox that delete the eleement when unselected+-- . This fixed widget is as such (using generic 'FormElem' class tags):+--+-- > ftag "div" <<< ftag "input" mempty+-- > `attrs` [("type","checkbox")+-- > ,("checked","")+-- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]+-- > ++> ftag "span" (fromStr $ fromJust x )+-- > ++> whidden( fromJust x)+wautocompleteEdit+ :: (Typeable a, MonadIO m,Functor m, Executable m+ , FormInput v)+ => String -- ^ the initial text of the box+ -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options.+ -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box+ -> [String] -- ^ initial set of values+ -> View v m [a] -- ^ resulting widget+wautocompleteEdit phold autocomplete elem values= do+ id1 <- genNewId+ let sel= "$('#" <> B.pack id1 <> "')"+ ajaxc <- ajax $ \(c:u) ->+ case c of+ 'f' -> prependWidget sel (elem $ Just u)+ _ -> do+ r <- liftIO $ autocomplete u+ return $ jaddtoautocomp r+++ requires [JScriptFile jqueryScript [events ajaxc] -- [events]+ ,CSSFile jqueryCSS+ ,JScriptFile jqueryUi []]++ ws' <- getEdited sel++ r<-(ftag "div" mempty `attrs` [("id", id1)]+ ++> manyOf (ws' ++ (map (changeMonad . elem . Just) values)))+ <++ ftag "input" mempty+ `attrs` [("type", "text")+ ,("id", "text1")+ ,("placeholder", phold)+ ,("oninput",ajaxc "'n'+$('#text1').attr('value')" )+ ,("autocomplete", "off")]+ delEdited sel ws'+ return r+ where+ events ajaxc=+ "$(document).ready(function(){ \+ \ $('#text1').keydown(function(){ \+ \ if(event.keyCode == 13){ \+ \ var v= $('#text1').attr('value'); \+ \ event.preventDefault();" +++ ajaxc "'f'+v"++";"+++ " $('#text1').val('');\+ \ }\+ \ });\+ \});"++ jaddtoautocomp us= "$('#text1').autocomplete({ source: " <> B.pack( show us) <> " });"++-- | A specialization of 'selectAutocompleteEdit' which make appear each option choosen with+-- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements.+wautocompleteList+ :: (Functor m, MonadIO m, Executable m, FormInput v) =>+ String -> (String -> IO [String]) -> [String] -> View v m [String]+wautocompleteList phold serverproc values=+ wautocompleteEdit phold serverproc wrender1 values+ where+ wrender1 x= ftag "div" <<< ftag "input" mempty+ `attrs` [("type","checkbox")+ ,("checked","")+ ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]+ ++> ftag "span" (fromStr $ fromJust x )+ ++> whidden( fromJust x)++------- Templating and localization ---------++writetField k s= atomically $ writetFieldSTM k s++writetFieldSTM k s= do+ phold <- readDBRef tFields `onNothing` return (M.fromList [])+ let r= M.insert k (toByteString s) phold+ writeDBRef tFields r++readtField text k= atomically $ do+ hs<- readDBRef tFields `onNothing` return (M.fromList [])+ let mp= M.lookup k hs+ case mp of+ Just c -> return $ fromStrNoEncode $ B.unpack c+ Nothing -> writetFieldSTM k text >> return text++type TFields = M.Map String B.ByteString+instance Indexable TFields where+ key _= "texts"+ defPath _= "texts/"++tFields :: DBRef TFields+tFields = getDBRef "texts"++type Key= String++-- | A widget that display the content of an html, But if logged as administrator,+-- it permits to edit it in place. So the editor could see the final appearance+-- of what he write in the page.+--+-- When the administrator double click in the paragraph, the content is saved and+-- identified by the key. Then, from now on, all the users will see the saved+-- content instead of the code content.+--+-- The content is saved in a file by default (/texts/ in this versions), but there is+-- a configurable version (`tFieldGen`). The content of the element and the formatting+-- is cached in memory, so the display is, theoretically, very fast.+--+-- THis is an example of how to use the content management primitives (in demos.blaze.hs):+--+-- > textEdit= do+-- > setHeader $ \t -> html << body << t+-- >+-- > let first= p << i <<+-- > (El.span << text "this is a page with"+-- > <> b << text " two " <> El.span << text "paragraphs")+-- >+-- > second= p << i << text "This is the original text of the second paragraph"+-- >+-- > pageEditable = (tFieldEd "first" first)+-- > **> (tFieldEd "second" second)+-- >+-- > ask $ first+-- > ++> second+-- > ++> wlink () (p << text "click here to edit it")+-- >+-- > ask $ p << text "Please login with admin/admin to edit it"+-- > ++> userWidget (Just "admin") userLogin+-- >+-- > ask $ p << text "now you can click the field and edit them"+-- > ++> p << b << text "to save the edited field, double click on it"+-- > ++> pageEditable+-- > **> wlink () (p << text "click here to see it as a normal user")+-- >+-- > logout+-- >+-- > ask $ p << text "the user sees the edited content. He can not edit"+-- > ++> pageEditable+-- > **> wlink () (p << text "click to continue")+-- >+-- > ask $ p << text "When text are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key"+-- > ++> tField "first"+-- > **> tField "second"+-- > **> p << text "End of edit field demo" ++> wlink () (p << text "click here to go to menu")+tFieldEd+ :: (Functor m, MonadIO m, Executable m,+ FormInput v) =>+ Key -> v -> View v m ()+tFieldEd k text=+ tFieldGen k (readtField text) writetField+++-- | Like 'tFieldEd' with user-configurable storage.+tFieldGen :: (MonadIO m,Functor m, Executable m+ ,FormInput v)+ => Key+ -> (Key -> IO v) -- ^ the read procedure, user defined+ -> (Key ->v -> IO()) -- ^ the write procedure, user defiend+ -> View v m ()+tFieldGen k getcontent create = wfreeze k 0 $ do+ content <- liftIO $ getcontent k+ admin <- getAdminName+ attribs <- do+ name <- genNewId+ let useradmin= "if(document.cookie.search('"++cookieuser++"="++admin++"') != -1)"+ nikeditor= "var myNicEditor = new nicEditor();"+ callback=useradmin +++ "bkLib.onDomLoaded(function() {\+ \ myNicEditor.addInstance('"++name++"');\+ \});"+ param= ("'"++k++ "'+','+ document.getElementById('"++name++"').innerHTML")+ ajaxjs <- ajax+ $ \str -> do+ let (k,s)= break (==',') str+ liftIO . create k $ fromStrNoEncode (tail s)+ liftIO $ flushCached k+ return "alert('saved');"++ requires+ [JScriptFile "http://js.nicedit.com/nicEdit-latest.js" [nikeditor, callback]+ ,JScript ajaxScript]++ return [("id", name),("ondblclick", useradmin++ajaxjs param)]++ wraw $ (ftag "span" content `attrs` attribs)++-- | Read the field value and present it without edition.+tField :: (MonadIO m,Functor m, Executable m+ , FormInput v)+ => Key+ -> View v m ()+tField k = wfreeze k 0 $ do+ content <- liftIO $ readtField (fromStrNoEncode "not found") k+ wraw content++-- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the+-- two characters of the language used.+mFieldEd k content= do+ lang <- getLang+ tFieldEd (k ++ ('-':lang)) content++-- | A multilanguage version of tField+mField k= do+ lang <- getLang+ tField $ k ++ ('-':lang)
src/MFlow/Forms/XHtml.hs view
@@ -22,28 +22,24 @@ module MFlow.Forms.XHtml where -+import MFlow (HttpData(..)) import MFlow.Forms+import MFlow.Cookies(contentHtml) import Data.ByteString.Lazy.Char8(pack,unpack) -import Text.XHtml as X+import Text.XHtml.Strict as X import Control.Monad.Trans import Data.Typeable - instance Monad m => ADDATTRS (View Html m a) where widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx) --- View $ do--- FormElm fs mx <- runView widget--- return $ FormElm [head fs ! atrs] mx -instance ToByteString Html where- toByteString = pack. showHtml- instance FormInput Html where-+ toByteString = pack. showHtmlFragment+ toHttpData = HttpData [contentHtml] [] . toByteString+ ftag t= tag t inred = X.bold ![X.thestyle "color:red"] finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else [] ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] )@@ -54,13 +50,13 @@ where selected msel = if msel then [X.selected] else [] - addAttributes tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)+ attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs) formAction action form = X.form ! [X.action action, method "post"] << form- fromString = stringToHtml-+ fromStr = stringToHtml+ fromStrNoEncode= primHtml flink v str = toHtml $ hotlink ( v) << str
src/MFlow/Hack.hs view
@@ -3,7 +3,12 @@ , MultiParamTypeClasses , DeriveDataTypeable , FlexibleInstances #-}- ++{- | Instantiation of the "MFlow" server for the Hack interface++see <http://hackage.haskell.org/package/hack>+-}+ module MFlow.Hack( module MFlow.Cookies ,module MFlow@@ -35,10 +40,11 @@ import MFlow.Hack.Response import Data.Monoid import Data.CaseInsensitive+import System.Time -import Debug.Trace-(!>)= flip trace+import System.Time + flow= "flow" instance Processable Env where @@ -54,33 +60,27 @@ -- getPort env= serverPort env -data Flow= Flow !Int deriving (Read, Show, Typeable) +data NFlow= NFlow !Integer deriving (Read, Show, Typeable) -instance Serializable Flow where+instance Serializable NFlow where serialize= B.pack . show deserialize= read . B.unpack -instance Indexable Flow where - key _= "Flow" +instance Indexable NFlow where + key _= "NFlow" -rflow= getDBRef . key $ Flow undefined- -newFlow= do - fl <- atomically $ do - m <- readDBRef rflow - case m of- Just (Flow n) -> do- writeDBRef rflow . Flow $ n+1- return n- - Nothing -> do- writeDBRef rflow $ Flow 1- return 0 - - - return $ show fl +rflow= getDBRef . key $ NFlow undefined +newFlow= do+ TOD t _ <- getClockTime + atomically $ do + NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) + writeDBRef rflow . NFlow $ n+1+ return . show $ t + n+ ++ --------------------------------------------- @@ -105,9 +105,9 @@ -- -> IO (TResp, ThreadId) --webScheduler = msgScheduler ---theDir= unsafePerformIO getCurrentDirectory +--theDir= unsafePerformIO getCurrentDirectory -wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) +wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message" -- | An instance of the abstract "MFlow" scheduler to the Hack interface@@ -160,7 +160,7 @@ Just fl -> return (fl, []) Nothing -> do fl <- newFlow - return ( fl, [( flow, fl, "/",Nothing)])+ return ( fl, [( flow, fl, "/",(Just $ show $ 365*24*60*60))]) {- for state persistence in cookies putStateCookie req1 cookies @@ -184,7 +184,7 @@ let resp''= toResponse resp' - let headers1= case retcookies of [] -> headers resp''; _ -> ctype : (cookieHeaders retcookies)+ let headers1= case retcookies of [] -> headers resp''; _ -> (cookieHeaders retcookies) let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} return resp
src/MFlow/Hack/Response.hs view
@@ -35,24 +35,24 @@ instance ToResponse TResp where- toResponse (TResp x)= toResponse x + toResponse (TResp x)= toResponse x toResponse (TRespR r)= toResponse r instance ToResponse Response where toResponse = id instance ToResponse ByteString where - toResponse x= Response{status=200, headers=[ctype {-,("Content-Length",show $ B.length x) -}], body= x} + toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x} instance ToResponse String where - toResponse x= Response{status=200, headers=[ctype{-,("Content-Length",show $ B.length x) -}], body= B.pack x}+ toResponse x= Response{status=200, headers=[contentHtml{-,("Content-Length",show $ B.length x) -}], body= B.pack x} instance ToResponse HttpData where toResponse (HttpData hs cookies x)= (toResponse x) {headers= hs++ cookieHeaders cookies} toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str} instance Typeable Env where - typeOf = \_-> mkTyConApp (mkTyCon "Hack.Env") [] + typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") [] -instance Typeable Response where - typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[] +--instance Typeable Response where +-- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
src/MFlow/Hack/XHtml/All.hs view
@@ -19,8 +19,8 @@ ,module MFlow.Forms ,module MFlow.Forms.XHtml ,module MFlow.Forms.Admin-,module MFlow.Forms.Ajax ,module MFlow.Hack.XHtml+,module MFlow.Forms.Widgets ,module Hack ,module Hack.Handler.SimpleServer ,module Text.XHtml.Strict@@ -33,7 +33,7 @@ import MFlow.Forms import MFlow.Forms.XHtml import MFlow.Forms.Admin-import MFlow.Forms.Ajax+import MFlow.Forms.Widgets import MFlow.Hack.XHtml import Hack(Env)
src/MFlow/Wai.hs view
@@ -1,116 +1,109 @@-{-# LANGUAGE UndecidableInstances- , TypeSynonymInstances- , MultiParamTypeClasses- , DeriveDataTypeable- , FlexibleInstances- , OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances + , TypeSynonymInstances + , MultiParamTypeClasses + , DeriveDataTypeable + , FlexibleInstances + , OverloadedStrings #-} -module MFlow.Wai(- module MFlow.Cookies- ,module MFlow- ,waiMessageFlow)-where+module MFlow.Wai( + module MFlow.Cookies + ,module MFlow + ,waiMessageFlow) +where import Data.Typeable import Network.Wai -+ import Control.Concurrent.MVar(modifyMVar_, readMVar) import Control.Monad(when) -import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail)-import Data.ByteString.Lazy(fromChunks)+import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail) +import Data.ByteString.Lazy(fromChunks) import qualified Data.ByteString.Char8 as SB import Control.Concurrent(ThreadId(..)) import System.IO.Unsafe -import Control.Concurrent.MVar-import Control.Concurrent+import Control.Concurrent.MVar +import Control.Concurrent import Control.Monad.Trans import Control.Exception -import qualified Data.Map as M+import qualified Data.Map as M import Data.Maybe -import Data.TCache+import Data.TCache import Data.TCache.DefaultPersistence import Control.Workflow hiding (Indexable(..)) import MFlow -import MFlow.Cookies-import Data.Monoid-import MFlow.Wai.Response-import Network.Wai-import Network.HTTP.Types hiding (urlDecode)-import Data.Conduit-import Data.Conduit.Lazy-import qualified Data.Conduit.List as CList-import Data.CaseInsensitive----import Debug.Trace---(!>)= flip trace--flow= "flow"---ciflow= mk flow+import MFlow.Cookies +import Data.Monoid +import MFlow.Wai.Response +import Network.Wai +import Network.HTTP.Types hiding (urlDecode) +import Data.Conduit +import Data.Conduit.Lazy +import qualified Data.Conduit.List as CList +import Data.CaseInsensitive +import System.Time +--import Debug.Trace +--(!>)= flip trace + +flow= "flow" +--ciflow= mk flow + instance Processable Request where pwfname env= if SB.null sc then noScript else SB.unpack sc where - sc= SB.tail $ rawPathInfo env-+ sc= SB.tail $ rawPathInfo env + puser env = fromMaybe anonymous $ fmap SB.unpack $ lookup ( mk $SB.pack cookieuser) $ requestHeaders env - pind env= fromMaybe (error ": No FlowID") $ fmap SB.unpack $ lookup (mk $ SB.pack flow) $ requestHeaders env- getParams= mkParams1 . requestHeaders- where- mkParams1 = Prelude.map mkParam1- mkParam1 ( x,y)= (SB.unpack $ original x, SB.unpack y)---- getServer env= serverName env--- getPath env= pathInfo env--- getPort env= serverPort env+ pind env= fromMaybe (error ": No FlowID") $ fmap SB.unpack $ lookup (mk $ SB.pack flow) $ requestHeaders env + getParams= mkParams1 . requestHeaders + where + mkParams1 = Prelude.map mkParam1 + mkParam1 ( x,y)= (SB.unpack $ original x, SB.unpack y) + +-- getServer env= serverName env +-- getPath env= pathInfo env +-- getPort env= serverPort env -data Flow= Flow !Int deriving (Read, Show, Typeable) --instance Serializable Flow where- serialize= B.pack . show+data NFlow= NFlow !Integer deriving (Read, Show, Typeable) + +instance Serializable NFlow where + serialize= B.pack . show deserialize= read . B.unpack -instance Indexable Flow where +instance Indexable NFlow where key _= "Flow" --rflow= getDBRef . key $ Flow undefined +rflow= getDBRef . key $ NFlow undefined + newFlow= liftIO $ do - fl <- atomically $ do - m <- readDBRef rflow - case m of- Just (Flow n) -> do- writeDBRef rflow . Flow $ n+1- return n- - Nothing -> do- writeDBRef rflow $ Flow 1- return 0 - return $ show fl + TOD t _ <- getClockTime + atomically $ do + NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) + writeDBRef rflow . NFlow $ n+1 + return . show $ t + n + --------------------------------------------- - - - -- --instance ConvertTo String TResp where -- convert = TResp . pack ---+-- --instance ConvertTo ByteString TResp where --- convert = TResp---+-- convert = TResp -- +-- --instance ConvertTo Error TResp where --- convert (Error e)= TResp . pack $ errorResponse e------instance ToResponse v =>ConvertTo (HttpData v) TResp where+-- convert (Error e)= TResp . pack $ errorResponse e +-- +--instance ToResponse v =>ConvertTo (HttpData v) TResp where -- convert= TRespR - + --webScheduler :: Request -- -> ProcList -- -> IO (TResp, ThreadId) @@ -121,37 +114,37 @@ --wFMiddleware :: (Request -> Bool) -> (Request-> IO Response) -> (Request -> IO Response) --wFMiddleware filter f = \ env -> if filter env then waiWorkflow env else f env -- !> "new message" --- | An instance of the abstract "MFlow" scheduler to the <http://hackage.haskell.org/package/wai> interface.---+-- | An instance of the abstract "MFlow" scheduler to the <http://hackage.haskell.org/package/wai> interface. +-- -- it accept the list of processes being scheduled and return a wai handler ------ Example:------ @main= do------ putStrLn $ options messageFlows--- 'run' 80 $ 'waiMessageFlow' messageFlows--- where--- messageFlows= [(\"main\", 'runFlow' flowname )--- ,(\"hello\", 'stateless' statelesproc)--- ,(\"trans\", 'transient' $ runflow transientflow]--- options msgs= \"in the browser choose\\n\\n\" ++--- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]--- @---waiMessageFlow :: [(String, (Token -> Workflow IO ()))]+-- +-- Example: +-- +-- @main= do +-- +-- putStrLn $ options messageFlows +-- 'run' 80 $ 'waiMessageFlow' messageFlows +-- where +-- messageFlows= [(\"main\", 'runFlow' flowname ) +-- ,(\"hello\", 'stateless' statelesproc) +-- ,(\"trans\", 'transient' $ runflow transientflow] +-- options msgs= \"in the browser choose\\n\\n\" ++ +-- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] +-- @ +--waiMessageFlow :: [(String, (Token -> Workflow IO ()))] -- -> (Request -> ResourceT IO Response) --waiMessageFlow messageFlows = -- unsafePerformIO (addMessageFlows messageFlows) `seq` --- waiWorkflow -- wFMiddleware f other+-- waiWorkflow -- wFMiddleware f other --- where--- f env = unsafePerformIO $ do--- paths <- getMessageFlows >>=--- return (pwfname env `elem` paths)-+-- where +-- f env = unsafePerformIO $ do +-- paths <- getMessageFlows >>= +-- return (pwfname env `elem` paths) + -- other= (\env -> defaultResponse $ "options: " ++ opts) --- (paths,_)= unzip messageFlows--- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths+-- (paths,_)= unzip messageFlows +-- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths splitPath ""= ("","","") @@ -161,21 +154,19 @@ (ext, rest)= span (/= '.') strr (mod, path)= span(/='/') $ tail rest in (tail $ reverse path, reverse mod, reverse ext) -- + waiMessageFlow :: Request -> ResourceT IO Response waiMessageFlow req1= do let httpreq1= getParams req1 -- let cookies=getCookies httpreq1 + let cookies=getCookies httpreq1 (flowval , retcookies) <- case lookup flow cookies of Just fl -> return (fl, []) Nothing -> do fl <- newFlow - return (fl, [(flow, fl, "/",Nothing)::Cookie])+ return (fl, [(flow, fl, "/",Nothing)::Cookie]) {- for state persistence in cookies putStateCookie req1 cookies @@ -184,37 +175,32 @@ Just ck -> ck:retcookies1 -} - input <- - case parseMethod $ requestMethod req1 of - Right POST -> if lookup ("Content-Type") httpreq1 == Just "application/x-www-form-urlencoded"- then do- inp <- liftIO $ runResourceT (requestBody req1 $$ CList.consume)- return . urlDecode $ concatMap SB.unpack inp- else return []+ input <- case parseMethod $ requestMethod req1 of + Right POST -> if lookup ("Content-Type") httpreq1 == Just "application/x-www-form-urlencoded" + then do + inp <- liftIO $ runResourceT (requestBody req1 $$ CList.consume) + return . urlDecode $ concatMap SB.unpack inp + else return [] - 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) + 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 [] let req = case retcookies of - [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" - _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ" - (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)-- let resp= case (resp',retcookies) of- (_,[]) -> resp'- (error@(Error _ _),_) -> error+ (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req) + + let resp= case (resp',retcookies) of + (_,[]) -> resp' + (error@(Error _ _),_) -> error (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str ---- let resp''= toResponse resp' --- let headers1= case retcookies of [] -> headers resp''; _ -> ctype : cookieHeaders retcookies--- let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} - return $ toResponse resp-+ return $ toResponse resp + ------persistent state in cookies (not tested) tvresources :: MVar (Maybe ( M.Map string string)) @@ -259,5 +245,5 @@ case mmap of Just map -> return $ Just $ M.delete (keyResource stat) map Nothing -> return $ Nothing ---}+ +-}
+ src/MFlow/Wai/Blaze/Html/All.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+--+-- 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.Wai+,module MFlow.FileServer+,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+) where+++import MFlow.Wai+import MFlow.FileServer+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+++++++++
src/MFlow/Wai/Response.hs view
@@ -11,9 +11,10 @@ import Data.Monoid import System.IO.Unsafe import Data.Map as M-import Data.CaseInsensitive+--import Data.CaseInsensitive import Network.HTTP.Types import Control.Workflow(WFErrors(..))+import Data.String --import Debug.Trace -- --(!>)= flip trace@@ -35,9 +36,9 @@ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) -ctype1= [mkparam ctype] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")]+contentHtml1= [mkparam contentHtml] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")] mkParams = Prelude.map mkparam-mkparam (x,y)= (mk $ SB.pack x, SB.pack y)+mkparam (x,y)= (fromString x, fromString y) instance ToResponse TResp where toResponse (TResp x)= toResponse x toResponse (TRespR r)= toResponse r@@ -46,15 +47,13 @@ toResponse = id instance ToResponse B.ByteString where - toResponse x= responseLBS status200 ctype1 {-,("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 ctype1{-,("Content-Length",show $ B.length x) -} $ B.pack x+ 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 (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs ++ cookieHeaders cookies)) x toResponse (Error NotFound str)= responseLBS status404 [] $ getNotFoundResponse str
src/MFlow/Wai/XHtml/All.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- ----- Module : MFloll.Wai.XHtml.All+-- Module : MFlow.Wai.XHtml.All -- Copyright : -- License : BSD3 --@@ -19,7 +19,7 @@ ,module MFlow.Forms ,module MFlow.Forms.XHtml ,module MFlow.Forms.Admin-,module MFlow.Forms.Ajax+,module MFlow.Forms.Widgets --,module MFlow.Wai.XHtml ,module Network.Wai ,module Network.Wai.Handler.Warp@@ -33,7 +33,7 @@ import MFlow.Forms import MFlow.Forms.XHtml import MFlow.Forms.Admin-import MFlow.Forms.Ajax+import MFlow.Forms.Widgets --import MFlow.Wai.XHtml import Network.Wai