MFlow 0.3.1.0 → 0.3.1.1
raw patch · 5 files changed
+151/−82 lines, 5 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ MFlow.Forms: delSessionData :: (Typeable a, MonadState (MFlowState view) m) => a -> m ()
- MFlow.Forms.Internals: runFlowOnce1 :: (MonadIO m, FormInput v) => FlowM v m a -> Token -> m Token
+ MFlow.Forms.Internals: runFlowOnce1 :: (Monad m, FormInput v) => FlowM v m a -> Token -> m Token
Files
- Demos/demos-blaze.hs +135/−46
- MFlow.cabal +3/−3
- src/MFlow.hs +0/−1
- src/MFlow/Forms.hs +4/−3
- src/MFlow/Forms/Internals.hs +9/−29
Demos/demos-blaze.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS -XDeriveDataTypeable -XQuasiQuotes -F -pgmF MonadLoc #-} module Main where -import MFlow.Wai.Blaze.Html.All -import Text.Blaze.Html5 as El +import MFlow.Wai.Blaze.Html.All hiding (article) +import Text.Blaze.Html5 as El hiding (article) import Text.Blaze.Html5.Attributes as At hiding (step) import Data.Typeable @@ -37,7 +37,8 @@ import Radio import SumView - +import Debug.Trace+(!>)= flip trace main= do setAdminUser "admin" "admin" @@ -60,53 +61,115 @@ | FViewMonad | Counter | WDialog |Push |PushDec |Trace deriving (Bounded, Enum,Read, Show,Typeable) - -mainmenu= do - setHeader stdheader - setTimeouts 100 0 +newtype Server= Server String deriving Typeable +mainmenu = do + host <- getRawParam "Host" `onNothing` return "mflowdemo.herokuapp.com/"+ setSessionData $ Server host+ setHeader $ stdheader + setTimeouts 100 0+ r <- ask $ wcached "menu" 0 $ - b << "PUSH" - ++> br ++> wlink Push << b << "Example of a widget with push" - <|> br ++> wlink PushDec << b << "A push counter" + b << "PUSH"+ ++> (li <<< wlink Push << b << "Push example"+ <++ b << " A push widget in append mode receives input from\+ \a text box with autorefresh"+ <> article pushl) + <|> (li <<< wlink PushDec << b << "A push counter"+ <++ b << " Show a countdown. Then goes to the main menu"+ <> article pushdec) <|> br ++> br - ++> b << "ERROR TRACES" - ++> br ++> wlink Trace << b << "Execution traces for errors" + ++> b << "ERROR TRACES" + ++> (li <<< wlink Trace << b << " Execution traces for errors"+ <++ b << " produces an error and show the complete execution trace"+ <> article errorTrace) <|> br ++> br ++> - b << "DIFFERENT KINDS OF FLOWS" - ++> br ++> a ! href (attr "/navigation") << "REST navigation" -- ordinary Blaze.Html link - ++> br ++> a ! href (attr "/shop") << "stateful flow: shopping" -- ordinary Blaze.Html link + b << "DIFFERENT KINDS OF FLOWS"+ + ++> (li $ do a ! href (attr "/navigation") << " REST navigation"+ b << " Navigates trough menus and a sucession of GET pages"+ article navigation)+ + ++> (li $ do a ! href (attr "/shop") << " Stateful flow: shopping"+ b << " Add articles to a persistent shopping cart"+ article stateful) - ++> br ++> br ++> b << "BASIC" - ++> br ++> wlink CountI << b << "increase an Int" - <|> br ++> wlink CountS << b << "increase a String" - <|> br ++> wlink Select << b << "select options" - <|> br ++> wlink CheckBoxes << b << "checkboxes" - <|> br ++> wlink Radio << b << "Radio buttons" + ++> br ++> br ++> b << "BASIC"+ + ++> (li <<< wlink CountI << b << "Increase an Int"+ <++ b << " A loop that increases the Int value of a text box")+ + <|> (li <<< wlink CountS << b << "Increase a String"+ <++ b << " A loop that concatenate text in a text box")+ + <|> (li <<< wlink Select << b << "Select options"+ <++ b << " A combo box")+ + <|> (li <<< wlink CheckBoxes << b << "Checkboxes")+ + <|> (li <<< wlink Radio << b << "Radio buttons") - <++ br <> br <> b << "WIDGET ACTIONS & CALLBACKS" - <|> br ++> wlink Action << b << "Example of action, executed when a widget is validated" - <|> br ++> wlink FViewMonad << b << "in page flow: sum of three numbers" - <|> br ++> wlink Counter << b << "Counter" - <|> br ++> wlink Multicounter << b << "Multicounter" - <|> br ++> wlink Combination << b << "combination of three active widgets" - <|> br ++> wlink WDialog << b << "modal dialog" + <++ br <> br <> b << "WIDGET ACTIONS & CALLBACKS"+ + <|> (li <<< wlink Action << b << "Example of action, executed when a widget is validated") ++ <|> (li <<< wlink FViewMonad << b << "in page flow: sum of three numbers"+ <++ b << " Page flows are monadic widgets that modifies themselves in the page"+ <> article pageflow) ++ <|> (li <<< wlink Counter << b << "Counter"+ <++ b << " A page flow which increases a counter by using a callback"+ <> article callbacks) ++ <|> (li <<< wlink Multicounter << b << "Multicounter"+ <++ b << " Page flow with many independent counters with autoRefresh, so they modify themselves in-place"+ <> article callbacks) ++ <|> (li <<< wlink Combination << b << "Combination of three dynamic widgets"+ <++ b << " Combination of autoRefreshe'd widgets in the same page, with\+ \ different behaviours"+ <> article combinationl) ++ <|> (li <<< wlink WDialog << b << "Modal dialog"+ <++ b << " A modal Dialog box with a form within a page flow") <|> br ++> br ++> b << "DYNAMIC WIDGETS" - ++> br ++> wlink Ajax << b << "AJAX example" - <|> br ++> wlink Autocomp << b << "autocomplete" - <|> br ++> wlink AutocompList << b << "autocomplete List" - <|> br ++> wlink ListEdit << b << "list edition" - <|> br ++> wlink Grid << b << "grid" - <|> br ++> wlink TextEdit << b << "Content Management" ++ ++> (li <<< wlink Ajax << b << "AJAX example"+ <++ b << " A onclick event in a text box invokes a server procedure that \+ \increment the integer value"+ <> article ajaxl) ++ <|> (li <<< wlink Autocomp << b << "autocomplete"+ <++ b << " Example of autocomplete, a widget which takes the suggested values from a server procedure") ++ <|> (li <<< wlink AutocompList << b << "autocomplete List"+ <++ b << " Example of a widget that generates a set of return values, suggested by a autocomplete input box"+ <> article editList) ++ <|> (li <<< wlink ListEdit << b << "list edition"+ <++ b << " Example of a widget that edit, update and delete a list of user-defined widgets") ++ <|> (li <<< wlink Grid << b << "grid"+ <++ b << " Example of the same widget In this case, containing a row of two fields, aranged in a table"+ <> article gridl) ++ <|> (li <<< wlink TextEdit << b << "Content Management"+ <++ b << " Example of the (basic) content management primitives defined in MFlow.Forms.Widgets") <|> br ++> br ++> b << "OTHERS" - ++> br ++> wlink Login << b << "login/logout" - <|> br ++> wlink PreventBack << b << "Prevent going back after a transaction" ++ ++> (li <<< wlink Login << b << "login/logout"+ <++ b << " Example of using the login and/or logout") ++ <|> (li <<< wlink PreventBack << b << "Prevent going back after a transaction"+ <++ b << " Control backtracking to avoid navigating back to undo something that can not be undone\+ \. For example, a payment"+ <> article preventbackl) case r of - CountI -> clickn 0 `showSource` "IncreaseInt.hs" + CountI -> clickn 0 `showSource` "IncreaseInt.hs" CountS -> clicks "1" `showSource` "IncreaseString.hs" Action -> actions 1 `showSource` "actions.hs" Ajax -> ajaxsample `showSource` "AjaxSample.hs" @@ -128,14 +191,31 @@ Push -> pushSample `showSource` "PushSample.hs" PushDec -> pushDecrease `showSource` "PushDecrease.hs" Trace -> traceSample `showSource` "TraceSample.hs" - ++space= preEscapedToMarkup " "+article link= space <> a ! href (attr link) << i << "(article)"++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"+ showSource w filename = do - host <- getRawParam "Host" `onNothing` return "mflowdemo.herokuapp.com/" - let path= attr $ "http://" <> host <> ('/':filename) - addHeader $ source path + Server host <- getSessionData `onNothing` error "host must have been set" + let path= attr $ "http://" <> host <> filename !> host + addHeader $ \html -> source path html <> download path w - where + where+ download path= p $ text "download " <> a ! href path << filename source path html = El.div $ do html @@ -170,7 +250,7 @@ page $ error $ "this is the error" -stdheader c= docTypeHtml +stdheader c= docTypeHtml $ El.head << (El.title << "MFlow examples" <> link ! rel ( attr "stylesheet") ! type_ ( attr "text/css") @@ -193,6 +273,15 @@ <> p << a ! href (attr "https://github.com/agocorona/MFlow/issues") << "bug tracker" <> p << a ! href (attr "https://github.com/agocorona/MFlow") << "source repository" <> p << a ! href (attr "http://hackage.haskell.org/package/MFlow") << "Hackage repository" - <> [shamlet| <script type="text/javascript" src="http://output18.rssinclude.com/output?type=js&id=727700&hash=8aa6c224101cac4ca2a7bebd6e28a2d7"></script>|] - - )) +-- <> (h3 $ do+-- text "SOURCE CODE:" +-- iframe ! At.style sty +-- ! At.height (attr "400") +-- ! At.src (attr $ "http://" <> host <> ('/':"demos-blaze.hs")) +-- $ b $ text "no iframes")+ )) + where+ sty= attr "float:left\ + \;width:100%\ + \;margin-left:5px;margin-right:10px;overflow:auto;" +
MFlow.cabal view
@@ -1,5 +1,5 @@ name: MFlow -version: 0.3.1.0 +version: 0.3.1.1 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -75,7 +75,7 @@ . -Clustering .- In this release, this issue has been fixed: <https://github.com/agocorona/MFlow/issues/7>+ In this release, this issue has been fixed: <https://github.com/agocorona/MFlow/issues/8> category: Web, Application Server author: Alberto Gómez Corona @@ -147,7 +147,7 @@ -- containers -any, mtl -any, old-time -any, stm -any, -- text -any, transformers -any, vector -any, hamlet -any, -- monadloc -any-+-- -- main-is: "demos-blaze.hs" -- ghc-options: -- -iDemos
src/MFlow.hs view
@@ -327,7 +327,6 @@ --class ToHttpData a where -- toHttpData :: a -> HttpData -thread t= show(unsafePerformIO myThreadId) ++ " "++ show (twfname t) sendToMF Token{..} msg= putMVar tsendq $ Req msg
src/MFlow/Forms.hs view
@@ -255,7 +255,8 @@ ,addHeader ,getHeader ,setSessionData-,getSessionData +,getSessionData+,delSessionData ,setTimeouts -- * Cookies @@ -536,7 +537,7 @@ getTextBox ms = getParam Nothing "text" ms -- | return the value of a parameter from the environment-getRawParam p= gets mfEnv >>= getParam1 p >>= return . valToMaybe+getRawParam p= gets mfEnv >>= getParam1 p >>= return . valToMaybe getParam :: (FormInput view, @@ -549,7 +550,7 @@ tolook <- case look of Nothing -> genNewId Just n -> return n - let nvalue x= case x of + let nvalue x = case x of Nothing -> "" Just v -> case cast v of
src/MFlow/Forms/Internals.hs view
@@ -54,7 +54,7 @@ import Control.Exception as CE(catch,SomeException,AsyncException,throw,fromException) import Control.Concurrent import Control.Monad.Loc - +-- --import Debug.Trace --(!>) = flip trace @@ -555,7 +555,7 @@ -- > html' <- getHistory -- > setHistory $ html' `mappend` html -setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m () +setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m () setSessionData x= modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)} @@ -794,7 +794,9 @@ let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True} let s''= s{inSync = inSync s2 ,mfRequirements=mfRequirements s2- ,mfPath= mfPath s2 + ,mfPath= mfPath s2+ ,mfPIndex= mfPIndex s2+ ,mfPageIndex= mfPageIndex s2 ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec} return $ (mfSeqCache s'') `seq` ((FormElm form mx2), s'') -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2)) @@ -910,8 +912,8 @@ modify $ \s -> s{mfEnv=[], newAsk= True} breturn () tr -> do- th <- liftIO myThreadId- error $ show th ++ disp tr++ error $ disp tr where disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr) -- to restart the flow in case of going back before the first page of the flow @@ -1042,28 +1044,6 @@ ---getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) --- => String -> Params -> [v] -> m (FormElm v a) ---getParam1 par req form= r --- where --- r= case lookup par req of --- Just x -> do --- modify $ \s -> s{inSync= True} --- maybeRead x -- !> x --- Nothing -> return $ FormElm form Nothing --- getType :: m (FormElm v a) -> a --- getType= undefined --- x= getType r --- maybeRead str= do --- if typeOf x == (typeOf ( undefined :: String)) --- then return . FormElm form . Just $ unsafeCoerce str --- else case readsPrec 0 $ str of --- [(x,"")] -> return . FormElm form $ Just x --- _ -> do --- --- let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) --- return $ FormElm (form++[err]) Nothing - data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show) getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) @@ -1073,8 +1053,8 @@ r= case lookup par req of Just x -> do modify $ \s -> s{inSync= True} - maybeRead x -- !> x - Nothing -> return NoParam + maybeRead x + Nothing -> return NoParam getType :: m (ParamResult v a) -> a getType= undefined x= getType r