MFlow 0.4.4 → 0.4.5

raw patch · 48 files changed

+3856/−856 lines, 48 filesdep +MFlowdep +acid-statedep +awsdep ~basedep ~clientsessiondep ~stmnew-component:exe:demos-blaze

Dependencies added: MFlow, acid-state, aws, conduit-extra, hamlet, hscolour, http-conduit, monad-logger, network, persistent, persistent-sqlite, persistent-template, safecopy, shakespeare, tcache-AWS, time

Dependency ranges changed: base, clientsession, stm, wai

Files

Demos/AcidState.hs +78/−0
Demos/Actions.hs +17/−0
Demos/AjaxSample.hs +24/−0
Demos/AutoCompList.hs +26/−0
Demos/AutoComplete.hs +27/−0
Demos/CheckBoxes.hs +22/−0
Demos/Combination.hs +89/−0
Demos/ContentManagement.hs +55/−0
Demos/Counter.hs +43/−0
Demos/Database.hs +88/−0
Demos/Dialog.hs +26/−0
Demos/GenerateForm.hs +182/−0
Demos/GenerateFormUndo.hs +192/−0
Demos/GenerateFormUndoMsg.hs +224/−0
Demos/Grid.hs +41/−0
Demos/IncreaseInt.hs +25/−0
Demos/IncreaseString.hs +21/−0
Demos/InitialConfig.hs +50/−0
Demos/LazyLoad.hs +33/−0
Demos/ListEdit.hs +42/−0
Demos/LoginSample.hs +34/−0
Demos/MCounter.hs +33/−0
Demos/MFlowPersistent.hs +89/−0
Demos/Menu.hs +464/−0
Demos/Multicounter.hs +33/−0
Demos/Options.hs +26/−0
Demos/PreventGoingBack.hs +35/−0
Demos/PushDecrease.hs +46/−0
Demos/PushSample.hs +54/−0
Demos/Radio.hs +20/−0
Demos/RuntimeTemplates.hs +132/−0
Demos/SearchCart.hs +122/−0
Demos/ShopCart.hs +69/−0
Demos/SumView.hs +31/−0
Demos/TestREST.hs +60/−0
Demos/TraceSample.hs +29/−0
Demos/WebService.hs +61/−0
Demos/demos-blaze.hs +134/−0
MFlow.cabal +38/−31
src/MFlow.hs +52/−47
src/MFlow/Forms.hs +168/−272
src/MFlow/Forms/Admin.hs +5/−3
src/MFlow/Forms/Cache.hs +181/−0
src/MFlow/Forms/Internals.hs +176/−68
src/MFlow/Forms/Test.hs +5/−9
src/MFlow/Forms/WebApi.hs +5/−5
src/MFlow/Forms/Widgets.hs +440/−415
src/MFlow/Wai/Blaze/Html/All.hs +9/−6

+ Demos/AcidState.hs view

@@ -0,0 +1,78 @@+-- Modified From: https://github.com/acid-state/acid-state/blob/master/examples/HelloDatabase.hs+-- Aistis Raulinaitis+{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-}+{-# OPTIONS -XCPP #-}+module AcidState (+acidState, initAcid+) where++import Data.Acid++import Control.Monad.State                   ( get, put )+import Control.Monad.Reader                  ( ask )+import Data.SafeCopy++-- #define ALONE++#ifdef ALONE+import MFlow.Wai.Blaze.Html.All++main = do+  db <- initAcid+  runNavigation "" . step $ acidState db++#else++import MFlow.Wai.Blaze.Html.All hiding(page)+import Menu  hiding (Database)++#endif++++type Message = String+data Database = Database [Message]+++initAcid= openLocalStateFrom "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+  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 view

@@ -0,0 +1,17 @@+
+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 view

