MFlow 0.4.5.5 → 0.4.5.6
raw patch · 39 files changed
+24/−2809 lines, 39 filesdep −MFlowdep −acid-statedep −awsdep ~basedep ~stm
Dependencies removed: MFlow, acid-state, aws, hamlet, hscolour, http-conduit, monad-logger, network, persistent, persistent-sqlite, persistent-template, safecopy, shakespeare, tcache-AWS
Dependency ranges changed: base, stm
Files
- Demos/AcidState.hs +0/−77
- Demos/Actions.hs +0/−17
- Demos/AjaxSample.hs +0/−24
- Demos/AutoCompList.hs +0/−26
- Demos/AutoComplete.hs +0/−27
- Demos/CheckBoxes.hs +0/−22
- Demos/Combination.hs +0/−89
- Demos/ContentManagement.hs +0/−55
- Demos/Counter.hs +0/−43
- Demos/Database.hs +0/−88
- Demos/Dialog.hs +0/−26
- Demos/GenerateForm.hs +0/−182
- Demos/GenerateFormUndo.hs +0/−192
- Demos/GenerateFormUndoMsg.hs +0/−224
- Demos/Grid.hs +0/−41
- Demos/IncreaseInt.hs +0/−25
- Demos/IncreaseString.hs +0/−21
- Demos/InitialConfig.hs +0/−50
- Demos/LazyLoad.hs +0/−35
- Demos/ListEdit.hs +0/−42
- Demos/LoginSample.hs +0/−34
- Demos/MCounter.hs +0/−33
- Demos/MFlowPersistent.hs +0/−89
- Demos/Menu.hs +0/−460
- Demos/Multicounter.hs +0/−33
- Demos/Options.hs +0/−26
- Demos/PreventGoingBack.hs +0/−35
- Demos/PushDecrease.hs +0/−46
- Demos/PushSample.hs +0/−54
- Demos/Radio.hs +0/−20
- Demos/RuntimeTemplates.hs +0/−132
- Demos/SearchCart.hs +0/−122
- Demos/ShopCart.hs +0/−69
- Demos/SumView.hs +0/−31
- Demos/TestREST.hs +0/−60
- Demos/TraceSample.hs +0/−29
- Demos/WebService.hs +0/−61
- Demos/demos-blaze.hs +0/−145
- MFlow.cabal +24/−24
− Demos/AcidState.hs
@@ -1,77 +0,0 @@--- Modified From: https://github.com/acid-state/acid-state/blob/master/examples/HelloDatabase.hs --- Aistis Raulinaitis -{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-} -{-# OPTIONS -XCPP #-} -module AcidState ( -acidState, initAcid -) where - -import Data.Acid - -import Control.Monad.State ( get, put ) -import Control.Monad.Reader ( ask ) -import Data.SafeCopy - --- #define ALONE - -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All - -main = do - db <- initAcid - runNavigation "" . step $ acidState db - -#else - -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu hiding (Database) - -#endif - - - -type Message = String -data Database = Database [Message] - - -initAcid= openLocalStateFrom "Demos/db/" (Database []) - -addMessage :: Message -> Update Database () -addMessage msg = do - Database messages <- get - put $ Database (msg:messages) - -viewMessages :: Int -> Query Database [Message] -viewMessages limit = do - Database messages <- Control.Monad.Reader.ask - return $ take limit messages - -$(deriveSafeCopy 0 'Data.SafeCopy.base ''Database) -$(makeAcidic ''Database ['addMessage, 'viewMessages]) - - -getLast10 :: AcidState (EventState AddMessage) -> IO String -getLast10 database = do - messages <- query database (ViewMessages 10) - return $ concat [ message ++ " " | message <- messages ] - -addMsg :: AcidState (EventState AddMessage) -> Message -> IO () -addMsg database msg = update database (AddMessage msg) - - - - -acidState db= do - r <- page $ h3 << "Persistent message demo." - ++> getString Nothing - <** submitButton "OK" - - liftIO $ addMsg db r - - last10 <- liftIO $ getLast10 db - - page $ b - << ("You typed: "++ r ++ ", it has been added to the acid state db.") - ++> p << ("Here are the last 10 things in the db: " ++ last10) - ++> wlink () << p << "next" - acidState db
− Demos/Actions.hs
@@ -1,17 +0,0 @@- -module Actions (actions) where - -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu - -actions = do - r<- page $ p << b << "Two boxes with one action each one" - ++> getString (Just "widget1") `waction` action - <+> getString (Just "widget2") `waction` action - <** submitButton "submit" - page $ p << ( show r ++ " returned") ++> wlink () << p << " menu" - where - action n= page $ getString (Just $ n ++ " action")<** submitButton "submit action" - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav actions
− Demos/AjaxSample.hs
@@ -1,24 +0,0 @@-{-# OPTIONS -XCPP #-} - -module AjaxSample ( ajaxsample) where - -import Data.Monoid -import Data.ByteString.Lazy.Char8 as B --- #define ALONE -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav ajaxsample -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -ajaxsample= do - r <- page $ 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" - page $ p << ( show r ++ " returned") ++> wlink () << p << " menu" -
− Demos/AutoCompList.hs
@@ -1,26 +0,0 @@-{-# OPTIONS -XCPP #-} -module AutoCompList ( autocompList) where -import Data.List -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav autocompList -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - - -autocompList= do - r <- page $ pageFlow "autoc" $ - p << "Autocomplete with a list of selected entries" - ++> p << "enter and press enter" - ++> p << "when submit is pressed, the entries are returned" - ++> wautocompleteList "red,green,blue" filter1 ["red"] - <** submitButton "submit" - page $ p << ( show r ++ " selected") ++> wlink () (p << " menu") - - where - filter1 s = return $ filter (isPrefixOf s) ["red","red rose","green","green grass","blue","blues"] - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav autocompList
− Demos/AutoComplete.hs
@@ -1,27 +0,0 @@-{-# OPTIONS -XCPP #-} -module AutoComplete ( autocomplete1) where -import Data.List - --- #define ALONE -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav autocomplete1 -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -autocomplete1= do - r <- page $ pageFlow "auto" - $ p << "Autocomplete " - ++> p << "when submit is pressed, the box value is returned" - ++> wautocomplete Nothing filter1 <! hint "red, green or blue" - <** submitButton "submit" - page $ p << (show r ++ " selected") ++> wlink () (p << " menu") - - where - filter1 s = return $ filter (isPrefixOf s) - ["red","red rose","green","green grass","blue","blues"] - -hint s= [("placeholder",s)] -
− Demos/CheckBoxes.hs
@@ -1,22 +0,0 @@-{-# OPTIONS -XCPP #-} -module CheckBoxes ( checkBoxes) where - -import Data.Monoid --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav checkBoxes -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -checkBoxes= do - r <- page $ getCheckBoxes((setCheckBox False "Red" <++ b << "red") - <> (setCheckBox False "Green" <++ b << "green") - <> (setCheckBox False "blue" <++ b << "blue")) - <** submitButton "submit" - - - page $ p << ( show r ++ " selected") ++> wlink () (p << " menu") -
− Demos/Combination.hs
@@ -1,89 +0,0 @@-{-# OPTIONS -XCPP #-} -module Combination ( combination, wlogin1) where -import Counter(counterWidget) -import Data.String --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav combination -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -text= fromString - -combination = page $ - p << "Three active widgets in the same page with autoRefresh. Each widget refresh itself" - ++> p << "with Ajax. If Ajax is not active, they will refresh by sending a new page." - ++> hr - ++> p << "Login widget (use admin/admin)" ++> pageFlow "r" (autoRefresh wlogin1) <++ hr - **> p << "Counter widget" ++> pageFlow "c" (autoRefresh $ counterWidget 0 ) <++ hr - **> p << "Dynamic form widget" ++> pageFlow "f" (autoRefresh formWidget) <++ hr - **> wlink () << b << "exit" - -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 - - - --- | If not logged, it present a page flow which page for the user name, then the password if not logged --- --- If logged, it present the user name and a link to logout --- --- normally to be used with autoRefresh and pageFlow when used with other widgets. -wlogin1 :: View Html IO () -wlogin1 = do - username <- getCurrentUser - if username /= anonymous - then return username - else do - name <- getString Nothing <! hint "username" <++ br - pass <- getPassword <! hint "password" <** 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 >> wlogin1) - -focus = [("onload","this.focus()")] - -
− Demos/ContentManagement.hs
@@ -1,55 +0,0 @@-{-# OPTIONS -XCPP #-} -module ContentManagement ( textEdit) where - -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.Monoid -import Data.TCache.Memoization - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav testEdit -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - - - -editUser= "edituser" - -textEdit= do - userRegister editUser editUser - 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" - - page $ p << b << "An example of content management" - ++> first - ++> second - ++> wlink () << p << "click here to edit it" - - page $ p << "Please login with edituser/edituser to edit it" - ++> userWidget (Just editUser) userLogin - - page $ p << "Now you can click the fields and edit them" - ++> p << b << "to save an edited field, press the save icon in the left" - ++> tFieldEd editUser "first" first - **> tFieldEd editUser "second" second - **> wlink () << p << "click here to see it as a normal user" - - logout - - page $ p << "the user sees the edited content. He can not edit" - ++> tFieldEd editUser "first" first - **> tFieldEd editUser "second" second - **> wlink "a" << p << "click to continue" - - page $ 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" -
− Demos/Counter.hs
@@ -1,43 +0,0 @@-{-# OPTIONS -XCPP -XDeriveDataTypeable #-} -module Counter ( counter, counterWidget) where -import Data.Monoid -import Data.String -import Data.Typeable - --- #define ALONE -- to execute it alone, uncomment this - -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ step counter -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -attr= fromString -text= fromString - -counter= do - page $ explain - ++> pageFlow "c" (counterWidget 0) - <++ br - <|> wlink () << p << "exit" - where - explain= do -- using the blaze-html monad - p << "This example emulates the" - a ! href (attr "http://www.seaside.st/about/examples/counter") << "seaside counter example" - p << "This widget uses a \"callback\" that permit an independent" - text " 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 recursively generates a new copy of the counter with the value modified." - -counterWidget n= - (h2 << show n - ++> wlink "i" << b << " ++ " - <|> wlink "d" << b << " -- ") - `wcallback` - \op -> case op of - "i" -> counterWidget (n + 1) - "d" -> counterWidget (n - 1)
− Demos/Database.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards - , OverloadedStrings, StandaloneDeriving - , ScopedTypeVariables, CPP #-} -module Database where - -import Data.Typeable -import Data.TCache.IndexQuery -import Data.TCache.DefaultPersistence -import Data.TCache.AWS -import Data.Monoid -import qualified Data.Text as T -import Data.String -import Data.ByteString.Lazy.Char8 hiding (index) - - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= do - syncWrite $ Asyncronous 120 defaultCheck 1000 - index idnumber - runNavigation "" $ transientNav grid -#else -import MFlow.Wai.Blaze.Html.All hiding(select, page) -import Menu -#endif - - - --- to run it alone, remove Menu.hs and uncomment this: - ---askm= ask --- ---main= do --- syncWrite $ Asyncronous 120 defaultCheck 1000 --- index idnumber --- runNavigation "" $ step database - -data MyData= MyData{idnumber :: Int, textdata :: T.Text} deriving (Typeable, Read, Show) -- that is enough for file persistence -instance Indexable MyData where - key= show . idnumber -- the key of the register - - -domain= "mflowdemo" - -instance Serializable MyData where - serialize= pack . show - deserialize= read . unpack - setPersist = const . Just $ amazonS3Persist domain -- False - -data Options= NewText | Exit deriving (Show, Typeable) - - - -database= do - liftIO $ index idnumber - database' - - -database'= do - all <- allTexts - - r <- page $ listtexts all - - case r of - NewText -> do - text <- page $ p "Insert the text" - ++> htmlEdit ["bold","italic"] "" -- rich text editor with bold and italic buttons - (getMultilineText "" <! [("rows","3"),("cols","80")]) <++ br - <** submitButton "enter" - - addtext all text -- store the name in the cache (later will be written to disk automatically) - database' - - Exit -> return () - where - menu= wlink NewText << p "enter a new text" <|> - wlink Exit << p "exit to the home page" - - listtexts all = do - h3 "list of all texts" - ++> mconcat[p $ preEscapedToHtml t >> hr | t <- all] - ++> menu - <++ b "or press the back button or enter the URL any other page in the web site" - - addtext all text= liftIO . atomically . newDBRef $ MyData (Prelude.length all) text - allTexts= liftIO . atomically . select textdata $ idnumber .>=. (0 :: Int) -
− Demos/Dialog.hs
@@ -1,26 +0,0 @@-{-# OPTIONS -XCPP #-} -module Dialog (wdialog1) where - --- #define ALONE -- to execute it alone, uncomment this - -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav wdialog1 -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - -wdialog1= do - page wdialogw - page (wlink () << "out of the page flow, press here to go to the menu") - -wdialogw= pageFlow "diag" $ do - r <- 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" -
− Demos/GenerateForm.hs
@@ -1,182 +0,0 @@------------------------------------------------------------------------------ --- --- Module : GenerateForm --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ExistentialQuantification #-} -module GenerateForm ( -genForm -) where -import MFlow.Wai.Blaze.Html.All -import MFlow.Forms.Internals -import Control.Monad.State -import Data.Typeable -import Data.Monoid -import Prelude hiding (div) -import Text.Blaze.Html5.Attributes as At hiding (step,span) -import Data.List(nub) - - - -main=do - userRegister "edituser" "edituser" - runNavigation "nav" . step $ genForm - - --- page with header -hpage w = page $ tFieldEd "editor" "genFormHeader.html" "header" **> w - -genForm= do - id <- getSessionId - let title= "generateForm/"++id ++ "/form.html" - initFormTemplate title - - desc <- hpage $ createForm title - - r <- hpage $ b "This is the form created, asking for input" - ++> hr - ++> generateForm title desc - <++ br - <** pageFlow "button" (submitButton "submit") - - hpage $ h3 "results of the form:" ++> p << show r ++> noWidget - return() - -type Template= String -data WType = Intv | Stringv | TextArea |OptionBox[String] - | WCheckBoxes [String] | Form Template [WType] deriving (Typeable,Read,Show) - -initFormTemplate title= do - liftIO $ writetField title $ - p "( delete this line. Press the save button to save the edits)" - - setSessionData ([] :: [WType]) - setSessionData $ Seq 0 - - -data Result = forall a.(Typeable a, Show a) => Result a deriving (Typeable) - -instance Show Result where - show (Result x)= show x - -genElem Intv= Result <$> getInt Nothing -genElem Stringv= Result <$> getString Nothing -genElem TextArea= Result <$> getMultilineText "" -genElem (OptionBox xs) = - Result <$> getSelect (setSelectedOption ""(p "select a option") <|> - firstOf[setOption op (fromStr op) | op <- xs]) - -genElem (WCheckBoxes xs) = - Result <$> getCheckBoxes(mconcat[setCheckBox False x <++ (fromStr x) | x <- xs]) - -genElem (Form temp desc)= Result <$> generateForm temp desc - -generateForm title xs= - input ! At.type_ "hidden" ! name "p0" ! value "()" - ++> template title - (pageFlow "" $ allOf $ map genElem xs ) - - -createForm title= do - divmenu <<< ( wlogin - **> - do br ++> wlink ("save" :: String) << b "Save the form and continue" - <++ br <> "(when finished)" - getSessionData `onNothing` return [] - <** do - wdesc <- chooseWidget <++ hr - desc <- getSessionData `onNothing` return [] - setSessionData $ mappend desc [wdesc] - content <- liftIO $ readtField mempty title - fieldview <- generateView wdesc - liftIO . writetField title $ content <> br <> fieldview - ) - <** divbody <<< wform (edTemplate "edituser" title (return ()) ) - -divbody= div ! At.style "float:right;width:65%" -divmenu= div ! At.style "background-color:#EEEEEE;float:left;margin-left:10px;margin-right:10px;overflow:auto;" - - -newtype Seq= Seq Int deriving (Typeable) - -generateView desc= View $ do - Seq n <- getSessionData `onNothing` return (Seq 0) - s <- get - let n'= if n== 0 then 1 else n - put s{mfSequence= n'} - FormElm render _ <- runView $ genElem desc - n'' <- gets mfSequence - setSessionData $ Seq n'' - return $ FormElm mempty $ Just ( br <> br <> render :: Html) - - - -chooseWidget= - (p $ a ! At.href "/" $ "home/reset") ++> - - (p <<< do wlink ("text":: String) "text field" - ul <<<(li <<< wlink Intv "returning Int" - <|> li <<< wlink Stringv "returning string")) - - <|> p <<< do wlink TextArea "text area" - - <|> p <<< do - wlink ("check" :: String) "checkBoxes" - ul <<< getOptions "comb" - - <|> p <<< do - wlink ("options" :: String) "options" - ul <<< getOptions "opt" - - - - - - -getOptions pf = - do - r <- wform $ submitButton "create" <|> submitButton "clear" - - case r of - "create" -> do - ops <- getSessionData - case ops of - Nothing -> stop - Just elem -> return elem - "clear" -> do - delSessionData (undefined :: WType) - stop - - <** do - op <- wform $ getString Nothing <! [("size","8") - ,("placeholder","option")] - <** submitButton "add" <++ br - - mops <- getSessionData - ops' <- case (mops,pf) of - (Nothing, "comb") -> do setSessionData $ WCheckBoxes [op] ; return [op] - (Nothing, "opt") -> do setSessionData $ OptionBox [op] ; return [op] - (Just (OptionBox _), "comb") -> do setSessionData $ WCheckBoxes [op] ; return [op] - (Just (WCheckBoxes _),"opt") -> do setSessionData $ OptionBox [op] ; return [op] - (Just (WCheckBoxes ops),"comb") -> do - let ops'= nub $ op:ops - setSessionData . WCheckBoxes $ ops' - return ops' - (Just (OptionBox ops),"opt") -> do - let ops'= nub $ op:ops - setSessionData . OptionBox $ ops' - return ops' - wraw $ mconcat [p << op | op <- ops'] - - - - ---delParam par= modify $ \s -> s{mfEnv=filter ( (par /=) . fst) $ mfEnv s}
− Demos/GenerateFormUndo.hs
@@ -1,192 +0,0 @@------------------------------------------------------------------------------ --- --- Module : GenerateForm --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ExistentialQuantification #-} -module GenerateFormUndo ( -genFormUndo -) where -import MFlow.Wai.Blaze.Html.All -import MFlow.Forms.Internals -import Control.Monad.State -import Data.Typeable -import Data.Monoid -import Prelude hiding (div) -import Text.Blaze.Html5.Attributes as At hiding (step,span) -import Data.List(nub) -import Control.Monad - - -main=do - userRegister "edituser" "edituser" - runNavigation "nav" . step $ genFormUndo - - --- page with header -hpage w = page $ tFieldEd "editor" "genFormUndoHeader.html" "header" **> w - - -genFormUndo= do - id <- getSessionId - let title= "generateForm/"++id ++ "/form.html" - initFormTemplate title - - desc <- createForm 0 title - - r <- hpage $ b "This is the form created, asking for input" - ++> hr - ++> generateForm title desc - <++ br - <** pageFlow "button" (submitButton "submit") - - hpage $ h3 "results of the form:" ++> p << show r ++> noWidget - return() - -type Template= String -data WType = Intv | Stringv | TextArea |OptionBox[String] - | WCheckBoxes [String] | Form Template [WType] deriving (Typeable,Read,Show) - -initFormTemplate title= do - liftIO $ writetField (title ++ show 1) $ - p "( delete this line. Press the save button to save the edits)" - - setSessionData ([] :: [WType]) - setSessionData $ Seq 0 - - -data Result = forall a.(Typeable a, Show a) => Result a deriving (Typeable) - -instance Show Result where - show (Result x)= show x - -genElem Intv= Result <$> getInt Nothing -genElem Stringv= Result <$> getString Nothing -genElem TextArea= Result <$> getMultilineText "" -genElem (OptionBox xs) = - Result <$> getSelect (setSelectedOption ""(p "select a option") <|> - firstOf[setOption op (fromStr op) | op <- xs]) - -genElem (WCheckBoxes xs) = - Result <$> getCheckBoxes(mconcat[setCheckBox False x <++ (fromStr x) | x <- xs]) - -genElem (Form temp desc)= Result <$> generateForm temp desc - -generateForm title xs= - input ! At.type_ "hidden" ! name "p0" ! value "()" - ++> template title - (pageFlow "" $ allOf $ map genElem xs ) - - -createForm n title= do - desc <- getSessionData `onNothing` return [] - Seq seq <- getSessionData `onNothing` return (Seq 0) - - r <- hpage $ do - divmenu <<<(wlogin - **> do - br ++> wlink ("save" :: String) << b "Save the form and continue" - <++ br <> "(when finished)" - content <- liftIO $ readtField (mempty :: Html) (title ++ show n) - liftIO . writetField title $ content - liftIO $ forM_ [1 .. n] $ \n -> writetField (title ++ show n) ("" :: Html) - Just <$> getSessionData `onNothing` return [] - <|> do - wdesc <- chooseWidget <++ hr - setSessionData $ mappend desc [wdesc] - content <- liftIO $ readtField mempty (title ++ show n) - fieldview <- generateView wdesc seq - liftIO . writetField (title ++ show (n+1)) $ content <> br <> fieldview - return Nothing - ) - <** divbody <<< wform (edTemplate "edituser" (title ++ show n) (return ()) ) - case r of - Just desc -> breturn desc - Nothing -> createForm (n+1) title - -divbody= div ! At.style "float:right;width:65%" -divmenu= div ! At.style "background-color:#EEEEEE;float:left;margin-left:10px;margin-right:10px;overflow:auto;" - - -newtype Seq= Seq Int deriving (Typeable) - -generateView desc n= View $ do - s <- get - let n'= if n== 0 then 1 else n - put s{mfSequence= n'} - FormElm render _ <- runView $ genElem desc - n'' <- gets mfSequence - setSessionData $ Seq n'' - return $ FormElm mempty $ Just ( br <> br <> render :: Html) - - - -chooseWidget= - (p $ a ! At.href "/" $ "home") ++> - (p <<< absLink ("" :: String) "reset") **> - (p <<< do wlink ("text":: String) "text field" - ul <<<(li <<< wlink Intv "returning Int" - <|> li <<< wlink Stringv "returning string")) - - <|> p <<< do wlink TextArea "text area" - - <|> p <<< do - wlink ("check" :: String) "checkBoxes" - ul <<< getOptions "comb" - - <|> p <<< do - wlink ("options" :: String) "options" - ul <<< getOptions "opt" - - - - - - -getOptions pf = - do - r <- wform $ submitButton "create" <|> submitButton "clear" - - case r of - "create" -> do - ops <- getSessionData - case ops of - Nothing -> stop - Just elem -> return elem - "clear" -> do - delSessionData (undefined :: WType) - stop - - <** do - op <- wform $ getString Nothing <! [("size","8") - ,("placeholder","option")] - <** submitButton "add" <++ br - - mops <- getSessionData - ops' <- case (mops,pf) of - (Nothing, "comb") -> do setSessionData $ WCheckBoxes [op] ; return [op] - (Nothing, "opt") -> do setSessionData $ OptionBox [op] ; return [op] - (Just (OptionBox _), "comb") -> do setSessionData $ WCheckBoxes [op] ; return [op] - (Just (WCheckBoxes _),"opt") -> do setSessionData $ OptionBox [op] ; return [op] - (Just (WCheckBoxes ops),"comb") -> do - let ops'= nub $ op:ops - setSessionData . WCheckBoxes $ ops' - return ops' - (Just (OptionBox ops),"opt") -> do - let ops'= nub $ op:ops - setSessionData . OptionBox $ ops' - return ops' - wraw $ mconcat [p << op | op <- ops'] - - - - ---delParam par= modify $ \s -> s{mfEnv=filter ( (par /=) . fst) $ mfEnv s}
− Demos/GenerateFormUndoMsg.hs
@@ -1,224 +0,0 @@------------------------------------------------------------------------------ --- --- Module : GenerateForm --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables, ExistentialQuantification #-} -module GenerateFormUndoMsg ( -genFormUndoMsg -) where -import MFlow.Wai.Blaze.Html.All -import MFlow.Forms.Internals -import Control.Monad.State -import Data.Typeable -import Data.Monoid -import Prelude hiding (div) -import Text.Blaze.Html5.Attributes as At hiding (step,span,form) -import Data.List(nub) -import Control.Monad -import Data.List((\\)) ---import Debug.Trace ---(!>)= flip trace - -main=do - userRegister "edituser" "edituser" - runNavigation "nav" . step $ genFormUndoMsg - - --- page with header -hpage w = page $ tFieldEd "editor" "genFormUndoMsgHeader.html" "HEADER EMPTY!" **> w - - - - -genFormUndoMsg= do - id <- getSessionId - let title= "generateForm/"++id ++ "/form.html" - initFormTemplate title - - desc <- createForm 0 title - - - hpage $ b "This is the form created. Test it" - ++> hr - ++> generateForm title desc - **> wlink () "home/reset" - - - - return() - -type Template= String -data WType = Intv | Stringv | TextArea |OptionBox[String] - | WCheckBoxes [String] | ShowResults - | Form Template [WType] deriving (Typeable,Read,Show,Eq) - -initFormTemplate title= do - liftIO $ writetField (title ++ show 1) $ - p "( delete this line. Press the save button to save the edits)" - - setSessionData ([] :: [WType]) - setSessionData $ Seq 0 - - -data Result = forall a.(Typeable a, Show a) => Result a deriving (Typeable) - -instance Show Result where - show (Result x)= show x - -genElem Intv = Result <$> dField (getInt Nothing) -genElem Stringv= Result <$> dField (getString Nothing) -genElem TextArea= Result <$> getMultilineText "" -genElem (OptionBox xs) = - Result <$> getSelect (setSelectedOption ""(p "select a option") <|> - firstOf[setOption op (fromStr op) | op <- xs]) - -genElem (WCheckBoxes xs) = - Result <$> getCheckBoxes(mconcat[setCheckBox False x <++ (fromStr x) | x <- xs]) - -genElem ShowResults = Result <$> do - xs <- getSessionData `onNothing` return [] - pageFlow "" (allOf (map genElem (xs \\ [ShowResults]))) <|> return [] - `wcallback` (\r -> pageFlow "button" $ - submitButton "submit" - **> h2 "Result:" - ++> dField(wraw $ b << show r) - **> return ()) - - - -genElem (Form temp desc)= Result <$> generateForm temp desc - -generateForm title xs= - input ! At.type_ "hidden" ! name "p0" ! value "()" - - ++> (div ! At.id "p0" - <<< input ! type_ "hidden" ! name "p0" ! value"()" - ++> ( template title . pageFlow "" . witerate . pageFlow "" . allOf $ map genElem xs)) - - --- n carries out the version number -createForm n title= do - desc <- getSessionData `onNothing` return [] - Seq seq <- getSessionData `onNothing` return (Seq 0) - - r <- hpage $ do - divmenu <<<(wlogin - **> do - br ++> wlink ("save" :: String) << b "Save the form and continue" - <++ br <> "(when finished)" - content <- liftIO $ readtField (mempty :: Html) (title ++ show n) - liftIO . writetField title $ content - liftIO $ forM_ [1 .. n] $ \n -> writetField (title ++ show n) ("" :: Html) -- delete - desc' <- getSessionData `onNothing` return [] - desc <- addResults title desc' - return $ Just desc - <|> do - wdesc <- chooseWidget <++ hr - addElem (title ++ show n) (title ++ show (n+1)) wdesc - setSessionData $ mappend desc [wdesc] - return Nothing - ) - <** divbody <<< (edTemplate "edituser" (title ++ show n) (return ()) ) - case r of - Just desc -> breturn desc - Nothing -> createForm (n+1) title - --- add a "show results" element to the form if it is not already there -addResults title desc = do - if (null $ filter (== ShowResults) desc) - then do - addElem title title ShowResults - return $ desc ++ [ShowResults] - else return desc - --- add a form elem to the page being edited -addElem title title2 wdesc = do - Seq seq <- getSessionData `onNothing` return (Seq 0) - content <- liftIO $ readtField mempty title - fieldview <- generateView wdesc seq - liftIO . writetField title2 $ content <> br <> fieldview - - -divbody= div ! At.style "float:right;width:65%" -divmenu= div ! At.style "background-color:#EEEEEE;float:left;margin-left:10px;margin-right:10px;overflow:auto;" - - -newtype Seq= Seq Int deriving (Typeable) - -generateView desc n= View $ do - s <- get - let n'= if n== 0 then 1 else n - put s{mfSequence= n'} - FormElm render mr <- runView $ genElem desc - n'' <- gets mfSequence - setSessionData $ Seq n'' - return $ FormElm mempty $ Just ( br <> br <> render :: Html) - - -nrlink x v= wlink x v <! noAutoRefresh - -chooseWidget= pageFlow "" $ autoRefresh $ - (p $ a ! At.class_ "_noAutoRefresh" ! At.href "/" $ "home") - ++>(p <<< absLink ("" ::String) "reset" <! noAutoRefresh) - **> p <<< do - wlink ("text":: String) "text field" - ul <<<(li <<< nrlink Intv "returning Int" - <|> li <<< nrlink Stringv "returning string") - - <|> p <<< do nrlink TextArea "text area" - - <|> p <<< do - wlink ("check" :: String) "checkBoxes" - ul <<< getOptions "comb" - - <|> p <<< do - wlink ("options" :: String) "options" - ul <<< getOptions "opt" - - <|> p <<< nrlink ShowResults "Show Form Results" - - - - -getOptions pf = autoRefresh . wform $ - do - noCache - (op,_) <- (,)<$> getString Nothing <! [("size","8"),("placeholder","option")] - <*> submitButton "add" - <** submitButton "clear" `waction` const (delSessionData (undefined :: WType)) - - mops <- getSessionData - ops' <- case (mops,pf) of - (Nothing, "comb") -> do setSessionData $ WCheckBoxes [op] ; return [op] - (Nothing, "opt") -> do setSessionData $ OptionBox [op] ; return [op] - (Just (OptionBox _), "comb") -> do setSessionData $ WCheckBoxes [op] ; return [op] - (Just (WCheckBoxes _),"opt") -> do setSessionData $ OptionBox [op] ; return [op] - (Just (WCheckBoxes ops),"comb") -> do - let ops'= nub $ op:ops - setSessionData . WCheckBoxes $ ops' - return ops' - (Just (OptionBox ops),"opt") -> do - let ops'= nub $ op:ops - setSessionData . OptionBox $ ops' - return ops' - wraw $ mconcat [p << op | op <- ops'] - - **> do - r <- submitButton "create" <! noAutoRefresh - ops <- getSessionData - case ops of - Nothing -> stop - Just elem -> do - delSessionData (undefined :: WType) - return elem - -
− Demos/Grid.hs
@@ -1,41 +0,0 @@-{-# OPTIONS -XCPP #-} -module Grid ( grid) where - -import Data.String -import Text.Blaze.Html5.Attributes as At hiding (step) - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav grid -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - -attr= fromString - -grid = do - r <- page $ pageFlow "grid" - $ addLink - ++> wEditList table row ["",""] "wEditListAdd" - <** submitButton "submit" - - page $ p << (show r ++ " returned") - ++> wlink () (p << " back to menu") - - where - 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") -
− Demos/IncreaseInt.hs
@@ -1,25 +0,0 @@-{-# OPTIONS -XCPP #-} -module IncreaseInt ( clickn) where - --- #define ALONE -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" . transientNav $ clickn 0 -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - --- |+| add a widget before and after another and return both results. --- in this case, a link wraps a form field - -clickn :: Int -> FlowM Html IO () -clickn n= do - r <- page $ p << b << "increase an Int" - ++> wlink "menu" << p << "menu" - |+| getInt (Just n) <* submitButton "submit" - - case r of - (Just _,_) -> return () -- page $ wlink () << p << "thanks" - (_, Just n') -> clickn $ n'+1 -
− Demos/IncreaseString.hs
@@ -1,21 +0,0 @@-{-# OPTIONS -XCPP #-} -module IncreaseString ( clicks) where - - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav grid -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - -clicks s= do - s' <- page $ 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" -
− Demos/InitialConfig.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} - - -module InitialConfig (initialConfig) where -import Data.Typeable -import Data.String(fromString) - - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All as MF -main= runNavigation "" initialConfig -#else -import MFlow.Wai.Blaze.Html.All as MF hiding(retry, page) -import Menu -#endif - -data Skin= Normal | Blue | Red deriving (Read,Show,Typeable, Bounded, Enum) - -initialConfig= do - mskin <- getSessionData - skin <- case mskin of - Nothing -> do - s <- step . page $ p << "choose skin" - ++> wlink Normal << p << "normal" - <|> wlink Blue << p << "blue" - <|> wlink Red << p << "red" - setSessionData s - return s - Just sk -> return sk - step $ restOfTheFlow skin - - where - restOfTheFlow skin = do - r <- page $ p << ("skin chosen so far: "++ show skin) - ++> p << ("you choosen the skin " ++ show skin) - ++> wlink "change" << MF.div << "Change the skin" - <++ br - <|> wlink "doOther" << p << "other things" - case r of - "change" -> breturn () - _ ->do - page $ p << ("skin chosen so far: "++ show skin) - ++> p << "other things" - ++> a ! href (fromString "http://www.google.com") << p << "google" - ++> br - ++> wlink() << p << "press here to return to the salutation" - restOfTheFlow skin - -
− Demos/LazyLoad.hs
@@ -1,35 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings #-} -module LazyLoad (lazyLoad) where -import Data.Typeable -import Data.String --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "lazy" . transientNav $ do - setHeader $ docTypeHtml . body - lazyLoad -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -data Opts= Sequence | Recursive deriving(Show, Typeable) - -lazyLoad= do - r <- page $ wlink Sequence << p "Lazy present the 20 numbers" - <|> wlink Recursive << p "present 20 numbers lazily recursive" - n <- case r of - Sequence -> page $ pageFlow "lazy" $ lazyPresent (0 :: Int) 20 - Recursive -> page $ pageFlow "lazy" $ lazyPresentR (0 :: Int) 20 - page $ wlink () << p << (show n ++ " selected. Go to home" ) - -lazyPresent i n= firstOf[lazy spinner (wlink i $ p << (show i) ) | i <- [i..n :: Int]] - -lazyPresentR i n - | i == n= noWidget - | otherwise= wlink i << p << (show i) <|> lazy spinner (lazyPresentR (i+1) n) - -spinner= img ! src (fromString spinnerurl) - where - spinnerurl= getConfig "spinner" "//ganglia.wikimedia.org/latest/img/spinner.gif" -
− Demos/ListEdit.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-} -module ListEdit ( wlistEd) where - -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.String --- #define ALONE -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav wlistEd -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - - - - -wlistEd= do - r <- page $ pageFlow "listed" $ - addLink - ++> br - ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd") - <++ br - <** submitButton "send" - - page $ p << (show r ++ " returned") - ++> wlink () (p " back to menu") - - - where - addLink = a ! At.id "wEditListAdd" - ! href "#" - $ b "add" - delBox = input ! type_ "checkbox" - ! checked "" - ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)" - getString1 mx= El.div <<< delBox ++> getString mx <++ br - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav wListEd -
− Demos/LoginSample.hs
@@ -1,34 +0,0 @@-{-# OPTIONS -XCPP #-} -module LoginSample ( loginSample) where - -import Data.Monoid --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runSecureNavigation "" $ transientNav loginSample -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -loginSample= do - userRegister "user" "user" - r <- page $ p << "Please login with user/user" - ++> userWidget Nothing userLogin - <|> wlink "exit" << p << "or exit" - - if r == "exit" then return () else do - user <- getCurrentUser - - r <- page $ b << ("user logged as " <> user) - ++> wlink True << p << "logout" - <|> wlink False << p << "or exit" - - if r - then do - logout - page $ p << "logged out" ++> wlink () << "press here to exit" - else return () - - -
− Demos/MCounter.hs
@@ -1,33 +0,0 @@-{-# OPTIONS -XCPP #-} -module MCounter ( -mcounter -) where -import Data.Monoid -import Data.String --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav grid -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - - - - -mcounter = do - (op,n) <- step . page $ do - n <- getSessionData `onNothing` return (0 :: Int) -- get Int data from the session - op <- h2 << show n - ++> wlink "i" << b << " ++ " - <|> wlink "d" << b << " -- " - - return(op,n) -- unlike in the case of the shopping example where the shopcart is not logged - -- here the state is smaller (the Int counter) anc can be logged - case op of - "i" -> setSessionData (n + 1) - "d" -> setSessionData (n - 1) - - mcounter -
− Demos/MFlowPersistent.hs
@@ -1,89 +0,0 @@--- This example ilustrate the use of MFlow with Persistent --- The code is taken from http://www.yesodweb.com/book/persistent by modifying the first example --- --- The example has a navigation of four pages and you can go forward and backward --- Note how little additions are necessary to change a console oriented application to a Web --- application with MFlow. While the flow looks like an ordinary imperative program, yo can go --- back and forth and to introduce any bookmark without producing navigation errors. --- --- You can press the back button, change the form input and see how the responses match --- the expected register values. - -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE CPP #-} - -module MFlowPersistent - -where - - -import Control.Monad.IO.Class (liftIO) -import Database.Persist -import Database.Persist.Sqlite -import Database.Persist.TH - -import System.IO.Unsafe - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav mFlowPersistent -#else -import MFlow.Wai.Blaze.Html.All hiding(select, page) -import Menu -#endif - - - - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -Person - name String - age Int Maybe - deriving Show -BlogPost - title String - authorId PersonId - deriving Show -|] - - - -pool= unsafePerformIO $ createSqlitePool ":memory:" 10 - -runSQL sql= liftIO $ runSqlPersistMPool sql pool - -migratesqlite= runSQL $ runMigration migrateAll - -mFlowPersistent :: FlowM Html IO () -mFlowPersistent = do - migratesqlite -- should be outside of the flow, in Main - (name, age) <- page $ (,) - <$> getString Nothing <! hint "your name" <++ br - <*> getInt Nothing <! hint "your age" - <** br - ++> submitButton "enter" - - userId <- runSQL $ insert $ Person name $ Just age - - post <- page $ getString Nothing <! hint "your post" <** submitButton "enter" - runSQL $ insert $ BlogPost post userId - - oneUserPost <- runSQL $ selectList [BlogPostAuthorId ==. userId] [LimitTo 1] - - page $ b << show (oneUserPost :: [Entity BlogPost]) ++> br ++> wlink () << b "click here" - - user <- runSQL $ get userId - - page $ b << show (user :: Maybe Person) ++> br ++> wlink () << b "click here" - where - hint h= [("placeholder",h)] - -
− Demos/Menu.hs
@@ -1,460 +0,0 @@------------------------------------------------------------------------------ --- --- Module : Menu --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | This is the menu shared by all the demo modules of demos-blaze.hs --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings , QuasiQuotes #-} -module Menu where -import Data.Typeable -import MFlow.Wai.Blaze.Html.All hiding (article, source,page,ask) -import qualified MFlow.Wai.Blaze.Html.All as MF(page,ask) -import Text.Blaze.Html5 as El hiding (article, source) -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.Monoid -import Data.String -import Data.TCache.Memoization -import Data.TCache.IndexQuery -import Data.List(isPrefixOf) -import Language.Haskell.HsColour -import Language.Haskell.HsColour.Colourise -import Text.Hamlet -import System.IO.Unsafe - - ---import Debug.Trace ---(!>) = flip trace - -newtype Filename= Filename String deriving Typeable - -adminname= getConfig "cadmin" "admin" -edadmin= getConfig "edadmin" "editor" - --- present the widget w decorated with the main menu on the left and the source code at the bottom -page w= MF.ask $ do - us <- getCurrentUser - if us == anonymous then public else private - filename <- getSessionData - tFieldEd edadmin "head" "set Header" - **> (El.div ! At.style "float:right" <<< wlogin ) - <++ hr - **> (divmenu <<< br ++> retry mainMenu) - **> (El.div ! At.style "float:right;width:65%;overflow:auto;" - <<< (insertForm $ widgetAndSource filename w)) - -divmenu= El.div - ! At.style ("background-color:#EEEEEE;float:left\ - \;width:30%;margin-left:10px;margin-right:10px;overflow:auto;") - ---topLogin= El.div ! At.style "float:right;top:5px;left:5px" --- <<< autoRefresh (pageFlow "login" wlogin) - - -ask= page - - -data Options= Wiki | CountI | CountS | Radio - | Login | TextEdit |Grid | Autocomp | AutocompList - | ListEdit |Shop | Action | Ajax | Select - | CheckBoxes | PreventBack | Multicounter - | Combination | ShopCart | MCounter | InitialConfig | SearchCart - | FViewMonad | Counter | WDialog |Push |PushDec |Trace | RESTNav - | Database | MFlowPersist | AcidState - | DatabaseSamples |PushSamples | ErrorTraces | Flows - | BasicWidgets | MonadicWidgets | DynamicWidgets | LoginLogout - | Templates | RuntimeTemplates | LoginWidget | CacheDataset - | ComplexThings | GenerateForm | GenerateFormUndo | GenerateFormUndoMsg - | LazyLoad - deriving (Bounded, Enum,Read, Show,Typeable) - - -auto w= autoRefresh $ public >> maxAge 300 >> w - -mainMenu :: View Html IO Options -mainMenu= pageFlow "menu" $ - ul<<<(li << a ! href "/" << b "HOME" - ++> tFieldEd "editor" "othermenu" "Other menu options" - **> (li <<< (absLink Wiki << b "Wiki") ) - <|> li << (b "About this menu" <> article cascade <> article menuarticle) - ++> hr - ++> ((auto $ li <<< do - absLink BasicWidgets << b "Basic Widgets" - ul <<< - (hr - ++>(li <<< (absLink CountI << b "Increase an Int") <! noAutoRefresh - <++ b " A loop that increases the Int value of a text box" - - <|> li <<< (absLink CountS << b "Increase a String") <! noAutoRefresh - <++ b " A loop that concatenate text in a text box" - - <|> li <<< (absLink Select << b "Select options") <! noAutoRefresh - <++ b " A combo box" - - <|> li <<< (absLink CheckBoxes << b "Checkboxes") <! noAutoRefresh - - <|> li <<< (absLink Radio << b "Radio buttons") <! noAutoRefresh - <++ hr))) - - <|> (auto $ li <<< do - absLink DynamicWidgets << b "Dynamic Widgets" - <++ " Widgets with Ajax and containers of other widgets" - ul <<< - (hr - ++>(li <<< (absLink Ajax << b "AJAX example") <! noAutoRefresh - <++ " A onclick event in a text box invokes a server procedure that \ - \increment the integer value" - <> article ajaxl - - <|> li <<< (absLink Autocomp << b "autocomplete") <! noAutoRefresh - <++ " Example of autocomplete, a widget which takes the suggested values from a \ - \ server procedure" - - <|> li <<< (absLink AutocompList << b "autocomplete List") <! noAutoRefresh - <++ " Example of a widget that generates a set of return values, suggested by a \ - \ autocomplete input box" - <> article editList - - <|> li <<< (absLink ListEdit << b "list edition") <! noAutoRefresh - <++ " Example of a widget that edit, update and delete a list of user-defined \ - \ widgets" - - <|> li <<< (absLink Grid << b "grid") <! noAutoRefresh - <++ " Example of the same widget In this case, containing a row of two fields,\ - \ aranged in a table" - <> article gridl - <> hr))) - - <|> (auto $ li <<< do - absLink MonadicWidgets << b "Monadic widgets, actions and callbacks" - <++ " autoRefresh, page flows, dialogs etc" - ul <<< - (hr - ++>(li <<< (absLink Action << b "Example of action") <! noAutoRefresh - <++ " executed when a widget is validated" - - <|> li <<< (absLink FViewMonad << b "in page flow: sum of three numbers") <! noAutoRefresh - <++ " Page flows are monadic widgets that modifies themselves in the page" - <> article pageflow - - <|> li <<< (absLink Counter << b "Counter") <! noAutoRefresh - <++ " A page flow which increases a counter by using a callback" - <> article callbacks - - <|> li <<< (absLink Multicounter << b "Multicounter") <! noAutoRefresh - <++ " Page flow with many independent counters with autoRefresh, so they modify themselves in-place" - <> article callbacks - - <|> li <<< (absLink Combination << b "Combination of three dynamic widgets") <! noAutoRefresh - <++ " Combination of autoRefreshe'd widgets in the same page, with\ - \ different behaviours" - <> article combinationl - - <|> li <<< (absLink WDialog << b "Modal dialog") <! noAutoRefresh - <++ " A modal Dialog box with a form within a page flow" - <> hr))) - - <|> (auto $ li <<< do - absLink DatabaseSamples << b "Database examples" - <++ " with different backends" - ul <<< - (hr - ++>(li <<< (absLink SearchCart << b "Shopping with data tier, queries and full text search") <! noAutoRefresh - <++ " The shopping example completed with a dynamic catalog stored using TCache" - <> article searchcart - - <|> li <<< (absLink MFlowPersist << b "Persistent") <! noAutoRefresh - <++ do -- blaze-html monad - " illustrates the use of MFlow with " - a "Persistent" ! href yesodweb - " (In this example sqlite backend is used) " - article persistentarticle - - <|> li <<< (absLink Database << b "Database") <! noAutoRefresh - <++ " Create, Store and retrieve lines of text from Amazon SimpleDB \ - \ storage " - <> article amazonarticle - <|> li <<< (absLink AcidState << b "Acid State") <! noAutoRefresh - <++ do -- blaze-html monad - " Create, Store and retrieve lines of text from " - a ! href "http://hackage.haskell.org/package/acid-state" $ "Acid State" - hr))) - - <|> (auto $ li <<< do - absLink PushSamples << b "Push Samples" - <++ " using long polling" - ul <<< - (hr - ++>(li <<< (absLink Push << b "Push example") <! noAutoRefresh - <++ " A push widget in append mode receives input from \ - \a text box with autorefresh" - <> article pushl - - <|> li <<< (absLink PushDec << b "A push counter") <! noAutoRefresh - <++ " Show a countdown. Then goes to the main menu" - <> article pushdec - <> hr))) - - <|> (auto $ li <<< do - absLink ErrorTraces << b "Error Traces" - ul <<< - (hr - ++>(li <<< (absLink Trace << b " Execution traces for errors") <! noAutoRefresh - <++ " produces an error and show the complete execution trace" - <> article errorTrace - <> hr))) - - <|> (auto $ li <<< do - absLink Flows << b "Different kinds of flows" - ul <<< - (hr - ++>(li <<< (absLink RESTNav << b " REST navigation") <! noAutoRefresh - <++ " Navigates trough menus and a sucession of GET pages" - <> article navigation - - - <|> li <<< (absLink ShopCart << b "Stateful persistent flow: shopping") <! noAutoRefresh - <++ " Add articles to a persistent shopping cart stored in the session log." - <> i " getSessionData is read in the View monad to get the most recent shopping cart\ - \even when the back button has been pressed" - <> article stateful - - <|> li <<< (absLink SearchCart << b "Shopping with data tier, queries and full text search") <! noAutoRefresh - <++ " The shopping example completed with a dynamic catalog stored using TCache" - <> article searchcart - - <|> li <<< (absLink MCounter << b "Persistent stateful flow: Counter") <! noAutoRefresh - <++ " a persistent counter. It uses the same mechanism than shopping, but it is\ - \a more simple example" - - <|> li <<< (absLink PreventBack << b "Prevent going back after a transaction") <! noAutoRefresh - <++ " Control backtracking to avoid navigating back to undo something that can not be undone\ - \. For example, a payment" - <> article preventbackl - - <|> li <<< (absLink InitialConfig $ b "Initial Configuration in session parameters") <! noAutoRefresh - <++ " the user is asked for some questions initially that never will be asked again \ - \ unless he likes to change them (all in session parameters)" - - <> hr))) - - - <|> (auto $ li <<< do - absLink Templates << b "Runtime templates" - <++ " Templates and content management modifiable at runtime" - ul <<< - (hr - ++>(li <<< (absLink RuntimeTemplates << b "Runtime templates") <! noAutoRefresh - <++ " Example of form templates and result templates modified at runtime" - <|> li <<< (absLink TextEdit << b "Content Management") <! noAutoRefresh - <++ " Example of content management primitives defined in MFlow.Forms.Widgets" - <> hr))) - - <|> (auto $ li <<< do - absLink LoginLogout << b "Login/logout" - ul <<< (hr ++> (li <<< (absLink Login << b "login/logout") <! noAutoRefresh - <++ " Example of using the login and/or logout" - <> hr))) - - <|> (li <<< (absLink CacheDataset << b "HTTP caching") - <++ " Navigating an infinite dataset in the browser by caching javascript programs\ - \ using the new composable caching directives") - - <|> li <<< absLink LazyLoad << b "Lazy loading of widgets, html, images etc" - - <|> (auto $ li <<< do - absLink ComplexThings << b "Really complex things" <++ " Reference impementations for GUI-like apps" - ul <<< (hr - ++> (li <<< (absLink GenerateForm << b "A form generator and editor") <! noAutoRefresh - <++ " Add widgets and edit the layout. Execute the generated form and see the results") - <|> (li <<< (absLink GenerateFormUndo << b "Form generator with undo") <! noAutoRefresh - <++ " The same above application with undo edits thanks to the backtracking mechanism of MFlow") - - <|> (li <<< (absLink GenerateFormUndoMsg << b "Form generator with no page refreshes") <! noAutoRefresh - <++ " The same above application with no page refresh for menu options. The form page show\ - \ validation errors and results via Ajax using witerate/dField" - - <> hr) )) - - <++ li << (a ! href "/noscript/wiki/webservices" $ b "Web Services")) - - <|> (El.div ! At.style "display:none" <<< mainMenu1)) - - - -- for compatibility with older paths published that did not have two-step cascaded menus - -- so that /noscript/databasesampes/mflowpersist and /noscript/mflowpersist produce the same page - -mainMenu1 :: View Html IO Options -mainMenu1= wcached "menu" 0 $ - wlink MFlowPersist mempty - <|> wlink Database mempty - <|> wlink Push mempty - <|> wlink PushDec mempty - <|> wlink Trace mempty - <|> wlink RESTNav mempty - <|> wlink ShopCart mempty - <|> wlink MCounter mempty - <|> wlink CountI mempty - <|> wlink CountS mempty - <|> wlink Select mempty - <|> wlink CheckBoxes mempty - <|> wlink Radio mempty - <|> wlink Action mempty - <|> wlink FViewMonad mempty - <|> wlink Counter mempty - <|> wlink Multicounter mempty - <|> wlink Combination mempty - <|> wlink WDialog mempty - <|> wlink Ajax mempty - <|> wlink Autocomp mempty - <|> wlink AutocompList mempty - <|> wlink ListEdit mempty - <|> wlink Grid << b "grid" - <|> wlink TextEdit << b "Content Management" - <|> wlink Login << b "login/logout" - <|> wlink PreventBack << b "Prevent going back after a transaction" - - -article link= " " <> a ! At.class_ "_noAutoRefresh" ! href link << i "(article)" - -searchcart= "http://haskell-web.blogspot.com.es/2013/04/mflow-what-about-data-tier-adding-it-to.html" -persistentarticle= "http://haskell-web.blogspot.com.es/2013/08/mflow-using-persistent-with-sqlite.html" -yesodweb= "http://www.yesodweb.com/book/persistent" -amazonarticle= "http://haskell-web.blogspot.com.es/2013/08/using-amazon-web-services-with-tcache.html" -pushdec= "http://haskell-web.blogspot.com.es/2013/07/maxwell-smart-push-counter.html" -pushl= "http://haskell-web.blogspot.com.es/2013/07/new-push-widgets-for-presentation-of.html" -errorTrace= "http://haskell-web.blogspot.com.es/2013/07/automatic-error-trace-generation-in.html" -navigation= "http://haskell-web.blogspot.com.es/2013/07/the-web-navigation-monad.html" -combinationl= "http://haskell-web.blogspot.com.es/2013/06/and-finally-widget-auto-refreshing.html" -pageflow= "http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html" -callbacks= "http://haskell-web.blogspot.com.es/2013/06/callbacks-in-mflow.html" -gridl= "http://haskell-web.blogspot.com.es/2013/01/now-example-of-use-of-active-widget.html" -editList= "http://haskell-web.blogspot.com.es/2012/12/on-spirit-of-mflow-anatomy-of-widget.html" -stateful= "http://haskell-web.blogspot.com.es/2013/04/more-on-session-management-in-mflow.html" -preventbackl= "http://haskell-web.blogspot.com.es/2013/04/controlling-backtracking-in-mflow.html" -ajaxl= "http://hackage.haskell.org/packages/archive/MFlow/0.3.1.0/doc/html/MFlow-Forms.html#g:17" -menuarticle= "http://haskell-web.blogspot.com.es/2013/08/how-to-handle-menus-and-other.html" -cascade="http://haskell-web.blogspot.com.es/2013/10/a-cascade-menu-coded-in-pure.html" - -widgetAndSource Nothing w = w -widgetAndSource (Just(Filename filename)) w = do - source <- getSource filename - El.div <<< tFieldEd edadmin (filename ++ "top") "top text" - <++ hr - **> h1 "Running example" - ++> "(in the light red box):" - ++> (divsample <<< w) --- <** tFieldEd edadmin (filename ++ "bottom") "botom text" - <++ do -- Blaze-html monad - br - hr - h1 $ "Source code:" - source - hr - disquscript - - - where - host = "mflowdemo.herokuapp.com/" - path = "http://" <> host <> "source/" <> filename - download path= p $ "download " <> a ! href path << filename - - sty= "float:bottom\ - \;width:100%\ - \;margin-left:5px;margin-right:10px;overflow:auto;" - -divsample= El.div ! At.style ( "background-color:#FFEEEE;") - -stdheader c= docTypeHtml $ do - El.head $ do - El.title "MFlow examples" - El.meta ! content "text/html; charset=UTF-8" ! httpEquiv "Content-Type" - - - El.style $ "body {\n\ - \font-family: \"rebuchet MS\", \"Helvetica\", \"Arial\", \"Verdana\", \"sans-serif\";\n\ - \font-size: 90.5%;}\n\ - \a:link {text-decoration:none;}\ - \a:visited {text-decoration:none;}\ - \a:hover {text-decoration:underline;}\ - \a:active {text-decoration:underline;}" - - body $ do - [shamlet| - <script> - (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){ - (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o), - m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m) - })(window,document,'script','//www.google-analytics.com/analytics.js','ga'); - - ga('create', 'UA-95693-6', 'mflowdemo.herokuapp.com'); - ga('send', 'pageview'); - - |] - - c - - where - sty= "float:left\ - \;width:100%\ - \;margin-left:5px;margin-right:10px;overflow:auto;" - -showSource w filename = do - setSessionData $ Filename filename - w - - -getSource file = liftIO $ cachedByKey file 0 $ do - source <- readFile $ "Demos/" ++ file - return . preEscapedToHtml - $ "<font size=2>" - ++ hscolour HTML colourPrefs False True file False source - ++ "</font>" - -colourPrefs= unsafePerformIO readColourPrefs - -wiki = page $ do- public >> maxAge 400 >> sMaxAge 300- pagname <- restp <|> return "index" - h1 ! At.style "text-align:center" <<< tFieldEd "editor" (wikip ++pagname ++ "title.html")- (fromString pagname) - **> tFieldEd "editor" (wikip ++ pagname ++ "body.html") "Enter the body"- <++ do- hr- disquscript - - - - -wikip="wiki/" - -disquscript= [shamlet| - <div id="disqus_thread"> - <script type="text/javascript"> - /* * * CONFIGURATION VARIABLES: EDIT BEFORE PASTING INTO YOUR WEBPAGE * * */ - var disqus_shortname = 'mflow'; // required: replace example with your forum shortname - - /* * * DON'T EDIT BELOW THIS LINE * * */ - (function() { - var dsq = document.createElement('script'); dsq.type = 'text/javascript'; dsq.async = true; - dsq.src = '//' + disqus_shortname + '.disqus.com/embed.js'; - (document.getElementsByTagName('head')[0] || document.getElementsByTagName('body')[0]).appendChild(dsq); - })(); - - <noscript>Please enable JavaScript to view the <a href="http://disqus.com/?ref_noscript">comments powered by Disqus. - <a href="http://disqus.com" class="dsq-brlink">comments powered by <span class="logo-disqus">Disqus - - |] - - - -wikientries= return . - filter (isPrefixOf "lmth.eltit" . reverse . fst) . - filter (isPrefixOf wikip . fst) =<< indexOf tfieldKey -
− Demos/Multicounter.hs
@@ -1,33 +0,0 @@-{-# OPTIONS -XCPP #-} -module Multicounter ( multicounter) where - -import Data.Monoid -import Data.String -import Counter(counterWidget) --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav multicounter -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -text= fromString -attr= fromString - -multicounter= page . pageFlow "m" $ explain - ++> firstOf [autoRefresh $ pageFlow (show i) (counterWidget 0) <++ hr | i <- [1..4]] - **> wlink () << p << "exit" - - where - explain= do - p << "This example emulates the" - a ! href (attr "http://www.seaside.st/about/examples/multicounter") - << " 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" - - -
− Demos/Options.hs
@@ -1,26 +0,0 @@-{-# OPTIONS -XCPP #-} -module Options (options) where - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav options -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -options= do - r <- page $ getSelect (setSelectedOption "" (p << "select a option") <|> - setOption "red" (b << "red") <|> - setOption "blue" (b << "blue") <|> - setOption "Green" (b << "Green") ) - <! dosummit - page $ p << (r ++ " selected") ++> wlink () (p << " menu") - - - where - dosummit= [("onchange","this.form.submit()")] - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav options
− Demos/PreventGoingBack.hs
@@ -1,35 +0,0 @@-{-# OPTIONS -XCPP #-} -module PreventGoingBack ( preventBack) where -import System.IO.Unsafe -import Control.Concurrent.MVar - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav preventBack -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - -rpaid= unsafePerformIO $ newMVar (0 :: Int) - - -preventBack= do - page $ wlink "don't care" << b << "press here to pay 100000 $ " - payIt - paid <- liftIO $ readMVar rpaid - preventGoingBack . page $ p << "You already paid 100000 before" - ++> p << "you can not go back until the end of the buy process" - ++> wlink () << p << "Please press here to continue" - - page $ 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 - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav preventBack
− Demos/PushDecrease.hs
@@ -1,46 +0,0 @@-{-# OPTIONS -XQuasiQuotes -XCPP #-} -module PushDecrease ( pushDecrease) where - -import Control.Concurrent.STM -import Text.Hamlet -import Control.Concurrent - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav pushDecrease -#else -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu -#endif - - -atomic= liftIO . atomically - -pushDecrease= do - tv <- liftIO $ newTVarIO 10 - - page $ - [shamlet| - <div> - <h2> Maxwell Smart push counter - <p> This example shows a reverse counter - <p> To avoid unnecessary load, the push process will be killed when reaching 0 - <p> The last push message will be an script that will redirect to the menu" - <h3> This message will be autodestroyed within ... - - |] ++> counter tv <++ b << "seconds" - - where - counter tv = pageFlow "push" . push Html 0 $ do - setTimeouts 2 0 -- kill the thread after 2 s of incactivity, when count finish - n <- atomic $ readTVar tv - if (n== -1) - then do - script << "window.location='/'" ++> noWidget - else do - atomic $ writeTVar tv $ n - 1 - liftIO $ threadDelay 1000000 - h1 << (show n) ++> noWidget - -
− Demos/PushSample.hs
@@ -1,54 +0,0 @@-{-# OPTIONS -XCPP #-} -module PushSample (pushSample) where - -import Control.Concurrent.STM -import System.IO.Unsafe - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav pushSample -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - - - -lastLine = unsafePerformIO $ newTVarIO $ "The content will be appended here" - -pushSample= do - last <- liftIO $ newTVarIO "" - page $ h2 << "Basic Chat as a push example" - ++> hr - ++> pageFlow "push" (push Append 1000 (disp last ) <** input ) - **> br - ++> br - ++> wlink () << b << "exit" - - where - -- the widget being pushed: - disp last = do - setTimeouts 100 0 -- after 100 seconds of inactivity , kill itself, but restart if needed - line <- tget last - p << line ++> noWidget - - input = autoRefresh $ do - line <- getString Nothing <** submitButton "Enter" - tput lastLine line - - - tput tv x = atomic $ writeTVar tv x - - tget last = atomic $ do - msg <- readTVar lastLine - lastmsg <- readTVar last - case lastmsg == msg of - False -> do - writeTVar last msg - return msg - True -> retry - - -atomic= liftIO . atomically -
− Demos/Radio.hs
@@ -1,20 +0,0 @@-{-# OPTIONS -XCPP #-} -module Radio ( radio) where - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav grid -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - -radio = do - r <- page $ p << b << "Radio buttons" - ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] - - page $ p << ( show r ++ " selected") ++> wlink () << p << " menu" - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav radio
− Demos/RuntimeTemplates.hs
@@ -1,132 +0,0 @@--- | example of runtime templates, storage and query by using tcache -{-# OPTIONS -XDeriveDataTypeable -XNoMonomorphismRestriction -XCPP #-} -module RuntimeTemplates where -import Data.TCache.DefaultPersistence -import Data.TCache.IndexQuery -import Control.Workflow.Configuration -import Data.Typeable -import Data.Monoid -import Data.ByteString.Lazy.Char8 as BS hiding (index) -import Control.Exception(SomeException) -import Control.Monad (when) - --- #define ALONE -- to execute it alone, uncomment this - --- Note: there are static links in templates in the main menu. unless they --- are updated using witerate/dField, the main menu of this example will not --- work when the app run alone since the expected paths are different. -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All hiding(name,select,base) -import Debug.Trace -(!>) = flip trace -main= runNavigation "" $ transientNav runtimeTemplates -#else -import MFlow.Wai.Blaze.Html.All hiding(name,select,base, page) -import Menu -#endif - - - -data MyData= MyData{name :: String} deriving (Typeable,Read, Show) - -instance Indexable MyData where key= name -- just to notify what is the key of the register - -instance Serializable MyData where -- default persistence - serialize= pack . show - deserialize= read . unpack - setPersist = \_ -> Just filePersist -- in files - -data Options= NewName | ListNames | Exit deriving (Show, Typeable,Eq) - -newtype NextReg = NextReg Int deriving Typeable - -runtimeTemplates= do - -- runConfiguration is usedd to create some example registers - liftIO $ runConfiguration "createDataforTemplates" $ do - ever $ index name -- index the name field, so I can query for it later - -- better, should put this sentence in main - - -- create ['a'..'z'] entries. Only the first time - -- runConfiguration prevent the execution of this again - once $ atomically $ mapM_ (newDBRef . MyData . return) ['a'..'z'] - process - -process= do - setSessionData $ NextReg 0 - r <- page $ edTemplate "edituser" "menuallnames" - $ wlink NewName << p << "enter a new name" - <|> wlink ListNames << p << "List names" - <|> wlink Exit << p << "Exit to the home page" - - case r of - Exit -> return() - NewName -> do - page $ edTemplate "edituser" "enterallnames" - $ pageFlow "enter" - $ witerate ( - do noCache - name <- dField (getString Nothing `validate` jsval) - <** submitButton "ok" <++ br - -- store the register in the cache - -- Later will be written by the default persistence automatically - liftIO . atomically . newDBRef $ MyData name - **> do - n <- countRegisters - dField (wraw $ b << show n) <++ fromStr " registers added ") - **> wlink () << b << "exit" - - ListNames -> do - -- query for all the names stored in all the registers - allnames <- getAllNames - - let len= Prelude.length allnames - - page $ pageFlow "iter" $ iterateResults allnames len - **> wlink "templ" << p << "click here to show the result within a runtime template" - - setSessionData $ NextReg 0 - page $ edTemplate "edituser" "listallnames" - $ pageFlow "iter" $ iterateResults allnames len - **> wlink "scroll" << p << "click here to present the results as a on-demand-filled scroll list" - - setSessionData $ NextReg 0 - page $ pageFlow "upd" $ appendUpdate ( do - NextReg ind <- getSessionData `onNothing` return (NextReg 0) - getData ind len allnames <++ br - getData (ind+1) len allnames <++ br - getData (ind+2) len allnames <++ br - getData (ind+3) len allnames <++ br - setSessionData . NextReg $ next ind len - wlink "more" << b << "more" <++ br) - - **> wlink () << p << "click here to go to the menu" - - if r == Exit then return() else process - - where - getAllNames= liftIO . atomically $ select name $ name .>. "" - - countRegisters= (getAllNames >>= return . Prelude.length) - - - iterateResults allnames len = witerate $ do - maxAge 300 - NextReg ind <- getSessionData `onNothing` return (NextReg 0) - dField(getData ind len allnames) <++ br - dField(getData (ind+1) len allnames) <++ br - dField(getData (ind+2) len allnames) <++ br - dField(getData (ind+3) len allnames) <++ br - r <- dField (wlink (next ind len) << b << "next" ) <++ fromStr " " - <|> dField (wlink (prev ind len) << b << "prev") - <|> restp - setSessionData $ NextReg r - - - getData i len all= wraw . fromStr $ if i >= len || i < 0 then "" else all !! i - next i len = case i > len of True -> 0 ; _ -> i + 4 - prev i len = case i < 0 of True -> len; _ -> i - 4 - - jsval s= - if Prelude.length s > 10 then do - return $ Just $ b << "length must be less than 10 chars" - else return Nothing
− Demos/SearchCart.hs
@@ -1,122 +0,0 @@-{-# OPTIONS -XCPP -XDeriveDataTypeable #-} -module SearchCart ( - searchCart -) where -import Data.TCache.DefaultPersistence -import Data.TCache.DefaultPersistence -import Data.TCache.IndexQuery as Q -import Data.TCache.IndexText -import Data.Maybe -import qualified Data.Map as M -import Control.Workflow.Configuration -import Control.Workflow (Workflow) -import qualified Data.Text.Lazy as T -import Data.ByteString.Lazy.Char8 -import Data.Typeable - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" searchCart -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - -type ProductName= String -type Quantity= Int -type Price= Float - -type Cart= M.Map ProductName (Quantity, Price) - -showCart :: Cart -> String -showCart = show - - -data Product= Product{ namep :: String - , typep :: [String] - , descriptionp :: String - , pricep :: Price - , stock :: Int} - deriving (Read,Show,Typeable) - -instance Indexable Product where - key prod= "Prod "++ namep prod - -instance Serializable Product where - serialize= pack . show - deserialize= read . unpack - setPersist= const $ Just filePersist - -createProducts= atomically $ mapM newDBRef - [ Product "ipad 3G" ["gadget","pad"] "ipad 8GB RAM, 3G" 400 200 - , Product "ipad" ["gadget","pad"] "ipad 8 GB RAM" 300 300 - , Product "iphone 3" ["gadget","phone"] "iphone 3 nice and beatiful" 200 100 - ] - -searchCart :: FlowM Html (Workflow IO) () -searchCart = do - liftIO $ runConfiguration "createprods" $ do -- better put this in main - ever $ Q.index namep - ever $ indexList typep (Prelude.map T.pack) - ever $ indexText descriptionp T.pack - once createProducts - catalog - where - catalog = do - bought <- step buyProduct - shoppingCart bought - catalog - - - - buyProduct :: FlowM Html IO ProductName - buyProduct = do - ttypes <- atomic $ allElemsOf typep - let types= Prelude.map T.unpack ttypes - r <- page $ h1 << "Product catalog" - ++> p << "search" ++> (Left <$> getString Nothing) - <|> p << "or choose product types" ++> (Right <$> showList types) - - prods <- case r of - Left str -> atomic $ Q.select namep $ descriptionp `contains` str - Right (Just type1) -> atomic $ Q.select namep $ typep `containsElem` type1 - Right Nothing -> return [] - - if Prelude.null prods - then do - page $ b << "no match " ++> wlink () << b << "search again" - buyProduct - else do - let search= case r of - Left str -> "for search of the term " ++ str - Right (Just type1) -> "of the type "++ type1 - - r <- page $ h1 << ("Products " ++ search) ++> showList prods - case r of - Nothing -> buyProduct - Just prod -> breturn prod - - shoppingCart bought= do - cart <- getSessionData `onNothing` return (M.empty :: Cart) - let (n,price) = fromMaybe (0,undefined) $ M.lookup bought cart - (n,price) <- step $ do - if n /= 0 then return (n,price) else do - [price] <- atomic $ Q.select pricep $ namep .==. bought - return (n, price) - setSessionData $ M.insert bought (n+1,price) cart - step $ do - r <- page $ do - cart <- getSessionData `onNothing` return (M.empty :: Cart) - h1 << "Shopping cart:" - ++> p << showCart cart - ++> wlink True << b << "continue shopping" - <|> wlink False << p << "proceed to buy" - - if not r then page $ wlink () << "not implemented, click here" - else breturn () - - - atomic= liftIO . atomically - showList []= wlink Nothing << p << "no results" - showList xs= Just <$> firstOf [wlink x << p << x | x <- xs]
− Demos/ShopCart.hs
@@ -1,69 +0,0 @@-{-# OPTIONS -XDeriveDataTypeable -XCPP #-} -module ShopCart ( shopCart) where -import Data.Typeable -import qualified Data.Vector as V -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.Monoid -import Data.String -import Data.Typeable--- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav grid-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- -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= shopCart1- -shopCart1 = do--- setHeader stdheader --- setTimeouts 200 $ 60*60 - prod <-- step . page $ do - 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")- <++ tdc << ( b << show ( cart V.! 0)) - <|> tr <<< td <<< wlink IPod (b << "ipod")- <++ tdc << ( b << show ( cart V.! 1)) - <|> tr <<< td <<< wlink IPad (b << "ipad")- <++ tdc << ( b << show ( cart V.! 2))) - <++ tr << td << linkHome - ))-- - let i = fromEnum prod- Cart cart <- getSessionData `onNothing` return emptyCart - setSessionData . Cart $ cart V.// [(i, cart V.! i + 1 )] - shopCart1 - - where- tdc= td ! At.style (attr "text-align:center") - linkHome= a ! href (attr $ "/" ++ noScript) << b << "home" - attr= fromString- moreexplain= do- p $ El.span <<( - "A persistent flow (uses step). The process is killed after the timeout set by setTimeouts "++ - "but it is restarted automatically. Event If you restart the whole server, it remember the shopping cart "++- " The shopping cart is not logged, just the products bought returned by step are logged. The shopping cart "++- " is rebuild from the events (that is an example of event sourcing."++ - " .Defines a table with links that return ints and a link to the menu, that abandon this flow. "++ - " .The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events.") -- p << "The second parameter of \"setTimeout\" is the time during which the cart is recorded"
− Demos/SumView.hs
@@ -1,31 +0,0 @@-{-# OPTIONS -XCPP #-} -module SumView (sumInView) where - --- #define ALONE -- to execute it alone, uncomment this -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav grid -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - -sumInView= page $ p << "ask for three numbers in the same page and display the result." - ++> p << "It is possible to modify the inputs and the sum will reflect it" - ++> sumWidget - -sumWidget= pageFlow "sum" $ do - n <- do - n1 <- p << "Enter first number" ++> getInt Nothing <++ br - n2 <- p << "Enter second number" ++> getInt Nothing <++ br - n3 <- p << "Enter third number" ++> getInt Nothing <++ br - return (n1+ n2 + n3) - - -- factoring out the button - <** br ++> pageFlow "button" (submitButton "submit") - - p << ("The result is: "++show n) ++> wlink () << b << " menu" - <++ p << "you can change the numbers in the boxes to see how the result changes" - --- to run it alone, replace page by ask and uncomment the following line ---main= runNavigation "" $ transientNav sumWidget
− Demos/TestREST.hs
@@ -1,60 +0,0 @@-{-# OPTIONS -XCPP #-} -module TestREST(testREST) where -import Data.Monoid -import Data.String - - - --- to execute it alone, uncomment this --- #define ALONE -#ifdef ALONE -import MFlow.Wai.Blaze.Html.All -main= runNavigation "" $ transientNav testREST -#else -import MFlow.Wai.Blaze.Html.All hiding(retry, page) -import Menu -#endif - --- A menu with two branches, each one is a sucession of pages - --- 9 pages , each page has a restful link (pagem = ask) - --- to run it alone, delete "import Menu" and uncomment the next lines - --- main= runNavigation "" $ transientNav testREST - --- pagem= page - - -testREST= do - option <- page options - - case option of - "1" -> do - page $ wlink "2" << contentFor "1" - page $ wlink "3" << contentFor "2" - page $ wlink "4" << contentFor "3" - page $ optionsorexit - return () - - "a" -> do - page $ wlink "b" << contentFor "a" - page $ wlink "c" << contentFor "b" - page $ wlink "d" << contentFor "c" - page $ optionsorexit - return () - -options= h2 << "Choose between:" - ++> absLink "a" << b << "letters " <++ i << " or " - <|> absLink "1" << b << "numbers" - -optionsorexit= options <|> wlink "home" << p << " or go to home" - -- if home is pressed, will return(). Otherwise, it will backtrack to one of the - -- two options since they are abslinks. - -contentFor x= do - p << "page for" - b << x - p << "goto next page" - p << "or press the back button for the previous page" -
− Demos/TraceSample.hs
@@ -1,29 +0,0 @@-{-# OPTIONS -F -pgmF MonadLoc #-} -module TraceSample ( traceSample) where - -import MFlow.Wai.Blaze.Html.All hiding (page) -import Control.Monad.Loc - -import Menu --- to run it alone, remove import menu and uncomment the following line ---main= runNavigation "" $ transientNav traceSample - - -traceSample= do - page $ h2 << "Error trace example" - ++> p << "MFlow now produces execution traces in case of error by making use of the backtracking mechanism" - ++> p << "It is more detailed than a call stack" - ++> p << "this example has a deliberate error" - ++> br - ++> p << "You must be logged as admin to see the trace" - ++> wlink () << p << "pres here" - - page $ p << "Please login with admin/admin" - ++> userWidget (Just "admin") userLogin - - u <- getCurrentUser - page $ p << "The trace will appear after you press the link. press one of the options available at the bottom of the pagem" - ++> p << ("user="++ u) ++> br - ++> wlink () << "press here" - page $ error $ "this is the error" -
− Demos/WebService.hs
@@ -1,61 +0,0 @@- -module WebService where - -import MFlow.Wai.Blaze.Html.All -import MFlow.Forms.WebApi - -import Debug.Trace - - - --- mainRest= runNavigation "apirest" . step $ ask $ -restService :: View Html IO () -restService= do - op <- getRestParam - term1 <- getRestParam - term2 <- getRestParam - case (op, term1,term2) of - (Just "sum", Just x, Just y) -> wrender (x + y :: Int) **> stop - (Just "prod", Just x, Just y) -> wrender (x * y) **> stop - _ ->do -- blaze Html - h1 << "ERROR. API usage:" - h3 << "http://server/apirest/sum/[Int]/[Int]" - h3 << "http://server/apirest/prod/[Int]/[Int]" - ++> stop - - ---mainService= runNavigation "apikv" . step $ ask $ -keyValueService :: View Html IO () -keyValueService= do - op <- getRestParam - term1 <- getKeyValueParam "t1" - term2 <- getKeyValueParam "t2" - case (op, term1,term2) of - (Just "sum", Just x, Just y) -> wrender (x + y :: Int) **> stop - (Just "prod", Just x, Just y) -> wrender (x * y) **> stop - _ ->do -- blaze Html - h1 << "ERROR. API usage:" - h3 << "http://server/apikv/sum?t1=[Int]&t2=[Int]" - h3 << "http://server/apikv/prod?t1=[Int]&t2=[Int]" - ++> stop - ---mainParser = runNavigation "apiparser" . step . asks $ --- or ---mainParser =do --- addMessageFlows[("apiparser",wstateless parserService)] --- wait $ run 80 waiMessageFlow - -parserService :: View Html IO () -parserService= - do rest "sum" ; disp $ (+) <$> wint "t1" <*> wint "t2" - <|> do rest "prod" ; disp $ (*) <$> wint "t1" <*> wint "t2" - <?> do -- blaze Html - h1 << "ERROR. API usage:" - h3 << "http://server/apiparser/sum?t1=[Int]&t2=[Int]" - h3 << "http://server/apiparser/prod?t1=[Int]&t2=[Int]" - where - asks w= ask $ w >> stop - wint p= wparam p :: View Html IO Int - - -
− Demos/demos-blaze.hs
@@ -1,145 +0,0 @@-{-# OPTIONS -XDeriveDataTypeable -XQuasiQuotes -XOverloadedStrings #-} -module Main where -import MFlow.Wai.Blaze.Html.All hiding (name) -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step,name) -import Data.TCache.IndexQuery -import Data.Typeable - - -import Data.Monoid -import Data.String -import Text.Hamlet - --- For error traces -import Control.Monad.Loc - -import Menu hiding (page) -import TestREST -import Actions -import IncreaseInt -import ShopCart -import AjaxSample -import IncreaseString -import AutoCompList -import ListEdit -import AutoComplete -import LoginSample -import CheckBoxes -import Multicounter -import Combination -import Options -import ContentManagement -import PreventGoingBack -import Counter -import PushDecrease -import Dialog -import PushSample -import Grid -import Radio -import SumView -import MCounter -import Database -import MFlowPersistent -import RuntimeTemplates -import TraceSample -import AcidState -import SearchCart -import InitialConfig -import GenerateForm -import GenerateFormUndo -import GenerateFormUndoMsg -import WebService -import CachingDataset -import LazyLoad -import Data.TCache.DefaultPersistence - -import Data.ByteString.Lazy.Char8 hiding (index) - - ---import Debug.Trace ---(!>)= flip trace - - -instance Serializable Int where - serialize= pack . show - deserialize= read . unpack - - -spinner= img ! src (fromString spinnerurl) - where - spinnerurl= getConfig "spinner" "//ganglia.wikimedia.org/latest/img/spinner.gif" - - -main= do - index tfieldKey - - setAdminUser adminname adminname - userRegister edadmin edadmin - userRegister "edituser" "edituser" - syncWrite $ Asyncronous 120 defaultCheck 1000 - db <- initAcid - setFilesPath $ getConfig "filesPath" "Demos/" - addMessageFlows[ - -- Web Services -- - ("apirest", wstateless restService), - ("apikv" , wstateless keyValueService), - ("apiparser", wstateless parserService)] - runNavigation "" $ do - - setHeader $ stdheader - setTimeouts 400 $ 60 * 60 - r <- step . page $ do - us <- getCurrentUser - if us == anonymous then public else private - tFieldEd edadmin "head" "set Header" <++ hr - **> (El.div ! At.style "float:right" <<< wlogin) - **> (divmenu <<< br ++> mainMenu) - <** (El.div ! At.style "float:right;width:65%;overflow:auto;" - <<< (tFieldEd edadmin "intro" "enter intro text" - <** tFieldEd edadmin "moreintro" "more intro text") - <++ do - hr - disquscript - ) - - - case r of - Wiki -> delSessionData (Filename "") >> transientNav wiki - CountI -> transientNav (clickn 0) `showSource` "IncreaseInt.hs" - CountS -> transientNav (clicks "1") `showSource` "IncreaseString.hs" - Action -> transientNav actions `showSource` "Actions.hs" - Ajax -> transientNav ajaxsample `showSource` "AjaxSample.hs" - Select -> transientNav options `showSource` "Options.hs" - CheckBoxes -> transientNav checkBoxes `showSource` "CheckBoxes.hs" - TextEdit -> transientNav textEdit `showSource` "ContentManagement.hs" - Grid -> transientNav grid `showSource` "Grid.hs" - Autocomp -> transientNav autocomplete1 `showSource` "AutoComplete.hs" - AutocompList -> transientNav autocompList `showSource` "AutoCompList.hs" - ListEdit -> transientNav wlistEd `showSource` "ListEdit.hs" - Radio -> transientNav radio `showSource` "Radio.hs" - Login -> transientNav loginSample `showSource` "LoginSample.hs" - PreventBack -> transientNav preventBack `showSource` "PreventGoingBack.hs" - Multicounter-> transientNav multicounter `showSource` "Multicounter.hs" - FViewMonad -> transientNav sumInView `showSource` "SumView.hs" - Counter -> transientNav counter `showSource` "Counter.hs" - Combination -> transientNav combination `showSource` "Combination.hs" - WDialog -> transientNav wdialog1 `showSource` "Dialog.hs" - Push -> transientNav pushSample `showSource` "PushSample.hs" - PushDec -> transientNav pushDecrease `showSource` "PushDecrease.hs" - Trace -> transientNav traceSample `showSource` "TraceSample.hs" - RESTNav -> transientNav testREST `showSource` "TestREST.hs" - Database -> transientNav database `showSource` "Database.hs" - ShopCart -> shopCart `showSource` "ShopCart.hs" - MCounter -> mcounter `showSource` "MCounter.hs" - MFlowPersist -> transientNav mFlowPersistent `showSource` "MFlowPersistent.hs" - RuntimeTemplates -> transientNav runtimeTemplates `showSource` "RuntimeTemplates.hs" - AcidState -> transientNav (acidState db) `showSource` "AcidState.hs" - InitialConfig -> initialConfig `showSource` "InitialConfig.hs" - SearchCart -> searchCart `showSource` "SearchCart.hs" - GenerateForm -> transientNav genForm - GenerateFormUndo -> transientNav genFormUndo - GenerateFormUndoMsg -> transientNav genFormUndoMsg - CacheDataset -> transientNav cachingDataset `showSource` "CachingDataset.hs" - LazyLoad -> transientNav lazyLoad `showSource` "LazyLoad.hs" -
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow -version: 0.4.5.5 +version: 0.4.5.6 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -120,26 +120,26 @@ other-modules: MFlow.Wai.Response -executable demos-blaze - build-depends: MFlow , RefSerialize , TCache , - tcache-AWS , directory , Workflow , base , - blaze-html , bytestring , containers , mtl , - old-time , stm , text , transformers , vector , - hamlet , shakespeare, monadloc , aws , network , hscolour , - persistent-template , persistent-sqlite , persistent , - conduit , http-conduit , monad-logger , safecopy , - time, acid-state - main-is: demos-blaze.hs - buildable: True - hs-source-dirs: Demos - other-modules: TestREST ShopCart AjaxSample TraceSample IncreaseString IncreaseInt - AutoCompList ListEdit AutoComplete Menu RuntimeTemplates - LoginSample CheckBoxes Multicounter MFlowPersistent - Combination Options ContentManagement Database - PreventGoingBack Counter MCounter PushDecrease - Dialog PushSample Grid Radio Actions - SumView AcidState SearchCart - InitialConfig GenerateForm GenerateFormUndo GenerateFormUndoMsg WebService - LazyLoad - ghc-options: -iDemos -threaded -rtsopts - +--executable demos-blaze +-- build-depends: MFlow , RefSerialize , TCache , +-- tcache-AWS , directory , Workflow , base , +-- blaze-html , bytestring , containers , mtl , +-- old-time , stm , text , transformers , vector , +-- hamlet , shakespeare, monadloc , aws , network , hscolour , +-- persistent-template , persistent-sqlite , persistent , +-- conduit , http-conduit , monad-logger , safecopy , +-- time, acid-state +-- main-is: demos-blaze.hs +-- buildable: True +-- hs-source-dirs: Demos +-- other-modules: TestREST ShopCart AjaxSample TraceSample IncreaseString IncreaseInt +-- AutoCompList ListEdit AutoComplete Menu RuntimeTemplates +-- LoginSample CheckBoxes Multicounter MFlowPersistent +-- Combination Options ContentManagement Database +-- PreventGoingBack Counter MCounter PushDecrease +-- Dialog PushSample Grid Radio Actions +-- SumView AcidState SearchCart +-- InitialConfig GenerateForm GenerateFormUndo GenerateFormUndoMsg WebService +-- LazyLoad CachingDataset +-- ghc-options: -iDemos -threaded -rtsopts +--