MFlow 0.3.0.0 → 0.3.0.1
raw patch · 11 files changed
+714/−571 lines, 11 filesdep +MFlowdep +hamletdep ~basedep ~containersdep ~stmnew-component:exe:demos-blazePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: MFlow, hamlet
Dependency ranges changed: base, containers, stm
API changes (from Hackage documentation)
- MFlow.Wai.Blaze.Html.All: runServer :: FormInput view => FlowM view (Workflow IO) () -> IO Bool
- MFlow.Wai.Blaze.Html.All: runServerTransient :: FormInput view => FlowM view IO () -> IO Bool
+ MFlow.Forms: instance [incoherent] Typeable1 MFOption
+ MFlow.Forms: transientNav :: (Serialize a, Typeable view, FormInput view, Typeable a) => FlowM view IO a -> FlowM view (Workflow IO) a
+ MFlow.Wai.Blaze.Html.All: runNavigation :: String -> FlowM Html (Workflow IO) () -> IO Bool
- MFlow: class Processable a where pwfname = head . pwfPath
+ MFlow: class Processable a where pwfname s = head $ pwfPath s !> "head mf"
- MFlow.Forms: getRadio :: (Monad m, Functor m, FormInput view) => [String -> View view m Radio] -> View view m String
+ MFlow.Forms: getRadio :: (Monad m, Functor m, FormInput view) => [String -> View view m (Radio a)] -> View view m a
- MFlow.Forms: setOption :: (Monad m, Show a, Typeable a, FormInput view) => a -> view -> View view m (MFOption a)
+ MFlow.Forms: setOption :: (Monad m, Show a, Eq a, Typeable a, FormInput view) => a -> view -> View view m (MFOption a)
- MFlow.Forms: setRadio :: (FormInput view, MonadIO m) => String -> String -> View view m Radio
+ MFlow.Forms: setRadio :: (FormInput view, MonadIO m, Read a, Typeable a, Eq a, Show a) => a -> String -> View view m (Radio a)
- MFlow.Forms: setRadioActive :: (FormInput view, MonadIO m) => String -> String -> View view m Radio
+ MFlow.Forms: setRadioActive :: (FormInput view, MonadIO m, Read a, Typeable a, Eq a, Show a) => a -> String -> View view m (Radio a)
- MFlow.Forms: setSelectedOption :: (Monad m, Show a, Typeable a, FormInput view) => a -> view -> View view m (MFOption a)
+ MFlow.Forms: setSelectedOption :: (Monad m, Show a, Eq a, Typeable a, FormInput view) => a -> view -> View view m (MFOption a)
Files
- Demos/demos-blaze.hs +505/−0
- Demos/demos.blaze.hs +0/−507
- Demos/testREST.hs +26/−0
- MFlow.cabal +17/−4
- src/MFlow.hs +1/−1
- src/MFlow/Forms.hs +56/−27
- src/MFlow/Forms/Blaze/Html.hs +2/−1
- src/MFlow/Forms/Internals.hs +35/−5
- src/MFlow/Forms/Widgets.hs +43/−8
- src/MFlow/Wai.hs +1/−1
- src/MFlow/Wai/Blaze/Html/All.hs +28/−17
+ Demos/demos-blaze.hs view
@@ -0,0 +1,505 @@+{-# LANGUAGE DeriveDataTypeable, QuasiQuotes #-} +module Main where +import MFlow.Wai.Blaze.Html.All +import Text.Blaze.Html5 as El +import Text.Blaze.Html5.Attributes as At hiding (step) +import Data.List +import Data.Typeable +import Control.Monad.Trans + +import qualified Data.ByteString.Lazy.Char8 as B +--import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Maybe +import Data.Monoid +import System.IO.Unsafe +import Debug.Trace+import Data.String +import Control.Concurrent.MVar++import Text.Hamlet ++-- +--import Control.Monad.State +--import MFlow.Forms.Internals +(!>) = const -- flip trace + +--test= runTest [(15,"shop")] + +main= do + setAdminUser "admin" "admin" + syncWrite SyncManual + setFilesPath "" + addMessageFlows [("shop", runFlow shopCart),("",transient $ runFlow mainmenu)]+ wait $ run 80 waiMessageFlow+-- runNavigation "" $ transientNav mainmenu + +attr= fromString +text = toMarkup + +data Options= CountI | CountS | Radio + | Login | TextEdit |Grid | Autocomp | AutocompList + | ListEdit |Shop | Action | Ajax | Select + | CheckBoxes | PreventBack | Multicounter + | Combination + | FViewMonad | Counter | WDialog + deriving (Bounded, Enum,Read, Show,Typeable) + + +mainmenu= do + setHeader stdheader + setTimeouts 100 0 + r <- ask $ do+ -- includes an style + requires[CSSFile "http://jqueryui.com/resources/demos/style.css"] + wcached "menu" 0 $ + b << "BASIC" + ++> br ++> wlink CountI << b << "increase an Int" + <|> br ++> wlink CountS << b << "increase a String" + <|> br ++> wlink Select << b << "select options" + <|> br ++> wlink CheckBoxes << b << "checkboxes" + <|> br ++> wlink Radio << b << "Radio buttons" + + <++ br <> br <> b << "WIDGET ACTIONS & CALLBACKS" + <|> br ++> wlink Action << b << "Example of action, executed when a widget is validated" + <|> br ++> wlink FViewMonad << b << "in page flow: sum of three numbers" + <|> br ++> wlink Counter << b << "Counter" + <|> br ++> wlink Multicounter << b << "Multicounter" + <|> br ++> wlink Combination << b << "combination of three active widgets" + <|> br ++> wlink WDialog << b << "modal dialog" + + <++ br <> br <> b << "DYNAMIC WIDGETS" + <|> br ++> wlink Ajax << b << "AJAX example" + <|> br ++> wlink Autocomp << b << "autocomplete" + <|> br ++> wlink AutocompList << b << "autocomplete List" + <|> br ++> wlink ListEdit << b << "list edition" + <|> br ++> wlink Grid << b << "grid" + <|> br ++> wlink TextEdit << b << "Content Management" + <++ br <> br <> b << "STATEFUL PERSISTENT FLOW" + <> br <> a ! href (attr "/shop") << "shopping" -- ordinary Blaze.Html link + + <> br <> br <> b << "OTHERS" + <|> br ++> wlink Login << b << "login/logout" + <|> br ++> wlink PreventBack << b << "Prevent going back after a transaction" + + + + case r of + CountI -> clickn (0 :: Int) + CountS -> clicks "1" + Action -> actions 1 + Ajax -> ajaxsample + Select -> options + CheckBoxes -> checkBoxes + TextEdit -> textEdit + Grid -> grid + Autocomp -> autocomplete1 + AutocompList -> autocompList + ListEdit -> wlistEd + Radio -> radio + Login -> loginSample + PreventBack -> preventBack + Multicounter-> multicounter + FViewMonad -> sumInView + Counter -> counter + Combination -> combination + WDialog -> wdialog1 + +wdialog1= do+ ask wdialogw+ ask (wlink () << "out of the page flow, press here to go to the menu")++wdialogw= pageFlow "diag" $ do + r <- wform $ p << "please enter your name" ++> getString (Just "your name") <** submitButton "ok" + wdialog "({modal: true})" "question" $ + p << ("Do your name is \""++r++"\"?") ++> getBool True "yes" "no" <** submitButton "ok" ++ `wcallback` \q -> if not q then wdialogw+ else wlink () << b << "thanks, press here to exit from the page Flow" + + +sumInView= ask $ p << "ask for three numbers in the same page and display the result.\ + \It is possible to modify the inputs and the sum will reflect it" + ++> sumWidget + +formWidget :: View Html IO () +formWidget= do + (n,s) <- (,) <$> p << "Who are you?" + ++> getString Nothing <! hint "name" <++ br + <*> getString Nothing <! hint "surname" <++ br + <** submitButton "ok" <++ br + + flag <- b << "Do you " ++> getRadio[radiob "work?",radiob "study?"] <++ br + + r<- case flag of + "work?" -> pageFlow "l" + $ Left <$> b << "do you enjoy your work? " + ++> getBool True "yes" "no" + <** submitButton "ok" <++ br + + "study?"-> pageFlow "r" + $ Right <$> b << "do you study in " + ++> getRadio[radiob "University" + ,radiob "High School"] + u <- getCurrentUser + p << ("You are "++n++" "++s) + ++> p << ("And your user is: "++ u) + ++> case r of + Left fl -> p << ("You work and it is " ++ show fl ++ " that you enjoy your work") + ++> noWidget + + Right stu -> p << ("You study at the " ++ stu) + ++> noWidget + + +hint s= [("placeholder",s)] +onClickSubmit= [("onclick","if(window.jQuery){\n\ + \$(this).parent().submit();}\n\ + \else {this.form.submit()}")] +radiob s n= wlabel (text s) $ setRadio s n <! onClickSubmit + +sumWidget= pageFlow "sum" $ do + n1 <- p << "Enter first number" ++> getInt Nothing <** submitButton "enter" <++ br + n2 <- p << "Enter second number" ++> getInt Nothing <** submitButton "enter" <++ br + n3 <- p << "Enter third number" ++> getInt Nothing <** submitButton "enter" <++ br + p << ("The result is: "++show (n1 + n2 + n3)) ++> wlink () << b << " menu" + <++ p << "you can change the numbers in the boxes to see how the result changes" + + + +combination = ask $ do + p << "Three active widgets in the same page with autoRefresh. Each widget refresh itself \ + \with Ajax. If Ajax is not active, they will refresh by sending a new page." + ++> hr + ++> p << "Login widget (use admin/admin)" ++> autoRefresh (pageFlow "r" wlogin) <++ hr + **> p << "Counter widget" ++> autoRefresh (pageFlow "c" (counterWidget 0)) <++ hr + **> p << "Dynamic form widget" ++> autoRefresh (pageFlow "f" formWidget) <++ hr + **> wlink () << b << "exit" + +wlogin :: View Html IO () +wlogin= (do + username <- getCurrentUser + if username /= anonymous + then return username + else do + name <- getString Nothing <! hint "username" <++ br + pass <- getPassword <! focus <** submitButton "login" <++ br + val <- userValidate (name,pass) + case val of + Just msg -> notValid msg + Nothing -> login name >> return name) + + `wcallback` (\name -> b << ("logged as " ++ name) + ++> p << ("navigate away of this page before logging out") + ++> wlink "logout" << b << " logout") + `wcallback` const (logout >> wlogin) + +focus = [("onload","this.focus()")] + + +multicounter= do + let explain= p << "This example emulates the" + <> a ! href (attr "http://www.seaside.st/about/examples/multicounter?_k=yBJEDEGp") + << " seaside example" + <> p << "It uses various copies of the " <> a ! href (attr "/noscript/counter") << "counter widget " + <> text "instantiated in the same page. This is an example of how it is possible to " + <> text "compose widgets with independent behaviours" + + ask $ explain ++> add (counterWidget 0) [1..4] <|> wlink () << p << "exit" + + +add widget list= firstOf [autoRefresh $ pageFlow (show i) widget <++ hr | i <- list] + +counter1= do + ask $ wlink "p" <<p<<"press here" + ask $ pageFlow "c" $ ex [ wlink i << text (show (i :: Int)) | i <- [1..] ] + where + + ex (a:as)= a >> ex as +counter= do + let explain= p <<"This example emulates the" + <> a ! href (attr "http://www.seaside.st/about/examples/counter") << "seaside counter example" + <> p << "This widget uses a callback to permit an independent" + <> p << "execution flow for each widget." <> a ! href (attr "/noscript/multicounter") << "Multicounter" <> (text " instantiate various counter widgets") + <> p << "But while the seaside case the callback update the widget object, in this case" + <> p << "the callback call generates a new copy of the counter with the value modified." + + ask $ explain ++> pageFlow "c" (counterWidget 0) <++ br <|> wlink () << p << "exit" + +counterWidget n= do + (h2 << show n !> show n + ++> wlink "i" << b << " ++ " + <|> wlink "d" << b << " -- ") + `wcallback` + \op -> case op of + "i" -> counterWidget (n + 1) !> "increment" + "d" -> counterWidget (n - 1) !> "decrement" + +rpaid= unsafePerformIO $ newMVar (0 :: Int) + + +preventBack= do + ask $ wlink () << b << "press here to pay 100000 $ " + payIt + paid <- liftIO $ readMVar rpaid + preventGoingBack . ask $ p << "You already paid 100000 before" + ++> p << "you can no go back until the end of the buy process" + ++> wlink () << p << "Please press here to continue" + ask $ p << ("you paid "++ show paid) + ++> wlink () << p << "Press here to go to the menu or press the back button to verify that you can not pay again" + where + payIt= liftIO $ do + print "paying" + paid <- takeMVar rpaid + putMVar rpaid $ paid + 100000 + +options= do + r <- ask $ getSelect (setSelectedOption "" (p << "select a option") <|> + setOption "red" (b << "red") <|> + setSelectedOption "blue" (b << "blue") <|> + setOption "Green" (b << "Green") ) + <! dosummit + ask $ p << (r ++ " selected") ++> wlink () (p << " menu") + + + where + dosummit= [("onchange","this.form.submit()")] + +checkBoxes= do + r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << "red") + <> (setCheckBox False "Green" <++ b << "green") + <> (setCheckBox False "blue" <++ b << "blue")) + <** submitButton "submit" + + + ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") + + +autocomplete1= do + r <- ask $ p << "Autocomplete " + ++> p << "when su press submit, the box value is returned" + ++> wautocomplete Nothing filter1 <! hint "red,green or blue" + <** submitButton "submit" + ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") + + where + filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] + +autocompList= do + r <- ask $ p << "Autocomplete with a list of selected entries" + ++> p << "enter and press enter" + ++> p << "when su press submit, the entries are returned" + ++> wautocompleteList "red,green,blue" filter1 ["red"] + <** submitButton "submit" + ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") + + where + filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] + +grid = do + let row _= tr <<< ( (,) <$> tdborder <<< getInt (Just 0) + <*> tdborder <<< getTextBox (Just "") + <++ tdborder << delLink) + addLink= a ! href (attr "#") + ! At.id (attr "wEditListAdd") + << "add" + delLink= a ! href (attr "#") + ! onclick (attr "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)") + << "delete" + tdborder= td ! At.style (attr "border: solid 1px") + + r <- ask $ addLink ++> ( wEditList table row ["",""] "wEditListAdd") <** submitButton "submit" + ask $ p << (show r ++ " returned") + ++> wlink () (p << " back to menu") + + + +wlistEd= do + r <- ask $ addLink + ++> br + ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd") + <++ br + <** submitButton "send" + + ask $ p << (show r ++ " returned") + ++> wlink () (p << " back to menu") + + + where + addLink = a ! At.id (attr "wEditListAdd") + ! href (attr "#") + $ b << "add" + delBox = input ! type_ (attr "checkbox") + ! checked (attr "") + ! onclick (attr "this.parentNode.parentNode.removeChild(this.parentNode)") + getString1 mx= El.div <<< delBox ++> getString mx <++ br + + +clickn n= do + r <- ask $ p << b << "increase an Int" + ++> wlink "menu" << p << "menu" + |+| getInt (Just n) <* submitButton "submit" + case r of + (Just _,_) -> return () -- ask $ wlink () << p << "thanks" + (_, Just n') -> clickn $ n'+1 + + +clicks s= do + s' <- ask $ p << b << "increase a String" + ++> p << b << "press the back button to go back to the menu" + ++>(getString (Just s) + <* submitButton "submit") + `validate` (\s -> return $ if length s > 5 then Just (b << "length must be < 5") else Nothing ) + clicks $ s'++ "1" + + +radio = do + r <- ask $ p << b << "Radio buttons" + ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] + + ask $ p << ( show r ++ " selected") ++> wlink () << p << " menu" + +ajaxsample= do + r <- ask $ p << b << "Ajax example that increment the value in a box" + ++> do + let elemval= "document.getElementById('text1').value" + ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'" + b << "click the box " + ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)] <** submitButton "submit" + ask $ p << ( show r ++ " returned") ++> wlink () << p << " menu" + + +---- recursive action +--actions n=do +-- ask $ wlink () (p << "exit from action") +-- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) + + +actions n= do + r<- ask $ p << b << "Two boxes with one action each one" + ++> getString (Just "widget1") `waction` action + <+> getString (Just "widget2") `waction` action + <** submitButton "submit" + ask $ p << ( show r ++ " returned") ++> wlink () << p << " menu" + where + action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action" + +data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum, Show,Read , Typeable) + +newtype Cart= Cart (V.Vector Int) deriving Typeable +emptyCart= Cart $ V.fromList [0,0,0] + +shopCart = do + + setHeader $ \html -> p << ( El.span << + "A persistent flow (uses step). The process is killed after 100 seconds of inactivity \ + \but it is restarted automatically. Event If you restart the whole server, it remember the shopping cart\n\n \ + \Defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.\n\ + \The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events." + + <> html) + setTimeouts 100 (60 * 60) + shopCart1 + where + shopCart1 = do + o <- step . ask $ do + let moreexplain= p << "The second parameter of \"setTimeout\" is the time during which the cart is recorded" + Cart cart <- getSessionData `onNothing` return emptyCart + + moreexplain + ++> + (table ! At.style (attr "border:1;width:20%;margin-left:auto;margin-right:auto") + <<< caption << "choose an item" + ++> thead << tr << ( th << b << "item" <> th << b << "times chosen") + ++> (tbody + <<< tr ! rowspan (attr "2") << td << linkHome + ++> (tr <<< td <<< wlink IPhone (b << "iphone") <++ td << ( b << show ( cart V.! 0)) + <|> tr <<< td <<< wlink IPod (b << "ipod") <++ td << ( b << show ( cart V.! 1)) + <|> tr <<< td <<< wlink IPad (b << "ipad") <++ td << ( b << show ( cart V.! 2))) + <++ tr << td << linkHome + )) + let i =fromEnum o + Cart cart <- getSessionData `onNothing` return emptyCart + setSessionData . Cart $ cart V.// [(i, cart V.! i + 1 )] + shopCart1 + + where + linkHome= a ! href (attr $ "/" ++ noScript) << b << "home" + + +loginSample= do + ask $ p << "Please login with admin/admin" + ++> userWidget (Just "admin") userLogin + user <- getCurrentUser + ask $ b << ("user logged as " <> user) ++> wlink () << p << " logout and go to menu" + logout + + + +textEdit= do + let first= p << i << + (El.span << "this is a page with" + <> b << " two " <> El.span << "paragraphs. this is the first") + + second= p << i << "This is the original of the second paragraph" + + + + ask $ p << b << "An example of content management" + ++> first + ++> second + ++> wlink () << p << "click here to edit it" + + + ask $ p << "Please login with admin/admin to edit it" + ++> userWidget (Just "admin") userLogin + + ask $ p << "Now you can click the fields and edit them" + ++> p << b << "to save an edited field, double click on it" + ++> tFieldEd "first" first + **> tFieldEd "second" second + **> wlink () << p << "click here to see it as a normal user" + + logout + + ask $ p << "the user sees the edited content. He can not edit" + ++> tFieldEd "first" first + **> tFieldEd "second" second + **> wlink () << p << "click to continue" + + ask $ p << "When texts are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key" + ++> tField "first" + **> tField "second" + **> p << "End of edit field demo" ++> wlink () << p << "click here to go to menu" + + + +--stdheader= html . body + +stdheader c= docTypeHtml+ $ El.head << (El.title << "MFlow examples"+ <> link ! rel ( attr "stylesheet")+ ! type_ ( attr "text/css")+ ! href (attr "http://jqueryui.com/resources/demos/style.css"))+ <> (body $ + a ! At.style (attr "align:center;") ! href ( attr "/html/MFlow/index.html") << h1 << "MFlow" + <> br + <> hr + <> (El.div ! At.style (attr "float:left\ + \;width:50%\ + \;margin-left:10px;margin-right:10px;overflow:auto;") $ + h2 << "Example of some features." +-- <> h3 << "This demo uses warp and blaze-html" + + <> br <> c) + <> (El.div ! At.style (attr "float:right;width:45%;overflow:auto;") $ + h2 << "Documentation" + <> br + <> p << a ! href (attr "/html/MFlow/index.html") << "MFlow package description and documentation" + <> p << a ! href (attr "https://github.com/agocorona/MFlow/blob/master/Demos/demos-blaze.hs") << "download demo source code" + <> p << a ! href (attr "https://github.com/agocorona/MFlow/issues") << "bug tracker" + <> p << a ! href (attr "https://github.com/agocorona/MFlow") << "source repository" + <> p << a ! href (attr "http://hackage.haskell.org/package/MFlow") << "Hackage repository" + <> [shamlet| <script type="text/javascript" src="http://output18.rssinclude.com/output?type=js&id=727700&hash=8aa6c224101cac4ca2a7bebd6e28a2d7"></script>|]++ ))
− Demos/demos.blaze.hs
@@ -1,507 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-} -module Main where -import MFlow.Wai.Blaze.Html.All -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.String -import Data.List -import Data.TCache -import Data.Typeable -import Control.Monad.Trans -import Control.Concurrent -import Control.Exception as E -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Data.Text as T -import qualified Data.Vector as V -import Data.Maybe -import Data.Monoid -import System.IO.Unsafe -import System.Environment -import Debug.Trace - --- ---import Control.Monad.State ---import MFlow.Forms.Internals -(!>) = const -- flip trace - ---test= runTest [(15,"shop")] - -main= do - setAdminUser "admin" "admin" - syncWrite SyncManual - setFilesPath "" - addMessageFlows - [("" , transient $ runFlow mainmenu) - ,("shop", runFlow shopCart)] - env <- getEnvironment - let port = fromIntegral . read . fromMaybe "80" $ lookup "PORT" env - wait $ run port waiMessageFlow - - -attr= fromString -text = fromString - -data Options= CountI | CountS | Radio - | Login | TextEdit |Grid | Autocomp | AutocompList - | ListEdit |Shop | Action | Ajax | Select - | CheckBoxes | PreventBack | Multicounter - | Combination - | FViewMonad | Counter | WDialog - deriving (Bounded, Enum,Read, Show,Typeable) - - -mainmenu= do - setHeader stdheader - setTimeouts 100 0 - r <- ask $ do - requires[CSSFile "http://jqueryui.com/resources/demos/style.css"] - wcached "menu" 0 $ - b << "BASIC" - ++> br ++> wlink CountI << b << "increase an Int" - <|> br ++> wlink CountS << b << "increase a String" - <|> br ++> wlink Select << b << "select options" - <|> br ++> wlink CheckBoxes << b << "checkboxes" - <|> br ++> wlink Radio << b << "Radio buttons" - - <++ br <> br <> b << "WIDGET ACTIONS & CALLBACKS" - <|> br ++> wlink Action << b << "Example of action, executed when a widget is validated" - <|> br ++> wlink FViewMonad << b << "in page flow: sum of three numbers" - <|> br ++> wlink Counter << b << "Counter" - <|> br ++> wlink Multicounter << b << "Multicounter" - <|> br ++> wlink Combination << b << "combination of three active widgets" - <|> br ++> wlink WDialog << b << "modal dialog" - - <++ br <> br <> b << "DYNAMIC WIDGETS" - <|> br ++> wlink Ajax << b << "AJAX example" - <|> br ++> wlink Autocomp << b << "autocomplete" - <|> br ++> wlink AutocompList << b << "autocomplete List" - <|> br ++> wlink ListEdit << b << "list edition" - <|> br ++> wlink Grid << b << "grid" - <|> br ++> wlink TextEdit << b << "Content Management" - <++ br <> br <> b << "STATEFUL PERSISTENT FLOW" - <> br <> a ! href (attr "/shop") << "shopping" -- ordinary Blaze.Html link - - <> br <> br <> b << "OTHERS" - <|> br ++> wlink Login << b << "login/logout" - <|> br ++> wlink PreventBack << b << "Prevent going back after a transaction" - - - - case r of - CountI -> clickn (0 :: Int) - CountS -> clicks "1" - Action -> actions 1 - Ajax -> ajaxsample - Select -> options - CheckBoxes -> checkBoxes - TextEdit -> textEdit - Grid -> grid - Autocomp -> autocomplete1 - AutocompList -> autocompList - ListEdit -> wlistEd - Radio -> radio - Login -> loginSample - PreventBack -> preventBack - Multicounter-> multicounter - FViewMonad -> sumInView - Counter -> counter - Combination -> combination - WDialog -> wdialog1 - -wdialog1= ask wdialogw--wdialogw= pageFlow "diag" $ do - r <- wform $ p<< "please enter your name" ++> getString (Just "your name") <** submitButton "ok" - wdialog "({modal: true})" "question" $ - p << ("Do your name is \""++r++"\"?") ++> getBool True "yes" "no" <** submitButton "ok" -- `wcallback` \q -> if not q then wdialogw- else wlink () << b << "thanks, press here to go to the menu" - - -sumInView= ask $ p << "ask for three numbers in the same page and display the result.\ - \It is possible to modify the inputs and the sum will reflect it" - ++> sumWidget - **> wlink () << text "exit" - -formWidget= wform $ do - (n,s) <- (,) <$> p << "Who are you?" - ++> getString Nothing <! hint "name" <++ br - <*> getString Nothing <! hint "surname" <++ br - <** submitButton "ok" <++ br - - flag <- b << "Do you " ++> getRadio[radiob "work?",radiob "study?"] <++ br - - r<- case flag of - "work?" -> pageFlow "l" - $ Left <$> b << "do you enjoy your work? " - ++> getBool True "yes" "no" - <** submitButton "ok" <++ br - - "study?"-> pageFlow "r" - $ Right <$> b << "do you study in " - ++> getRadio[radiob "University" - ,radiob "High School"] - u <- getCurrentUser - p << ("You are "++n++" "++s) - ++> p << ("And your user is: "++ u) - ++> case r of - Left fl -> p << ("You work and it is " ++ show fl ++ " that you enjoy your work") - ++> noWidget - - Right stu -> p << ("You study at the " ++ stu) - ++> noWidget - - -hint s= [("placeholder",s)] -onClickSubmit= [("onclick","if(window.jQuery){\n\ - \$(this).parent().submit();}\n\ - \else {this.form.submit()}")] -radiob s n= wlabel (text s) $ setRadio s n <! onClickSubmit - -sumWidget= do - n1 <- p << "Enter first number" ++> getInt Nothing <** submitButton "enter" <++ br - n2 <- p << "Enter second number" ++> getInt Nothing <** submitButton "enter" <++ br - n3 <- p << "Enter third number" ++> getInt Nothing <** submitButton "enter" <++ br - p << ("The result is: "++show (n1 + n2 + n3)) ++> wlink () << b << " menu" - <++ p << "you can change them to see the result" - - - -combination = ask $ - p << "Three active widgets in the same page with autoRefresh. Each widget refresh itself \ - \with Ajax. If Ajax is not active, they will refresh by sending a new page." - ++> hr - ++> p << "Login widget (use admin/admin)" ++> autoRefresh (pageFlow "r" wlogin) <++ hr - **> p << "Counter widget" ++> autoRefresh (pageFlow "c" (counterWidget 0)) <++ hr - **> p << "Dynamic form widget" ++> autoRefresh (pageFlow "f" formWidget) <++ hr - **> wlink () << b << "exit" - -wlogin :: View Html IO () -wlogin= wform (do - username <- getCurrentUser - if username /= anonymous - then return username - else do - name <- getString Nothing <! hint "username" <++ br - pass <- getPassword <! focus <** submitButton "login" <++ br - val <- userValidate (name,pass) - case val of - Just msg -> notValid msg - Nothing -> login name >> return name) - - `wcallback` (\name -> b << ("logged as " ++ name) - ++> p << ("navigate away of this page before logging out") - ++> wlink "logout" << b << " logout") - `wcallback` const (logout >> wlogin) - -focus = [("onload","this.focus()")] - - -multicounter= do - let explain= p << "This example emulates the" - <> a ! href (attr "http://www.seaside.st/about/examples/multicounter?_k=yBJEDEGp") - << " seaside example" - <> p << "It uses various copies of the " <> a ! href (attr "/noscript/counter") << "counter widget " - <> text "instantiated in the same page. This is an example of how it is possible to " - <> text "compose widgets with independent behaviours" - - ask $ explain ++> add (counterWidget 0) [1,2] <|> wlink () << p << "exit" - - -add widget list= firstOf [pageFlow (show i) widget <++ hr | i <- list] - -counter1= do - ask $ wlink "p" <<p<<"press here" - ask $ pageFlow "c" $ ex [ wlink i << text (show (i :: Int)) | i <- [1..] ] - where - - ex (a:as)= a >> ex as -counter= do - let explain= p <<"This example emulates the" - <> a ! href (attr "http://www.seaside.st/about/examples/counter") << "seaside counter example" - <> p << "This widget uses a callback to permit an independent" - <> p << "execution flow for each widget." <> a ! href (attr "/noscript/multicounter") << "Multicounter" <> (text " instantiate various counter widgets") - <> p << "But while the seaside case the callback update the widget object, in this case" - <> p << "the callback call generates a new copy of the counter with the value modified." - - ask $ explain ++> pageFlow "c" (counterWidget 0) <++ br <|> wlink () << p << "exit" - -counterWidget n= do - (h2 << show n !> show n - ++> wlink "i" << b << " ++ " - <|> wlink "d" << b << " -- ") - `wcallback` - \op -> case op of - "i" -> counterWidget (n + 1) !> "increment" - "d" -> counterWidget (n - 1) !> "decrement" - -rpaid= unsafePerformIO $ newMVar (0 :: Int) - - -preventBack= do - ask $ wlink () << b << "press here to pay 100000 $ " - payIt - paid <- liftIO $ readMVar rpaid - preventGoingBack . ask $ p << "You already paid 100000 before" - ++> p << "you can no go back until the end of the buy process" - ++> wlink () << p << "Please press here to continue" - ask $ p << ("you paid "++ show paid) - ++> wlink () << p << "Press here to go to the menu or press the back button to verify that you can not pay again" - where - payIt= liftIO $ do - print "paying" - paid <- takeMVar rpaid - putMVar rpaid $ paid + 100000 - -options= do - r <- ask $ getSelect (setSelectedOption "" (p << "select a option") <|> - setOption "red" (b << "red") <|> - setSelectedOption "blue" (b << "blue") <|> - setOption "Green" (b << "Green") ) - <! dosummit - ask $ p << (r ++ " selected") ++> wlink () (p << " menu") - - - where - dosummit= [("onchange","this.form.submit()")] - -checkBoxes= do - r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << "red") - <> (setCheckBox False "Green" <++ b << "green") - <> (setCheckBox False "blue" <++ b << "blue")) - <** submitButton "submit" - - - ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") - - -autocomplete1= do - r <- ask $ p << "Autocomplete " - ++> p << "when su press submit, the box value is returned" - ++> wautocomplete Nothing filter1 <! hint "red,green or blue" - <** submitButton "submit" - ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") - - where - filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] - -autocompList= do - r <- ask $ p << "Autocomplete with a list of selected entries" - ++> p << "enter and press enter" - ++> p << "when su press submit, the entries are returned" - ++> wautocompleteList "red,green,blue" filter1 ["red"] - <** submitButton "submit" - ask $ p << ( show r ++ " selected") ++> wlink () (p << " menu") - - where - filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] - -grid = do - let row _= tr <<< ( (,) <$> tdborder <<< getInt (Just 0) - <*> tdborder <<< getString (Just "") - <++ tdborder << delLink) - addLink= a ! href (attr "#") - ! At.id (attr "wEditListAdd") - << "add" - delLink= a ! href (attr "#") - ! onclick (attr "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)") - << "delete" - tdborder= td ! At.style (attr "border: solid 1px") - - r <- ask $ addLink ++> ( wEditList table row ["",""] "wEditListAdd") <** submitButton "submit" - ask $ p << (show r ++ " returned") - ++> wlink () (p << " back to menu") - - - -wlistEd= do - r <- ask $ addLink - ++> br - ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd") - <++ br - <** submitButton "send" - - ask $ p << (show r ++ " returned") - ++> wlink () (p << " back to menu") - - - where - addLink = a ! At.id (attr "wEditListAdd") - ! href (attr "#") - $ b << "add" - delBox = input ! type_ (attr "checkbox") - ! checked (attr "") - ! onclick (attr "this.parentNode.parentNode.removeChild(this.parentNode)") - getString1 mx= El.div <<< delBox ++> getString mx <++ br - - -clickn n= do - r <- ask $ p << b << "increase an Int" - ++> wlink "menu" << p << "menu" - |+| getInt (Just n) <* submitButton "submit" - case r of - (Just _,_) -> return () -- ask $ wlink () << p << "thanks" - (_, Just n') -> clickn $ n'+1 - - -clicks s= do - s' <- ask $ p << b << "increase a String" - ++> p << b << "press the back button to go back to the menu" - ++>(getString (Just s) - <* submitButton "submit") - `validate` (\s -> return $ if length s > 5 then Just (b << "length must be < 5") else Nothing ) - clicks $ s'++ "1" - - -radio = do - r <- ask $ p << b << "Radio buttons" - ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] - - ask $ p << ( show r ++ " selected") ++> wlink () << p << " menu" - -ajaxsample= do - r <- ask $ p << b << "Ajax example that increment the value in a box" - ++> do - let elemval= "document.getElementById('text1').value" - ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'" - b << "click the box " - ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)] <** submitButton "submit" - ask $ p << ( show r ++ " returned") ++> wlink () << p << " menu" - - ----- recursive action ---actions n=do --- ask $ wlink () (p << "exit from action") --- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) - - -actions n= do - r<- ask $ p << b << "Two boxes with one action each one" - ++> getString (Just "widget1") `waction` action - <+> getString (Just "widget2") `waction` action - <** submitButton "submit" - ask $ p << ( show r ++ " returned") ++> wlink () << p << " menu" - where - action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action" - -data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum, Show,Read , Typeable) - -newtype Cart= Cart (V.Vector Int) deriving Typeable -emptyCart= Cart $ V.fromList [0,0,0] - -shopCart = do - - setHeader $ \html -> p << ( El.span << - "A persistent flow (uses step). The process is killed after 100 seconds of inactivity \ - \but it is restarted automatically. Event If you restart the whole server, it remember the shopping cart\n\n \ - \Defines a table with links enclosed that return ints and a link to the menu, that abandon this flow.\n\ - \The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events." - - <> html) - setTimeouts 100 (60 * 60) - shopCart1 - where - shopCart1 = do - o <- step . ask $ do - let moreexplain= p << "The second parameter of \"setTimeout\" is the time during which the cart is recorded" - Cart cart <- getSessionData `onNothing` return emptyCart - - moreexplain - ++> - (table ! At.style (attr "border:1;width:20%;margin-left:auto;margin-right:auto") - <<< caption << "choose an item" - ++> thead << tr << ( th << b << "item" <> th << b << "times chosen") - ++> (tbody - <<< tr ! rowspan (attr "2") << td << linkHome - ++> (tr <<< td <<< wlink IPhone (b << "iphone") <++ td << ( b << show ( cart V.! 0)) - <|> tr <<< td <<< wlink IPod (b << "ipod") <++ td << ( b << show ( cart V.! 1)) - <|> tr <<< td <<< wlink IPad (b << "ipad") <++ td << ( b << show ( cart V.! 2))) - <++ tr << td << linkHome - )) - let i =fromEnum o - Cart cart <- getSessionData `onNothing` return emptyCart - setSessionData . Cart $ cart V.// [(i, cart V.! i + 1 )] - shopCart1 - - where - linkHome= a ! href (attr $ "/" ++ noScript) << b << "home" - - -loginSample= do - ask $ p << "Please login with admin/admin" - ++> userWidget (Just "admin") userLogin - user <- getCurrentUser - ask $ b << ("user logged as " <> user) ++> wlink () << p << " logout and go to menu" - logout - - - -textEdit= do - let first= p << i << - (El.span << "this is a page with" - <> b << " two " <> El.span << "paragraphs. this is the first") - - second= p << i << "This is the original of the second paragraph" - - - - ask $ p << b << "An example of content management" - ++> first - ++> second - ++> wlink () << p << "click here to edit it" - - - ask $ p << "Please login with admin/admin to edit it" - ++> userWidget (Just "admin") userLogin - - ask $ p << "Now you can click the fields and edit them" - ++> p << b << "to save an edited field, double click on it" - ++> tFieldEd "first" first - **> tFieldEd "second" second - **> wlink () << p << "click here to see it as a normal user" - - logout - - ask $ p << "the user sees the edited content. He can not edit" - ++> tFieldEd "first" first - **> tFieldEd "second" second - **> wlink () << p << "click to continue" - - ask $ p << "When texts are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key" - ++> tField "first" - **> tField "second" - **> p << "End of edit field demo" ++> wlink () << p << "click here to go to menu" - - - -stdheader= html . body - -stdheader1 c= docTypeHtml $ body $ - a ! At.style (attr "-align:center") ! href ( attr "/html/MFlow/index.html") << h1 << "MFlow" - <> br - <> hr - <> (El.div ! At.style (attr "position:fixed;top:40px;left:0%\ - \;width:50%\ - \;margin-left:10px;margin-right:10px") $ - h2 << "Example of some features." --- <> h3 << "This demo uses warp and blaze-html" - - <> br <> c) - <> (El.div ! At.style (attr "position:fixed;top:40px;left:50%;width:50%") $ - h2 << "Documentation" - <> br - <> p << a ! href (attr "/html/MFlow/index.html") << "MFlow package description and documentation" - <> p << a ! href (attr "demos.blaze.hs") << "download demo source code" - <> p << a ! href (attr "https://github.com/agocorona/MFlow/issues") << "bug tracker" - <> p << a ! href (attr "https://github.com/agocorona/MFlow") << "source repository" - <> p << a ! href (attr "http://hackage.haskell.org/package/MFlow") << "Hackage repository" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/11/mflow-now-widgets-can-express.html") << "MFlow: now the widgets can express requirements" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/12/on-spirit-of-mflow-anatomy-of-widget.html") << "On the \"spirit\" of MFlow. Anatomy of a Widget" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2013/01/now-example-of-use-of-active-widget.html") << "MFlow active widgets example" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2013/01/stateful-but-stateless-at-last-thanks.html") << "Stateful, but virtually stateless, thanks to event sourcing" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/11/i-just-added-some-templatingcontent.html") << "Content Management and multilanguage in MFlow" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/10/testing-mflow-applications_9.html") << "Testing MFlow applications" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/09/a.html") << "A Web app. that creates Haskel computations from form responses, that store, retrieve and execute them? It´s easy" - <> p << a ! href (attr "http://haskell-web.blogspot.com.es/2012/09/announce-mflow-015.html") << "ANNOUNCE MFlow 0.1.5 Web app server for stateful processes with safe, composable user interfaces." - )
+ Demos/testREST.hs view
@@ -0,0 +1,26 @@+import MFlow.Wai.Blaze.Html.All++-- 9 pages , each page has a restful link (page = ask)+main= runNavigation "" $ transientNav $ do+ liftIO $ print "start/restart"++ setHeader $ html . body++ option <- page $ wlink "a" << p << "letters " <++ p << "or"+ <|> wlink "1" << p << "numbers"++ case option of+ "1" -> do+ page $ wlink "2" << cont "1"+ page $ wlink "3" << cont "2"+ page $ wlink "4" << cont "3"+ page $ wlink () << "menu"++ "a" -> do+ page $ wlink "b" << cont "a"+ page $ wlink "c" << cont "b"+ page $ wlink "d" << cont "c"+ page $ wlink () << "menu"+++cont x= p << ("page for " ++ x ++ " goto next page")
MFlow.cabal view
@@ -1,6 +1,6 @@ name: MFlow -version: 0.3.0.0 -cabal-version: >=1.6 +version: 0.3.0.1 +cabal-version: >=1.8 build-type: Simple license: BSD3 license-file: LICENSE @@ -70,7 +70,8 @@ category: Web, Application Server author: Alberto Gómez Corona data-dir: "" -extra-source-files: Demos/demos.blaze.hs +extra-source-files: Demos/demos-blaze.hs+ , Demos/testREST.hs , src/MFlow/Hack.hs , src/MFlow/Hack/Response.hs , src/MFlow/Hack/XHtml.hs @@ -90,7 +91,8 @@ utf8-string -any, wai -any, case-insensitive -any, http-types -any, conduit -any, text -any, parsec -any, warp -any, random -any, - blaze-html -any, blaze-markup -any + blaze-html -any, blaze-markup -any+ exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms MFlow.Forms.Admin @@ -103,3 +105,14 @@ buildable: True hs-source-dirs: src . +executable demos-blaze+ build-depends: MFlow -any, RefSerialize -any, TCache -any, directory -any,+ Workflow -any, base -any, blaze-html -any, bytestring -any,+ containers == 0.4.2.1, mtl -any, old-time -any, stm -any,+ text -any, transformers -any, vector -any, hamlet -any+ main-is: "demos-blaze.hs"+ ghc-options:+ -threaded+ -rtsopts+ buildable: True+ hs-source-dirs: Demos
src/MFlow.hs view
@@ -129,7 +129,7 @@ class Processable a where pwfname :: a -> String - pwfname= head . pwfPath + pwfname s= head $ pwfPath s !> "head mf" pwfPath :: a -> [String] puser :: a -> String pind :: a -> String
src/MFlow/Forms.hs view
@@ -256,7 +256,7 @@ , flatten, normalize -- * Running the flow monad -,runFlow,runFlowOnce,runFlowIn,runFlowConf,MFlow.Forms.Internals.step, goingBack,breturn, preventGoingBack+,runFlow, transientNav,runFlowOnce,runFlowIn,runFlowConf,MFlow.Forms.Internals.step, goingBack,breturn, preventGoingBack -- * Setting parameters ,setHeader@@ -331,7 +331,7 @@ case me of Just str -> return $ FormElm ( form ++ [inred str]) Nothing - Nothing -> return $ FormElm [] mx + Nothing -> return $ FormElm form mx _ -> return $ FormElm form mx -- | Actions are callbacks that are executed when a widget is validated.@@ -416,17 +416,20 @@ View view m String getPassword = getParam Nothing "password" Nothing -data Radio= Radio String+newtype Radio a= Radio a -- | 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 :: (FormInput view, MonadIO m,+ Read a, Typeable a, Eq a, Show a) => + a -> String -> View view m (Radio a) setRadioActive v n = View $ do st <- get put st{needForm= True} let env = mfEnv st mn <- getParam1 n env- return $ FormElm [finput n "radio" v + let str = if typeOf v == typeOf(undefined :: String)+ then unsafeCoerce v else show v+ return $ FormElm [finput n "radio" str ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()")] (fmap Radio $ valToMaybe mn) @@ -442,21 +445,24 @@ -- | 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 :: (FormInput view, MonadIO m,+ Read a, Typeable a, Eq a, Show a) => + a -> String -> View view m (Radio a) setRadio v n= View $ do st <- get put st{needForm= True} let env = mfEnv st mn <- getParam1 n env- return $ FormElm [finput n "radio" v + let str = if typeOf v == typeOf(undefined :: String)+ then unsafeCoerce v else show v+ return $ FormElm [finput n "radio" str ( isValidated mn && v== fromValidated mn) Nothing] (fmap Radio $ valToMaybe mn) -- | encloses a set of Radio boxes. Return the option selected getRadio :: (Monad m, Functor m, FormInput view) =>- [String -> View view m Radio] -> View view m String+ [String -> View view m (Radio a)] -> View view m a getRadio rs= do id <- genNewId Radio r <- firstOf $ map (\r -> r id) rs@@ -482,7 +488,7 @@ 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+ mn= if null strs then Nothing else Just $ head strs !> "head 3" val = inSync st let ret= case val of -- !> show val of True -> Just $ CheckBoxes strs -- !> show strs@@ -640,37 +646,54 @@ st <- get let env = mfEnv st put st{needForm= True}- FormElm form mr <- (runView opts) r <- getParam1 tolook env+ setSessionData $ fmap MFOption $ valToMaybe r+ FormElm form mr <- (runView opts) + return $ FormElm [fselect tolook $ mconcat form] $ valToMaybe r -data MFOption a= MFOption +newtype MFOption a= MFOption a deriving Typeable+ 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- :: (Monad m, Show a, Typeable a, FormInput view) =>+ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) => a -> view -> View view m (MFOption a)-setOption n v = setOption1 n v False+setOption n v = do+ mo <- getSessionData+ case mo of+ Nothing -> setOption1 n v False+ Just Nothing -> setOption1 n v False+ Just (Just (MFOption o)) -> setOption1 n v $ n == o -- | Set the selected option for getSelect. Options are concatenated with `<|>` setSelectedOption- :: (Monad m, Show a, Typeable a, FormInput view) =>+ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) => a -> view -> View view m (MFOption a)-setSelectedOption n v= setOption1 n v True+setSelectedOption n v= do+ mo <- getSessionData+ case mo of+ Nothing -> setOption1 n v True+ Just Nothing -> setOption1 n v True+ Just (Just o) -> setOption1 n v $ n == o+ setOption1 :: (FormInput view, - Monad m, Typeable a, Show a) => + Monad m, Typeable a, Eq 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 + let n = if typeOf nam == typeOf(undefined :: String)+ then unsafeCoerce nam+ else show nam+ + return . FormElm [foption n val check] . Just $ MFOption nam -- | Enclose Widgets within some formating. @@ -742,7 +765,7 @@ infixl 8 <! widget <! attribs= View $ do FormElm fs mx <- runView widget- return $ FormElm (head fs `attrs` attribs:tail fs) mx+ return $ FormElm (head fs `attrs` attribs:tail fs) mx !> "head 4" -- case fs of -- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx -- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs@@ -1026,7 +1049,9 @@ put st'{newAsk= True , mfEnv=[] ,mfPageIndex=Nothing- ,mfPIndex= length (mfPath st') -1+ ,mfPIndex= case isJust $ mfPageIndex st' of+ True -> length (mfPath st') -1+ False -> mfPIndex st' } breturn x@@ -1116,7 +1141,7 @@ updateParams False _ req= req !> "NOT IN PAGE FLOW" updateParams True env req= let params= takeWhile isparam env- fs= fst $ head req+ fs= fst $ head req !> "head 1" parms= (case findIndex (\p -> fst p == fs) params of Nothing -> params Just i -> take i params)@@ -1273,8 +1298,10 @@ name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String) then unsafeCoerce x else show x)- index' = mfPIndex st + if linkMatched st then -1 else 0- + if Just (mfPIndex st)== mfPageIndex st then 1 else 0+ index' = mfPIndex st+ + if linkMatched st then -1 else 0+ + if Just (mfPIndex st)== mfPageIndex st then 1 else 0+ index = if index'== 0 then 1 else index' lpath = mfPath st @@ -1295,7 +1322,9 @@ return Nothing !> (name ++ " 0 Fail") Just n -> do- modify $ \st -> st{ inSync= True,linkMatched= True,mfPIndex= index+1,mfLinks= M.insert name (n-1) $ mfLinks st}+ modify $ \st -> st{ inSync= True,linkMatched= True+ , mfPIndex= index + 1+ , mfLinks= M.insert name (n-1) $ mfLinks st} !> (name ++" "++ show n ++ " Match") return $ Just x Nothing -> return Nothing !> (name ++ " 0 Fail")@@ -1353,7 +1382,7 @@ 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 + res1= if null res then Nothing else head res !> "head 2" return $ FormElm vs res1 -- | from a list of widgets, it return the validated ones.
src/MFlow/Forms/Blaze/Html.hs view
@@ -25,7 +25,8 @@ import Unsafe.Coerce -- | used to insert html elements within a tag with the appropriate infix priority for the--- other operators used in MFlow+-- other operators used in MFlow. Also it can be used for adding markup to+-- widgets with this signature such are 'wlink' ad 'setOption' (<<) :: ToMarkup a => (Markup -> t) -> a -> t (<<) tag v= tag $ toMarkup v
src/MFlow/Forms/Internals.hs view
@@ -52,7 +52,7 @@ import Debug.Trace -(!>) = const -- flip trace +(!>) = const -- flip trace instance Serialize a => Serializable a where serialize= runW . showp @@ -334,8 +334,18 @@ return $ FormElm (form1 ++ form2) mk Nothing -> - return $ FormElm form1 Nothing + return $ FormElm form1 Nothing+ + View x >> f = View $ do + FormElm form1 mk <- x + case mk of + Just k -> do + modify $ \st -> st{linkMatched= False} !> "------M--------" + FormElm form2 mk <- runView f + return $ FormElm (form1 ++ form2) mk + Nothing -> + return $ FormElm form1 Nothing return = View . return . FormElm [] . Just -- fail msg= View . return $ FormElm [fromStr msg] Nothing @@ -520,7 +530,7 @@ linkMatched :: Bool, mfLinks :: M.Map String Int, - mfAutorefresh :: Bool, + mfAutorefresh :: Bool, mfTrace :: Maybe [String] } deriving Typeable @@ -550,7 +560,10 @@ setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m () setSessionData x= modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)} - ++delSessionData x=+ modify $ \st -> st{mfData= M.delete (typeOf 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 @@ -938,6 +951,23 @@ -- when recovery of a workflow, the MFlow state is not considered when( mfSequence s' /= -1) $ put s' !> (show $ mfSequence s') -- else put s{newAsk=True} return r ++-- | to execute transient flows as if they were persistent+--+-- > transient $ runFlow f === runFlow $ transientNav f+transientNav + :: (Serialize a, + Typeable view, + FormInput view, + Typeable a) => + FlowM view IO a + -> FlowM view (Workflow IO) a +transientNav f= do + s <- get + flowM $ BackT $ do + (r,s') <- lift . unsafeIOtoWF $ runStateT (runBackT $ runFlowM f) s+ put s' + return r --stepWFRef -- :: (Serialize a, @@ -1072,7 +1102,7 @@ installAllRequirements1 v []= return v installAllRequirements1 v rs= do - let typehead= case head rs of {Requirement r -> typeOf r} + let typehead= case head rs !> "head i1" of {Requirement r -> typeOf r} (rs',rs'')= partition1 typehead rs v' <- installRequirements2 rs' installAllRequirements1 (v `mappend` v') rs''
src/MFlow/Forms/Widgets.hs view
@@ -107,7 +107,7 @@ ta= undefined getEdited1 id= do- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))+ 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@@ -116,7 +116,7 @@ B.ByteString -> m [View v m1 a] getEdited id= do r <- getEdited1 id- let (k,ws)= unzip r+ let (_,ws)= unzip r return ws -- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter@@ -126,11 +126,18 @@ => B.ByteString -- ^ identifier -> [View v m1 a] -> m () -- ^ withess delEdited id witness=do- (ks,ws) <- return . unzip =<< getEdited1 id+ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))+ let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored+ return $ ws `asTypeOf` witness- mapM (liftIO . flushCached) ks- setEdited id ([] `asTypeOf` (zip (repeat "") witness))+ liftIO $ mapM flushCached ks+ let stored'= M.delete id stored+ setSessionData . Medit $ stored' +++-- 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@@ -147,13 +154,15 @@ modifyWidget selector modifier w = View $ do ws <- getEdited selector let n = length (ws `asTypeOf` [w])- let key= "widget"++ show selector ++ show n+ let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w) 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 <> "');"-+ where+ typ :: View v Identity a -> a+ typ = undefined -- | 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'@@ -249,6 +258,32 @@ delEdited sel ws' return r +wpush+ :: (Typeable a,+ FormInput v) =>+ (v -> v)+ -> String+ -> String+ -> String+ -> (String -> View v IO a)+ -> View v IO a+wpush holder modifier addId expr w = do+ id1<- genNewId+ let sel= "$('#" <> B.pack id1 <> "')"+ callAjax <- ajax $ \s -> appendWidget sel ( changeMonad $ w s)+ let installevents= "$(document).ready(function(){\+ \$('#"++addId++"').click(function(){"++callAjax expr ++ "});})"++ requires [JScriptFile jqueryScript [installevents] ]++ ws <- getEdited sel++ r <- holder <<< firstOf ws <! [("id",id1)]+ delEdited sel ws+ return r+++ -- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box. wautocomplete :: (Show a, MonadIO m, FormInput v)@@ -584,7 +619,7 @@ Validated (x :: String) -> View $ do let t= mfToken st- FormElm form mr <- runView w+ FormElm form mr <- runView $ insertForm w st <- get let HttpData ctype c s= toHttpData $ mconcat form liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st) (mfCookies st ++ c) s
src/MFlow/Wai.hs view
@@ -57,7 +57,7 @@ p'= reverse p in case p' of [] -> [] - p' -> if T.null $ head p' then reverse(tail p') else p + p' -> if T.null $ head p' then reverse(tail p') else p puser env = fromMaybe anonymous $ fmap SB.unpack $ lookup ( mk $SB.pack cookieuser) $ requestHeaders env
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -27,8 +27,7 @@ ,module Text.Blaze.Html5 ,module Text.Blaze.Html5.Attributes ,module Control.Monad.IO.Class-,runServerTransient-,runServer +,runNavigation ) where import MFlow @@ -45,7 +44,7 @@ import Data.TCache import Text.Blaze.Internal(text) -import Control.Workflow (Workflow) +import Control.Workflow (Workflow, unsafeIOtoWF) import Control.Applicative @@ -54,14 +53,20 @@ import Data.Maybe(fromMaybe) import Data.Char(isNumber) --- | run a transient flow (see 'transient'). The port is read from the first exectution parameter--- if no parameter, it is read from the PORT environment variable.--- if this does not exist, the port 80 is used. -runServerTransient :: FormInput view => FlowM view IO () -> IO Bool-runServerTransient f= do - addMessageFlows[("", transient $ runFlow f)]- porti <- getPort- wait $ run porti waiMessageFlow+---- | run a transient flow (see 'transient'). The port is read from the first exectution parameter+---- if no parameter, it is read from the PORT environment variable.+---- if this does not exist, the port 80 is used. +--runServerTransient :: FormInput view => FlowM view IO () -> IO Bool+--runServerTransient f= do +-- addMessageFlows[("", transient $ runFlow f)]+-- porti <- getPort+-- wait $ run porti waiMessageFlow+--+---- | a more grandiloquent name for runServerTransient+----+---- > runNavigation= runServerTransient+--runNavigation :: FormInput view => FlowM view IO () -> IO Bool+--runNavigation= runServerTransient -- The port is read from the first exectution parameter@@ -83,12 +88,18 @@ -- | run a persistent flow. The port is read from the first exectution parameter -- if no parameter, it is read from the PORT environment variable. -- if this does not exist, the port 80 is used.-runServer :: FormInput view => FlowM view (Workflow IO) () -> IO Bool-runServer f= do- addMessageFlows[("", runFlow f)] +runNavigation :: String -> FlowM Html (Workflow IO) () -> IO Bool+runNavigation n f= do+ addMessageFlows[(n, runFlow f)] porti <- getPort- wait $ run porti waiMessageFlow - - + wait $ run porti waiMessageFlow+ +++---- | a more grandiloquent synonym of runServerTransient+----+---- > runPersNavigation= runServer+--runPersistentNavigation :: FormInput view => FlowM view (Workflow IO) () -> IO Bool +--runPersistentNavigation= runServer