@@ -0,0 +1,24 @@+{-# 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 view

@@ -0,0 +1,26 @@+{-# 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 view

@@ -0,0 +1,27 @@+{-# 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 view

@@ -0,0 +1,22 @@+{-# 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 view

@@ -0,0 +1,89 @@+{-# 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 view

@@ -0,0 +1,55 @@+{-# 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 view

@@ -0,0 +1,43 @@+{-# 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 view

@@ -0,0 +1,88 @@+{-# 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 view

@@ -0,0 +1,26 @@+{-# 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 view

@@ -0,0 +1,182 @@+-----------------------------------------------------------------------------+--+-- 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 view

@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------+--+-- 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 view

@@ -0,0 +1,224 @@+-----------------------------------------------------------------------------+--+-- 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 view

@@ -0,0 +1,41 @@+{-# 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 view

@@ -0,0 +1,25 @@+{-# 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 view

@@ -0,0 +1,21 @@+{-# 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 view

@@ -0,0 +1,50 @@+{-# 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 view

@@ -0,0 +1,33 @@+{-# 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 view

@@ -0,0 +1,42 @@+{-# 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 view

@@ -0,0 +1,34 @@+{-# 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 view

@@ -0,0 +1,33 @@+{-# 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 view

@@ -0,0 +1,89 @@+-- 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)]
+
+

@@ -0,0 +1,464 @@+-----------------------------------------------------------------------------
+--
+-- 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 view

@@ -0,0 +1,33 @@+{-# 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 view

@@ -0,0 +1,26 @@+{-# 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 view

@@ -0,0 +1,35 @@+{-# 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 view

@@ -0,0 +1,46 @@+{-# 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 view

@@ -0,0 +1,54 @@+{-# 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 view

@@ -0,0 +1,20 @@+{-# 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 view

@@ -0,0 +1,132 @@+-- | 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 view

@@ -0,0 +1,122 @@+{-# 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 view

@@ -0,0 +1,69 @@+{-# 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 view

@@ -0,0 +1,31 @@+{-# 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 view

@@ -0,0 +1,60 @@+{-# 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 view

@@ -0,0 +1,29 @@+{-# 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 view

@@ -0,0 +1,61 @@+
+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 view

@@ -0,0 +1,134 @@+{-# 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+   db <- initAcid                             -- for the AcidState example
+   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 db)     `showSource`  "AcidState.hs"+             InitialConfig -> initialConfig                      `showSource`  "InitialConfig.hs"+             SearchCart    -> searchCart                         `showSource`  "SearchCart.hs"+             GenerateForm  -> transientNav genForm+             GenerateFormUndo -> transientNav genFormUndo+             GenerateFormUndoMsg -> transientNav genFormUndoMsg+             CacheDataset -> transientNav cachingDataset         `showSource` "CachingDataset.hs"+             LazyLoad     -> transientNav lazyLoad               `showSource` "LazyLoad.hs"+

MFlow.cabal view

@@ -1,5 +1,5 @@ name: MFlow-version: 0.4.4+version: 0.4.5 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -44,6 +44,11 @@              .              Bindings for hack, and hsp >= 0.8,  are not compiled by Hackage, and do not appear, but are included in the package files. To use them, add then to the exported modules and execute cabal install              .+             NOTE: compatibility with GHC 7.8: you will have compilation errors related with Typeable.+             Follow the instruction in the open issues in the git repository.+             .+             The version 0.4.5 composable HTTP caching, lazy load, caching datasets in the browser HTTP cache+             .              The version 0.4.0 add encrypted cookies, secure sessions, add REST web services, fixes UTF8 errors, pageFlow fixes, add onBacktrack, compensate              .              Thes version 0.3.3 run with wai 2.0@@ -97,43 +102,45 @@     location: http://github.com/agocorona/MFlow  library-    build-depends: Workflow -any, transformers -any, mtl -any,-                   extensible-exceptions -any,  base >4.0 && <5,-                   bytestring -any, containers -any, RefSerialize -any, TCache -any,-                   stm >2, old-time -any, vector -any, directory -any,-                   utf8-string -any, wai >=2.0.0, case-insensitive -any,-                   http-types -any, conduit -any, text -any, parsec -any, warp -any,-                   warp-tls -any, random -any, blaze-html -any, blaze-markup -any,-                   monadloc -any, clientsession ==0.9.0.3+    build-depends: Workflow , transformers , mtl ,+                   extensible-exceptions ,  base >4.0 && <5,+                   bytestring , containers , RefSerialize , TCache ,+                   stm >2, time, old-time , vector , directory ,+                   utf8-string , wai , case-insensitive ,+                   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                      MFlow.Forms.Admin MFlow.Cookies MFlow.Wai                      MFlow.Forms.Blaze.Html MFlow.Forms.Test-                     MFlow.Forms.Widgets MFlow.Forms.Internals MFlow.Forms.WebApi+                     MFlow.Forms.Widgets MFlow.Forms.Internals+                     MFlow.Forms.WebApi MFlow.Forms.Cache     exposed: True     buildable: True     hs-source-dirs: src .     other-modules:  MFlow.Wai.Response  ---executable demos-blaze---    build-depends: MFlow -any, RefSerialize -any, TCache -any,---                   tcache-AWS -any, directory -any, Workflow -any, base -any,---                   blaze-html -any, bytestring -any, containers -any, mtl -any,---                   old-time -any, stm -any, text -any, transformers -any, vector -any,---                   hamlet -any, monadloc -any, aws -any, network -any, hscolour -any,---                   persistent-template -any, persistent-sqlite -any, persistent -any,---                   conduit -any, http-conduit -any, monad-logger -any, safecopy -any,---                   acid-state -any---    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---    ghc-options: -O -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 ,+                   acid-state , 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

src/MFlow.hs view

@@ -112,16 +112,16 @@ import qualified Data.Text as T
 import System.Posix.Internals
 import Control.Exception
-import Debug.Trace
-(!>)  =   flip trace
+--import Debug.Trace
+--(!>)  =   flip trace
 
 
 -- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable`
 -- message that arrives and send the mesage to the appropriate flow.
-data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp}  deriving  Typeable
+data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tblock:: MVar Bool, tsendq :: MVar Req, trecq :: MVar Resp}  deriving  Typeable
 
 instance Indexable  Token  where
-     key (Token w u i _ _ _ _  )=  i
+     key (Token w u i _ _ _ _ _  )=  i
 --          if u== anonymous then  u ++ i   -- ++ "@" ++ w
 --                          else  u       -- ++ "@" ++ w
 
@@ -130,8 +130,8 @@ 
 instance Read Token where
      readsPrec _ ('T':'o':'k':'e': 'n':' ':str1)
-       | anonymous `isPrefixOf` str1= [(Token  w anonymous i [] [] (newVar 0) (newVar 0), tail str2)]
-       | otherwise                 = [(Token  w ui "0" [] []  (newVar 0) (newVar 0), tail str2)]
+       | anonymous `isPrefixOf` str1= [(Token  w anonymous i [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
+       | otherwise                 = [(Token  w ui "0" [] [] (newVar True)  (newVar 0) (newVar 0), tail str2)]
 
         where
 
@@ -165,8 +165,9 @@       case mqs of
               Nothing  -> do
                  q  <- newEmptyMVar  -- `debug` (i++w++u)
-                 qr <- newEmptyMVar
-                 let token= Token w u i ppath penv q qr
+                 qr <- newEmptyMVar+                 pblock <- newMVar True
+                 let token= Token w u i  ppath penv pblock q qr
                  addTokenToList token
                  return token
 
@@ -243,33 +244,32 @@ -}
 -- | send a complete response 
 --send ::   Token  -> HttpData -> IO()
-send  t@(Token _ _ _ _ _ _ qresp) msg=   do
-      ( putMVar qresp  . Resp $  msg )  -- !> ("<<<<< send "++ thread t) 
+send  t@(Token _ _ _ _ _ _ _ qresp) msg=   do
+      ( putMVar qresp  . Resp $  msg )   -- !> ("<<<<< send "++ show t) 
 
-sendFlush t msg= flushRec t >> send t msg     -- !> "sendFlush "
+sendFlush t msg=  flushRec t >>  send t msg      -- !> "sendFlush "
 
 -- | send a response fragment. Useful for streaming. the last packet must be sent trough 'send'
 sendFragment ::  Token  -> HttpData -> IO()
-sendFragment (Token _ _ _ _ _ _ qresp) msg=   putMVar qresp  . Fragm $  msg
+sendFragment (Token _ _ _ _ _ _ _ qresp) msg=   putMVar qresp  . Fragm $  msg
 
 {-# DEPRECATED sendEndFragment "use \"send\" to end a fragmented response instead" #-}
 sendEndFragment :: Token -> HttpData -> IO()
-sendEndFragment (Token _ _ _ _ _ _ qresp) msg=  putMVar qresp  $ EndFragm   msg
+sendEndFragment (Token _ _ _ _ _ _ _ qresp) msg=  putMVar qresp  $ EndFragm   msg
 
 --emptyReceive (Token  queue _  _)= emptyQueue queue
 receive ::  Typeable a => Token -> IO a
 receive t= receiveReq t >>= return  . fromReq
 -flushResponse t@(Token _ _ _ _ _ _ qresp)= do
-   empty <-  isEmptyMVar  qresp
-   when (not empty) $ takeMVar qresp >> return ()+flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
+ 
-flushRec t@(Token _ _ _ _ _ queue _)= do
-   empty <-  isEmptyMVar  queue
-   when (not empty) $ takeMVar queue >> return ()    -- !> "flushRec"
+flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar  queue   -- !> "flushRec"
 
 receiveReq ::  Token -> IO Req
-receiveReq t@(Token _ _ _ _ _ queue  _)=   readMVar queue   -- !> (">>>>>> receiveReq "++ thread t)
+receiveReq t@(Token _ _ _ _ _ _ queue  _)= do+ r <-   readMVar queue      -- !> (">>>>>> receiveReq ")+ return r                   -- !> "receiveReq >>>>"
 
 fromReq :: Typeable a => Req -> a
 fromReq  (Req x) = x' where
@@ -301,7 +301,7 @@ stateless ::  (Params -> IO HttpData) -> Flow
 stateless f = transient proc
   where
-  proc t@(Token _ _ _ _ _ queue qresp) = loop t queue qresp
+  proc t@(Token _ _ _ _ _ _ queue qresp) = loop t queue qresp
   loop t queue qresp=do
     req <- takeMVar queue                       -- !> (">>>>>> stateless " ++ thread t)
     resp <- f (getParams req)
@@ -334,13 +334,13 @@ delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
 
 
-sendToMF Token{..} msg= putMVar tsendq $ Req msg
+sendToMF Token{..} msg= putMVar tsendq (Req msg)  -- !> "sendToMF"
 
 --recFromMF :: (Typeable a,  Typeable c, Processable a) => Token -> a -> IO c
-recFromMF Token{..}  = do  
-    m <-  takeMVar trecq                  -- !> ("<<<<<< recFromMF"++ thread t)
+recFromMF t@Token{..}  = do  
+    m <-  takeMVar trecq                          -- !> "recFromMF <<<<<< "
     case m  of
-        Resp r  ->  return  r              -- !> ("recibido  recFromMF"++ thread t)
+        Resp r  ->  return  r                      -- !> "<<<<<<   recFromMF"
         Fragm r -> do
                    result <- getStream   r
                    return  result
@@ -373,13 +373,20 @@   :: (Typeable a,Processable a)
   => a  -> IO (HttpData, ThreadId)
 msgScheduler x  = do
-  token <- getToken x
-  let wfname = takeWhile (/='/') $ pwfname x
-  sendToMF token x                                 
-  th <- startMessageFlow wfname token     
-  r  <- recFromMF token                            --  !> let HttpData _ _ r1=r in unpack r1 
-  return (r,th)
-  where
+  token <- getToken x+  th <- myThreadId
+  let wfname = takeWhile (/='/') $ pwfname x+  criticalSection (tblock token) $ do
+     sendToMF token x                             -- !> show th                             
+     th <- startMessageFlow wfname token     
+     r  <- recFromMF token                          
+     return (r,th)                                --  !> let HttpData _ _ r1=r in B.unpack r1 
+  where+  criticalSection mv f= bracket
+      (takeMVar mv)
+      (putMVar mv)
+      $ const $ f+      
   --start the flow if not started yet
   startMessageFlow wfname token = 
    forkIO $ do
@@ -512,12 +519,12 @@ 
 newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
 -defConfig= Config1 $ M.fromList-            [("cadmin","admin")-            ,("cjqueryScript","//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js")-            ,("cjqueryCSS","//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css")-            ,("cjqueryUI","//code.jquery.com/ui/1.10.3/jquery-ui.js")-            ,("cnicEditUrl","//js.nicedit.com/nicEdit-latest.js")]+--defConfig= Config1 $ M.fromList+--            [("cadmin","admin")+--            ,("cjqueryScript","//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js")+--            ,("cjqueryCSS","//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css")+--            ,("cjqueryUI","//code.jquery.com/ui/1.10.3/jquery-ui.js")+--            ,("cnicEditUrl","//js.nicedit.com/nicEdit-latest.js")] 
 data Config0 = Config{cadmin :: UserStr           -- ^ Administrator name                      ,cjqueryScript :: String     -- ^ URL of jquery@@ -547,7 +554,7 @@   Config1 c <- atomically $! readConfig   return c -readConfig=  readDBRef rconf `onNothing` return defConfig+readConfig=  readDBRef rconf `onNothing`  return (Config1 $ M.fromList []) -- defConfig  readOld :: ByteString -> Config readOld s= (change . read . B.unpack $ s)@@ -560,16 +567,14 @@ 
 instance  Serializable Config where
   serialize = B.pack . show
-  deserialize s = unsafePerformIO $ do-                     let r = read $! B.unpack s-                     print r-                     return r+  deserialize s = unsafePerformIO $  (return $! read $! B.unpack s)                    `CE.catch` \(e :: SomeException) ->  return (readOld s)
   setPersist = \_ -> Just filePersist
 --- | read a config variable from the config-getConfig s= case M.lookup s config of-     Nothing -> ""+-- | read a config variable from the config file \"mflow.config\". if it is not set, uses the second parameter and+-- add it to the configuration list, so next time the administrator can change it in the configuration file+getConfig k v= case M.lookup k config of+     Nothing -> unsafePerformIO $ setConfig k v >> return v      Just s  -> s  -- | set an user-defined config variable@@ -597,7 +602,7 @@  
 
-getAdminName= getConfig "cadmin" 
+getAdminName= getConfig "cadmin"  "admin"
 
 
 --------------- ERROR RESPONSES --------

src/MFlow/Forms.hs view

@@ -222,10 +222,9 @@ ,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
 getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
 submitButton,resetButton, whidden, wlink, absLink, getKeyValueParam,-getRestParam, returning, wform, firstOf, manyOf, allOf, wraw, wrender, notValid,-fileUpload+getRestParam, returning, wform, firstOf, manyOf, allOf, wraw, wrender, notValid -- * FormLet modifiers
-,validate, noWidget, stop, waction, wcallback, clear, wmodify,
+,validate, noWidget, stop, waction, wcallback, wmodify,
 
 -- * Caching widgets
 cachedWidget, wcached, wfreeze,
@@ -233,19 +232,19 @@ -- * Widget combinators
 (<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
 
--- * Normalized (convert to ByteString) widget combinators
--- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings
---
--- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
--- can be cached with `cachedWidget`
-,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
+---- * Normalized (convert to ByteString) widget combinators
+---- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings
+----
+---- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
+---- can be cached with `cachedWidget`
+--,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
 
 -- * Formatting combinators
-(<<<),(++>),(<++),(<!),
+,(<<<),(++>),(<++),(<!)
 
--- * Normalized (convert to ByteString) formatting combinators
--- | Some combinators that convert the formatting of their arguments to lazy byteString
-(.<<.),(.<++.),(.++>.)
+---- * Normalized (convert to ByteString) formatting combinators
+---- | Some combinators that convert the formatting of their arguments to lazy byteString
+----(.<<.),(.<++.),(.++>.)
 
 -- * ByteString tags
 ,btag,bhtml,bbody
@@ -265,7 +264,8 @@ ,addHeader
 ,getHeader
 ,setSessionData
-,getSessionData
+,getSessionData+,getSData
 ,delSessionData
 ,setTimeouts
 
@@ -294,13 +294,13 @@ )
 where
 
-import Data.RefSerialize hiding ((<|>))
+import Data.RefSerialize hiding ((<|>),empty)
 import Data.TCache
 import Data.TCache.Memoization
 import MFlow
 import MFlow.Forms.Internals
 import MFlow.Cookies
-import Data.ByteString.Lazy as B(ByteString,cons,append,empty,fromChunks)+import Data.ByteString.Lazy.Char8 as B(ByteString,cons,append,empty,fromChunks,unpack) import Data.ByteString.Lazy.UTF8 hiding (length, take) import qualified Data.String as S
 import qualified Data.Text as T
@@ -323,7 +323,7 @@ import System.IO.Unsafe
 import Data.Char(isNumber,toLower)
 import Network.HTTP.Types.Header
-
+import MFlow.Forms.Cache
 
 -- | Validates a form or widget result against a validating procedure
 --
@@ -341,7 +341,7 @@       modify (\s -> s{inSync= True})
       case me of
          Just str ->
-           return $ FormElm ( form ++ [inred  str]) Nothing
+           return $ FormElm ( form <> inred  str) Nothing
          Nothing  -> return $ FormElm form mx
     _ -> return $ FormElm form mx
 
@@ -373,17 +373,17 @@               r <- runSup $ runFlowM  x
               case r of
                 NoBack x ->
-                     return (FormElm [] $ Just x)
+                     return (FormElm mempty $ Just x)
                 BackPoint x->
-                     return (FormElm [] $ Just x)
+                     return (FormElm mempty $ Just x)
                 GoBack-> do
                      modify $ \s ->s{notSyncInAction= True}
-                     return (FormElm [] Nothing)
+                     return (FormElm mempty Nothing)
 
 -- | change the rendering and the return value of a page. This is superseeded by page flows.
 wmodify :: (Monad m, FormInput v)
         => View v m a
-        -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
+        -> (v -> Maybe a -> WState v m (v, Maybe b))
         -> View v m b
 wmodify formt act = View $ do
    FormElm f mx <- runView  formt
@@ -428,8 +428,8 @@   mn <- getParam1 n env
   let str = if typeOf v == typeOf(undefined :: String)
                    then unsafeCoerce v else show v
-  return $ FormElm [finput n "radio" str
-          ( isValidated mn  && v== fromValidated mn) (Just  "this.form.submit()")]
+  return $ FormElm (finput n "radio" str
+          ( isValidated mn  && v== fromValidated mn) (Just  "this.form.submit()"))
           (fmap Radio $ valToMaybe mn)
 
 
@@ -445,8 +445,8 @@   mn <- getParam1 n env
   let str = if typeOf v == typeOf(undefined :: String)
                    then unsafeCoerce v else show v
-  return $ FormElm [finput n "radio" str
-          ( isValidated mn  && v== fromValidated mn) Nothing]
+  return $ FormElm (finput n "radio" str
+          ( isValidated mn  && v== fromValidated mn) Nothing)
           (fmap Radio $ valToMaybe mn)
 
 -- | encloses a set of Radio boxes. Return the option selected
@@ -484,8 +484,8 @@         True  -> Just $ CheckBoxes  strs  -- !> show strs
         False -> Nothing
   return $ FormElm
-      ( [ finput n "checkbox" v
-        ( checked || (isJust mn  && v== fromJust mn)) Nothing])
+      ( finput n "checkbox" v
+        ( checked || (isJust mn  && v== fromJust mn)) Nothing)
       ret
 
 -- | Read the checkboxes dinamically created by JavaScript within the view parameter
@@ -503,7 +503,7 @@   let ret= case val of
         True ->  Just $ CheckBoxes  strs
         False -> Nothing
-  return $ FormElm [ftag "span" v `attrs`[("id",n)]] ret
+  return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
 
 whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
 whidden x= View $ do
@@ -513,20 +513,20 @@               Just x' -> x'
               Nothing -> show x
   r <- getParam1 n env
-  return $ FormElm [finput n "hidden" showx False Nothing] $ valToMaybe r
+  return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
 
 getCheckBoxes :: (FormInput view, Monad m)=> View view m  CheckBoxes -> View view m [String]
 getCheckBoxes boxes =  View $ do
     n  <- genNewId
     st <- get
     let env =  mfEnv st
-    let form= [finput n "hidden" "" False Nothing]
+    let form= finput n "hidden" "" False Nothing
     mr  <- getParam1 n env
 
     let env = mfEnv st
     modify $ \st -> st{needForm= HasElems}
     FormElm form2 mr2 <- runView boxes
-    return $ FormElm (form ++ form2) $
+    return $ FormElm (form <> form2) $
         case (mr `asTypeOf` Validated ("" :: String),mr2) of
           (NoParam,_) ->  Nothing
           (Validated _,Nothing) -> Just []
@@ -568,9 +568,9 @@     put st{needForm= HasElems}
     r <- getParam1 tolook env
     case r of
-       Validated x        -> return $ FormElm [finput tolook type1 (nvalue $ Just x) False Nothing] $ Just x
-       NotValidated s err -> return $ FormElm ([finput tolook type1 s False Nothing]++[err]) $ Nothing
-       NoParam            -> return $ FormElm [finput tolook type1 (nvalue mvalue) False Nothing] $ Nothing
+       Validated x        -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
+       NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
+       NoParam            -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing
 
 
 
@@ -591,9 +591,9 @@     env <- gets mfEnv
     r <- getParam1 tolook env
     case r of
-       Validated x        -> return $ FormElm [ftextarea tolook  x] $ Just x
-       NotValidated s err -> return $ FormElm [ftextarea tolook  (T.pack s)]  Nothing
-       NoParam            -> return $ FormElm [ftextarea tolook  nvalue]  Nothing
+       Validated x        -> return $ FormElm (ftextarea tolook  x) $ Just x
+       NotValidated s err -> return $ FormElm (ftextarea tolook  (T.pack s))  Nothing
+       NoParam            -> return $ FormElm (ftextarea tolook  nvalue)  Nothing
 
 
 --instance  (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
@@ -615,18 +615,8 @@                   <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
    if  r == truestr  then return True else return False
 
---View $ do
---    tolook <- genNewId
---    st <- get
---    let env = mfEnv st
---    put st{needForm= True}
---    r <- getParam1 tolook env
---    let flag = isValidated r && fromstr (fromValidated r)
---    let form = [fselect tolook (foption1 truestr flag `mappend` foption1 falsestr (not flag))]
---    return . FormElm form . fmap fromstr $ valToMaybe r
---    where
---    fromstr x = if x == truestr then True else False
 
+
 -- | Display a dropdown box with the options in the first parameter is optionally selected
 -- . It returns the selected option.
 getSelect :: (FormInput view,
@@ -641,7 +631,7 @@     setSessionData $ fmap MFOption $ valToMaybe r
     FormElm form mr <- (runView opts)
 
-    return $ FormElm [fselect tolook $ mconcat form] $ valToMaybe r
+    return $ FormElm (fselect tolook  form)  $ valToMaybe r
 
 
 newtype MFOption a= MFOption a deriving Typeable
@@ -684,12 +674,12 @@                    then unsafeCoerce nam
                    else show nam
 
-    return . FormElm [foption n val check]  . Just $ MFOption nam
+    return . FormElm (foption n val check)  . Just $ MFOption nam
 
-fileUpload :: (FormInput view,
-      Monad  m) =>
-      View view m T.Text-fileUpload= getParam Nothing "file" Nothing+--fileUpload :: (FormInput view,
+--      Monad  m) =>
+--      View view m T.Text+--fileUpload= getParam Nothing "file" Nothing  
 -- | Enclose Widgets within some formating.
@@ -719,7 +709,7 @@          -> View view m a
 (<<<) v form= View $ do
   FormElm f mx <- runView form 
-  return $ FormElm [v $ mconcat f] mx
+  return $ FormElm (v  f) mx
 
 
 infixr 5 <<<
@@ -734,16 +724,16 @@ -- @ getString "hi" <++ H1 << "hi there"@
 --
 -- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
-(<++) :: (Monad m)
+(<++) :: (Monad m, Monoid v)
       => View v m a
       -> v
       -> View v m a
 (<++) form v= View $ do
   FormElm f mx <-  runView  form
-  return $ FormElm ( f ++ [ v]) mx
+  return $ FormElm ( f <> v) mx
 
-infixr 6  ++> , .++>.
-infixr 6 <++ , .<++.
+infixr 6  ++> 
+infixr 6 <++ 
 -- | Prepend formatting code to a widget
 --
 -- @bold << "enter name" ++> getString Nothing @
@@ -751,8 +741,10 @@ -- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
 (++>) :: (Monad m,  Monoid view)
        => view -> View view m a -> View view m a
-html ++> digest =  (html `mappend`) <<< digest
-
+html ++> w =  --  (html <>) <<< digest
+ View $ do
+  FormElm f mx <- runView w 
+  return $ FormElm (html  <>  f) mx
 
 
 
@@ -762,7 +754,7 @@ infixl 8 <!
 widget <! attribs= View $ do
       FormElm fs  mx <- runView widget
-      return $ FormElm  (head fs `attrs` attribs:tail fs) mx
+      return $ FormElm  (fs `attrs` attribs) mx -- (head fs `attrs` attribs:tail fs) mx
 --      case fs of
 --        [hfs] -> return $ FormElm  [hfs `attrs` attribs] mx
 --        _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
@@ -781,11 +773,11 @@ userFormLine :: (FormInput view, Functor m, Monad m)
             => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
 userFormLine=
-       ((,)  <$> getString (Just "enter user")                  <! [("size","5")]
+        ((,) <$> getString (Just "enter user")                  <! [("size","5")]
              <*> getPassword                                    <! [("size","5")]
          <** submitButton "login")
          <+> (fromStr "  password again" ++> getPassword      <! [("size","5")]
-         <*  submitButton "register")
+         <** submitButton "register")
 
 -- | Example of user\/password form (no validation) to be used with 'userWidget'
 userLogin :: (FormInput view, Functor m, Monad m)
@@ -803,15 +795,15 @@ --
 -- It returns a non valid value.
 noWidget ::  (FormInput view,
-     Monad m) =>
+     Monad m, Functor m) =>
      View view m a
-noWidget= View . return $ FormElm  [] Nothing
+noWidget= Control.Applicative.empty
  -- | a sinonym of noWidget that can be used in a monadic expression in the View monad does not continue stop :: (FormInput view,
-     Monad m) =>
+     Monad m, Functor m) =>
      View view m a-stop= noWidget+stop= Control.Applicative.empty 
 -- | Render a Show-able  value and return it
 wrender
@@ -821,11 +813,11 @@ 
 -- | Render raw view formatting. It is useful for displaying information.
 wraw :: Monad m => view -> View view m ()
-wraw x= View . return . FormElm [x] $ Just ()
+wraw x= View . return . FormElm x $ Just ()
 
 -- To display some rendering and return  a no valid value
 notValid :: Monad m => view -> View view m a
-notValid x= View . return $ FormElm [x] Nothing
+notValid x= View . return $ FormElm x Nothing
 
 -- | Wether the user is logged or is anonymous
 isLogged :: MonadState (MFlowState v) m => m Bool
@@ -837,7 +829,7 @@ --
 -- If the process is backtraking, it does not validate,
 -- in order to continue the backtracking
-returnIfForward :: (Monad m, FormInput view) => b -> View view m b
+returnIfForward :: (Monad m, FormInput view,Functor m) => b -> View view m b
 returnIfForward x = do
      back <- goingBack
      if back then noWidget else return x
@@ -949,7 +941,8 @@   :: (Num a1,S.IsString a, MonadIO m,
       MonadState (MFlowState view) m) =>
      (String -> [Char] -> a -> Maybe a1 -> m ()) -> m ()
-logout' setCookieFunc = do
+logout' setCookieFunc = do+    public
     back <- goingBack
     if back then return () else do
      st <- get
@@ -989,90 +982,8 @@    Auth _ val <- getAuthMethod
    val u p >>= return .  fmap  fromStr
 
--- | Join two widgets in the same page
--- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
--- if both return Noting, the widget return @Nothing@ (invalid).
---
--- it has a low infix priority: @infixr 2@
---
---  > r <- ask  widget1 <+>  widget2
---  > case r of (Just x, Nothing) -> ..
-(<+>) , mix ::  (Monad m, FormInput view)
-      => View view m a
-      -> View view m b
-      -> View view m (Maybe a, Maybe b)
-mix digest1 digest2= View $ do
-  FormElm f1 mx' <- runView  digest1-  s1 <- get
-  FormElm f2 my' <- runView  digest2-  s2 <- get-  (mix, hasform) <- controlForms s1 s2 f1 f2-  when hasform $ put s2{needForm= HasForm}
-  return $ FormElm mix
-         $ case (mx',my') of
-              (Nothing, Nothing) -> Nothing
-              other              -> Just other
 
-infixr 2 <+>, .<+>.
 
-(<+>)  = mix
-
-
-
--- | The first elem result (even if it is not validated) is discarded, and the secod is returned
--- . This contrast with the applicative operator '*>' which fails the whole validation if
--- the validation of the first elem fails.
---
--- The first element is displayed however, as happens in the case of '*>' .
---
--- Here @w\'s@ are widgets and @r\'s@ are returned values
---
---   @(w1 <* w2)@  will return @Just r1@ only if w1 and w2 are validated
---
---   @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
---
---  it has a low infix priority: @infixr 1@
-
-(**>) :: (Functor m, Monad m, FormInput view)
-      => View view m a -> View view m b -> View view m b
---(**>) form1 form2 = valid form1 *> form2-(**>) f g = View $ do-   FormElm form1 k <- runView $ valid f-   s1 <- get
-   FormElm form2 x <- runView g-   s2 <- get-   (mix,hasform) <- controlForms s1 s2 form1 form2-   when hasform $ put s2{needForm= HasForm}
-   return $ FormElm mix (k *> x)
-
-
-infixr 1  **> , .**>. ,  <** , .<**.
-
--- | The second elem result (even if it is not validated) is discarded, and the first is returned
--- . This contrast with the applicative operator '*>' which fails the whole validation if
--- the validation of the second elem fails.
--- The second element is displayed however, as in the case of '<*'.
--- see the `<**` examples
---
---  it has a low infix priority: @infixr 1@
-(<**) :: (Functor m, Monad m, FormInput view) =>
-     View view m a -> View view m b -> View view m a
--- (<**) form1 form2 =  form1 <* valid form2
-(<**) f g = View $ do-   FormElm form1 k <- runView f-   s1 <- get
-   FormElm form2 x <- runView $ valid g-   s2 <- get-   (mix,hasform) <- controlForms s1 s2 form1 form2-   when hasform $ put s2{needForm= HasForm}
-   return $ FormElm mix (k <* x)
-
--
-valid form= View $ do
-   FormElm form mx <- runView form
-   return $ FormElm form $ Just undefined
-
 -- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
 -- This is the non testing version
 --
@@ -1104,10 +1015,12 @@ -- other state in the flow if the request has the required parameters.
 ask :: (FormInput view) =>
        View view IO a -> FlowM view IO a
-ask w =  do
+ask w =  do+ resetCachePolicy
  st1 <- get >>= \s -> return s{mfSequence=                                    let seq= mfSequence s in-                                   if seq ==inRecovery then 0 else seq} 
+                                   if seq ==inRecovery then 0 else seq+                              ,mfHttpHeaders =[],mfAutorefresh= False } 
  if not . null $ mfTrace st1 then fail "" else do
   -- AJAX
   let env= mfEnv st1
@@ -1125,54 +1038,53 @@  --  mfPagePath : contains the REST path of the page. --  it is set for each page---  if it does not exist, backtrack (to fill the field)+--  if it does not exist then it comes from a state recovery, backtrack (to fill-in the field)     let pagepath = mfPagePath st1     if null pagepath then fail "" --  if exist and it is not prefix of the current path being navigated to, backtrack       else if not $  pagepath `isPrefixOf` mfPath st1 then fail ""   -- !> ("pagepath fail with "++ show (mfPath st1))        else do---  wlinks set it for the next page    
      let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False} 
      put st
-
      FormElm forms mx <- FlowM . lift  $ runView  w
-
+     setCachePolicy
      st' <- get
      if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
 
       else
       case mx  of
        Just x -> do
-         put st'{newAsk= True , mfEnv=[]-                ,mfPagePath=  mfPagePath st'}
-         breturn x                                -- !> ("BRETURN "++ show (mfPagePath st') )
+         put st'{newAsk= True , mfEnv=[]}
+         breturn x                                    -- !> ("BRETURN "++ show (mfPagePath st') )
 
        Nothing ->
          if  not (inSync st')  && not (newAsk st')
---                                                        !> ("insync="++show (inSync st'))
---                                                        !> ("newask="++show (newAsk st'))
+                                                       -- !> ("insync="++show (inSync st'))
+                                                       -- !> ("newask="++show (newAsk st'))
           then fail ""                                 -- !> "FAIL**********"
           else if mfAutorefresh st' then do
-                     resetState st st'
+                     resetState st st'                 -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st'])
+--                     modify $ \st -> st{mfPagePath=mfPagePath st'} !> "REPEAT"                      FlowM $ lift  nextMessage
-                     ask w                                -- !> "EN AUTOREFRESH"
+                     ask w                                 
           else do
-             reqs <-  FlowM $ lift installAllRequirements    --  !> "REPEAT"
+             reqs <-  FlowM $ lift installAllRequirements     --  !> "REPEAT"+             
              let header= mfHeader st'
                  t= mfToken st'
              cont <- case (needForm1 st') of
                       True ->  do
                                frm <- formPrefix  st' forms False 
                                return . header $  reqs <> frm
-                      _    ->  return . header $  reqs <> mconcat  forms
+                      _    ->  return . header $  reqs <> forms
 
              let HttpData ctype c s= toHttpData cont
              liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
-
+                          
 
              resetState st st'
-             FlowM $ lift  nextMessage       --  !> "NEXTMESSAGE"+             FlowM $ lift  nextMessage         -- !> "NEXTMESSAGE"              ask w
     where
     resetState st st'=
@@ -1248,28 +1160,9 @@ wstateless
   :: (Typeable view,  FormInput view) =>
      View view IO () -> Flow
-wstateless w =  runFlow . transientNav . ask $ w **> (stop `asTypeOf` w) -- loop
---  where
---  loop= do
---      ask w
---      env <- get
---      put $ env{ mfSequence= 0}
---      loop
+wstateless w =  runFlow . transientNav . ask $ w **> (stop `asTypeOf` w) 
 
 
----- This version writes a log with all the values returned by ask
---wstatelessLog
---  :: (Typeable view, ToHttpData view, FormInput view,Serialize a,Typeable a) =>
---     View view IO a -> (Token -> Workflow IO ())
---wstatelessLog w = runFlow loop
---  where
---  loop= do
---      MFlow.Forms.step $ do
---         r <- ask w
---         env <- get
---         put $ env{ mfSequence= 0,prevSeq=[]}
---         return r
---      loop
 
 
 
@@ -1284,13 +1177,14 @@      st <- get
      form1 <- formPrefix st form True
      put st{needForm=HasForm}
-     return $ FormElm [form1] mr
+     return $ FormElm form1 mr
 
 
 
 
 resetButton :: (FormInput view, Monad m) => String -> View view m ()
-resetButton label= View $ return $ FormElm [finput  "reset" "reset" label False Nothing]   $ Just ()
+resetButton label= View $ return $ FormElm (finput  "reset" "reset" label False Nothing)+                        $ Just ()
 
 submitButton :: (FormInput view, Monad m) => String -> View view m String
 submitButton label= getParam Nothing "submit" $ Just label
@@ -1333,28 +1227,28 @@ --
 -- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
 ajaxSend
-  :: (Read a,MonadIO m) => View v m ByteString -> View v m a
+  :: (Read a,Monoid v, MonadIO m) => View v m ByteString -> View v m a
 ajaxSend cmd=  View $ do
    AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"
    env <- getEnv
    t <- getToken
    case (lookup "ajax" $ env, lookup "val" env) of
-       (Nothing,_) -> return $ FormElm [] Nothing
+       (Nothing,_) -> return $ FormElm mempty Nothing
        (Just id, Just _) -> do
            FormElm __ (Just  str) <- runView  cmd
            liftIO $ sendFlush t  $ HttpData [("Content-Type", "text/plain")][] $ str <>  readEvalLoop t id "''"
            nextMessage
            env <- getEnv
            case (lookup "ajax" $ env,lookup "val" env) of
-               (Nothing,_) -> return $ FormElm [] Nothing
+               (Nothing,_) -> return $ FormElm mempty Nothing
                (Just id, Just v2) -> do
-                    return $ FormElm []  . Just  $ read v2
+                    return $ FormElm mempty  . Just  $ read v2
    where
    readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
 
 -- | Like @ajaxSend@ but the result is ignored
 ajaxSend_
-  :: MonadIO m => View v m ByteString -> View v m ()
+  :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
 ajaxSend_ = ajaxSend
 
 wlabel
@@ -1362,11 +1256,8 @@ wlabel str w = do
    id <- genNewId
    ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
---     
-    
 
+
 -- | Creates a link to a the next step within the flow. -- A link can be composed with other widget elements. --  It can not be broken by its own definition.@@ -1389,13 +1280,16 @@              True -> do
                   modify $ \s -> s{inSync= True
                                  ,linkMatched= True-                                 ,mfPagePath= mfPagePath st ++ [name] }
+                                 ,mfPagePath= newPath }
 
-                  return $ Just x                          --  !> (name ++ "<-" ++ "lpath=" ++show (mfPagePath st))
-             False ->  return Nothing                      --  !> ( "NOT MATCHED "++name++" LP= "++show (mfPagePath st))
+                  return $ Just x+--                         !> (name ++ "<-" ++ "link path=" ++show newPath)
+             False ->  return Nothing+--                         !> ( "NOT MATCHED "++name++" link path= "++show newPath+--                             ++ "path="++  show lpath)
 -      let path= currentPath st ++ ('/':name)
-      return $ FormElm [flink path v ] r
+      let path= concat ['/':v| v <- newPath ]
+      return $ FormElm (flink path v) r
  -- Creates an absolute link. While a `wlink` path depend on the page where it is located and -- ever points to the code of the page that had it inserted, an absLink point to the first page@@ -1435,14 +1329,14 @@              True -> do
                   modify $ \s -> s{inSync= True
                                  ,linkMatched= True-                                 ,mfPagePath= mfPagePath st ++ [name] }
+                                 ,mfPagePath= newPath }
 
                   return $ Just x                             --  !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
              False ->  return Nothing                         --  !> ( "NOT MATCHED "++name++" LP= "++show  lpath)
        path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
 -      return $ FormElm [flink path v ] r  -- !> name
+      return $ FormElm (flink path v) r  -- !> name
   
@@ -1468,7 +1362,7 @@             in (verb ++ "?" ++  name ++ "=" ++ showx)
           toSend= expr string
       r <- getParam1 name env
-      return $ FormElm [toSend] $ valToMaybe r
+      return $ FormElm toSend $ valToMaybe r
 
 
 
@@ -1496,7 +1390,7 @@ manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a]  -> View view m [a]
 manyOf xs= whidden () *> (View $ do
       forms <- mapM runView  xs
-      let vs  = concatMap (\(FormElm v _) ->  [mconcat v]) forms
+      let vs  = mconcat $ map (\(FormElm v _) ->   v) forms
           res1= catMaybes $ map (\(FormElm _ r) -> r) forms
       return . FormElm vs $ Just res1)
 @@ -1506,11 +1400,11 @@          then return Nothing          else return $ Just mempty 
-(>:>) :: Monad m => View v m a -> View v m [a]  -> View v m [a]
+(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a]  -> View v m [a]
 (>:>) w ws = View $ do
     FormElm fs mxs <- runView $  ws
     FormElm f1 mx  <- runView w
-    return $ FormElm (f1++ fs)
+    return $ FormElm (f1 <> fs)
          $ case( mx,mxs) of
              (Just x, Just xs) -> Just $ x:xs
              (Nothing, mxs)    -> mxs
@@ -1520,21 +1414,23 @@ --
 -- it has a infix priority @infixr 5@
 (|*>) :: (MonadIO m, Functor m, FormInput view)
-            => View view m r
+           => View view m r
            -> [View view m r']
            -> View view m (Maybe r,Maybe r')
 (|*>) x xs= View $ do
-  FormElm fxs rxs <-  runView $ firstOf  xs
-  FormElm fx rx   <- runView $  x
-
-  return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx)
+  fs <-  mapM runView  xs
+  FormElm fx rx   <- runView  x
+  let (fxs, rxss) = unzip $ map (\(FormElm v r) -> (v,r)) fs+      rs= filter isJust rxss+      rxs= if null rs then Nothing else  head rs 
+  return $ FormElm (fx <> mconcat (intersperse  fx fxs) <> fx)
          $ case (rx,rxs) of
             (Nothing, Nothing) -> Nothing
             other -> Just other
 
 
 
-infixr 5 |*>, .|*>.
+infixr 5 |*>
 
 -- | Put a widget before and after other. Useful for navigation links in a page that appears at toAdd
 -- and at the bottom of a page.
@@ -1546,7 +1442,7 @@       -> View view m (Maybe r, Maybe r')
 (|+|) w w'=  w |*> [w']
 
-infixr 1 |+|, .|+|.
+infixr 1 |+|
 
 
 -- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator
@@ -1596,55 +1492,55 @@   doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)
   doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
 
-infixr 7 .<<.
--- | > (.<<.) w x = w $ toByteString x
-(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
-(.<<.) w x = w ( toByteString x)
-
--- | > (.<+>.) x y = normalize x <+> normalize y
-(.<+>.)
-  :: (Monad m, FormInput v, FormInput v1) =>
-     View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
-(.<+>.) x y = normalize x <+> normalize y
-
--- | > (.|*>.) x y = normalize x |*> map normalize y
-(.|*>.)
-  :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
-     View v m r
-     -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
-(.|*>.) x y = normalize x |*> map normalize y
-
--- | > (.|+|.) x y = normalize x |+| normalize y
-(.|+|.)
-  :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
-     View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
-(.|+|.) x y = normalize x |+| normalize y
-
--- | > (.**>.) x y = normalize x **> normalize y
-(.**>.)
-  :: (Monad m, Functor m, FormInput v, FormInput v1) =>
-     View v m a -> View v1 m b -> View ByteString m b
-(.**>.) x y = normalize x **> normalize y
-
--- | > (.<**.) x y = normalize x <** normalize y
-(.<**.)
-  :: (Monad m, Functor m, FormInput v, FormInput v1) =>
-     View v m a -> View v1 m b -> View ByteString m a
-(.<**.) x y = normalize x <** normalize y
-
--- | > (.<|>.) x y= normalize x <|> normalize y
-(.<|>.)
-  :: (Monad m, Functor m, FormInput v, FormInput v1) =>
-     View v m a -> View v1 m a -> View ByteString m a
-(.<|>.) x y= normalize x <|> normalize y
-
--- | > (.<++.) x v= normalize x <++ toByteString v
-(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
-(.<++.) x v= normalize x <++ toByteString v
-
--- | > (.++>.) v x= toByteString v ++> normalize x
-(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
-(.++>.) v x= toByteString v ++> normalize x
+--infixr 7 .<<.
+---- | > (.<<.) w x = w $ toByteString x
+--(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
+--(.<<.) w x = w ( toByteString x)
+--
+---- | > (.<+>.) x y = normalize x <+> normalize y
+--(.<+>.)
+--  :: (Monad m, FormInput v, FormInput v1) =>
+--     View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
+--(.<+>.) x y = normalize x <+> normalize y
+--
+---- | > (.|*>.) x y = normalize x |*> map normalize y
+--(.|*>.)
+--  :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
+--     View v m r
+--     -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
+--(.|*>.) x y = normalize x |*> map normalize y
+--
+---- | > (.|+|.) x y = normalize x |+| normalize y
+--(.|+|.)
+--  :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
+--     View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
+--(.|+|.) x y = normalize x |+| normalize y
+--
+---- | > (.**>.) x y = normalize x **> normalize y
+--(.**>.)
+--  :: (Monad m, Functor m, FormInput v, FormInput v1) =>
+--     View v m a -> View v1 m b -> View ByteString m b
+--(.**>.) x y = normalize x **> normalize y
+--
+---- | > (.<**.) x y = normalize x <** normalize y
+--(.<**.)
+--  :: (Monad m, Functor m, FormInput v, FormInput v1) =>
+--     View v m a -> View v1 m b -> View ByteString m a
+--(.<**.) x y = normalize x <** normalize y
+--
+---- | > (.<|>.) x y= normalize x <|> normalize y
+--(.<|>.)
+--  :: (Monad m, Functor m, FormInput v, FormInput v1) =>
+--     View v m a -> View v1 m a -> View ByteString m a
+--(.<|>.) x y= normalize x <|> normalize y
+--
+---- | > (.<++.) x v= normalize x <++ toByteString v
+--(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
+--(.<++.) x v= normalize x <++ toByteString v
+--
+---- | > (.++>.) v x= toByteString v ++> normalize x
+--(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
+--(.++>.) v x= toByteString v ++> normalize x
 
 
 instance FormInput  ByteString  where
@@ -1688,7 +1584,7 @@        put s{mfPrefix= str ++ mfPrefix s
             ,mfSequence=0 
             ,mfPageFlow= True-             }                              -- !> ("PARENT pageflow. prefix="++ str)
+             }                               -- !> ("PARENT pageflow. prefix="++ str)
 
        r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
                                    ,mfPrefix= mfPrefix s@@ -1698,7 +1594,7 @@ 
 
        else do
-       put s{mfPrefix= str++ mfPrefix s,mfSequence=0}                                                                       --  !> ("CHILD pageflow. prefix="++ str)
+       put s{mfPrefix= str++ mfPrefix s,mfSequence=0}      -- !> ("PARENT pageflow. prefix="++ str)                                                                 --  !> ("CHILD pageflow. prefix="++ str)
 
        widget <** (modify (\s' -> s'{mfSequence= mfSequence s
                                  ,mfPrefix= mfPrefix s}))

src/MFlow/Forms/Admin.hs view

@@ -21,7 +21,7 @@ import Data.Typeable
 import Data.Monoid
 import Data.Maybe
-import Data.Map as M (keys)
+import Data.Map as M (keys, toList)
 import System.Exit
 import Control.Exception as E
 import Control.Concurrent
@@ -70,8 +70,10 @@ -- | execute the process and wait for its finalization.
 --  then it synchronizes the cache
 wait f= do+    putChar '\n'     putStrLn "Using configuration: "-    print config
+    mapM_ putStrLn [k ++"= "++ show v | (k,v) <- M.toList config]+    putChar '\n'
     mv <- newEmptyMVar
     forkIO (f1 >> putMVar mv True)
     putStrLn "wait: ready"
@@ -163,7 +165,7 @@ optionsUser  us = do
     wfs <- liftIO $ return . M.keys =<< getMessageFlows
     stats <-  let u= undefined
-              in  liftIO $ mapM  (\wf -> getWFHistory wf (Token wf us u u u u u)) wfs
+              in  liftIO $ mapM  (\wf -> getWFHistory wf (Token wf us u u u u u u)) wfs
     let wfss= filter (isJust . snd) $ zip wfs stats
     if null wfss
      then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")

+ src/MFlow/Forms/Cache.hs view

@@ -0,0 +1,181 @@+-----------------------------------------------------------------------------+-- | Composable cache and HTTP header directives.+-- Intended to permit each widget to express his caching needs to the whole page+-- The page will compile them and choose the most strict ones+-- Autorefreshed, push and witerate'd widgets do not inherit the page rules. they must specify+-- their own.+--+-- The composition rules are explained in the corresponding combinators. This is a work in progress+-----------------------------------------------------------------------------+{-# LANGUAGE DeriveDataTypeable,FlexibleContexts, OverloadedStrings #-}+module MFlow.Forms.Cache (+resetCachePolicy,setCachePolicy,noCache,noCache',noStore,expires,maxAge+,private, public,sMaxAge,noTransform, proxyRevalidate, etag, vary,+) where+import MFlow.Forms.Internals+import Control.Applicative+import Data.Typeable+import Control.Monad.IO.Class+import Control.Monad.State+import Data.ByteString.Char8+import Data.List (insert,partition,sort)+import Data.Monoid+++data CacheElem = Private | Public | NoCache | NoStore+               | Expires ByteString | MaxAge Int+               | SMaxAge Int | NoTransform+               | NoCache' ByteString+               | MustRevalidate | ProxyRevalidate+               | ETag ByteString | Vary ByteString+               deriving(Typeable, Show,Eq,Ord)++-- | to delete all previous directives+resetCachePolicy :: (MonadState (MFlowState v) m, Monad m) => m ()+resetCachePolicy= do+  modify $ \s -> s{mfHttpHeaders=[]}+  setSessionData ([] :: [CacheElem])++-- | add @no-cache@ to the @Cache-Control@ header directive. It deletes all expires and put max-age=0+--+-- It means that the widget need not to be cached+noCache :: (MonadState (MFlowState v) m, MonadIO m) => m ()+noCache =  set  NoCache++-- | add @no-cache: <string>@  to the Cache-Control header directive+--+-- it deletes the header string (sensible cookies for example) from the data stored in the cache+noCache' :: (MonadState (MFlowState v) m, MonadIO m) => ByteString -> m ()+noCache' s =  set ( NoCache' s)++-- | add @no-store@ to the @Cache-Control@ header directive. It deletes  @expires@ and put @max-age: 0@+--+-- stronger kind of noCache. Not even store temporally+noStore :: (MonadState (MFlowState v) m, MonadIO m) => m ()+noStore =  set NoStore++-- | add @expires: <date string>@ to the @Cache-Control@ header directive. it deletes @max-age@+-- Currently it takes the last one if many+--+-- The page will be cached until this date+expires :: (MonadState (MFlowState v) m, MonadIO m) =>  ByteString ->  m ()+expires s =  set (Expires  s)++-- | add @max-age: <seconds>@ to the @Cache-Control@ header directive. if there are more than one, it chooses the lower one+--+-- The page will be stored in the cache for that amount of seconds+maxAge  :: (MonadState (MFlowState v) m, MonadIO m) =>   Int ->   m ()+maxAge t =  set (MaxAge t)++-- | add @private@ to the @Cache-Control@ header directive. it delete @public@ if any+--+-- It means that the page that holds the widget must not be shared by other users.+private :: (MonadState (MFlowState v) m, MonadIO m) => m ()+private =  set Private++-- | add @public@ to the @Cache-Control@ header directive.+--+-- means that the cache can share the page content with other users.+public :: (MonadState (MFlowState v) m, MonadIO m) => m ()+public =  set Public++-- | add @sMaxAge <seconds>@ to the @Cache-Control@ header directive. if many, chooses the minimum+--+-- specify the time to hold the page for intermediate caches: for example proxies and CDNs.+sMaxAge :: (MonadState (MFlowState v) m, MonadIO m) => Int -> m ()+sMaxAge secs =  set (SMaxAge secs)++-- | add @noTransform@ to the @Cache-Control@ header directive.+--+-- Tell CDNs that the content should not be transformed to save space and so on+noTransform :: (MonadState (MFlowState v) m, MonadIO m) => m ()+noTransform =  set NoTransform++-- | add @mustRevalidate@ to the @Cache-Control@ header directive.+--+-- the cache must verify that the page has not changed.+mustRevalidate  :: (MonadState (MFlowState v) m, MonadIO m) => m ()+mustRevalidate =  set MustRevalidate++-- | add @proxyRevalidate@ to the @Cache-Control@ header directive.+--+-- The same than mustRevalidate, for shared caches (proxies etc)+proxyRevalidate :: (MonadState (MFlowState v) m, MonadIO m) => m ()+proxyRevalidate =  set ProxyRevalidate++-- | add @etag <string>@ to the  header directives.+--+-- it is a resource identifier for the page that substitutes the URL identifier+etag :: (MonadState (MFlowState v) m, MonadIO m) =>  ByteString ->  m ()+etag s =  set (ETag s)++-- | add @vary <string>@ to the header directives.+--+-- Usually the page add this identifier to the URL string, that is the default identifier+-- So the same page with different etags will be cached and server separately+vary :: (MonadState (MFlowState v) m, MonadIO m) =>  ByteString ->  m ()+vary s =  set (Vary s)++generate ::  [CacheElem] -> [(ByteString,ByteString)]+generate []= []+generate xs = generatep xs [controlempty]+ where+ controlempty= ("Cache-Control","")+ generatep [] res= if Prelude.head res == controlempty then Prelude.tail res else res+++ generatep (x:xs) ((k,v):rs) =+  case gen x of+   Right s ->  generatep xs ((k, v <> ", " <>s): rs)++   Left pair -> generatep xs (rs++[pair])++ gen NoCache= Right "no-cache"+ gen (NoCache' s)=  Right $ "no-cache= " <>s+ gen NoStore= Right "no-store"+ gen (Expires s)=  Right $ "expires= "<>s+ gen (MaxAge t)= Right $ "max-age= "<> pack (show t)+ gen Private= Right "private"+ gen Public=  Right "public"+ gen (SMaxAge t)= Right $ "s-maxage" <> pack (show t)+ gen NoTransform= Right "no-transform"+ gen MustRevalidate = Right "must-revalidate"+ gen ProxyRevalidate= Right "proxy-revalidate"+ gen (ETag s)= Left ("etag", s) :: Either (ByteString, ByteString) ByteString+ gen (Vary s)= Left ("vary",s)++set r = do+  rs <- getSessionData `onNothing` return []+  setSessionData $ r:rs++++compile rs = comp $ Data.List.sort rs+   where+   comp []= []+   comp [x]= [x]+   comp (x:(xs@(x':_))) | x==x'= comp xs             -- !> ("drop repetitions "++ show x)+   comp (Private:Public: xs) = comp  $ Private:comp xs+   comp (NoCache:NoStore:xs)= comp $ NoCache: comp xs+   comp (NoStore: Expires _: xs)= comp $ NoStore: comp xs+   comp (NoStore:MaxAge _ : xs)= comp $ NoStore: comp xs+   comp (NoCache:MaxAge _ : xs)= comp $ NoCache: comp xs+   comp (SMaxAge t:SMaxAge t':xs)= comp $ MaxAge (Prelude.min t t'): comp xs+   comp (Expires t:Expires t':xs)= comp $ Expires t: comp xs+   comp (Expires t:MaxAge _:xs)= comp $ Expires t: comp xs+   comp (MaxAge t:MaxAge t':xs)= comp $ MaxAge (Prelude.min t t'): comp xs+   comp (x:xs) = x: comp xs++onNothing  mmx mmy= do+  mx <- mmx+  case mx of+   Just x -> return x+   Nothing -> mmy+++-- | return the composition of the current directives. Used by the page internally+setCachePolicy :: (MonadState (MFlowState v) m, Monad m) => m ()+setCachePolicy= do+   rs <- getSessionData `onNothing` return  []+   let hs =generate $ compile rs                     -- !> show rs+   mapM_ (\(n,v) -> setHttpHeader n v ) hs           -- !> ("headers1="++ show hs)

src/MFlow/Forms/Internals.hs view

@@ -21,7 +21,6 @@              -XFlexibleContexts
              -XOverlappingInstances
              -XRecordWildCards
-             -XTemplateHaskell
 #-}
 
 module MFlow.Forms.Internals where
@@ -52,7 +51,9 @@ import Data.List(stripPrefix) import Data.Maybe(isJust) import Control.Concurrent.STM---import Data.String
+import Data.TCache.Memoization+--import Data.String+
 --
 ---- for traces
 --
@@ -160,11 +161,11 @@ type WState view m = StateT (MFlowState view) m
 type FlowMM view m=  Sup (WState view m)
 
-data FormElm view a = FormElm [view] (Maybe a) deriving Typeable
+data FormElm view a = FormElm view (Maybe a) deriving Typeable
 
-instance Serialize a => Serialize (FormElm view a) where
+instance (Monoid view,Serialize a) => Serialize (FormElm view a) where
    showp (FormElm _ x)= showp x
-   readp= readp >>= \x -> return $ FormElm  [] x
+   readp= readp >>= \x -> return $ FormElm  mempty x
 
 -- | @View v m a@ is a widget (formlet)  with formatting `v`  running the monad `m` (usually `IO`) and which return a value of type `a`
 --
@@ -277,7 +278,7 @@              case CE.fromException e :: Maybe AsyncException of
                 Just e -> CE.throw e            -- !> ("TROWN ASYNC=" ++ show e)
                 Nothing ->
-                  return (FormElm [] Nothing, s{mfTrace= [show e]}) -- !> loc
+                  return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
 
 
 
@@ -285,19 +286,6 @@ 
 
 
-instance (FormInput v,Serialize a)
-   => Serialize (a,MFlowState v) where
-   showp (x,s)= case mfDebug s of
-      False -> showp x
-      True  -> showp(x, mfEnv s)
-   readp= choice[nodebug, debug]
-    where
-    nodebug= readp  >>= \x -> return  (x, mFlowState0{mfSequence= inRecovery})
-    debug=  do
-     (x,env) <- readp
-     return  (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
-    
-
 instance Functor (FormElm view ) where
   fmap f (FormElm form x)= FormElm form (fmap f x)
 
@@ -305,15 +293,15 @@   fmap f x= View $   fmap (fmap f) $ runView x
 
   
-instance (Functor m, Monad m) => Applicative (View view m) where
-  pure a  = View $  return (FormElm [] $ Just a)
+instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
+  pure a  = View  .  return . FormElm mempty $ Just a
   View f <*> View g= View $
                    f >>= \(FormElm form1 k) ->
                    g >>= \(FormElm form2 x) ->
-                   return $ FormElm (form1 ++ form2) (k <*> x) 
+                   return $ FormElm (form1 `mappend` form2) (k <*> x) 
 
 instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
-  empty= View $ return $ FormElm [] Nothing
+  empty= View $ return $ FormElm mempty Nothing
   View f <|> View g= View $ do                    path <- gets mfPagePath
                    FormElm form1 k <- f@@ -330,7 +318,7 @@                          _          -> path                    if hasform then put s2{needForm= HasForm,mfPagePath= path3}                               else put s2{mfPagePath=path3}
-                   return $ FormElm mix (k <|> x)
+                   return $ FormElm mix (k <|> x) 
 
 
 instance  (FormInput view, Monad m) => Monad (View view m) where
@@ -352,7 +340,7 @@                         
 
 
-    return = View .  return . FormElm  [] . Just
+    return = View .  return . FormElm  mempty . Just
 --    fail msg= View . return $ FormElm [inRed msg] Nothing
 
 @@ -379,31 +367,25 @@    FormElm form1 mk <- x
    case mk of
      Just k  -> do
-       modify $ \st -> st{linkMatched= False, needForm=NoElems}-                       
-       runView (f k)
+       modify $ \st -> st{linkMatched= False, needForm=NoElems}
+       runView (f k)+       
      Nothing -> return $ FormElm form1 Nothing
 
 
 
-clear :: (FormInput v,Monad m) => View v m ()
-clear = wcallback (return()) (const $ return()) 
 
 
 
-
-
-
-
-instance MonadTrans (View view) where
-  lift f = View $  (lift  f) >>= \x ->  return $ FormElm [] $ Just x
+instance Monoid view => MonadTrans (View view) where
+  lift f = View $  (lift  f) >>= \x ->  return $ FormElm mempty $ Just x
 
 instance MonadTrans (FlowM view) where
   lift f = FlowM $ lift (lift  f) -- >>= \x ->  return x
 
 instance  (FormInput view, Monad m)=> MonadState (MFlowState view) (View view m) where
-  get = View $  get >>= \x ->  return $ FormElm [] $ Just x
-  put st = View $  put st >>= \x ->  return $ FormElm [] $ Just x
+  get = View $  get >>= \x ->  return $ FormElm mempty $ Just x
+  put st = View $  put st >>= \x ->  return $ FormElm mempty $ Just x
 
 --instance  (Monad m)=> MonadState (MFlowState view) (FlowM view m) where
 --  get = FlowM $  get >>= \x ->  return $ FormElm [] $ Just x
@@ -419,7 +401,98 @@ changeMonad w= View . StateT $ \s ->
     let (r,s')= execute $ runStateT  ( runView w)    s
     in mfSequence s' `seq` return (r,s')
++++----- some combinators ---- 
+-- | Join two widgets in the same page
+-- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
+-- if both return Noting, the widget return @Nothing@ (invalid).
+--
+-- it has a low infix priority: @infixr 2@
+--
+--  > r <- ask  widget1 <+>  widget2
+--  > case r of (Just x, Nothing) -> ..
+(<+>) , mix ::  (Monad m, FormInput view)
+      => View view m a
+      -> View view m b
+      -> View view m (Maybe a, Maybe b)
+mix digest1 digest2= View $ do
+  FormElm f1 mx' <- runView  digest1+  s1 <- get
+  FormElm f2 my' <- runView  digest2+  s2 <- get+  (mix, hasform) <- controlForms s1 s2 f1 f2+  when hasform $ put s2{needForm= HasForm}
+  return $ FormElm mix
+         $ case (mx',my') of
+              (Nothing, Nothing) -> Nothing
+              other              -> Just other
+
+infixr 2 <+>
+
+(<+>)  = mix
+
+
+
+-- | The first elem result (even if it is not validated) is discarded, and the secod is returned
+-- . This contrast with the applicative operator '*>' which fails the whole validation if
+-- the validation of the first elem fails.
+--
+-- The first element is displayed however, as happens in the case of '*>' .
+--
+-- Here @w\'s@ are widgets and @r\'s@ are returned values
+--
+--   @(w1 <* w2)@  will return @Just r1@ only if w1 and w2 are validated
+--
+--   @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
+--
+--  it has a low infix priority: @infixr 1@
+
+(**>) :: (Functor m, Monad m, FormInput view)
+      => View view m a -> View view m b -> View view m b
+--(**>) form1 form2 = valid form1 *> form2+(**>) f g = View $ do+   FormElm form1 k <- runView $ valid f+   s1 <- get
+   FormElm form2 x <- runView g+   s2 <- get+   (mix,hasform) <- controlForms s1 s2 form1 form2+   when hasform $ put s2{needForm= HasForm}
+   return $ FormElm mix (k *> x)
+
++
+valid form= View $ do
+   FormElm form mx <- runView form
+   return $ FormElm form $ Just undefined
+
+infixr 1  **>  ,  <** 
+
+-- | The second elem result (even if it is not validated) is discarded, and the first is returned
+-- . This contrast with the applicative operator '*>' which fails the whole validation if
+-- the validation of the second elem fails.
+-- The second element is displayed however, as in the case of '<*'.
+-- see the `<**` examples
+--
+--  it has a low infix priority: @infixr 1@
+(<**) :: (Functor m, Monad m, FormInput view) =>
+     View view m a -> View view m b -> View view m a
+-- (<**) form1 form2 =  form1 <* valid form2
+(<**) f g = View $ do+   FormElm form1 k <- runView f+   s1 <- get
+   FormElm form2 x <- runView $ valid g+   s2 <- get+   (mix,hasform) <- controlForms s1 s2 form1 form2+   when hasform $ put s2{needForm= HasForm}
+   return $ FormElm mix (k <* x)
+
+++-------- Flow control+
 -- | True if the flow is going back (as a result of the back button pressed in the web browser).
 --  Usually this check is nos necessary unless conditional code make it necessary
 --
@@ -608,6 +681,13 @@  typeResp :: m (Maybe x) -> x
  typeResp= undefined
 +-- | getSessionData specialized for the View monad. if Nothing, the monadic computation+-- does not continue.+getSData :: (Monad m,Typeable a,Monoid v) => View v m a+getSData= View $ do+    r <- getSessionData+    return $ FormElm mempty r+ -- | Return the session identifier getSessionId :: MonadState (MFlowState v) m => m String getSessionId= gets mfToken >>= return . key@@ -715,7 +795,7 @@           -> SB.ByteString  -- ^ value
           -> m ()
 setHttpHeader n v =
-    modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st }
+    modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
 
 
 -- | Set
@@ -756,7 +836,7 @@ normalize :: (Monad m, FormInput v) => View v m a -> View B.ByteString m a
 normalize f=  View .  StateT $ \s ->do
        (FormElm fs mx, s') <-  runStateT  ( runView f) $ unsafeCoerce s
-       return  (FormElm (map toByteString fs ) mx,unsafeCoerce s')
+       return  (FormElm (toByteString fs ) mx,unsafeCoerce s')
 
 
 
@@ -885,8 +965,8 @@    adminLoop
 @
 -}
---runFlow :: (FormInput view, MonadIO m)
---        => FlowM view m () -> Token -> m () 
+runFlow :: (FormInput view, MonadIO m)
+        => FlowM view (Workflow m) () -> Token -> Workflow m () 
 runFlow  f t=
   loop (startState t) f   t 
   where
@@ -904,8 +984,8 @@ 
 inRecovery= -1
 
---runFlowOnce :: (MonadIO m, FormInput view)
---        => FlowM view m () -> Token -> m ()
+runFlowOnce :: (FormInput view, MonadIO m)
+            => FlowM view (Workflow m) () -> Token -> Workflow m ()
 runFlowOnce f t= runFlowOnce1 f t  >> return ()
 
 runFlowOnce1 f t  = runFlowOnce2 (startState t)  f
@@ -977,10 +1057,15 @@ runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a ->  m a
 runFlowConf  f = do
   q  <- liftIO newEmptyMVar  -- `debug` (i++w++u)
-  qr <- liftIO newEmptyMVar
-  let t=  Token "" "" "" [] [] q  qr
+  qr <- liftIO newEmptyMVar+  block <- liftIO $ newMVar True
+  let t=  Token "" "" "" [] [] block q  qr
   evalStateT (runSup . runFlowM $   f )  mFlowState0{mfToken=t} >>= return . fromFailBack   -- >> return ()
 
++-- | run a transient Flow from the IO monad.+--runNav :: String -> FlowM Html IO () -> IO ()+--runNav ident f= exec1 ident $ runFlowOnce (transientNav f) undefined 
 
 -- | Clears the environment
@@ -990,6 +1075,21 @@   put st{ mfEnv= []}
 
 
+
+instance (FormInput v,Serialize a)
+   => Serialize (a,MFlowState v) where
+   showp (x,s)= case mfDebug s of
+      False -> showp x
+      True  -> showp(x, mfEnv s)
+   readp= choice[nodebug, debug]
+    where
+    nodebug= readp  >>= \x -> return  (x, mFlowState0{mfSequence= inRecovery})
+    debug=  do
+     (x,env) <- readp
+     return  (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
++
+
 -- | stores the result of the flow in a  persistent log. When restarted, it get the result
 -- from the log and it does not execute it again. When no results are in the log, the computation
 -- is executed. It is equivalent to 'Control.Workflow.step' but in the FlowM monad.
@@ -1118,13 +1218,15 @@    else case  stripPrefix (mfPagePath st) lpath  of      Nothing -> return Nothing      Just [] -> return Nothing   
-     Just xs -> do-          let name = head xs-          r <-  fmap valToMaybe $ readParam name 
-          when (isJust r) $ modify $ \s -> s{inSync= True
-                                            ,linkMatched= True-                                            ,mfPagePath= mfPagePath s++[name]}-          return r 
+     Just xs ->+        case stripPrefix  (mfPrefix st) (head xs)  of+             Nothing -> return Nothing+             Just name -> do+              r <-  fmap valToMaybe $ readParam name 
+              when (isJust r) $ modify $ \s -> s{inSync= True
+                                                ,linkMatched= True+                                                ,mfPagePath= mfPagePath s++[name]}+              return r 
              
  @@ -1183,7 +1285,7 @@ installAllRequirements :: ( Monad m, FormInput view) =>  WState view m view
 installAllRequirements= do
  rs <- gets mfRequirements
- installAllRequirements1 mempty rs 
+ installAllRequirements1 mempty rs
  where
 
  installAllRequirements1 v []= return v
@@ -1205,11 +1307,15 @@                            else (ts, x:fs)
 
 -- Web requirements ---
-loadjsfile filename lcallbacks=
-  "var fileref=document.createElement('script');\
-  \fileref.setAttribute('type','text/javascript');\
-  \fileref.setAttribute('src',\'" ++ filename ++ "\');\
-  \document.getElementsByTagName('head')[0].appendChild(fileref);"
+loadjsfile filename lcallbacks=+ let name= addrStr filename in+  "var fileref = document.getElementById('"++name++"');\+  \if (fileref === null){\
+      \fileref=document.createElement('script');\+      \fileref.setAttribute('id','"++name++"');\
+      \fileref.setAttribute('type','text/javascript');\
+      \fileref.setAttribute('src',\'" ++ filename ++ "\');\
+      \document.getElementsByTagName('head')[0].appendChild(fileref);};"
   ++ onload
   where
   onload= case lcallbacks of
@@ -1246,8 +1352,8 @@                      deriving(Typeable,Eq,Ord,Show)
 
 instance Eq (String, Flow) where
-   (x,_) == (y,_)= x == y
-
+   (x,_) == (y,_)= x == y+ 
 instance Ord (String, Flow) where
    compare(x,_)  (y,_)= compare x y
 instance Show (String, Flow) where
@@ -1260,7 +1366,7 @@ 
 installWebRequirements ::  (Monad m,FormInput view) =>[WebRequirement] -> m view
 installWebRequirements rs= do
-  let s =  jsRequirements $ sort rs
+  let s =  jsRequirements $ sort rs  
 
   return $ ftag "script" (fromStrNoEncode  s)
 
@@ -1326,7 +1432,7 @@                         anchor <- genNewId
                         return ('#':anchor, (ftag "a") mempty  `attrs` [("name",anchor)])
                False -> return (mempty,mempty)
-     return $ formAction (path ++ anchor ) $  mconcat ( anchorf:form)  -- !> anchor
+     return $ formAction (path ++ anchor ) $  anchorf <> form  -- !> anchor
 
 -- | insert a form tag if the widget has form input fields. If not, it does nothing
 insertForm w=View $ do
@@ -1337,22 +1443,22 @@                        frm <- formPrefix  st forms False
                        put st{needForm= HasForm}
                        return   frm
-              _    ->  return $ mconcat  forms
+              _    ->  return forms
     
-    return $ FormElm [cont] mx
+    return $ FormElm cont mx
  -- isert a form tag if necessary when two pieces of HTML have to mix as a result of >>= >> <|>  or <+> operators controlForms :: (FormInput v, MonadState (MFlowState v) m)-    => MFlowState v -> MFlowState v -> [v] -> [v] -> m ([v],Bool)+    => MFlowState v -> MFlowState v -> v -> v -> m (v,Bool) controlForms s1 s2 v1 v2= case (needForm s1, needForm s2) of --    (HasForm,HasElems) -> do --       v2' <- formPrefix s2 v2 True --       return (v1 ++ [v2'], True)     (HasElems, HasForm) -> do        v1' <- formPrefix s1 v1 True-       return ([v1'] ++ v2 , True)+       return (v1' <> v2 , True) -    _ -> return (v1 ++ v2, False)
+    _ -> return (v1 <> v2, False)
 
 currentPath  st=  concat ['/':v| v <- mfPagePath st ]
 
@@ -1386,4 +1492,6 @@     True  -> do
       let n = mfSeqCache st
       return $  'c' : (show n)
++

src/MFlow/Forms/Test.hs view

@@ -93,9 +93,6 @@           typeOfIO = undefined
 
 -- | run a list of flows with a number of simultaneous threads
-
-
-
 runTest :: [(Int, Flow)] -> IO () 
 runTest ps= do
   mapM_ (forkIO . run1) ps
@@ -109,10 +106,9 @@     name <- generate
     x <- generate
     y <- generate
-    z <- generate 
-    r1<- liftIO newEmptyMVar
-    r2<- liftIO newEmptyMVar 
-    let t = Token x y z [] [] r1 r2
+    z <- generate+     
+    let t = Token x y z [] [] undefined undefined undefined
     WF.start  name   f t
 
 testNumber= unsafePerformIO $ newIORef 0
@@ -144,7 +140,7 @@ ask w = do
     FormElm forms mx <- FlowM . lift $ runView  w
     r <- liftIO generate
-    let n= B.length . toByteString $ mconcat forms
+    let n= B.length $ toByteString  forms
     breturn $ n `seq` mx `seq` r
 --    let u= undefined
 --    liftIO $ runStateT (runView mf) s
@@ -168,7 +164,7 @@ askt v w =  do
     FormElm forms mx <- FlowM . lift $ runView  w
     n <- getTestNumber
-    let l= B.length . toByteString $ mconcat forms
+    let l= B.length $ toByteString  forms
     breturn $ l `seq` mx `seq` v n
 
 --mvtestopts :: MVar (M.Map String (Int,Dynamic))

src/MFlow/Forms/WebApi.hs view

@@ -38,14 +38,14 @@ import MFlow.Forms(stop,(++>)) import Control.Monad.State import Data.Typeable-+import Data.Monoid -- | Get the next segment of the REST path. if there is no one or if the data does not match -- with the type expected, then ir return invalid. --  Therefore a monadic sequence in the View monad will not continue restp :: (Monad m,Functor m, FormInput v,Typeable a,Read a) => View v m a restp =  View $ do    mr <- getRestParam-   return $ FormElm [] mr+   return $ FormElm mempty mr   @@ -60,7 +60,7 @@ -- | get a parameter from a GET or POST key-value input. wparam par= View $ do    mr <- getKeyValueParam par-   return $ FormElm [] mr+   return $ FormElm mempty mr  -- | append to the output the result of an expression dispv :: (Monad m, FormInput v) => View v m v -> View  v m ()@@ -68,7 +68,7 @@    FormElm f mx <- runView w    case mx of      Nothing -> return $ FormElm f Nothing-     justx@(Just x) -> return $ FormElm (f++[x]) $ return ()+     justx@(Just x) -> return $ FormElm (f <> x) $ return ()   -- | append to the output the result of an expression@@ -77,7 +77,7 @@    FormElm f mx <- runView w    case mx of      Nothing -> return $ FormElm f Nothing-     justx@(Just x) -> return $ FormElm (f++[fromStr $ show x]) $ return ()+     justx@(Just x) -> return $ FormElm (f <>fromStr (show x)) $ return ()  -- | error message when a applicative expression do not match infixl 3 <?>

src/MFlow/Forms/Widgets.hs view

@@ -5,17 +5,16 @@ to create other active widgets.
 -}
 
-{-# LANGUAGE UndecidableInstances,ExistentialQuantification
+{-# LANGUAGE  UndecidableInstances,ExistentialQuantification
             , FlexibleInstances, OverlappingInstances, FlexibleContexts
-            , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables
-            , TemplateHaskell #-}
+            , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables  #-}
 
 
 
 
 module MFlow.Forms.Widgets (
 -- * Ajax refreshing of widgets
-autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..)
+autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
 
 -- * JQueryUi widgets
 ,datePicker, getSpinner, wautocomplete, wdialog,
@@ -45,7 +44,8 @@ import MFlow.Forms
 import MFlow.Forms.Internals
 import Data.Monoid
-import Data.ByteString.Lazy.UTF8 as B hiding (length,span)
+import Data.ByteString.Lazy.UTF8 as B hiding (length,span)+import Data.ByteString.Lazy.Char8 (unpack)
 import Control.Monad.Trans
 import Data.Typeable
 import Data.List
@@ -65,6 +65,7 @@ import Control.Workflow(killWF)
 import Unsafe.Coerce
 import Control.Exception
+import MFlow.Forms.Cache 
 
 
@@ -77,10 +78,10 @@ --jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
 --jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
 
-jqueryScript= getConfig "cjqueryScript"
-jqueryCSS= getConfig "cjqueryCSS"
-jqueryUI= getConfig "cjqueryUI"
-nicEditUrl= getConfig "cnicEditUrl"
+jqueryScript= getConfig "cjqueryScript" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
+jqueryCSS=    getConfig "cjqueryCSS"    "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
+jqueryUI=     getConfig "cjqueryUI"     "//code.jquery.com/ui/1.10.3/jquery-ui.js"
+nicEditUrl=   getConfig "cnicEditUrl"   "//js.nicedit.com/nicEdit-latest.js"
 ------- User Management ------
 
 -- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.
@@ -103,21 +104,25 @@       then do
           cmd <- ajax $ const $ return "window.location=='/'" --refresh
           fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
-      else noWidget
-
+      else noWidget+ 
-data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])
-instance (Typeable view, Typeable a) => Typeable (Medit view m a) where
-  typeOf= \v -> mkTyConApp (mkTyCon3 "MFlow" "MFlow.Forms.Widgets" "Medit" )
-                [typeOf (tview v)
-                ,typeOf (ta v)]
-      where
-      tview :: Medit v m a -> v
-      tview= undefined
-      tm :: Medit v m a -> m a
-      tm= undefined
-      ta :: Medit v m a -> a
-      ta= undefined
+data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])+-- #if MIN_VERSION_ghc(7, 7, 0)+--    deriving Typeable+-- #else+instance (Typeable view, Typeable a) => Typeable (Medit view m a) where+  typeOf= \v -> mkTyConApp (mkTyCon3 "MFlow" "MFlow.Forms.Widgets" "Medit" )+                [typeOf (tview v)+                ,typeOf (ta v)]+      where+      tview :: Medit v m a -> v+      tview= undefined+      tm :: Medit v m a -> m a+      tm= undefined+      ta :: Medit v m a -> a+      ta= undefined+-- #endif
 
 -- | If not logged, it present a page flow which askm  for the user name, then the password if not logged
 --
@@ -128,7 +133,9 @@ wlogin=  do
    username <- getCurrentUser
    if username /= anonymous  
-         then return username 
+         then do+           private; noCache;noStore+           return username 
          else do
           name <- getString Nothing <! hint "login name"                                     <! size 9@@ -202,8 +209,8 @@      let cw = wcached key 0  w
      addEdited selector (key,cw)
      FormElm form _ <-  runView cw
-     let elem=  toByteString  $ mconcat form
-     return . FormElm [] . Just $   selector <> "." <> modifier <>"('" <> elem <> "');"
+     let elem=  toByteString   form
+     return . FormElm mempty . Just $   selector <> "." <> modifier <>"('" <> elem <> "');"
      where
      typ :: View v Identity a -> a
      typ = undefined
@@ -291,8 +298,7 @@     id1<- genNewId
     let sel= "$('#" <>  fromString id1 <> "')"
     callAjax <- ajax . const $ prependWidget sel wn
-    let installevents= "$(document).ready(function(){\
-              \$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
+    let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
 
     requires [JScriptFile jqueryScript [installevents] ]
 
@@ -302,29 +308,6 @@     delEdited sel ws'
     return r
 
---wpush
---  :: (Typeable a,
---      FormInput v) =>
---     (v -> v)
---     -> String
---     -> String
---     -> String
---     -> (String -> View v IO a)
---     -> View v IO a
---wpush  holder modifier addId expr w = do
---    id1 <- genNewId
---    let sel= "$('#" <>  fromString id1 <> "')"
---    callAjax <- ajax $ \s ->  appendWidget sel ( changeMonad $ w s)
---    let installevents= "$(document).ready(function(){\
---              \$('#"++addId++"').click(function(){"++callAjax expr ++ "});})"
---
---    requires [JScriptFile jqueryScript [installevents] ]
---
---    ws <- getEdited sel
---
---    r <-  holder  <<< firstOf ws  <! [("id",id1)]
---    delEdited sel ws
---    return r
 
 
 
@@ -410,15 +393,15 @@     where
     events textx ajaxc=
          "$(document).ready(function(){   \
-         \  $('#"++textx++"').keydown(function(){ \
-         \   if(event.keyCode == 13){  \
-             \   var v= $('#"++textx++"').val(); \
-             \   if(event.preventDefault) event.preventDefault();\
-             \   else if(event.returnValue) event.returnValue = false;" ++
+           \$('#"++textx++"').keydown(function(){ \
+            \if(event.keyCode == 13){  \
+                \var v= $('#"++textx++"').val(); \
+                \if(event.preventDefault) event.preventDefault();\
+                \else if(event.returnValue) event.returnValue = false;" ++
                  ajaxc "'f'+v"++";"++
              "   $('#"++textx++"').val('');\
-         \  }\
-         \ });\
+           \}\
+          \});\
          \});"
 
     jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> "  });"
@@ -451,27 +434,11 @@     serialize (TField k content)  = content
     deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
 
---       where
 
---       des1 _ bs=
---          let s= B.unpack bs -- read . B.unpack
---          in case s of
---               ('T':'F':'i':'e':'l':'d':' ':s)  ->
---                  let
---                      [(k,rest)] =  readsPrec 0 s
---                      [(content,_)] = readsPrec 0 $ tail rest
---                  in TField k (fromString content)
---               _ -> error "not match"
     setPersist =   \_ -> Just filePersist
 
 
---applyDeserializers [] k str = x where
---     x= error $ "can not deserialize "++ B.unpack str++" to type: "++ show (typeOf x)
---
---applyDeserializers (d:ds) k str=  unsafePerformIO $
---      (return $! d k str) `catch` (\(_ :: SomeException)-> return (applyDeserializers ds k str))
 
-
 writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
 
 
@@ -497,11 +464,11 @@   id <- genNewId
 
   let installHtmlField=
-          "\nfunction installHtmlField(muser,cookieuser,name,buttons){\n\
-            \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\n\
-                 \ bkLib.onDomLoaded(function() {\n\
-                 \   var myNicEditor = new nicEditor({buttonList : buttons});\n\
-                 \   myNicEditor.panelInstance(name);\n\
+          "\nfunction installHtmlField(muser,cookieuser,name,buttons){\
+            \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
+                  \bkLib.onDomLoaded(function() {\
+                    \var myNicEditor = new nicEditor({buttonList : buttons});\
+                    \myNicEditor.panelInstance(name);\
                  \})};\n"
       install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
 
@@ -542,45 +509,48 @@            flushCached k
            sendFlush token $ HttpData [] [] ""
            return()
-
+   
    requires [JScriptFile nicEditUrl [install]
             ,JScript     ajaxSendText
             ,JScript     installEditField
 --            ,JScriptFile jqueryScript []
             ,ServerProc  ("_texts",  transient getTexts)]
-
++   us <- getCurrentUser+   when(us== muser) noCache+   
    (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
     notValid (ftag "span" content `attrs` [("id", name)])
 
 
 
 installEditField=
-          "\nfunction installEditField(muser,cookieuser,name,ipanel){\n\
-            \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\n\
-                 \ bkLib.onDomLoaded(function() {\n\
-                 \   var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
-                 \        ajaxSendText(id,content);\n\
-                 \        myNicEditor.removeInstance(name);\n\
-                 \        myNicEditor.removePanel(ipanel);\n\
-                 \      }});\n\
-                 \   myNicEditor.addInstance(name);\n\
-                 \   myNicEditor.setPanel(ipanel);\n\
+          "\nfunction installEditField(muser,cookieuser,name,ipanel){\
+            \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
+                  \bkLib.onDomLoaded(function() {\
+                    \var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
+                         \ajaxSendText(id,content);\
+                         \myNicEditor.removeInstance(name);\
+                         \myNicEditor.removePanel(ipanel);\
+                       \}});\
+                    \myNicEditor.addInstance(name);\
+                    \myNicEditor.setPanel(ipanel);\
                  \})};\n"
 
-ajaxSendText = "\nfunction ajaxSendText(id,content){\n\
-        \var arr= id.split('-');\n\
-        \var k= arr[1];\n\
-        \$.ajax({\n\
-        \       type: 'POST',\n\
-        \       url: '/_texts',\n\
-        \       data: k + '='+ encodeURIComponent(content),\n\
-        \       success: function (resp) {},\n\
-        \       error: function (xhr, status, error) {\n\
-        \                var msg = $('<div>' + xhr + '</div>');\n\
-        \                id1.html(msg);\n\
-        \       }\n\
-        \   });\n\
-        \return false;\n\
+ajaxSendText = "\nfunction ajaxSendText(id,content){\
+        \var arr= id.split('-');\
+        \var k= arr[1];\
+        \$.ajax({\
+               \type: 'POST',\
+               \url: '/_texts',\
+               \data: k + '='+ encodeURIComponent(content),\
+               \success: function (resp) {},\
+               \error: function (xhr, status, error) {\
+                        \var msg = $('<div>' + xhr + '</div>');\
+                        \id1.html(msg);\
+               \}\
+           \});\
+        \return false;\
         \};\n"
 
 -- | a text field. Read the cached  field value and present it without edition.
@@ -628,163 +598,130 @@ witerate
   :: (MonadIO m, Functor m, FormInput v) =>
       View v m a -> View v m a
-witerate  w= do
-   name  <- genNewId
-   setSessionData $ IteratedId name
+witerate w= do
+   name <- genNewId
+   setSessionData $ IteratedId name 
    st <- get
    let t= mfkillTime st
    let installAutoEval=
-        "$(document).ready(function(){\n\
+        "$(document).ready(function(){\
            \autoEvalLink('"++name++"',0);\
            \autoEvalForm('"++name++"');\
            \})\n"
-   let r = lookup ("auto"++name) $ mfEnv st
+   let r = lookup ("auto"++name) $ mfEnv st+       w'= w `wcallback` (const $ do+                              modify $ \s -> s{mfPagePath=mfPagePath st+                                             ,mfSequence= mfSequence st+                                             ,mfRequirements= if r== Nothing then  mfRequirements s else []+                                             ,mfHttpHeaders=[]}+                              w) 
+
    ret <- case r of
     Nothing -> do
      requires [JScript     autoEvalLink
               ,JScript     autoEvalForm
-              ,JScript     setId
               ,JScript     $ timeoutscript t
-              ,JScriptFile jqueryScript [installAutoEval]]
-
-     (ftag "div" <<<   w) <! [("id",name)]  
+              ,JScriptFile jqueryScript [installAutoEval]+              ,JScript     setId]    
 
+     (ftag "div" <<< w') <! [("id",name)] 
 
     Just sind -> View $ do
          let t= mfToken st
-         modify $ \s -> s{mfRequirements=[]}
-
-         FormElm _ mr <- runView  w
-
+         modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
+         resetCachePolicy 
+         FormElm _ mr <- runView w'
+         setCachePolicy 
          reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements
-         let js = jsRequirements reqs
+         let js = jsRequirements reqs++         st' <- get 
          liftIO . sendFlush t $ HttpData
-                                (mfHttpHeaders st) 
-                                (mfCookies st) (fromString js)
-         modify $ \st -> st{mfAutorefresh=True,inSync=True}
-         return $ FormElm [] mr  
+                                (mfHttpHeaders st') 
+                                (mfCookies st') (fromString js)
+         put st'{mfAutorefresh=True, inSync=True} 
+         return $ FormElm mempty Nothing  
 
    delSessionData $ IteratedId name
-   return ret
+   return ret ---    \       url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'='+ind,\n\-    
-autoEvalLink = "\nfunction autoEvalLink(id,ind){\n\
-    \var id1= $('#'+id);\n\
-    \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\n\
-    \ida.click(function () {\n\
-    \ if (hadtimeout == true) return true;\n\
-    \ var pdata = $(this).attr('data-value');\n\
-    \ var actionurl = $(this).attr('href');\n\
-    \ var dialogOpts = {\n\
-    \       type: 'GET',\n\-    \       url: actionurl+'?auto'+id+'='+ind,\n\
-    \       data: pdata,\n\
-    \       success: function (resp) {\n\
-    \           eval(resp);\n\
-    \       },\n\
-    \       error: function (xhr, status, error) {\n\
-    \           var msg = $('<div>' + xhr + '</div>');\n\
-    \           id1.html(msg);\n\
-    \       }\n\
-    \   };\n\
-    \ $.ajax(dialogOpts);\n\
-    \ return false;\n\
-    \});\n\
++
+autoEvalLink = "\nfunction autoEvalLink(id,ind){\
+    \var id1= $('#'+id);\
+    \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\+    \ida.off('click');\
+    \ida.click(function () {\
+     \if (hadtimeout == true) return true;\
+     \var pdata = $(this).attr('data-value');\
+     \var actionurl = $(this).attr('href');\
+     \var dialogOpts = {\
+           \type: 'GET',\+           \url: actionurl+'?auto'+id+'='+ind,\
+           \data: pdata,\
+           \success: function (resp) {\
+               \eval(resp);\+               \autoEvalLink(id,ind);\+               \autoEvalForm(id);\
+           \},\
+           \error: function (xhr, status, error) {\
+               \var msg = $('<div>' + xhr + '</div>');\
+               \id1.html(msg);\
+           \}\
+       \};\
+     \$.ajax(dialogOpts);\
+     \return false;\
+    \});\
   \}\n"
 -autoEvalForm = "\nfunction autoEvalForm(id) {\n\-    \var buttons= $('#'+id+' input[type=\"submit\"]')\n\-    \var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\n\-    \buttons.click(function(event) {\n\-    \  if ($(this).attr('class') != '_noAutoRefresh'){\n\-    \    event.preventDefault();\n\-    \    if (hadtimeout == true) return true;\n\-    \    var $form = $(this).closest('form');\n\
-    \    var url = $form.attr('action');\n\-    \    pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\n\-    \    postForm(id,url,pdata);\-    \    return false;\n\-    \    }else {\n\
-    \      noajax= true;\n\-    \      return true;\n\-    \    }\n\-    \ })\n\+autoEvalForm = "\nfunction autoEvalForm(id) {\+    \var buttons= $('#'+id+' input[type=\"submit\"]');\+    \var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\+    \buttons.off('click');\+    \buttons.click(function(event) {\+      \if ($(this).attr('class') != '_noAutoRefresh'){\+        \event.preventDefault();\+        \if (hadtimeout == true) return true;\+        \var $form = $(this).closest('form');\
+        \var url = $form.attr('action');\+        \pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\+        \postForm(id,url,pdata);\+        \return false;\+        \}else {\
+          \noajax= true;\+          \return true;\+        \}\+     \})\     \\n\-    \var noajax;\n\-    \idform.submit(function(event) {\n\-    \ if(noajax) {noajax=false; return true;}\n\-    \   event.preventDefault();\n\-    \   var $form = $(this);\n\
-    \   var url = $form.attr('action');\n\-    \   var pdata = 'auto'+id+'=true&' + $form.serialize();\n\-    \   postForm(id,url,pdata);\n\-    \   return false;})\n\-    \}\n\-    \function postForm(id,url,pdata){\n\-        \var id1= $('#'+id);\n\-         \$.ajax({\n\
-            \type: 'POST',\n\
-            \url: url,\n\
-            \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\n\
-            \success: function (resp) {\n\
-                \eval(resp);\n\
-            \},\n\-            \error: function (xhr, status, error) {\n\
-                \var msg = $('<div>' + xhr + '</div>');\n\
-                \id1.html(msg);\n\
-            \}\n\-        \});\n\
+    \var noajax;\+    \idform.submit(function(event) {\+     \if(noajax) {noajax=false; return true;}\+       \event.preventDefault();\+       \var $form = $(this);\
+       \var url = $form.attr('action');\+       \var pdata = 'auto'+id+'=true&' + $form.serialize();\+       \postForm(id,url,pdata);\+       \return false;})\+    \}\+    \function postForm(id,url,pdata){\+        \var id1= $('#'+id);\+         \$.ajax({\
+            \type: 'POST',\
+            \url: url,\
+            \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
+            \success: function (resp) {\
+                \eval(resp);\+                \autoEvalLink(id,0);\+                \autoEvalForm(id);\
+            \},\+            \error: function (xhr, status, error) {\
+                \var msg = $('<div>' + xhr + '</div>');\
+                \id1.html(msg);\
+            \}\+        \});\
        \}" ---autoEvalForm = "\nfunction autoEvalForm(id) {\n\
---    \var id1= $('#'+id);\n\---    \var buttons= $('#'+id+' input[type=\"submit\"][class!=\"_noAutoRefresh\"]').click(function(event) {\n\
---        \if (hadtimeout == true) return true;\n\
---        \event.preventDefault();\n\
---        \var $form = $(this).closest('form');\n\
---        \var url = $form.attr('action');\n\
---        \var pdata = $form.serialize();\n\
---        \$.ajax({\n\
---            \type: 'POST',\n\
---            \url: url,\n\
---            \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\n\
---            \success: function (resp) {\n\
---                \eval(resp);\n\
---            \},\n\
---            \error: function (xhr, status, error) {\n\
---                \var msg = $('<div>' + xhr + '</div>');\n\
---                \id1.html(msg);\n\
---            \}\n\
---        \});\n\
---       \});\n\
---      \return false;\n\
---     \}\n" 
---autoEvalForm = "\nfunction autoEvalForm(id) {\n\
---    \var id1= $('#'+id);\n\
---    \var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\n\
---    \idform.submit(function (event) {\n\
---        \if (hadtimeout == true) return true;\n\
---        \event.preventDefault();\n\
---        \var $form = $(this);\n\
---        \var url = $form.attr('action');\n\
---        \var pdata = $form.serialize();\n\
---        \$.ajax({\n\
---            \type: 'POST',\n\
---            \url: url,\n\
---            \data: 'auto'+id+'=true&'+pdata,\n\
---            \success: function (resp) {\n\
---                \eval(resp);\n\
---            \},\n\
---            \error: function (xhr, status, error) {\n\
---                \var msg = $('<div>' + xhr + '</div>');\n\
---                \id1.html(msg);\n\
---            \}\n\
---        \});\n\
---       \});\n\
---      \return false;\n\
---     \}\n"
 
 setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
 
@@ -796,23 +733,29 @@      View view m  b -> View view m b
 dField w= View $ do
     id <- genNewId
-    FormElm vs mx <- runView w
-    let render = mconcat vs
+    FormElm render mx <- runView w
     st <- get
     let env =  mfEnv st
 
     IteratedId name <- getSessionData `onNothing` return (IteratedId noid)
     let r =  lookup ("auto"++name) env
-    if r == Nothing || (name == noid && newAsk st== True)  then do
-       requires [JScriptFile jqueryScript ["$(document).ready(function() {setId('"++id++"','" ++ toString (toByteString $ render)++"')});\n"]]
-       return $ FormElm[(ftag "span" render) `attrs` [("id",id)]] mx
+    if r == Nothing || (name == noid && newAsk st== True)+     then do
+--       requires [JScriptFile jqueryScript ["$(document).ready(function() {setId('"++id++"','" ++ toString (toByteString render)++"')});\n"]]
+       return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
      else do
        requires [JScript $  "setId('"++id++"','" ++ toString (toByteString $ render)++"');\n"]
        return $ FormElm mempty mx
 
 noid= "noid"
 
-
++-- | permits the edition of the rendering of a widget at run time. Once saved, the new rendering+-- becomes the new rendering of the widget for all the users. You must keep the active elements of the+-- template+--+-- the first parameter is the user that has permissions for edition. the second is a key that+-- identifies the template.
 edTemplate
   :: (MonadIO m, FormInput v, Typeable a) =>
       UserStr -> Key -> View v m a -> View v m a
@@ -821,7 +764,7 @@ 
    let ipanel= nam++"panel"
        name= nam++"-"++k
-       install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
+       install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
 
 
    requires [JScriptFile nicEditUrl [install]
@@ -829,12 +772,13 @@             ,JScript     installEditField
             ,JScriptFile jqueryScript []
             ,ServerProc  ("_texts",  transient getTexts)]
-
+   us <- getCurrentUser+   when(us== muser) noCache
    FormElm text mx <- runView w
-   content <- liftIO $ readtField (mconcat text) k
+   content <- liftIO $ readtField text k
 
-   return $ FormElm [ftag "div" mempty `attrs` [("id",ipanel)]
-                    ,ftag "span" content `attrs` [("id", name)]]
+   return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
+                     ftag "span" content `attrs` [("id", name)])
                      mx
    where
    getTexts :: (Token -> IO ())
@@ -849,11 +793,14 @@    viewFormat :: View v m a -> v
    viewFormat= undefined -- is a type function
 
--- | Does the same than template but without the edition facility
+-- | Does the same than template but without the edition facility+template
+  :: (MonadIO m, FormInput v, Typeable a) =>
+      Key -> View v m a -> View v m a
 template k w= View $ do
     FormElm text mx <- runView  w
-    let content= unsafePerformIO $ readtField  (mconcat text) k
-    return $ FormElm [content] mx
+    let content= unsafePerformIO $ readtField   text k
+    return $ FormElm content mx
 
 
 
@@ -886,10 +833,10 @@ wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
 wdialog conf title w= do
     id <- genNewId
-    let setit= "$(document).ready(function() {\n\
-                   \$('#"++id++"').dialog "++ conf ++";\n\
-                   \var idform= $('#"++id++" form');\n\
-                   \idform.submit(function(){$(this).dialog(\"close\")})\n\
+    let setit= "$(document).ready(function() {\
+                   \$('#"++id++"').dialog "++ conf ++";\
+                   \var idform= $('#"++id++" form');\
+                   \idform.submit(function(){$(this).dialog(\"close\")})\
                 \});"
 
     modify $ \st -> st{needForm= HasForm}
@@ -969,160 +916,138 @@   => B.ByteString
   -> View v m a
   -> View v m a
-update method w= View $ do
+update method w= do
     id <- genNewId
     st <- get 
     let t = mfkillTime st -1
 
         installscript=
-            "$(document).ready(function(){\n"
-               ++ "ajaxGetLink('"++id++"');"
-               ++ "ajaxPostForm('"++id++"');"
-               ++ "})\n"
-    FormElm form mr <- runView $ insertForm w+            "$(document).ready(function(){\
+                 \ajaxGetLink('"++id++"');\
+                 \ajaxPostForm('"++id++"');\
+                 \});"     st <- get     let insync =  inSync st     let env= mfEnv st
     let r= lookup ("auto"++id) env      
-    if r == Nothing || insync == False+    if r == Nothing -- || isJust mr  -- || insync == False !> (show r ++ show insync)       then do
          requires [JScript $ timeoutscript t
                   ,JScript ajaxGetLink
                   ,JScript ajaxPostForm
                   ,JScriptFile jqueryScript [installscript]] 
-         return $ FormElm[ftag "div" (mconcat form) `attrs` [("id",id)]] mr 
-
-      else do
-         let t= mfToken st
+         (ftag "div" <<< insertForm w) <! [("id",id)] 
 
-         let HttpData ctype c s= toHttpData $ method <> " " <> toByteString (mconcat form)+      else View $ do
+         let t= mfToken st            -- !> "JUST"+         modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
+         resetCachePolicy+         FormElm form mr <- runView $ insertForm w+         setCachePolicy+         st' <- get+         let HttpData ctype c s= toHttpData $ method <> " " <> toByteString  form                           
-         (liftIO . sendFlush t $ HttpData (ctype ++ {-("Cache-Control", "no-cache, no-store"): -}-                                mfHttpHeaders st) (mfCookies st ++ c) s)
-         put st{mfAutorefresh=True,inSync=True}
-         return $ FormElm [] mr 
+         (liftIO . sendFlush t $ HttpData (ctype +++                                mfHttpHeaders st') (mfCookies st' ++ c) s)+         put st'{mfAutorefresh=True,newAsk=True}+            
+         return $ FormElm mempty Nothing 
 
   where
   -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal
---    \       url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\-  ajaxGetLink = "\nfunction ajaxGetLink(id){\n\-    \var id1= $('#'+id);\n\
-    \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\n\
-    \ida.click(function () {\n\
-    \if (hadtimeout == true) return true;\n\
-    \var pdata = $(this).attr('data-value');\n\
-    \var actionurl = $(this).attr('href');\n\
-    \var dialogOpts = {\n\
-    \       type: 'GET',\n\-    \       url: actionurl+'?auto'+id+'=true',\n\
-    \       data: pdata,\n\
-    \       success: function (resp) {\n\
-    \            var ind= resp.indexOf(' ');\n\
-    \            var dat= resp.substr(ind);\n\
-    \            var method= resp.substr(0,ind);\n\
-    \            if(method== 'html')id1.html(dat);\n\
-    \            else if (method == 'append') id1.append(dat);\n\
-    \            else id1.prepend(dat);\n\
-    \            ajaxGetLink(id);\n\-    \            ajaxPostForm(id);\n\
-    \       },\n\
-    \       error: function (xhr, status, error) {\n\
-    \           var msg = $('<div>' + xhr + '</div>');\n\
-    \           id1.html(msg);\n\
-    \       }\n\
-    \   };\n\
-    \$.ajax(dialogOpts);\n\
-    \return false;\n\
-    \});\n\
+--           \url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\+  ajaxGetLink = "\nfunction ajaxGetLink(id){\+    \var id1= $('#'+id);\
+    \var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\+    \ida.off('click');\
+    \ida.click(function () {\
+    \if (hadtimeout == true) return true;\
+    \var pdata = $(this).attr('data-value');\
+    \var actionurl = $(this).attr('href');\
+    \var dialogOpts = {\
+           \type: 'GET',\+           \url: actionurl+'?auto'+id+'=true',\
+           \data: pdata,\
+           \success: function (resp) {\
+                \var ind= resp.indexOf(' ');\
+                \var dat= resp.substr(ind);\
+                \var method= resp.substr(0,ind);\
+                \if(method== 'html')id1.html(dat);\
+                \else if (method == 'append') id1.append(dat);\
+                \else if (method == 'prepend') id1.prepend(dat);\+                \else $(':root').html(resp);\
+                \ajaxGetLink(id);\+                \ajaxPostForm(id);\
+           \},\
+           \error: function (xhr, status, error) {\
+               \var msg = $('<div>' + xhr + '</div>');\
+               \id1.html(msg);\
+           \}\
+       \};\
+    \$.ajax(dialogOpts);\
+    \return false;\
+    \});\
   \}\n"
 -  ajaxPostForm = "\nfunction ajaxPostForm(id) {\n\-    \var buttons= $('#'+id+' input[type=\"submit\"]')\n\-    \var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\n\-    \buttons.click(function(event) {\n\-    \  if ($(this).attr('class') != '_noAutoRefresh'){\n\-    \    event.preventDefault();\n\-    \    if (hadtimeout == true) return true;\n\
-    \    var $form = $(this).closest('form');\n\
-    \    var url = $form.attr('action');\n\-    \    pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\n\-    \    postForm(id,url,pdata);\-    \    return false;\n\-    \    }else {\n\
-    \      noajax= true;\n\-    \      return true;\n\-    \    }\n\-    \ })\n\+  ajaxPostForm = "\nfunction ajaxPostForm(id) {\+    \var buttons= $('#'+id+' input[type=\"submit\"]');\+    \var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\+    \buttons.off('click');\+    \buttons.click(function(event) {\+      \if ($(this).attr('class') != '_noAutoRefresh'){\+        \event.preventDefault();\+        \if (hadtimeout == true) return true;\
+        \var $form = $(this).closest('form');\
+        \var url = $form.attr('action');\+        \pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\+        \postForm(id,url,pdata);\+        \return false;\+        \}else {\
+          \noajax= true;\+          \return true;\+        \}\+     \})\     \\n\-    \var noajax;\n\-    \idform.submit(function(event) {\n\-    \ if(noajax) {noajax=false; return true;}\n\-    \   event.preventDefault();\n\-    \   var $form = $(this);\n\
-    \   var url = $form.attr('action');\n\-    \   var pdata = 'auto'+id+'=true&' + $form.serialize();\n\-    \   postForm(id,url,pdata);\n\-    \   return false;})\n\-    \}\n\-    \function postForm(id,url,pdata){\n\-        \var id1= $('#'+id);\n\
-        \$.ajax({\n\
-            \type: 'POST',\n\
-            \url: url,\n\
-            \data: pdata,\n\
-            \success: function (resp) {\n\
-    \            var ind= resp.indexOf(' ');\n\
-    \            var dat = resp.substr(ind);\n\
-    \            var method= resp.substr(0,ind);\n\
-    \            if(method== 'html')id1.html(dat);\n\
-    \            else if (method == 'append') id1.append(dat);\n\
-    \            else id1.prepend(dat);\n\-    \            ajaxGetLink(id);\n\
-    \            ajaxPostForm(id);\n\
-            \},\n\
-            \error: function (xhr, status, error) {\n\
-                \var msg = $('<div>' + xhr + '</div>');\n\
-                \id1.html(msg);\n\
-            \}\n\
-        \});\n\
+    \var noajax;\+    \idform.submit(function(event) {\+     \if(noajax) {noajax=false; return true;}\+       \event.preventDefault();\+       \var $form = $(this);\
+       \var url = $form.attr('action');\+       \var pdata = 'auto'+id+'=true&' + $form.serialize();\+       \postForm(id,url,pdata);\+       \return false;})\+    \}\+    \function postForm(id,url,pdata){\+        \var id1= $('#'+id);\
+        \$.ajax({\
+            \type: 'POST',\
+            \url: url,\
+            \data: pdata,\
+            \success: function (resp) {\
+                \var ind= resp.indexOf(' ');\
+                \var dat = resp.substr(ind);\
+                \var method= resp.substr(0,ind);\
+                \if(method== 'html')id1.html(dat);\
+                \else if (method == 'append') id1.append(dat);\
+                \else if (method == 'prepend') id1.prepend(dat);\+                \else $(':root').html(resp);\+                \ajaxGetLink(id);\
+                \ajaxPostForm(id);\
+            \},\
+            \error: function (xhr, status, error) {\
+                \var msg = $('<div>' + xhr + '</div>');\
+                \id1.html(msg);\
+            \}\
+        \});\
        \};"
 
  
---  ajaxPostForm = "\nfunction ajaxPostForm(id) {\n\
---    \var id1= $('#'+id);\n\
---    \var idform= $('#'+id+' form[class!=\"_noAutoRefresh\"]');\n\
---    \idform.submit(function (event) {\n\
---        \if (hadtimeout == true) return true;\n\
---        \event.preventDefault();\n\
---        \var $form = $(this);\n\
---        \var url = $form.attr('action');\n\
---        \var pdata = 'auto'+id+'=true&'+$form.serialize();\n\
---        \$.ajax({\n\
---            \type: 'POST',\n\
---            \url: url,\n\
---            \data: pdata,\n\
---            \success: function (resp) {\n\
---    \            var ind= resp.indexOf(' ');\n\
---    \            var dat = resp.substr(ind);\n\
---    \            var method= resp.substr(0,ind);\n\
---    \            if(method== 'html')id1.html(dat);\n\
---    \            else if (method == 'append') id1.append(dat);\n\
---    \            else id1.prepend(dat);\n\
---    \            ajaxPostForm(id);\n\
---            \},\n\
---            \error: function (xhr, status, error) {\n\
---                \var msg = $('<div>' + xhr + '</div>');\n\
---                \id1.html(msg);\n\
---            \}\n\
---        \});\n\
---       \});\n\
---      \return false;\n\
---     \}\n"
 
 timeoutscript t=
-     "\nvar hadtimeout=false;\n\
+     "\nvar hadtimeout=false;\
      \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
 
 
@@ -1223,38 +1148,38 @@ 
 
 
-   ajaxPush procname=" function ajaxPush(id,waititime){\n\
-    \var cnt=0; \n\
-    \var id1= $('#'+id);\n\
-    \var idstatus= $('#'+id+'status');\n\
-    \var ida= $('#'+id+' a');\n\
-    \   var actionurl='/"++procname++"';\n\
-    \   var dialogOpts = {\n\
-    \       cache: false,\n\
-    \       type: 'GET',\n\
-    \       url: actionurl,\n\
-    \       data: '',\n\
-    \       success: function (resp) {\n\
-    \         idstatus.html('')\n\
-    \         cnt=0;\n\
-    \         id1."++method++"(resp);\n\
-    \         ajaxPush1();\n\
-    \       },\n\
-    \       error: function (xhr, status, error) {\n\
-    \            cnt= cnt + 1;\n\
-    \            if  (false) \n\
-    \               idstatus.html('no more retries');\n\
-    \            else {\n\
-    \               idstatus.html('waiting');\n\
-    \               setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\n\
-    \            }\n\
-    \       }\n\
-    \   };\n\
-    \function ajaxPush1(){\n\
-    \   $.ajax(dialogOpts);\n\
-    \   return false;\n\
-    \ }\n\
-    \ ajaxPush1();\n\
+   ajaxPush procname=" function ajaxPush(id,waititime){\
+    \var cnt=0; \
+    \var id1= $('#'+id);\
+    \var idstatus= $('#'+id+'status');\
+    \var ida= $('#'+id+' a');\
+       \var actionurl='/"++procname++"';\
+       \var dialogOpts = {\
+           \cache: false,\
+           \type: 'GET',\
+           \url: actionurl,\
+           \data: '',\
+           \success: function (resp) {\
+             \idstatus.html('')\
+             \cnt=0;\
+             \id1."++method++"(resp);\
+             \ajaxPush1();\
+           \},\
+           \error: function (xhr, status, error) {\
+                \cnt= cnt + 1;\
+                \if  (false) \
+                   \idstatus.html('no more retries');\
+                \else {\
+                   \idstatus.html('waiting');\
+                   \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
+                \}\
+           \}\
+       \};\
+    \function ajaxPush1(){\
+       \$.ajax(dialogOpts);\
+       \return false;\
+     \}\
+     \ajaxPush1();\
   \}"
 
 
@@ -1267,9 +1192,9 @@      String -> Maybe a -> View view m a
 getSpinner conf mv= do
     id <- genNewId
-    let setit=   "$(document).ready(function() {\n\
-                 \var spinner = $( '#"++id++"' ).spinner "++conf++";\n\
-                 \spinner.spinner( \"enable\" );\n\
+    let setit=   "$(document).ready(function() {\
+                 \var spinner = $( '#"++id++"' ).spinner "++conf++";\
+                 \spinner.spinner( \"enable\" );\
                  \});"
     requires
       [CSSFile      jqueryCSS
@@ -1277,7 +1202,107 @@       ,JScriptFile  jqueryUI [setit]]
 
     getTextBox mv <! [("id",id)]
-
+ 
++-- | takes as argument a widget and delay the load until it is visible. The renderring to+-- be shown during the load is the specified in the first parameter. The resulting lazy+-- widget behaves programatically in the same way.+--+-- It can lazily load recursively. It means that if the loaded widget has a lazy statement,+-- it will be honored as well.+--+-- Because a widget can contain arbitrary HTML, images or javascript, lazy can be used to lazy+-- load anything.+--+-- To load a image:+--+-- lazy temprendering $ wraw ( img ! href imageurl)+--+-- or+--+-- lazy temprendering $ img ! href imageurl ++> noWidget+lazy :: (FormInput v,Functor m,MonadIO m) => v -> View v m a -> View v m a+lazy v w=  do
+    id <- genNewId
+    st <- get+    let path = currentPath st+        env = mfEnv st
+        r= lookup ("auto"++id) env   
+        t = mfkillTime st -1
+        installscript =  "$(document).ready(function(){\+                \function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\+                \$(window).one('scroll',lazyexec);\+                \$(window).trigger('scroll');\+                 \});"++--        installscript2= "$(window).one('scroll',function(){\+--                \function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\+--                \lazyexec()});"+ 
+    if r == Nothing  then View $ do
+      requires [JScript lazyScript
+                  ,JScriptFile jqueryScript [installscript,scrollposition]]+      FormElm rendering mx <- runView w+      return $ FormElm (ftag "div" v `attrs` [("id",id)]) mx+         
+      else View $ do+         modify $ \s -> s{mfHttpHeaders=[], mfRequirements=[]} 
+         resetCachePolicy+         st' <- get+         FormElm form mx <- runView w+         setCachePolicy 
+         let t= mfToken st'+         reqs <- installAllRequirements+         let HttpData ctype c s= toHttpData $ toByteString  form
+         liftIO . sendFlush t $ HttpData (ctype +++                                mfHttpHeaders st') (mfCookies st' ++ c)+                              $ toByteString reqs <> s  -- !> (unpack $ toByteString reqs)+         put st'{mfAutorefresh=True,inSync= True} 
+         return $ FormElm mempty mx+++    where++--    waitAndExecute= "function waitAndExecute(sym,f) {\+--        \if (eval(sym)) {f();}\+--          \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\+--        \}\n"++    scrollposition= "$.fn.scrollposition= function(){\+       \var pos= $(this).position();\+       \if (typeof(pos)==='undefined') {return 1;}\+       \else{\+         \return pos.top - $( window ).scrollTop() - $( window ).height();\+         \}};"++    lazyScript= "function lazy (id,actionurl,f) {\+     \var now = new Date().getTime(),\+         \id1= $('#'+id),\+         \lastCall= 0;\+     \diff = now - lastCall;\+     \if (diff < 5000) {\+        \$(window).one('scroll',f);}\+     \else {\+      \lastCall = now;\+    \if(id1.scrollposition() > 0){\+    \$(window).one('scroll',f);}\+    \else{\
+    \var dialogOpts = {\
+           \type: 'GET',\+           \url: actionurl+'?auto'+id+'=true',\
+           \success: function (resp) {\
+                \id1.html(resp);\+                \$(window).trigger('scroll');\
+           \},\+           \error: function (xhr, status, error) {\
+               \var msg = $('<div>' + xhr + '</div>');\
+               \id1.html(msg);\+           \}\
+       \};\
+    \$.ajax(dialogOpts);\
+    \}}};"++

src/MFlow/Wai/Blaze/Html/All.hs view

@@ -1,4 +1,4 @@------------------------------------------------------------------------------
+----------------------------------------------------------------------------
 --
 -- Module      :  MFlow.Wai.Blaze.Html.All
 -- Copyright   :
@@ -22,8 +22,9 @@ ,module Control.Applicative
 ,module Text.Blaze.Html5
 ,module Text.Blaze.Html5.Attributes
-,module Control.Monad.IO.Class+,module Control.Monad.IO.Class
 ,module MFlow.Forms.WebApi
+,module MFlow.Forms.Cache
 ,runNavigation
 ,runSecureNavigation
 ) where
@@ -33,12 +34,13 @@ import MFlow.Forms
 import MFlow.Forms.Widgets
 import MFlow.Forms.Admin
-import MFlow.Forms.Blaze.Html+import MFlow.Forms.Blaze.Html
 import MFlow.Forms.WebApi
+import MFlow.Forms.Cache
 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(run,defaultSettings,Settings,settingsPort)
+import Network.Wai.Handler.Warp(run,defaultSettings,Settings,setPort)
 import Data.TCache
 import Text.Blaze.Internal(text)
 
@@ -81,7 +83,7 @@     --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
 
 -- | Exactly the same as runNavigation, but with TLS added.
--- | Expects certificate.pem and key.pem in project directory.
+-- Expects certificate.pem and key.pem in project directory.
 
 runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
 
@@ -90,4 +92,5 @@     unless (null n) $ setNoScript n
     addMessageFlows[(n, runFlow f)]
     porti <- getPort
-    wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
+    let s' = setPort porti s
+    wait $ TLS.runTLS t s' waiMessageFlow