diff --git a/Demos/demos-blaze.hs b/Demos/demos-blaze.hs new file mode 100644 --- /dev/null +++ b/Demos/demos-blaze.hs @@ -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 getString Nothing 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 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 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" <> 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") ) + 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 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) 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| |] + + )) diff --git a/Demos/demos.blaze.hs b/Demos/demos.blaze.hs deleted file mode 100644 --- a/Demos/demos.blaze.hs +++ /dev/null @@ -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 getString Nothing 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 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 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" <> 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") ) - 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 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) 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." - ) diff --git a/Demos/testREST.hs b/Demos/testREST.hs new file mode 100644 --- /dev/null +++ b/Demos/testREST.hs @@ -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") diff --git a/MFlow.cabal b/MFlow.cabal --- a/MFlow.cabal +++ b/MFlow.cabal @@ -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 diff --git a/src/MFlow.hs b/src/MFlow.hs --- a/src/MFlow.hs +++ b/src/MFlow.hs @@ -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 diff --git a/src/MFlow/Forms.hs b/src/MFlow/Forms.hs --- a/src/MFlow/Forms.hs +++ b/src/MFlow/Forms.hs @@ -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 "head 4" -- case fs of -- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx -- _ -> error $ "operator 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. diff --git a/src/MFlow/Forms/Blaze/Html.hs b/src/MFlow/Forms/Blaze/Html.hs --- a/src/MFlow/Forms/Blaze/Html.hs +++ b/src/MFlow/Forms/Blaze/Html.hs @@ -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 diff --git a/src/MFlow/Forms/Internals.hs b/src/MFlow/Forms/Internals.hs --- a/src/MFlow/Forms/Internals.hs +++ b/src/MFlow/Forms/Internals.hs @@ -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'' diff --git a/src/MFlow/Forms/Widgets.hs b/src/MFlow/Forms/Widgets.hs --- a/src/MFlow/Forms/Widgets.hs +++ b/src/MFlow/Forms/Widgets.hs @@ -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 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 diff --git a/src/MFlow/Wai.hs b/src/MFlow/Wai.hs --- a/src/MFlow/Wai.hs +++ b/src/MFlow/Wai.hs @@ -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 diff --git a/src/MFlow/Wai/Blaze/Html/All.hs b/src/MFlow/Wai/Blaze/Html/All.hs --- a/src/MFlow/Wai/Blaze/Html/All.hs +++ b/src/MFlow/Wai/Blaze/Html/All.hs @@ -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