MFlow 0.4.5.2 → 0.4.5.3
raw patch · 40 files changed
+26/−2806 lines, 40 filesdep −MFlowdep −awsdep −hamletdep ~basedep ~stmdep ~warp
Dependencies removed: MFlow, aws, hamlet, hscolour, http-conduit, monad-logger, network, persistent, persistent-sqlite, persistent-template, safecopy, shakespeare, tcache-AWS
Dependency ranges changed: base, stm, warp
Files
- Demos/AcidState.hs +0/−81
- 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/−33
- Demos/ListEdit.hs +0/−42
- Demos/LoginSample.hs +0/−34
- Demos/MCounter.hs +0/−33
- Demos/MFlowPersistent.hs +0/−89
- Demos/Menu.hs +0/−464
- 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/−134
- MFlow.cabal +25/−25
- src/MFlow/Wai/Blaze/Html/All.hs +1/−1
− Demos/AcidState.hs
@@ -1,81 +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-) 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 "dist/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- page $ wlink () << p << "disabled for compatibility with stackage. uncomment it to run it"--- 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,33 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings #-}-module LazyLoad (lazyLoad) where-import Data.Typeable---- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "showResults" . 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"- r <- case r of- Sequence -> page $ pageFlow "lazy" $ lazyPresent (0 :: Int) 20- Recursive -> page $ pageFlow "lazy" $ lazyPresentR (0 :: Int) 20- page $ wlink () << p << (show r ++ " 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 "//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,464 +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= "admin" -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 "" $ -- bad practice: pageflows should have a non null string- -- but that would change the URLs of the options- -- and they are published as such.- -- that would produce collisions in identifiers with other- -- widgets - 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- pagname <- restp <|> return "index" - (docTypeHtml $ El.head $ El.title << pagname) - ++> (El.body - <<< ( 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 = 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,134 +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)-instance Serializable Int where- serialize= pack . show- deserialize= read . unpack----main= do- index tfieldKey - setAdminUser adminname adminname- userRegister edadmin edadmin- userRegister "edituser" "edituser" - syncWrite $ Asyncronous 120 defaultCheck 1000- - setFilesPath "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;"- <<< (pageFlow "del" (tFieldEd edadmin "intro" "enter 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 undefined) `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.2+version: 0.4.5.3 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -107,7 +107,7 @@ bytestring , containers , RefSerialize , TCache , stm >2, time, old-time , vector , directory , utf8-string , wai , case-insensitive ,- http-types , conduit ,conduit-extra, text , parsec , warp == 2.0.3.4 ,+ http-types , conduit ,conduit-extra, text , parsec , warp , warp-tls , random , blaze-html , blaze-markup , monadloc, clientsession exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms@@ -121,26 +121,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- 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, monadloc-pp+-- 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+--
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -40,7 +40,7 @@ import Text.Blaze.Html5 hiding (map) import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form) import Network.Wai -import Network.Wai.Handler.Warp -- hiding (getPort) --(run,defaultSettings,Settings ,setPort) +import Network.Wai.Handler.Warp hiding (getPort) --(run,defaultSettings,Settings ,setPort) import Data.TCache import Text.Blaze.Internal(text)