MFlow 0.3.3 → 0.4.0
raw patch · 38 files changed
+3723/−4581 lines, 38 filesdep +acid-statedep +clientsessiondep +hscolourdep ~wai
Dependencies added: acid-state, clientsession, hscolour, safecopy, warp-tls
Dependency ranges changed: wai
Files
- Demos/Actions.hs +0/−17
- Demos/AjaxSample.hs +0/−24
- Demos/AutoCompList.hs +0/−25
- Demos/AutoComplete.hs +0/−24
- Demos/CheckBoxes.hs +0/−22
- Demos/Combination.hs +0/−90
- Demos/ContentManagement.hs +0/−55
- Demos/Counter.hs +0/−42
- Demos/Dialog.hs +0/−21
- Demos/Grid.hs +0/−40
- Demos/IncreaseInt.hs +0/−21
- Demos/IncreaseString.hs +0/−21
- Demos/ListEdit.hs +0/−41
- Demos/LoginSample.hs +0/−34
- Demos/MCounter.hs +0/−33
- Demos/Multicounter.hs +0/−34
- Demos/Options.hs +0/−26
- Demos/PreventGoingBack.hs +0/−35
- Demos/PushDecrease.hs +0/−46
- Demos/PushSample.hs +0/−54
- Demos/Radio.hs +0/−20
- Demos/ShopCart.hs +0/−69
- Demos/SumView.hs +0/−31
- Demos/TestREST.hs +0/−50
- Demos/TraceSample.hs +0/−29
- Demos/demos-blaze.hs +0/−107
- MFlow.cabal +130/−131
- src/MFlow.hs +50/−47
- src/MFlow/Cookies.hs +148/−175
- src/MFlow/Forms.hs +1690/−1614
- src/MFlow/Forms/Admin.hs +8/−4
- src/MFlow/Forms/Blaze/Html.hs +22/−18
- src/MFlow/Forms/Internals.hs +251/−228
- src/MFlow/Forms/WebApi.hs +89/−0
- src/MFlow/Forms/Widgets.hs +1282/−1304
- src/MFlow/Wai.hs +24/−33
- src/MFlow/Wai/Blaze/Html/All.hs +24/−11
- src/MFlow/Wai/Response.hs +5/−5
− Demos/Actions.hs
@@ -1,17 +0,0 @@- -module Actions (actions) where - -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu- -actions = do - r<- page $ p << b << "Two boxes with one action each one" - ++> getString (Just "widget1") `waction` action - <+> getString (Just "widget2") `waction` action - <** submitButton "submit" - page $ p << ( show r ++ " returned") ++> wlink () << p << " menu" - where - action n= page $ getString (Just $ n ++ " action")<** submitButton "submit action" - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav actions
− Demos/AjaxSample.hs
@@ -1,24 +0,0 @@-{-# OPTIONS -XCPP #-} - -module AjaxSample ( ajaxsample) where - -import Data.Monoid -import Data.ByteString.Lazy.Char8 as B--- #define ALONE-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav ajaxsample-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif- -ajaxsample= do - r <- page $ p << b << "Ajax example that increment the value in a box" - ++> do - let elemval= "document.getElementById('text1').value" - ajaxc <- ajax $ \n -> return . B.pack $ elemval <> "='" <> show(read n +1) <> "'" - b << "click the box " - ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)] <** submitButton "submit" - page $ p << ( show r ++ " returned") ++> wlink () << p << " menu" -
− Demos/AutoCompList.hs
@@ -1,25 +0,0 @@-{-# OPTIONS -XCPP #-} -module AutoCompList ( autocompList) where -import Data.List-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav autocompList-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif- - -autocompList= do - r <- page $ p << "Autocomplete with a list of selected entries" - ++> p << "enter and press enter" - ++> p << "when submit is pressed, the entries are returned" - ++> wautocompleteList "red,green,blue" filter1 ["red"] - <** submitButton "submit" - page $ p << ( show r ++ " selected") ++> wlink () (p << " menu") - - where - filter1 s = return $ filter (isPrefixOf s) ["red","red rose","green","green grass","blue","blues"] - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav autocompList
− Demos/AutoComplete.hs
@@ -1,24 +0,0 @@-{-# OPTIONS -XCPP #-} -module AutoComplete ( autocomplete1) where -import Data.List--- #define ALONE-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav autocomplete1-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - -autocomplete1= do - r <- page $ p << "Autocomplete " - ++> p << "when submit is pressed, the box value is returned" - ++> wautocomplete Nothing filter1 <! hint "red,green or blue" - <** submitButton "submit" - page $ p << ( show r ++ " selected") ++> wlink () (p << " menu") - - where - filter1 s = return $ filter (isPrefixOf s) ["red","red rose","green","green grass","blue","blues"] - -hint s= [("placeholder",s)] -
− Demos/CheckBoxes.hs
@@ -1,22 +0,0 @@-{-# OPTIONS -XCPP #-} -module CheckBoxes ( checkBoxes) where - -import Data.Monoid--- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav autocomplete1-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - -checkBoxes= do - r <- page $ getCheckBoxes( (setCheckBox False "Red" <++ b << "red") - <> (setCheckBox False "Green" <++ b << "green") - <> (setCheckBox False "blue" <++ b << "blue")) - <** submitButton "submit" - - - page $ p << ( show r ++ " selected") ++> wlink () (p << " menu") -
− Demos/Combination.hs
@@ -1,90 +0,0 @@-{-# OPTIONS -XCPP #-} -module Combination ( combination, wlogin1) where -import Counter(counterWidget) -import Data.String--- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav combination-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - -text= fromString - -combination = page $ - p << "Three active widgets in the same page with autoRefresh. Each widget refresh itself"- ++> p << "with Ajax. If Ajax is not active, they will refresh by sending a new page." - ++> hr - ++> p << "Login widget (use admin/admin)" ++> autoRefresh (pageFlow "r" wlogin1) <++ hr - **> p << "Counter widget" ++> autoRefresh (pageFlow "c" (counterWidget 0)) <++ hr - **> p << "Dynamic form widget" ++> autoRefresh (pageFlow "f" 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 - clear - pass <- getPassword <! hint "password" <** submitButton "login" <++ br - val <- userValidate (name,pass) - case val of - Just msg -> notValid msg - Nothing -> login name >> return name - - `wcallback` (\name -> b << ("logged as " ++ name) - ++> p << "navigate away of this page before logging out" - ++> wlink "logout" << b << " logout") - `wcallback` const (logout >> wlogin1) - -focus = [("onload","this.focus()")] - -
− Demos/ContentManagement.hs
@@ -1,55 +0,0 @@-{-# OPTIONS -XCPP #-} -module ContentManagement ( textEdit) where - -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.Monoid -import Data.TCache.Memoization - --- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav testEdit-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - - - -editUser= "edituser" - -textEdit= do - userRegister editUser editUser - let first= p << i << - (El.span << "this is a page with" - <> b << " two " <> El.span << "paragraphs. this is the first") - - second= p << i << "This is the original of the second paragraph" - - page $ p << b << "An example of content management" - ++> first - ++> second - ++> wlink () << p << "click here to edit it" - - page $ p << "Please login with edituser/edituser to edit it" - ++> userWidget (Just editUser) userLogin - - page $ p << "Now you can click the fields and edit them" - ++> p << b << "to save an edited field, press the save icon in the left" - ++> tFieldEd editUser "first" first - **> tFieldEd editUser "second" second - **> wlink () << p << "click here to see it as a normal user" - - logout - - page $ p << "the user sees the edited content. He can not edit" - ++> tFieldEd editUser "first" first - **> tFieldEd editUser "second" second - **> wlink "a" << p << "click to continue" - - page $ p << "When texts are fixed,the edit facility and the original texts can be removed. The content is indexed by the field key" - ++> tField "first" - **> tField "second" - **> p << "End of edit field demo" ++> wlink () << p << "click here to go to menu" -
− Demos/Counter.hs
@@ -1,42 +0,0 @@-{-# OPTIONS -XCPP #-} -module Counter ( counter, counterWidget) 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 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 to permit an independent" - p << "execution flow for each widget." - a ! href (attr "/noscript/multicounter") << "Multicounter" - text " instantiate various counter widgets" - p << "But while the seaside case the callback update the widget object, in this case" - p << "the callback recursvely 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/Dialog.hs
@@ -1,21 +0,0 @@- -module Dialog (wdialog1) where - -import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu - -wdialog1= do - page wdialogw - page (wlink () << "out of the page flow, press here to go to the menu") - -wdialogw= pageFlow "diag" $ do - r <- wform $ p << "please enter your name" ++> getString (Just "your name") <** submitButton "ok" - wdialog "({modal: true})" "question" $ - p << ("Do your name is \""++r++"\"?") ++> getBool True "yes" "no" <** submitButton "ok" - - `wcallback` \q -> if not q then wdialogw - else wlink () << b << "thanks, press here to exit from the page Flow" - - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav wdialog1
− Demos/Grid.hs
@@ -1,40 +0,0 @@-{-# OPTIONS -XCPP #-} -module Grid ( grid) where - -import Data.String -import Text.Blaze.Html5.Attributes as At hiding (step)- --- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav grid-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- -attr= fromString - -grid = do - r <- page $ addLink - ++> wEditList table row ["",""] "wEditListAdd" - <** submitButton "submit" - - page $ p << (show r ++ " returned") - ++> wlink () (p << " back to menu") - - where - row _= tr <<< ( (,) <$> tdborder <<< getInt (Just 0) - <*> tdborder <<< getTextBox (Just "") - <++ tdborder << delLink) - - addLink= a ! href (attr "#") - ! At.id (attr "wEditListAdd") - << "add" - - delLink= a ! href (attr "#") - ! onclick (attr "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)") - << "delete" - - tdborder= td ! At.style (attr "border: solid 1px") -
− Demos/IncreaseInt.hs
@@ -1,21 +0,0 @@- -module IncreaseInt ( clickn) where - -import MFlow.Wai.Blaze.Html.All hiding(page) -import Menu- --- |+| 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 - --- to run it alone, change page by page and uncomment this: ---main= runNavigation "" $ transientNav sumWidget
− Demos/IncreaseString.hs
@@ -1,21 +0,0 @@-{-# OPTIONS -XCPP #-} -module IncreaseString ( clicks) where - -import MFlow.Wai.Blaze.Html.All hiding(page) --- #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/ListEdit.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-} -module ListEdit ( wlistEd) where - -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.String--- #define ALONE-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav wlistEd-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif- - - - -wlistEd= do - r <- page $ addLink - ++> br - ++> (wEditList El.div getString1 ["hi", "how are you"] "wEditListAdd") - <++ br - <** submitButton "send" - - page $ p << (show r ++ " returned") - ++> wlink () (p " back to menu") - - - where - addLink = a ! At.id "wEditListAdd" - ! href "#" - $ b "add" - delBox = input ! type_ "checkbox" - ! checked "" - ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)" - getString1 mx= El.div <<< delBox ++> getString mx <++ br - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav wListEd -
− Demos/LoginSample.hs
@@ -1,34 +0,0 @@-{-# OPTIONS -XCPP #-} -module LoginSample ( loginSample) where - -import Data.Monoid --- #define ALONE to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav autocomplete1-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - -loginSample= do - userRegister "user" "user" - r <- page $ p << "Please login with user/user" - ++> userWidget Nothing userLogin - <|> wlink "exit" << p << "or exit" - - if r == "exit" then return () else do - user <- getCurrentUser - - r <- page $ b << ("user logged as " <> user) - ++> wlink True << p << "logout" - <|> wlink False << p << "or exit" - - if r - then do - logout - page $ p << "logged out" ++> wlink () << "press here to exit" - else return () - - -
− Demos/MCounter.hs
@@ -1,33 +0,0 @@-{-# OPTIONS -XCPP #-}-module MCounter ( -mcounter -) where -import Data.Monoid -import Data.String--- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav grid-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- - - - -mcounter = do - (op,n) <- step . page $ do - n <- getSessionData `onNothing` return (0 :: Int) -- get Int data from the session - op <- h2 << show n - ++> wlink "i" << b << " ++ " - <|> wlink "d" << b << " -- " - - return(op,n) -- unlike in the case of the shopping example where the shopcart is not logged - -- here the state is smaller (the Int counter) anc can be logged - case op of - "i" -> setSessionData (n + 1) - "d" -> setSessionData (n - 1) - - mcounter -
− Demos/Multicounter.hs
@@ -1,34 +0,0 @@-{-# OPTIONS -XCPP #-} -module Multicounter ( multicounter) where - -import Data.Monoid -import Data.String -import Counter(counterWidget)--- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav multicounter-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - -text= fromString -attr= fromString - -multicounter= - page $ explain - ++> add (counterWidget 0) [1..4] - <|> wlink () << p << "exit" - - where - explain= 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" - - - add widget list= firstOf [autoRefresh $ pageFlow (show i) widget <++ hr | i <- list] -
− Demos/Options.hs
@@ -1,26 +0,0 @@-{-# OPTIONS -XCPP #-} -module Options (options) where - --- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav options-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif- -options= do - r <- page $ getSelect (setSelectedOption "" (p << "select a option") <|> - setOption "red" (b << "red") <|> - setOption "blue" (b << "blue") <|> - setOption "Green" (b << "Green") ) - <! dosummit - page $ p << (r ++ " selected") ++> wlink () (p << " menu") - - - where - dosummit= [("onchange","this.form.submit()")] - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav options
− Demos/PreventGoingBack.hs
@@ -1,35 +0,0 @@-{-# OPTIONS -XCPP #-} -module PreventGoingBack ( preventBack) where -import System.IO.Unsafe -import Control.Concurrent.MVar---- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav preventBack-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - -rpaid= unsafePerformIO $ newMVar (0 :: Int) - - -preventBack= do - page $ wlink "don't care" << b << "press here to pay 100000 $ " - payIt - paid <- liftIO $ readMVar rpaid - preventGoingBack . page $ p << "You already paid 100000 before" - ++> p << "you can not go back until the end of the buy process" - ++> wlink () << p << "Please press here to continue" - - page $ p << ("you paid "++ show paid) - ++> wlink () << p << "Press here to go to the menu or press the back button to verify that you can not pay again" - where - payIt= liftIO $ do - print "paying" - paid <- takeMVar rpaid - putMVar rpaid $ paid + 100000 - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav preventBack
− Demos/PushDecrease.hs
@@ -1,46 +0,0 @@-{-# OPTIONS -XQuasiQuotes -XCPP #-} -module PushDecrease ( pushDecrease) where - -import Control.Concurrent.STM -import Text.Hamlet -import Control.Concurrent - --- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav pushDecrease-#else-import MFlow.Wai.Blaze.Html.All hiding(page)-import Menu-#endif - - -atomic= liftIO . atomically - -pushDecrease= do - tv <- liftIO $ newTVarIO 10 - - page $ - [shamlet| - <div> - <h2> Maxwell Smart push counter - <p> This example shows a reverse counter - <p> To avoid unnecessary load, the push process will be killed when reaching 0 - <p> The last push message will be an script that will redirect to the menu" - <h3> This message will be autodestroyed within ... - - |] ++> counter tv <++ b << "seconds" - - where - counter tv = push Html 0 $ do - setTimeouts 2 0 -- kill the thread after 2 s of incactivity, when count finish - n <- atomic $ readTVar tv - if (n== -1) - then do - script << "window.location='/'" ++> noWidget - else do - atomic $ writeTVar tv $ n - 1 - liftIO $ threadDelay 1000000 - h1 << (show n) ++> noWidget - -
− Demos/PushSample.hs
@@ -1,54 +0,0 @@-{-# OPTIONS -XQuasiQuotes -XCPP #-} -module PushSample (pushSample) where- -import Control.Concurrent.STM-import System.IO.Unsafe ---- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav pushSample-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- ---lastLine = unsafePerformIO $ newTVarIO $ "The content will be appended here"- -pushSample= do - last <- liftIO $ newTVarIO "" - page $ h2 << "Basic Chat as a push example" - ++> hr - ++> pageFlow "push" (push Append 1000 (disp last ) <** input ) - **> br - ++> br - ++> wlink () << b << "exit" - - where - -- the widget being pushed: - disp last = do - setTimeouts 100 0 -- after 100 seconds of inactivity , kill itself, but restart if needed - line <- tget last - p << line ++> noWidget - - input = autoRefresh $ do - line <- getString Nothing <** submitButton "Enter" - tput lastLine line - - - tput tv x = atomic $ writeTVar tv x - - tget last = atomic $ do - msg <- readTVar lastLine- lastmsg <- readTVar last - case lastmsg == msg of - False -> do- writeTVar last msg- return msg - True -> retry- - -atomic= liftIO . atomically -
− Demos/Radio.hs
@@ -1,20 +0,0 @@-{-# OPTIONS -XCPP #-} -module Radio ( radio) where - --- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav grid-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- -radio = do - r <- page $ p << b << "Radio buttons" - ++> getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] - - page $ p << ( show r ++ " selected") ++> wlink () << p << " menu" - --- to run it alone, change page by ask and uncomment this: ---main= runNavigation "" $ transientNav radio
− Demos/ShopCart.hs
@@ -1,69 +0,0 @@-{-# OPTIONS -XDeriveDataTypeable -XCPP #-} -module ShopCart ( shopCart) where -import Data.Typeable -import qualified Data.Vector as V -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step) -import Data.Monoid -import Data.String -import Data.Typeable--- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav grid-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- -data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum, Show,Read , Typeable) - -newtype Cart= Cart (V.Vector Int) deriving Typeable- -emptyCart= Cart $ V.fromList [0,0,0] --shopCart= shopCart1- -shopCart1 = do- setHeader stdheader --- setTimeouts 200 $ 60*60 - prod <-- step . page $ do - Cart cart <- getSessionData `onNothing` return emptyCart - - moreexplain - ++> - (table ! At.style (attr "border:1;width:20%;margin-left:auto;margin-right:auto") - <<< caption << "choose an item" - ++> thead << tr << ( th << b << "item" <> th << b << "times chosen") - ++> (tbody - <<< tr ! rowspan (attr "2") << td << linkHome - ++> (tr <<< td <<< wlink IPhone (b << "iphone")- <++ tdc << ( b << show ( cart V.! 0)) - <|> tr <<< td <<< wlink IPod (b << "ipod")- <++ tdc << ( b << show ( cart V.! 1)) - <|> tr <<< td <<< wlink IPad (b << "ipad")- <++ tdc << ( b << show ( cart V.! 2))) - <++ tr << td << linkHome - ))-- - let i = fromEnum prod- Cart cart <- getSessionData `onNothing` return emptyCart - setSessionData . Cart $ cart V.// [(i, cart V.! i + 1 )] - shopCart1 - - where- tdc= td ! At.style (attr "text-align:center") - linkHome= a ! href (attr $ "/" ++ noScript) << b << "home" - attr= fromString- moreexplain= do- p $ El.span <<( - "A persistent flow (uses step). The process is killed after the timeout set by setTimeouts "++ - "but it is restarted automatically. Event If you restart the whole server, it remember the shopping cart "++- " The shopping cart is not logged, just the products bought returned by step are logged. The shopping cart "++- " is rebuild from the events (that is an example of event sourcing."++ - " .Defines a table with links that return ints and a link to the menu, that abandon this flow. "++ - " .The cart state is not stored, Only the history of events is saved. The cart is recreated by running the history of events.") -- p << "The second parameter of \"setTimeout\" is the time during which the cart is recorded"
− Demos/SumView.hs
@@ -1,31 +0,0 @@-{-# OPTIONS -XCPP #-} -module SumView (sumInView) where - --- #define ALONE -- to execute it alone, uncomment this-#ifdef ALONE-import MFlow.Wai.Blaze.Html.All-main= runNavigation "" $ transientNav grid-#else-import MFlow.Wai.Blaze.Html.All hiding(retry, page)-import Menu-#endif- -sumInView= page $ p << "ask for three numbers in the same page and display the result." - ++> p << "It is possible to modify the inputs and the sum will reflect it" - ++> sumWidget - -sumWidget= pageFlow "sum" $ do - n <- do - n1 <- p << "Enter first number" ++> getInt Nothing <++ br - n2 <- p << "Enter second number" ++> getInt Nothing <++ br - n3 <- p << "Enter third number" ++> getInt Nothing <++ br - return (n1+ n2 + n3) - - -- factoring out the button - <** br ++> pageFlow "button" (submitButton "submit") - - p << ("The result is: "++show n) ++> wlink () << b << " menu" - <++ p << "you can change the numbers in the boxes to see how the result changes" - --- to run it alone, replace page by ask and uncomment the following line ---main= runNavigation "" $ transientNav sumWidget
− Demos/TestREST.hs
@@ -1,50 +0,0 @@-{-# OPTIONS -XCPP #-} -module TestREST where -import Menu -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- --- 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 $ h2 << "Choose between:" - ++> wlink "a" << b << "letters " <++ i << " or " - <|> wlink "1" << b << "numbers" - - case option of - "1" -> do - page $ wlink "2" << contentFor "1" - page $ wlink "3" << contentFor "2" - page $ wlink "4" << contentFor "3" - page $ wlink () << "menu" - - "a" -> do - page $ wlink "b" << contentFor "a" - page $ wlink "c" << contentFor "b" - page $ wlink "d" << contentFor "c" - page $ wlink () << "menu" - - -contentFor x= do - p << "page for" - b << x - p << "goto next page" - p << "or press the back button for the previous page" -
− Demos/TraceSample.hs
@@ -1,29 +0,0 @@-{-# OPTIONS -F -pgmF MonadLoc #-} -module TraceSample ( traceSample) where - -import MFlow.Wai.Blaze.Html.All hiding (page) -import Control.Monad.Loc --import Menu--- to run it alone, remove import menu and uncomment the following line ---main= runNavigation "" $ transientNav traceSample -- -traceSample= do - page $ h2 << "Error trace example" - ++> p << "MFlow now produces execution traces in case of error by making use of the backtracking mechanism" - ++> p << "It is more detailed than a call stack" - ++> p << "this example has a deliberate error" - ++> br - ++> p << "You must be logged as admin to see the trace" - ++> wlink () << p << "pres here" - - page $ p << "Please login with admin/admin" - ++> userWidget (Just "admin") userLogin - - u <- getCurrentUser - page $ p << "The trace will appear after you press the link. press one of the options available at the bottom of the pagem" - ++> p << ("user="++ u) ++> br - ++> wlink () << "press here" - page $ error $ "this is the error" -
− Demos/demos-blaze.hs
@@ -1,107 +0,0 @@-{-# OPTIONS -XDeriveDataTypeable -XQuasiQuotes -XOverloadedStrings #-} -module Main where -import MFlow.Wai.Blaze.Html.All hiding (name) -import Text.Blaze.Html5 as El -import Text.Blaze.Html5.Attributes as At hiding (step,name) -import Data.TCache.IndexQuery -import Data.Typeable -- -import Data.Monoid -import Data.String -import Text.Hamlet - --- For error traces -import Control.Monad.Loc --import Menu hiding (page) -import TestREST -import Actions -import IncreaseInt -import ShopCart -import AjaxSample -import IncreaseString -import AutoCompList -import ListEdit -import AutoComplete -import LoginSample -import CheckBoxes -import Multicounter -import Combination -import Options -import ContentManagement -import PreventGoingBack -import Counter -import PushDecrease -import Dialog -import PushSample -import Grid -import Radio -import SumView-import MCounter-import Database-import MFlowPersistent-import RuntimeTemplates-import TraceSample--import Data.TCache.DefaultPersistence-import Data.ByteString.Lazy.Char8 hiding (index)-instance Serializable Int where- serialize= pack . show- deserialize= read . unpack----main= do- index idnumber -- for the Database example- index tfieldKey - setAdminUser adminname adminname- userRegister edadmin edadmin- userRegister "edituser" "edituser" - syncWrite $ Asyncronous 120 defaultCheck 1000- - setFilesPath "Demos/"- runNavigation "" $ do- setHeader $ stdheader - setTimeouts 400 $ 60 * 60- - r <- step . page $ tFieldEd edadmin "head" "set Header" <++ hr- **> (El.div ! At.style "float:right" <<< autoRefresh wlogin )- **> (divmenu <<< br ++> mainMenu) - <** (El.div ! At.style "float:right;width:65%;overflow:auto;"- <<< tFieldEd edadmin "intro" "enter intro text") - - case r of- Wiki -> delSessionData (Filename "") >> step wiki - CountI -> step (clickn 0) `showSource` "IncreaseInt.hs" - CountS -> step (clicks "1") `showSource` "IncreaseString.hs" - Action -> step actions `showSource` "Actions.hs" - Ajax -> step ajaxsample `showSource` "AjaxSample.hs" - Select -> step options `showSource` "Options.hs" - CheckBoxes -> step checkBoxes `showSource` "CheckBoxes.hs" - TextEdit -> step textEdit `showSource` "ContentManagement.hs" - Grid -> step grid `showSource` "Grid.hs" - Autocomp -> step autocomplete1 `showSource` "AutoComplete.hs" - AutocompList -> step autocompList `showSource` "AutoCompList.hs" - ListEdit -> step wlistEd `showSource` "ListEdit.hs" - Radio -> step radio `showSource` "Radio.hs" - Login -> step loginSample `showSource` "LoginSample.hs" - PreventBack -> step preventBack `showSource` "PreventGoingBack.hs" - Multicounter-> step multicounter `showSource` "Multicounter.hs" - FViewMonad -> step sumInView `showSource` "SumView.hs" - Counter -> step counter `showSource` "Counter.hs" - Combination -> step combination `showSource` "Combination.hs" - WDialog -> step wdialog1 `showSource` "Dialog.hs" - Push -> step pushSample `showSource` "PushSample.hs" - PushDec -> step pushDecrease `showSource` "PushDecrease.hs" - Trace -> step traceSample `showSource` "TraceSample.hs"- RESTNav -> step testREST `showSource` "TestREST.hs"- Database -> step database `showSource` "Database.hs" - ShopCart -> shopCart `showSource` "ShopCart.hs"- MCounter -> mcounter `showSource` "MCounter.hs"- MFlowPersist -> step mFlowPersistent `showSource` "MFlowPersistent.hs"- RuntimeTemplates -> step runtimeTemplates `showSource` "RuntimeTemplates.hs"----
MFlow.cabal view
@@ -1,138 +1,137 @@-name: MFlow -version: 0.3.3 -cabal-version: >=1.8 -build-type: Simple -license: BSD3 -license-file: LICENSE -maintainer: agocorona@gmail.com -stability: experimental -bug-reports: https://github.com/agocorona/MFlow/issues -synopsis: stateful, RESTful web framework -description: MFlow is a Web Framework that turns Web programing back into just ordinary programming by automating all the extra - complexities. - . - The goals of MFlow are: - . - -To invert back the inversion of control of web applications and turn web programming into ordinary, intuitive, imperative-like, programming as seen by the programmer. - . - -At the same time, to maintain, for the user, all the freedom that it has in web applications. - -For scalability-sensitive applications, to avoid the fat state snapshots that continuation based frameworks need to cope with these two previous requirements. State replication and Horizontal scalability must be possible. - . - -For REST advocates, to maintain the elegant notation of REST urls and the statelessness of GET requests. - . - -For expert haskell programmers, to reuse the already existent web libraries and techniques. - . - -For beginner programmers and for Software Enginners, to provide with a high level DSL of reusable, self contained widgets for the user interface, and multipage procedures that can work together provided that they statically typecheck, with zero configuration. - . - -For highly interactive applications, to give dynamic widgets that have their own dynamic behaviors in the page, and communicate themselves without the need of explicit JavaScript programming. - . - -No deployment, in order to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html> - . - MFlow try to solve the first requirements using a different approach. The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links point to alternative routes within this monadic computation just like a textual menu in a console application. Any GET page is directly reachable by means of a RESTful URL. - . - At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar. If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match. From this position on, the execution goes forward until the rest of the path match. Thus, no matter the previous state of the server process, it recover the state of execution appropriate for the request. This way the server process is virtually stateless for any GET request. However, it is possible to store a session state, which may backtrack or not when the navigation goes back and forth. It is up to the programmer. Synchronization between server state and web browser state is supported out-of-the-box. - . - When the state matters, and user interactions can last for long, such are shopping carts etc. It uses a log for thread state persistence. The server process shut itself down after a programmer defined timeout. Once a new request of the same user arrive, the log is used to recover the process state. There is no need to store a snapshot of every continuation, just the result of each step. - . - State consistence and transactions are given by the TCache package. It is data cache within the STM monad (Software Transactional Memory). Serialization and deserialization of data is programmer defined, so it can adapt it to any database, although any other database interface can be used. Default persistence in files comes out of the box for rapid development purposes. - . - The processes interact trough widgets, that are an extension of formlets with additional applicative combinators , formatting, link management, callbacks, modifiers, caching and AJAX. All is coded in pure haskell. Each widget return statically typed data. They can dynamically modify themselves using AJAX internally (ust prefix it with autorefresh). They are auto-contained: they may include their own JavaScript code, server code and client code in a single pure Haskell procedure that can be combined with other widgets with no other configuration. - . - To combine widgets, applicative combinators are used. Widgets with dynamic behaviours can use the monadic syntax and callbacks. - . - The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString, Hack and WAI but it can be extended to non Web based architectures. - . - 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 +name: MFlow+version: 0.4.0+cabal-version: >=1.8+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: agocorona@gmail.com+stability: experimental+bug-reports: https://github.com/agocorona/MFlow/issues+synopsis: stateful, RESTful web framework+description: MFlow is a Web Framework that turns Web programing back into just ordinary programming by automating all the extra+ complexities. .+ The goals of MFlow are: .- This version 0.3.3 run with wai 2.0+ -To invert back the inversion of control of web applications and turn web programming into ordinary, intuitive, imperative-like, programming as seen by the programmer. .+ -At the same time, to maintain, for the user, all the freedom that it has in web applications.+ -For scalability-sensitive applications, to avoid the fat state snapshots that continuation based frameworks need to cope with these two previous requirements. State replication and Horizontal scalability must be possible.+ .+ -For REST advocates, to maintain the elegant notation of REST urls and the statelessness of GET requests.+ .+ -For expert haskell programmers, to reuse the already existent web libraries and techniques.+ .+ -For beginner programmers and for Software Enginners, to provide with a high level DSL of reusable, self contained widgets for the user interface, and multipage procedures that can work together provided that they statically typecheck, with zero configuration.+ .+ -For highly interactive applications, to give dynamic widgets that have their own dynamic behaviors in the page, and communicate themselves without the need of explicit JavaScript programming.+ .+ -No deployment, in order to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>+ .+ MFlow try to solve the first requirements using a different approach. The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links point to alternative routes within this monadic computation just like a textual menu in a console application. Any GET page is directly reachable by means of a RESTful URL.+ .+ At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar. If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match. From this position on, the execution goes forward until the rest of the path match. Thus, no matter the previous state of the server process, it recover the state of execution appropriate for the request. This way the server process is virtually stateless for any GET request. However, it is possible to store a session state, which may backtrack or not when the navigation goes back and forth. It is up to the programmer. Synchronization between server state and web browser state is supported out-of-the-box.+ .+ When the state matters, and user interactions can last for long, such are shopping carts etc. It uses a log for thread state persistence. The server process shut itself down after a programmer defined timeout. Once a new request of the same user arrive, the log is used to recover the process state. There is no need to store a snapshot of every continuation, just the result of each step.+ .+ State consistence and transactions are given by the TCache package. It is data cache within the STM monad (Software Transactional Memory). Serialization and deserialization of data is programmer defined, so it can adapt it to any database, although any other database interface can be used. Default persistence in files comes out of the box for rapid development purposes.+ .+ The processes interact trough widgets, that are an extension of formlets with additional applicative combinators , formatting, link management, callbacks, modifiers, caching and AJAX. All is coded in pure haskell. Each widget return statically typed data. They can dynamically modify themselves using AJAX internally (ust prefix it with autorefresh). They are auto-contained: they may include their own JavaScript code, server code and client code in a single pure Haskell procedure that can be combined with other widgets with no other configuration.+ .+ To combine widgets, applicative combinators are used. Widgets with dynamic behaviours can use the monadic syntax and callbacks.+ .+ The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString, Hack and WAI but it can be extended to non Web based architectures.+ .+ 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+ .+ 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+ . The version 0.3.2 add runtime templates. It also add witerate and dField, two modifiers for single page development. dField creates a placeholder for a widget that is updated via implicit AJAX by witerate. http://haskell-web.blogspot.com.es/2013/11/more-composable-elements-for-single.html- . - The version 0.3.1 included: - . - - Push widgets: 'http://haskell-web.blogspot.com.es/2013/07/maxwell-smart-push-counter.html' - . - - Complete execution traces for errors: 'http://haskell-web.blogspot.com.es/2013/07/automatic-error-trace-generation-in.html' - . - The version 0.3 added: - - RESTful URLs: 'http://haskell-web.blogspot.com.es/2013/07/the-web-navigation-monad.html' - . - - Automatic independent refreshing of widgets via Ajax. (see 'http://haskell-web.blogspot.com.es/2013/06/and-finally-widget-auto-refreshing.html') - . - - Page flows: Monadic widgets that can express his own behaviour and can run its own independent page flow. (see http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html) - . - - Widget callbacks, used in page flows, that change the rendering of the widget (see http://haskell-web.blogspot.com.es/2013/06/callbacks-in-mflow.html) - . - - Widgets in modal and non modal dialogs (using jQuery dialog) - . - - Other jQuery widgets as MFlow widgets - . - The version 0.2 added better WAI integration, higher level dynamic Widgets, content management, multilanguage, blaze-html support, stateful ajax for server-side control, user-defined data in sessions and widget requirements for automatic installation of scripts, CSS and server flows. - . - The version 0.1 had transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX, and WAI integration. - . - . - See "MFlow.Forms" for details - . - To do: - . - -Clustering - . - -category: Web, Application Server -author: Alberto Gómez Corona -data-dir: "" -extra-source-files: Demos/demos-blaze.hs Demos/TestREST.hs - Demos/Actions.hs Demos/IncreaseInt.hs Demos/ShopCart.hs - Demos/AjaxSample.hs Demos/TraceSample.hs Demos/IncreaseString.hs - Demos/AutoCompList.hs Demos/ListEdit.hs Demos/AutoComplete.hs - Demos/LoginSample.hs Demos/CheckBoxes.hs Demos/Multicounter.hs - Demos/Combination.hs Demos/Options.hs Demos/ContentManagement.hs - Demos/PreventGoingBack.hs Demos/Counter.hs Demos/PushDecrease.hs - Demos/Dialog.hs Demos/PushSample.hs Demos/Grid.hs Demos/Radio.hs - Demos/SumView.hs src/MFlow/Hack.hs src/MFlow/Hack/Response.hs - Demos/MCounter.hs src/MFlow/Hack/XHtml.hs - src/MFlow/Hack/XHtml/All.hs src/MFlow/Forms/HSP.hs - -source-repository head - type: git - location: http://github.com/agocorona/MFlow - -library - build-depends: Workflow -any, transformers -any, mtl -any, - extensible-exceptions -any, xhtml -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 -any, case-insensitive -any, - http-types -any, conduit -any, text -any, parsec -any, warp -any, - random -any, blaze-html -any, blaze-markup -any, monadloc -any, - hamlet -any - exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms - MFlow.Forms.Admin MFlow.Cookies MFlow.Wai MFlow.Wai.XHtml.All - MFlow.Forms.XHtml MFlow.Forms.Blaze.Html MFlow.Forms.Test - MFlow.Forms.Widgets MFlow.Forms.Internals - exposed: True - buildable: True + .+ The version 0.3.1 included:+ .+ - Push widgets: 'http://haskell-web.blogspot.com.es/2013/07/maxwell-smart-push-counter.html'+ .+ - Complete execution traces for errors: 'http://haskell-web.blogspot.com.es/2013/07/automatic-error-trace-generation-in.html'+ .+ The version 0.3 added:+ - RESTful URLs: 'http://haskell-web.blogspot.com.es/2013/07/the-web-navigation-monad.html'+ .+ - Automatic independent refreshing of widgets via Ajax. (see 'http://haskell-web.blogspot.com.es/2013/06/and-finally-widget-auto-refreshing.html')+ .+ - Page flows: Monadic widgets that can express his own behaviour and can run its own independent page flow. (see http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html)+ .+ - Widget callbacks, used in page flows, that change the rendering of the widget (see http://haskell-web.blogspot.com.es/2013/06/callbacks-in-mflow.html)+ .+ - Widgets in modal and non modal dialogs (using jQuery dialog)+ .+ - Other jQuery widgets as MFlow widgets+ .+ The version 0.2 added better WAI integration, higher level dynamic Widgets, content management, multilanguage, blaze-html support, stateful ajax for server-side control, user-defined data in sessions and widget requirements for automatic installation of scripts, CSS and server flows.+ .+ The version 0.1 had transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting, AJAX, and WAI integration.+ .+ .+ See "MFlow.Forms" for details+ .+ To do:+ .+ -Clustering+ .+category: Web, Application Server+author: Alberto Gómez Corona+data-dir: ""+extra-source-files: src/MFlow/Hack.hs+ src/MFlow/Hack/Response.hs+ src/MFlow/Hack/XHtml.hs+ src/MFlow/Hack/XHtml/All.hs src/MFlow/Forms/HSP.hs++source-repository head+ type: git+ location: http://github.com/agocorona/MFlow++library+ build-depends: Workflow -any, transformers -any, mtl -any,+ extensible-exceptions -any, xhtml -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, hamlet -any, clientsession ==0.9.0.3, safecopy -any,+ acid-state -any, hscolour -any+ exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms+ MFlow.Forms.Admin MFlow.Cookies MFlow.Wai MFlow.Wai.XHtml.All+ MFlow.Forms.XHtml MFlow.Forms.Blaze.Html MFlow.Forms.Test+ MFlow.Forms.Widgets MFlow.Forms.Internals MFlow.Forms.WebApi+ exposed: True+ buildable: True hs-source-dirs: src .- ghc-options: - 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, 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, persistent-sqlite, persistent, --- conduit, http-conduit, monad-logger --- --- --- main-is: demos-blaze.hs --- buildable: True --- hs-source-dirs: Demos --- other-modules: MFlowPersistent MCounter --- ghc-options: -O -iDemos -threaded -rtsopts - + 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+
src/MFlow.hs view
@@ -60,7 +60,7 @@ Flow, Params, HttpData(..),Processable(..) , Token(..), ProcList -- * low level comunication primitives. Use `ask` instead -,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment +,flushRec, flushResponse, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment , sendEndFragment, sendToMF -- * Flow configuration ,setNoScript,addMessageFlows,getMessageFlows,delMessageFlow, transient, stateless,anonymous @@ -70,7 +70,9 @@ btag, bhtml, bbody,Attribs, addAttrs -- * user , userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod --- * static files +-- * static files+-- * config+,Config(..), config ,setFilesPath -- * internal use ,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow @@ -176,12 +178,6 @@ data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show) ---instance ToHttpData HttpData where --- toHttpData= id --- ---instance ToHttpData ByteString where --- toHttpData bs= HttpData [] [] bs - instance Monoid HttpData where mempty= HttpData [] [] B.empty mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s' @@ -252,23 +248,26 @@ sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush " --- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' +-- | 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 {-# DEPRECATED sendEndFragment "use \"send\" to end a fragmented response instead" #-} -sendEndFragment :: Token -> HttpData -> IO() -sendEndFragment (Token _ _ _ _ _ _ qresp ) msg= putMVar qresp $ EndFragm msg +sendEndFragment :: Token -> HttpData -> IO() +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 () flushRec t@(Token _ _ _ _ _ queue _)= do empty <- isEmptyMVar queue when (not empty) $ takeMVar queue >> return () -- !> "flushRec" - receiveReq :: Token -> IO Req receiveReq t@(Token _ _ _ _ _ queue _)= readMVar queue -- !> (">>>>>> receiveReq "++ thread t) @@ -308,7 +307,6 @@ resp <- f (getParams req) (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t) loop t queue qresp -- !> ("enviado stateless " ++ thread t) --- @@ -335,10 +333,7 @@ delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms) ---class ToHttpData a where --- toHttpData :: a -> HttpData - sendToMF Token{..} msg= putMVar tsendq $ Req msg --recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c @@ -370,7 +365,7 @@ -- | The scheduler creates a Token with every `Processable` --- message that arrives and send the mesage to the appropriate flow, then waht for the response +-- message that arrives and send the mesage to the appropriate flow, then wait for the response -- and return it. -- -- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it @@ -396,7 +391,7 @@ `CE.catch` \(e:: CE.SomeException) -> do showError wfname token (show e) -- sendFlush token (Error NotFound $ "Not found: " <> pack wfname) - deleteTokenInList token + deleteTokenInList token Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname) @@ -415,14 +410,13 @@ showError wfname token@Token{..} e= do - t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime - let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv + t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime + let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv + logError msg + fresp <- getNotFoundResponse + let admin= getAdminName + sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg] - logError msg - fresp <- getNotFoundResponse - admin <- getAdminName --- sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg] - sendFlush token . Error $ fresp True $ Prelude.concat[ "<br/>"++ s | s <- lines msg] errorMessage t e u path env= "\n---------------------ERROR-------------------------\ @@ -468,6 +462,7 @@ { userName :: String , upassword :: String } deriving (Read, Show, Typeable) + eUser= User (error1 "username") (error1 "password") @@ -517,7 +512,24 @@ -data Config = Config UserStr deriving (Read, Show, Typeable) +data Config = Config{cadmin :: UserStr -- ^ Administrator name+ ,cjqueryScript :: String -- ^ URL of jquery+ ,cjqueryCSS :: String -- ^ URL of jqueryCSS+ ,cjqueryUI :: String -- ^ URL of jqueryUI+ ,cnicEditUrl :: String -- ^ URL of the nicEdit editor+ }+ deriving (Read, Show, Typeable) ++defConfig= Config "admin" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"+ "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"+ "//code.jquery.com/ui/1.10.3/jquery-ui.js"+ "//js.nicedit.com/nicEdit-latest.js"++config= unsafePerformIO $! atomically $! readConfig++readConfig= readDBRef rconf `onNothing` return defConfig++ keyConfig= "mflow.config" instance Indexable Config where key _= keyConfig @@ -530,20 +542,23 @@ type UserStr= String type PasswdStr= String - +++-- | set the Administrator user and password.+-- It must be defined in Main , before any configuration parameter is read, before the execution+-- of any flow setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m () setAdminUser user password= liftIO $ do - userRegister user password - atomically $ writeDBRef rconf $ Config user + userRegister user password+ atomically $ do+ conf <- readConfig + writeDBRef rconf $ conf{cadmin= user} + -getAdminName :: MonadIO m => m UserStr -getAdminName= liftIO $ do - cu <- atomically $ readDBRef rconf - case cu of - Nothing -> setAdminUser "admin" "admin" >> getAdminName - Just (Config u) -> return u +getAdminName= cadmin config + --------------- ERROR RESPONSES -------- defNotFoundResponse isAdmin msg= fresp $ @@ -863,16 +878,4 @@ ("z", "application/x-compress") ] --- --- -- inspired by Pepe Iborra withLocTH ---locTH :: Q Exp ---locTH = do --- loc <- qLocation --- let loc_msg = showLoc loc --- [|loc_msg |] --- ---showLoc :: Loc -> String ---showLoc Loc{loc_module=mod, loc_filename=filename, loc_start=start} = --- {- text package <> char '.' <> -} --- printf "%s (%s). %s" mod filename (show start)
src/MFlow/Cookies.hs view
@@ -1,70 +1,73 @@-{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}--module MFlow.Cookies-(Cookie,contentHtml,cookieuser,cookieHeaders,getCookies)-where-import Control.Monad(MonadPlus(..), guard, replicateM_, when)-import Data.Char-import Data.Maybe(fromMaybe)-import System.IO.Unsafe-import Control.Exception(handle)-import Data.Typeable-import Data.Maybe(fromJust)-import Unsafe.Coerce-import Data.Monoid-import Text.Parsec-import Control.Monad.Identity-import Data.ByteString.Char8 as B----import Debug.Trace---(!>)= flip trace--contentHtml :: (ByteString, ByteString)-contentHtml= ("Content-Type", "text/html")--type Cookie= (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)--cookieuser :: String-cookieuser= "cookieuser"---getCookies httpreq=- case lookup "Cookie" $ httpreq of- Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]- Nothing -> []--cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs--showCookie :: Cookie -> B.ByteString-showCookie (n,v,p,me) = n <> "=" <> v <>- ";path=" <> p <>- showMaxAge me-- where- showMaxAge Nothing = "" - showMaxAge (Just e) = ";Max-age=" <> e-----showCookie :: Cookie -> String---showCookie (n,v,p,me) =--- let e= fromMaybe "" me --- in showString n . showString "=" . showString v . showString "; path=" --- . showString p . showMaxAge e . showString "\n" $ ""---------showMaxAge [] = showString "" ---showMaxAge e = showString "; Max-age=" . showString e------+{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-} + +module MFlow.Cookies ( + CookieT, + Cookie(..), + contentHtml, + cookieuser, + cookieHeaders, + getCookies, + paranoidEncryptCookie, + paranoidDecryptCookie, + encryptCookie, + decryptCookie + ) +where +import Control.Monad(MonadPlus(..), guard, replicateM_, when) +import Data.Char +import Data.Maybe(fromMaybe, fromJust) +import System.IO.Unsafe +import Control.Exception(handle) +import Data.Typeable +import Unsafe.Coerce +import Data.Monoid +import Text.Parsec +import Control.Monad.Identity +import Data.ByteString.Char8 as B +import Web.ClientSession +import System.Environment + +--import Debug.Trace +--(!>)= flip trace + +contentHtml :: (ByteString, ByteString) +contentHtml= ("Content-Type", "text/html; charset=UTF-8") + +type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString) + +data Cookie + = UnEncryptedCookie CookieT + | EncryptedCookie CookieT + | ParanoidCookie CookieT + deriving (Eq, Read, Show) + +cookieuser :: String +cookieuser= "cookieuser" + +getCookies httpreq= + case lookup "Cookie" $ httpreq of + Just str -> splitCookies str :: [(B.ByteString, B.ByteString)] + Nothing -> [] + +cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs + +showCookie :: Cookie -> B.ByteString +showCookie c@(EncryptedCookie _) = showCookie' $ decryptAndToTuple c +showCookie c@(ParanoidCookie _) = showCookie' $ decryptAndToTuple c +showCookie (UnEncryptedCookie c) = showCookie' c + +showCookie' (n,v,p,me) = n <> "=" <> v <> + ";path=" <> p <> + showMaxAge me + +showMaxAge Nothing = "" +showMaxAge (Just e) = ";Max-age=" <> e + splitCookies cookies = f cookies [] where f s r | B.null s = r f xs0 r = - let+ let xs = B.dropWhile (==' ') xs0 name = B.takeWhile (/='=') xs xs1 = B.dropWhile (/='=') xs @@ -73,107 +76,12 @@ xs3 = B.dropWhile (/=';') xs2 xs4 = B.dropWhile (==';') xs3 xs5 = B.dropWhile (==' ') xs4 - in f xs5 ((name,val):r)------------------------------------------------------------------------------- --- %*************************************************************************** --- %* * --- \subsection[CGI-Parser]{Yet another combinator parser library}. chuck of code taken from Erik Meijer --- %* * --- %*************************************************************************** - --- NOTE: This is all a little bit of a sledgehammer here for the simple task --- at hand... + in f xs5 ((name,val):r) --- The parser monad +---------------------------- --- ---newtype Parser a = Parser (String -> [(a,String)]) --- ---instance Functor Parser where --- -- map :: (a -> b) -> (Parser a -> Parser b) --- fmap f (Parser p) = Parser (\inp -> [(f v, out) | (v, out) <- p inp]) --- ---instance Monad Parser where --- -- return :: a -> Parser a --- return v = Parser (\inp -> [(v,inp)]) --- --- -- >>= :: Parser a -> (a -> Parser b) -> Parser b --- (Parser p) >>= f = Parser (\inp -> concat [papply (f v) out --- | (v,out) <- p inp]) --- ---instance MonadPlus Parser where --- -- zero :: Parser a --- mzero = Parser (\_ -> []) --- -- (++) :: Parser a -> Parser a -> Parser a --- (Parser p) `mplus` (Parser q) = Parser (\inp -> (p inp ++ q inp)) --- --- ----- Other primitive parser combinators --- --- ---item :: Parser Char ---item = Parser (\inp -> case inp of --- [] -> [] --- (x:xs) -> [(x,xs)]) --- ---force :: Parser a -> Parser a ---force (Parser p) = Parser (\inp -> let x = p inp in --- (fst (head x), snd (head x)) : tail x) --- ---first :: Parser a -> Parser a ---first (Parser p) = Parser (\inp -> case p inp of --- [] -> [] --- (x:_) -> [x]) --- ---papply :: Parser a -> String -> [(a,String)] ---papply (Parser p) inp = p inp --- --- ----- Derived combinators --- --- ---(+++) :: Parser a -> Parser a -> Parser a ---p +++ q = first (p `mplus` q) --- ---sat :: (Char -> Bool) -> Parser Char ---sat p = do {x <- item; guard (p x); return x} --- ---many :: Parser a -> Parser [a] ---many p = force (many1 p +++ return []) --- ---many1 :: Parser a -> Parser [a] ---many1 p = do {x <- p; xs <- many p; return (x:xs)} --- ---sepby :: Parser a -> Parser b -> Parser [a] ---p `sepby` sep = (p `sepby1` sep) +++ return [] --- ---sepby1 :: Parser a -> Parser b -> Parser [a] ---p `sepby1` sep = do x <- p --- xs <- many (do {sep; p}) --- return(x:xs) --- ---char :: Char -> Parser Char ---char x = sat (x==) --- ---alphanum :: Parser Char ---alphanum = sat (\c -> isAlphaNum c || c == '@' || c =='\'' ) -- Added @ as a valid character --- ---string :: String -> Parser String ---string "" = return "" ---string (x:xs) = do char x --- string xs --- return (x:xs) --- ---hexdigit :: Parser Char ---hexdigit = sat isHexDigit --- --- --readEnv :: Parser [(String,String)] -readEnv = (do+readEnv = (do n <- urlEncoded string "=" v <- urlEncoded @@ -185,8 +93,8 @@ `mplus` do{ char '+' ; return ' '} `mplus` do{ char '%' ; hexadecimal } ) - + --extra :: Parser Char extra = satisfy (`Prelude.elem` "!*'(),/\"") -- @@ -199,17 +107,82 @@ return .chr $ toInt d1* 16 + toInt d2 where toInt d | isDigit d = ord d - ord '0' toInt d | isHexDigit d = (ord d - ord 'A') + 10 - toInt d = error ("hex2int: illegal hex digit " ++ [d]) ---type HexString = String + toInt d = error ("hex2int: illegal hex digit " ++ [d]) ---hex2int :: HexString -> Int ---hex2int ds = Prelude.foldl (\n d -> n*16+d) 0 (Prelude.map (toInt . toUpper) ds) --- where toInt d | isDigit d = ord d - ord '0' --- toInt d | isHexDigit d = (ord d - ord 'A') + 10 --- toInt d = error ("hex2int: illegal hex digit " ++ [d]) ----urlDecode :: String -> [([(String, String)],String)]---urlDecode str= case parse readEnv "" str of -- let Parser p= readEnv in p str--- Left err -> error $ "urlDecode: decode error: " ++ show err--- Right r -> r--- !> ("decode="++str)+ + +decryptCookie :: Cookie -> IO Cookie +decryptCookie c@(UnEncryptedCookie _) = return c +decryptCookie (EncryptedCookie c) = decryptCookie' c +decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c + +-- Uses 4 seperate keys, corresponding to the 4 seperate fields in the Cookie. +paranoidEncryptCookie :: CookieT -> IO Cookie +paranoidEncryptCookie (a,b,c,d) = do + key1 <- getKey "CookieKey1.key" + key2 <- getKey "CookieKey2.key" + key3 <- getKey "CookieKey3.key" + key4 <- getKey "CookieKey4.key" + iv1 <- randomIV + iv2 <- randomIV + iv3 <- randomIV + iv4 <- randomIV + return $ ParanoidCookie + ( encrypt key1 iv1 a, + encrypt key2 iv2 b, + encrypt key3 iv3 c, + encryptMaybe key4 iv4 d) + +paranoidDecryptCookie :: CookieT -> IO Cookie +paranoidDecryptCookie (a,b,c,d) = do + key1 <- getKey "CookieKey1.key" + key2 <- getKey "CookieKey2.key" + key3 <- getKey "CookieKey3.key" + key4 <- getKey "CookieKey4.key" + return $ UnEncryptedCookie + ( decryptFM key1 a, + decryptFM key2 b, + decryptFM key3 c, + decryptMaybe key4 d) + +-- Uses a single key to encrypt all 4 fields. +encryptCookie :: CookieT -> IO Cookie +encryptCookie (a,b,c,d) = do + key <- getKey "CookieKey.key" + iv1 <- randomIV + iv2 <- randomIV + iv3 <- randomIV + iv4 <- randomIV + return $ EncryptedCookie + ( encrypt key iv1 a, + encrypt key iv2 b, + encrypt key iv3 c, + encryptMaybe key iv4 d) + +decryptCookie' :: CookieT -> IO Cookie +decryptCookie' (a,b,c,d) = do + key <- getKey "CookieKey.key" + return $ UnEncryptedCookie + ( decryptFM key a, + decryptFM key b, + decryptFM key c, + decryptMaybe key d) + +encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString +encryptMaybe k i (Just s) = Just $ encrypt k i s +encryptMaybe _ _ Nothing = Nothing + +decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString +decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s +decryptMaybe _ Nothing = Nothing + +decryptFM :: Key -> ByteString -> ByteString +decryptFM k b = fromMaybe "" $ decrypt k b + +cookieToTuple :: Cookie -> CookieT +cookieToTuple (UnEncryptedCookie c) = c +cookieToTuple (EncryptedCookie c) = c +cookieToTuple (ParanoidCookie c) = c + +decryptAndToTuple :: Cookie -> CookieT +decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
src/MFlow/Forms.hs view
@@ -9,1617 +9,1693 @@ -XFlexibleContexts -XRecordWildCards -XIncoherentInstances - -XTypeFamilies- -XTypeOperators- -XOverloadedStrings- -XTemplateHaskell- -#-} - -{- |-MFlow run stateful server processes. This version is the first stateful web framework-that is as RESTful as a web framework can be.--The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links-point to alternative routes within this monadic computation just like a textual menu-in a console application. Any GET page is directly reachable by means of a RESTful URL.--At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar.-If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match-. From this position the execution goes forward until the rest of the path match. This way the-statelessness is optional. However, it is possible to store a session state, which may backtrack or-not when the navigation goes back and forth. It is upto the programmer.---All the flow of requests and responses are coded by the programmer in a single procedure. -Allthoug single request-response flows are possible. Therefore, the code is -more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for -handling the back button. Back button state syncronization is supported out-of-the-box--The MFlow architecture is scalable, since the state is serializable and small - -The processes are stopped and restarted by the -application server on demand, including the execution state (if the Wokflow monad is used). -Therefore session management is automatic. State consistence and transactions are given by the TCache package. - -The processes interact trough widgets, that are an extension of formlets with -additional applicative combinators, formatting, link management, callbacks, modifiers, caching, -byteString conversion and AJAX. All is coded in pure haskell.--The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString -, Hack and WAI but it can be extended to non Web based architectures. - -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- -It is designed for applications that can be run with no deployment with runghc in order -to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>--This module implement stateful processes (flows) that are optionally persistent.-This means that they automatically store and recover his execution state. They are executed by the MFlow app server.-defined in the "MFlow" module.--These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to-the calling process. Because flows are stateful, not request-response, the code is more understandable, because-all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug-single request-response flows and callbacks are possible.--This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an-instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .-To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.--`ask` is the only method for user interaction. It run in the @MFlow view m@ monad, with @m@ the monad chosen by the user, usually IO.-It send user interfaces (in the @View view m@ monad) and return statically -typed responses. The user interface definitions are based on a extension of-formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,- extra combinators, callbaks and modifiers.-The interaction with the user is stateful. In the same computation there may be many-request-response interactions, in the same way than in the case of a console applications. --* APPLICATION SERVER--Therefore, session and state management is simple and transparent: it is in the haskell-structures in the scope of the computation. `transient` (normal) procedures have no persistent session state-and `stateless` procedures accept a single request and return a single response.--`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that-remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.-This state management is transparent. There is no programer interface for session management.--The programmer set the process timeout and the session timeout with `setTimeouts`. -If the procedure has been stopped due to the process timeout or due to a system shutdowm,-the procedure restart in the last state when a request for this procedure arrives-(if the procedure uses the `step` monad transformer)--* WIDGETS--The correctness of the web responses is assured by the use of formLets.-But unlike formLets in its current form, it permits the definition of widgets.-/A widget is a combination of formLets and links within its own formatting template/, all in-the same definition in the same source file, in plain declarative Haskell style.--The formatting is abstract. It has to implement the 'FormInput' class.-There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")-and ByteString. So widgets-can use any formatting that is instance of `FormInput`.-It is possible to use more than one format in the same widget.--Links defined with `wlink` are treated the same way than forms. They are type safe and return values- to the same flow of execution.-It is posssible to combine links and forms in the same widget by using applicative combinators but also-additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can-be combined as such.--* NEW IN THIS RELEASE--[@Runtime templates@] 'template', 'edTemplate', 'witerate' and 'dField' permit the edition of-the widget content at runtime, and the management of placeholders with input fields and data fields-within the template with no navigation in the client, little bandwidth usage and little server load. Enven less-than using 'autoRefresh'.--* IN PREVIOUS RELEASES--{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page--[@Push@] With `push` a widget can push new content to the browser when something in the server happens--[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.---[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession-of links clicked to reach such page and such point in the procedure. Just what you would expect.--[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can-refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a-subpage flow by adding a well know indetifier prefix for links and form parameters.--[@Modal Dialogs@] 'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic-widget-formlet can add different form elements depending on the user responses, 'wcallback' can-substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples)--[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'--[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.--[@blaze-html support@] see <http://hackage.haskell.org/package/blaze-html> import "MFlow.Forms.Blaze.Html" or "MFlow.Wai.Blaze.Html.All" to use Blaze-Html--[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead-of a single request-response (see 'ajaxSend').--[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the-server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others.--[@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes- and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements'--[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'--[@multilanguage@] see 'mField' and 'mFieldEd'--[@URLs to internal states@] if the web navigation is trough GET forms or links,- an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users.-Just like in the case of an ordinary stateless application.---[@Back Button@] This is probably the first implementation in any language where the navigation-can be expressed procedurally and still it works well with the back button, thanks-to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)---[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)-, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if-the widget content comes from a database and it is shared by all users.---[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.-The callback may initate a flow of interactions with the user or simply executes an internal computation.-Callbacks are necessary for the creation of abstract container-widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes.---[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a-login form and substitute it by the username if already logged.--Example:--@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@---[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator---[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the- ByteString level, and to permit many formatring styles-in the same page, there are operators that combine different formats which are converted to ByteStrings.-For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.--[@File Server@] With file caching. See "MFlow.FileServer"-- --} - -module MFlow.Forms(- --- * Basic definitions --- FormLet(..), -FlowM, View(..), FormElm(..), FormInput(..)- --- * Users -, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName -,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, userWidget, login,-userName, --- * User interaction -ask, page, askt, clearEnv, wstateless, pageFlow, --- * formLets --- | They usually produce the HTML form elements (depending on the FormInput instance used)--- It is possible to modify their attributes with the `<!` operator.--- They are combined with applicative ombinators and some additional ones--- formatting can be added with the formatting combinators.--- modifiers change their presentation and behaviour -getString,getInt,getInteger, getTextBox -,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,-getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,-submitButton,resetButton, whidden, wlink, getRestParam, returning, wform, firstOf, manyOf, wraw, wrender, notValid--- * FormLet modifiers-,validate, noWidget, waction, wcallback, clear, wmodify,---- * Caching widgets-cachedWidget, wcached, wfreeze,- --- * 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`-,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),---- * Formatting combinators-(<<<),(++>),(<++),(<!),---- * Normalized (convert to ByteString) formatting combinators--- | Some combinators that convert the formatting of their arguments to lazy byteString-(.<<.),(.<++.),(.++>.)---- * ByteString tags-,btag,bhtml,bbody---- * Normalization-,flatten, normalize- --- * Running the flow monad -,runFlow, transientNav, runFlowOnce, runFlowIn-,runFlowConf,MFlow.Forms.Internals.step--- * controlling backtracking-,goingBack,returnIfForward, breturn, preventGoingBack, retry- --- * Setting parameters -,setHeader-,addHeader-,getHeader-,setSessionData-,getSessionData-,delSessionData -,setTimeouts- --- * Cookies -,setCookie--- * Ajax-,ajax-,ajaxSend-,ajaxSend_--- * Requirements-,Requirements(..)-,WebRequirement(..)-,requires--- * Utility-,getLang-,genNewId-,getNextId-,changeMonad-,FailBack-,fromFailBack-,toFailBack-,getRawParam- -) -where --import Data.RefSerialize hiding ((<|>))-import Data.TCache-import Data.TCache.Memoization -import MFlow-import MFlow.Forms.Internals -import MFlow.Cookies-import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks)-import qualified Data.Text as T-import Data.Text.Encoding -import Data.List---import qualified Data.CaseInsensitive as CI -import Data.Typeable -import Data.Monoid -import Control.Monad.State.Strict -import Data.Maybe -import Control.Applicative -import Control.Exception-import Control.Concurrent -import Control.Workflow as WF -import Control.Monad.Identity-import Unsafe.Coerce-import Data.List(intersperse) -import Data.IORef -import qualified Data.Map as M-import System.IO.Unsafe-import Data.Char(isNumber,toLower)-import Network.HTTP.Types.Header -- --- | Validates a form or widget result against a validating procedure --- --- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@ -validate- :: (FormInput view, Monad m) =>- View view m a- -> (a -> WState view m (Maybe view))- -> View view m a -validate formt val= View $ do - FormElm form mx <- runView formt - case mx of - Just x -> do - me <- val x- modify (\s -> s{inSync= True}) - case me of - Just str -> - return $ FormElm ( form ++ [inred str]) Nothing - Nothing -> return $ FormElm form mx - _ -> return $ FormElm form mx ---- | Actions are callbacks that are executed when a widget is validated.--- A action may be a complete flow in the flowM monad. It takes complete control of the navigation--- while it is executed. At the end it return the result to the caller and display the original--- calling page.--- It is useful when the widget is inside widget containers that may treat it as a black box.------ It returns a result that can be significative or, else, be ignored with '<**' and '**>'.--- An action may or may not initiate his own dialog with the user via `ask`-waction- :: (FormInput view, Monad m)- => View view m a- -> (a -> FlowM view m b)- -> View view m b-waction f ac = do- x <- f- s <- get- let env = mfEnv s- let seq = mfSequence s- put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True{-,mfLinkSelected= False-}}- r <- flowToView $ ac x- modify $ \s-> s{mfSequence= seq, mfEnv= env}- return r- where- flowToView x=- View $ do- r <- runSup $ runFlowM x- case r of- NoBack x ->- return (FormElm [] $ Just x)- BackPoint x->- return (FormElm [] $ Just x)- GoBack-> do- modify $ \s ->s{notSyncInAction= True}- return (FormElm [] 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))- -> View v m b-wmodify formt act = View $ do- FormElm f mx <- runView formt - (f',mx') <- act f mx- return $ FormElm f' mx'---- | Display a text box and return a non empty String -getString :: (FormInput view,Monad m) => - Maybe String -> View view m String -getString ms = getTextBox ms- `validate`- \s -> if null s then return (Just $ fromStr "")- else return Nothing ---- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation) -getInteger :: (FormInput view, MonadIO m) => - Maybe Integer -> View view m Integer -getInteger = getTextBox ---- | Display a text box and return a Int (if the value entered is not an Int, fails the validation) -getInt :: (FormInput view, MonadIO m) => - Maybe Int -> View view m Int -getInt = getTextBox ---- | Display a password box -getPassword :: (FormInput view, - Monad m) => - View view m String -getPassword = getParam Nothing "password" Nothing --newtype Radio a= Radio a---- | Implement a radio button that perform a submit when pressed.--- the parameter is the name of the radio group-setRadioActive :: (FormInput view, MonadIO m,- Read a, Typeable a, Eq a, Show a) => - a -> String -> View view m (Radio a)-setRadioActive v n = View $ do- st <- get- put st{needForm= True}- let env = mfEnv st- mn <- getParam1 n env- let str = if typeOf v == typeOf(undefined :: String)- then unsafeCoerce v else show v- return $ FormElm [finput n "radio" str - ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()")]- (fmap Radio $ valToMaybe mn)-- --- | Implement a radio button--- the parameter is the name of the radio group-setRadio :: (FormInput view, MonadIO m,- Read a, Typeable a, Eq a, Show a) => - a -> String -> View view m (Radio a)-setRadio v n= View $ do- st <- get- put st{needForm= True}- let env = mfEnv st- mn <- getParam1 n env- let str = if typeOf v == typeOf(undefined :: String)- then unsafeCoerce v else show v- return $ FormElm [finput n "radio" str - ( isValidated mn && v== fromValidated mn) Nothing]- (fmap Radio $ valToMaybe mn)---- | encloses a set of Radio boxes. Return the option selected-getRadio- :: (Monad m, Functor m, FormInput view) =>- [String -> View view m (Radio a)] -> View view m a-getRadio rs= do- id <- genNewId- Radio r <- firstOf $ map (\r -> r id) rs- return r--data CheckBoxes = CheckBoxes [String]--instance Monoid CheckBoxes where- mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys- mempty= CheckBoxes []----instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where--- mappend x y= mappend <$> x <*> y--- mempty= return (CheckBoxes [])----- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)-setCheckBox :: (FormInput view, MonadIO m) => - Bool -> String -> View view m CheckBoxes-setCheckBox checked v= View $ do- n <- genNewId- st <- get- put st{needForm= True}- let env = mfEnv st- strs= map snd $ filter ((==) n . fst) env- mn= if null strs then Nothing else Just $ head strs- val = inSync st- let ret= case val of -- !> show val of- True -> Just $ CheckBoxes strs -- !> show strs- False -> Nothing- return $ FormElm- ( [ finput n "checkbox" v - ( checked || (isJust mn && v== fromJust mn)) Nothing])- ret---- | Read the checkboxes dinamically created by JavaScript within the view parameter--- see for example `selectAutocomplete` in "MFlow.Forms.Widgets"-genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes-genCheckBoxes v= View $ do- n <- genNewId- st <- get- put st{needForm= True}- let env = mfEnv st- strs= map snd $ filter ((==) n . fst) env- mn= if null strs then Nothing else Just $ head strs-- val <- gets inSync- let ret= case val of- True -> Just $ CheckBoxes strs- False -> Nothing- 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- n <- genNewId- env <- gets mfEnv- let showx= case cast x of- Just x' -> x'- Nothing -> show x- r <- getParam1 n env- 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]- mr <- getParam1 n env-- let env = mfEnv st- modify $ \st -> st{needForm= True}- FormElm form2 mr2 <- runView boxes- return $ FormElm (form ++ form2) $- case (mr `asTypeOf` Validated ("" :: String),mr2) of- (NoParam,_) -> Nothing- (Validated _,Nothing) -> Just []- (Validated _, Just (CheckBoxes rs)) -> Just rs- ---- -getTextBox - :: (FormInput view, - Monad m, - Typeable a, - Show a, - Read a) => - Maybe a -> View view m a -getTextBox ms = getParam Nothing "text" ms ---- | return the value of a parameter from the environment-getRawParam p= gets mfEnv >>= getParam1 p >>= return . valToMaybe- -getParam - :: (FormInput view, - Monad m, - Typeable a, - Show a, - Read a) => - Maybe String -> String -> Maybe a -> View view m a -getParam look type1 mvalue = View $ do - tolook <- case look of - Nothing -> genNewId - Just n -> return n - let nvalue x = case x of - Nothing -> "" - Just v ->- case cast v of- Just v' -> v'- Nothing -> show v- st <- get- let env = mfEnv st- put st{needForm= True} - 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 - -----getCurrentName :: MonadState (MFlowState view) m => m String---getCurrentName= do--- st <- get--- let parm = mfSequence st--- return $ "p"++show parm----- | Display a multiline text box and return its content-getMultilineText :: (FormInput view - , Monad m) - => T.Text- -> View view m T.Text -getMultilineText nvalue = View $ do - tolook <- genNewId- 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 - - ---instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where --- digest mv = getBool b "True" "False" --- where --- b= case mv of --- Nothing -> Nothing --- Just bool -> Just $ case bool of--- True -> "True"--- False -> "False"---- | Display a dropdown box with the two values (second (true) and third parameter(false))--- . With the value of the first parameter selected. -getBool :: (FormInput view, - Monad m, Functor m) => - Bool -> String -> String -> View view m Bool -getBool mv truestr falsestr= do- r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])- <|> 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, - Monad m,Typeable a, Read a) => - View view m (MFOption a) -> View view m a -getSelect opts = View $ do - tolook <- genNewId- st <- get- let env = mfEnv st- put st{needForm= True}- r <- getParam1 tolook env- setSessionData $ fmap MFOption $ valToMaybe r- FormElm form mr <- (runView opts) -- return $ FormElm [fselect tolook $ mconcat form] $ valToMaybe r ---newtype MFOption a= MFOption a deriving Typeable--instance (Monad m, Functor m) => Monoid (View view m (MFOption a)) where- mappend = (<|>)- mempty = Control.Applicative.empty---- | Set the option for getSelect. Options are concatenated with `<|>`-setOption- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>- a -> view -> View view m (MFOption a)-setOption n v = do- mo <- getSessionData- case mo of- Nothing -> setOption1 n v False- Just Nothing -> setOption1 n v False- Just (Just (MFOption o)) -> setOption1 n v $ n == o---- | Set the selected option for getSelect. Options are concatenated with `<|>`-setSelectedOption- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>- a -> view -> View view m (MFOption a)-setSelectedOption n v= do- mo <- getSessionData- case mo of- Nothing -> setOption1 n v True- Just Nothing -> setOption1 n v True- Just (Just o) -> setOption1 n v $ n == o-- -setOption1 :: (FormInput view, - Monad m, Typeable a, Eq a, Show a) => - a -> view -> Bool -> View view m (MFOption a) -setOption1 nam val check= View $ do- st <- get- let env = mfEnv st- put st{needForm= True}- let n = if typeOf nam == typeOf(undefined :: String)- then unsafeCoerce nam- else show nam- - return . FormElm [foption n val check] . Just $ MFOption nam -- --- | Enclose Widgets within some formating. --- @view@ is intended to be instantiated to a particular format------ NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,--- unless the we want to enclose all the widgets in the right side.--- Most of the type errors in the DSL are due to the low priority of this operator.------ This is a widget, which is a table with some links. it returns an Int------ > import MFlow.Forms.Blaze.Html--- >--- > tableLinks :: View Html Int--- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"--- > <<< caption << text "choose an item"--- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")--- > ++> (tbody--- > <<< tr ! rowspan "2" << td << linkHome--- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))--- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))--- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))--- > ) -(<<<) :: (Monad m, Monoid view) - => (view ->view) - -> View view m a - -> View view m a -(<<<) v form= View $ do - FormElm f mx <- runView form - return $ FormElm [v $ mconcat f] mx - - -infixr 5 <<< - ----- --- | Append formatting code to a widget --- --- @ getString "hi" <++ H1 << "hi there"@------ It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators -(<++) :: (Monad m) - => View v m a - -> v - -> View v m a -(<++) form v= View $ do - FormElm f mx <- runView form - return $ FormElm ( f ++ [ v]) mx - -infixr 6 <++ , .<++. , ++> , .++>. --- | Prepend formatting code to a widget --- --- @bold << "enter name" ++> getString Nothing @ ------ 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 - - - ---- | Add attributes to the topmost tag of a widget------ it has a fixity @infix 8@-infixl 8 <!-widget <! attribs= View $ do- FormElm fs mx <- runView widget- return $ FormElm (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- - --- | Is an example of login\/register validation form needed by 'userWidget'. In this case--- the form field appears in a single line. it shows, in sequence, entries for the username,--- password, a button for loging, a entry to repeat password necesary for registering--- and a button for registering.--- The user can build its own user login\/validation forms by modifying this example------ @ userFormLine=--- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")--- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"--- @-userFormLine :: (FormInput view, Functor m, Monad m)- => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr) -userFormLine=- ((,) <$> getString (Just "enter user") <! [("size","5")]- <*> getPassword <! [("size","5")]- <** submitButton "login")- <+> (fromStr " password again" ++> getPassword <! [("size","5")]- <* submitButton "register")---- | Example of user\/password form (no validation) to be used with 'userWidget'-userLogin :: (FormInput view, Functor m, Monad m)- => View view m (Maybe (UserStr,PasswdStr), Maybe String)-userLogin=- ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]- <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]- <** submitButton "login")- <+> (noWidget- <* noWidget)------ | Empty widget that return Nothing. May be used as \"empty boxes\" inside larger widgets.------ It returns a non valid value.-noWidget :: (FormInput view, - Monad m) => - View view m a-noWidget= View . return $ FormElm [] Nothing---- | Render a Show-able value and return it-wrender- :: (Monad m, Functor m, Show a, FormInput view) =>- a -> View view m a-wrender x = (fromStr $ show x) ++> return x---- | Render raw view formatting. It is useful for displaying information.-wraw :: Monad m => view -> View view m ()-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---- | Wether the user is logged or is anonymous-isLogged :: MonadState (MFlowState v) m => m Bool-isLogged= do- rus <- return . tuser =<< gets mfToken - return . not $ rus == anonymous---- | return the result if going forward------ 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 x = do- back <- goingBack- if back then noWidget else return x---- | forces backtracking if the widget validates, because a previous page handle this widget response--- . This is useful for recurrent cached widgets that are present in multiple pages. For example--- in the case of menus or common options. The active elements of this widget must be cached with no timeout.-retry :: Monad m => View v m a -> View v m ()-retry w= w >> modify (\st -> st{inSync=False})---- | It creates a widget for user login\/registering. If a user name is specified--- in the first parameter, it is forced to login\/password as this specific user.--- If this user was already logged, the widget return the user without asking.--- If the user press the register button, the new user-password is registered and the--- user logged.-userWidget :: ( MonadIO m, Functor m - , FormInput view) - => Maybe String- -> View view m (Maybe (UserStr,PasswdStr), Maybe String)- -> View view m String -userWidget muser formuser= do- user <- getCurrentUser- if muser== Just user || isNothing muser && user/= anonymous- then returnIfForward user- else formuser `validate` val muser `wcallback` login1 - where- val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"-- val mu (Just us, Nothing)=- if isNothing mu || isJust mu && fromJust mu == fst us- then userValidate us- else return . Just $ fromStr "This user has no permissions for this task"-- val mu (Just us, Just p)=- if isNothing mu || isJust mu && fromJust mu == fst us- then if length p > 0 && snd us== p- then return Nothing- else return . Just $ fromStr "The passwords do not match"- else return . Just $ fromStr "wrong user for the operation"---- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"-- login1- :: (MonadIO m, MonadState (MFlowState view) m) =>- (Maybe (String, String), Maybe String) -> m String- login1 (Just (uname,_), Nothing)= login uname >> return uname-- login1 (Just us@(u,p), Just _)= do -- register button pressed- userRegister u p- login u- return u---- | change the user------ It is supposed that the user has been validated---login uname= do- back <- goingBack- if back then return () else do- st <- get- let t = mfToken st- u = tuser t- if u == uname then return () else do- let t'= t{tuser= uname}- -- moveState (twfname t) t t'- put st{mfToken= t'}--- liftIO $ deleteTokenInList t- liftIO $ addTokenToList t'- setCookie cookieuser uname "/" (Just $ 365*24*60*60)---- | logout. The user is reset to the `anonymous` user-logout :: (MonadIO m, MonadState (MFlowState view) m) => m () -logout= do- back <- goingBack- if back then return () else do- st <- get- let t = mfToken st- t'= t{tuser= anonymous}- if tuser t == anonymous then return () else do--- moveState (twfname t) t t'- put st{mfToken= t'}--- liftIO $ deleteTokenInList t- liftIO $ addTokenToList t'- setCookie cookieuser anonymous "/" (Just $ -1000)- --- | If not logged, perform login. otherwise return the user------ @getUserSimple= getUser Nothing userFormLine@-getUserSimple :: ( FormInput view, Typeable view)- => FlowM view IO String-getUserSimple= getUser Nothing userFormLine- --- | Very basic user authentication. The user is stored in a cookie. --- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed --- user-password combination.--- The user-password combination is only asked if the user has not logged already--- otherwise, the stored username is returned.------ @getUser mu form= ask $ userWidget mu form@ -getUser :: ( FormInput view, Typeable view) - => Maybe String- -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)- -> FlowM view IO String -getUser mu form= ask $ userWidget mu form ---- | Authentication against `userRegister`ed users. --- to be used with `validate` -userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view) -userValidate (u,p) = liftIO $ do- 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 - => 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 - FormElm f2 my' <- runView digest2 - return $ FormElm (f1++f2) - $ 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)- => View view m a -> View view m b -> View view m b-(**>) form1 form2 = valid form1 *> form2--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) =>- View view m a -> View view m b -> View view m a-(<**) form1 form2 = form1 <* valid form2---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------ > askt v w= ask w------ hide one or the other-askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a-askt v w = ask w-- --- | It is the way to interact with the user. --- It takes a widget and return the input result. If the widget is not validated (return @Nothing@)--- , the page is presented again------ If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction,--- it will not ask to the user and return the result.--- To force asking in any case, add an `clearEnv` statement before.--- It also handles ajax requests------ 'ask' also synchronizes the execution of the flow with the user page navigation by---- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between--- get and post parameters and what is expected by the widgets --- until a total or partial match is found.------ * Advancing in the flow by matching a single requests with one or more sucessive ask statements------ Backtracking and advancing can occur in a single request, so the flow in any state can reach any--- 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- st1 <- get- if not . null $ mfTrace st1 then fail "" else do- -- AJAX- let env= mfEnv st1- mv1= lookup "ajax" env- majax1= mfAjax st1-- case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of- (Just ajaxl,Just v1,Just f, Just v2) -> do- FlowM . lift $ (unsafeCoerce f) v2- FlowM $ lift nextMessage- ask w- -- END AJAX-- _ -> do- let st= st1{needForm= False, inSync= False, mfRequirements= [], linkMatched= False} - put st-- FormElm forms mx <- FlowM . lift $ runView w- - st' <- get- if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w-- else- case mx of - Just x -> do- put st'{newAsk= True, mfEnv=[]- ,mfPageIndex=Nothing- ,mfPIndex= case isJust $ mfPageIndex st' of- True -> length (mfPath st') -1- False -> mfPIndex st'- }- breturn x -- !> "BRETURN"- - Nothing ->- if not (inSync st') && not (newAsk st')--- !> ("pageIndex="++ show (mfPageIndex st'))--- !> ("insync="++show (inSync st'))--- !> ("newask="++show (newAsk st'))--- !> ("mfPIndex="++ show( mfPIndex st'))- then do- let index = mfPIndex st'- nindex= if index== 0 then 1 else index - 1- put st'{mfPIndex= nindex} -- !> "BACKTRACK"- fail "" -- !> "FAIL**********"- else if mfAutorefresh st' then do- resetState st st'- FlowM (lift nextMessage)- ask w -- !> "EN AUTOREFRESH"- else do- reqs <- FlowM $ lift installAllRequirements -- !> "REPEAT"- let header= mfHeader st'- t= mfToken st'- cont <- case (needForm st') of- True -> do- frm <- formPrefix (mfPIndex st') (twfname t ) st' forms False- return . header $ reqs <> frm- _ -> return . header $ reqs <> mconcat 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"- ask w- where- resetState st st'=- put st{mfCookies=[]- ,mfHttpHeaders=[]- ,newAsk= False- ,mfToken= mfToken st'- ,mfPageIndex= mfPageIndex st'- ,mfAjax= mfAjax st'- ,mfSeqCache= mfSeqCache st'- ,mfData= mfData st' }----- | A synonym of ask.------ Maybe more appropiate for pages with long interactions with the user--- while the result has little importance.-page- :: (FormInput view) =>- View view IO a -> FlowM view IO a-page= ask - -nextMessage :: MonadIO m => WState view m () -nextMessage= do - st <- get - let t= mfToken st - t1= mfkillTime st- t2= mfSessionTime st- msg <- liftIO ( receiveReqTimeout t1 t2 t)- let req= getParams msg- env= updateParams inPageFlow (mfEnv st) req- npath= pwfPath msg- path= mfPath st- inPageFlow= case (comparep,mfPageIndex st) of- (n, Just n') -> if n < n' then Nothing else Just n'- _ -> Nothing- comparep= comparePaths (mfPIndex st) 1 (tail path) (tail npath) - put st{ mfPath= npath- , mfPIndex= case inPageFlow of- Just n -> n- Nothing -> comparep-- , mfPageIndex= inPageFlow- , mfLinks= if isNothing inPageFlow then M.empty else mfLinks st- , mfEnv= env } -- !> show req--- where-- comparePaths _ n [] xs= n- comparePaths o n _ [] = o- comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath- | otherwise= n-- updateParams :: Maybe Int -> Params -> Params -> Params- updateParams Nothing _ req= req- updateParams (Just _) env req=- let params= takeWhile isparam env- fs= fst $ head req- parms= (case findIndex (\p -> fst p == fs) params of- Nothing -> params- Just i -> take i params)- ++ req- in parms--- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )--- !> ("env=" ++ show env)--- !> ("req=" ++ show req)-- --isparam ('p': r:_,_)= isNumber r-isparam ('c': r:_,_)= isNumber r-isparam _= False---- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a--- higuer level form of the latter -wstateless- :: (Typeable view, FormInput view) =>- View view IO () -> Flow-wstateless w = transient . runFlow . ask $ w **> noWidget -- loop--- where--- loop= do--- ask w--- env <- get--- put $ env{ mfSequence= 0} --- loop------- 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- --- --- | Wrap a widget with form element within a form-action element.--- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless--- there are more than one form in the page. -wform :: (Monad m, FormInput view) - => View view m b -> View view m b -wform x = View $ do - FormElm form mr <- (runView $ x )- st <- get- verb <- getWFName - form1 <- formPrefix (mfPIndex st) verb st form True- put st{needForm=False} - 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 () --submitButton :: (FormInput view, Monad m) => String -> View view m String-submitButton label= getParam Nothing "submit" $ Just label --newtype AjaxSessionId= AjaxSessionId String deriving Typeable---- | Install the server code and return the client code for an AJAX interaction.--- It is very lightweight, It does no t need jQuery.------ This example increases the value of a text box each time the box is clicked------ > ask $ do--- > let elemval= "document.getElementById('text1').value"--- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"--- > b << text "click the box"--- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]-ajax :: (MonadIO m)- => (String -> View v m ByteString) -- ^ user defined procedure, executed in the server.Receives the value of the javascript expression and must return another javascript expression that will be executed in the web browser- -> View v m (String -> String) -- ^ returns a function that accept a javascript expression and return a javascript event handler expression that invokes the ajax server procedure-ajax f = do- requires[JScript ajaxScript]- t <- gets mfToken- id <- genNewId- installServerControl id $ \x-> do- setSessionData $ AjaxSessionId id- r <- f x- liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )- return ()--installServerControl :: MonadIO m => String -> (String -> View v m ()) -> View v m (String -> String)-installServerControl id f= do- t <- gets mfToken- st <- get- let ajxl = fromMaybe M.empty $ mfAjax st- let ajxl'= M.insert id (unsafeCoerce f ) ajxl- put st{mfAjax=Just ajxl'}- return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")" ---- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back------ 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-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- (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- (Just id, Just v2) -> do- return $ FormElm [] . Just $ read v2- where- readEvalLoop t id v = "doServer('"<> pack (twfname t)<>"','"<> pack id<>"',"<>v<>");" :: ByteString---- | Like @ajaxSend@ but the result is ignored-ajaxSend_- :: MonadIO m => View v m ByteString -> View v m ()-ajaxSend_ = ajaxSend--wlabel- :: (Monad m, FormInput view) => view -> View view m a -> View view m a-wlabel str w = do- id <- genNewId--- modify $ \s ->case mfCached s of--- True -> s{mfSeqCache= mfSeqCache s -1}--- False -> s{mfSequence= mfSequence s -1}- ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]--getRestParam :: (Read a, Typeable a,Monad m,Functor m, FormInput v) => FlowM v m (Maybe a)-getRestParam= do- st <- get- let lpath = mfPath st- let index' = mfPIndex st- + if linkMatched st then -1 else 0- + if Just (mfPIndex st)== mfPageIndex st then 1 else 0- index = if index'== 0 then 1 else index'-- case index < length lpath of- True -> do- modify $ \s -> s{inSync= True- ,linkMatched= True, mfPIndex= index+1 } -- !> (name ++ "<-" ++show index++ " MATCHED")- fmap valToMaybe $ readParam $ lpath !! index- False -> return Nothing-- --- | Creates a link wiget. A link can be composed with other widget elements, -wlink :: (Typeable a, Show a, MonadIO m, FormInput view) - => a -> view -> View view m a -wlink x v= View $ do - verb <- getWFName- st <- get- - let- name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)- then unsafeCoerce x- else show x)- index' = mfPIndex st- + if linkMatched st then -1 else 0- + if Just (mfPIndex st)== mfPageIndex st then 1 else 0-- index = if index'== 0 then 1 else index'- lpath = mfPath st-- back = True -- not $ inSync st || (inSync st && linkMatched st)-- let path= currentPath back index lpath verb ++ ('/':name)- -- !> (show $ mfPath st) - toSend = flink path v--- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page- else- if isJust $ mfPageIndex st -- !> (show $ mfPageIndex st)- then- case M.lookup name $ mfLinks st of- Just 0 -> do- modify $ \st -> st{ inSync= True}- return Nothing -- !> (name ++ " 0 Fail")-- Just n -> do- modify $ \st -> st{ inSync= True,linkMatched= True- , mfPIndex= index + 1- , mfLinks= M.insert name (n-1) $ mfLinks st}- -- !> (name ++" "++ show n ++ " Match")- return $ Just x- Nothing -> return Nothing -- !> (name ++ " 0 Fail")- else- case index < length lpath && name== lpath !! index of- True -> do- modify $ \s -> s{inSync= True- ,linkMatched= True, mfPIndex= index+1 } -- !> (name ++ "<-" ++show index++ " MATCHED")- return $ Just x- False -> return Nothing -- !> ( "NOT MATCHED "++name++"<-" ++show index++ " "++(if index < length lpath then lpath !! index else ""))-- return $ FormElm [toSend] r ------- | When some user interface return some response to the server, but it is not produced by--- a form or a link, but for example by an script, @returning@ convert this code into a--- widget.------ At runtime the parameter is read from the environment and validated.------ . The parameter is the visualization code, that accept a serialization function that generate--- the server invocation string, used by the visualization to return the value by means--- of an script, usually. -returning :: (Typeable a, Read a, Show a,Monad m, FormInput view) - => ((a->String) ->view) -> View view m a-returning expr=View $ do- verb <- getWFName - name <- genNewId- env <- gets mfEnv- let string x= - let showx= case cast x of- Just x' -> x'- _ -> show x - in (verb ++ "?" ++ name ++ "=" ++ showx)- toSend= expr string - r <- getParam1 name env- return $ FormElm [toSend] $ valToMaybe r- --- - ---instance (Widget a b m view, Monoid view) => Widget [a] b m view where --- widget xs = View $ do --- forms <- mapM(\x -> (runView $ widget x )) xs --- let vs = concatMap (\(FormElm v _) -> v) forms --- res = filter isJust $ map (\(FormElm _ r) -> r) forms --- res1= if null res then Nothing else head res --- return $ FormElm [mconcat vs] res1---- | Concat a list of widgets of the same type, return a the first validated result -firstOf :: (Monoid view, Monad m, Functor m)=> [View view m a] -> View view m a -firstOf xs= View $ do - forms <- mapM runView xs - let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms - res = filter isJust $ map (\(FormElm _ r) -> r) forms - res1= if null res then Nothing else head res - return $ FormElm vs res1 ---- | from a list of widgets, it return the validated ones.-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 - res1= catMaybes $ map (\(FormElm _ r) -> r) forms - return . FormElm vs $ Just res1)--(>:>) :: Monad m => 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)- $ case( mx,mxs) of- (Just x, Just xs) -> Just $ x:xs- (Nothing, mxs) -> mxs- (Just x, _) -> Just [x]---- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.------ it has a infix priority @infixr 5@-(|*>) :: (MonadIO m, Functor m,Monoid view)- => 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)- $ case (rx,rxs) of- (Nothing, Nothing) -> Nothing- other -> Just other----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.---- It has a low infix priority: @infixr 1@-(|+|) :: (Functor m, Monoid view, MonadIO m)- => View view m r- -> View view m r'- -> View view m (Maybe r, Maybe r')-(|+|) w w'= w |*> [w']--infixr 1 |+|, .|+|.----- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator--- into a single tuple with the same elements in the same order.--- This is useful for easing matching. For example:------ @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@------ @res@ has type:------ @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@------ but @flatten res@ has type:------ @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@--flatten :: Flatten (Maybe tree) list => tree -> list-flatten res= doflat $ Just res--class Flatten tree list where- doflat :: tree -> list---type Tuple2 a b= Maybe (Maybe a, Maybe b)-type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)-type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)-type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)-type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)--instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where- doflat (Just(ma,mb))= (ma,mb)- doflat Nothing= (Nothing,Nothing)--instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where- doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)- doflat Nothing= (Nothing,Nothing,Nothing)--instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where- doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)- doflat Nothing= (Nothing,Nothing,Nothing,Nothing)--instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where- doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)--instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where- 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---instance FormInput ByteString where- toByteString= id- toHttpData = HttpData [contentHtml ] []- ftag x= btag x []- inred = btag "b" [("style", "color:red")]- finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []- ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""- ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text]-- fselect name options= btag "select" [("name", name)] options-- foption value content msel= btag "option" ([("value", value)] ++ selected msel) content- where- selected msel = if msel then [("selected","true")] else []-- attrs = addAttrs--- formAction action form = btag "form" [("action", action),("method", "post")] form- fromStr = pack- fromStrNoEncode= pack-- flink v str = btag "a" [("href", v)] str-------- page Flows -------- | prepares the state for a page flow.--- It add a prefix to every form element or link identifier for the formlets and also--- keep the state of the links clicked and form imput entered within the widget.--- If the computation within the widget has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier------ See "http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html"-pageFlow- :: (Monad m, Functor m, FormInput view) =>- String -> View view m a -> View view m a-pageFlow str flow=do- s <- get-- if isNothing $ mfPageIndex s- then do- put s{mfPrefix= str ++ mfPrefix s- ,mfSequence=0- ,mfLinks= acum M.empty $ drop (mfPIndex s) (mfPath s)- ,mfPageIndex= Just $ mfPIndex s } -- !> ("PARENT pageflow. prefix="++ str)-- flow <** (modify (\s' -> s'{mfSequence= mfSequence s- ,mfPrefix= mfPrefix s}))- -- !> ("END PARENT pageflow. prefix="++ str))--- else do- put s{mfPrefix= str++ mfPrefix s- ,mfLinks= acum M.empty $ drop (fromJust $ mfPageIndex s) (mfPath s)- ,mfSequence=0} -- !> ("CHILD pageflow. prefix="++ str)-- flow <** (modify (\s' -> s'{mfSequence= mfSequence s- ,mfPrefix= mfPrefix s}))- -- !> ("END CHILD pageflow. prefix="++ str))----acum map []= map-acum map (x:xs) =- let map' = case M.lookup x map of- Nothing -> M.insert x 1 map- Just n -> M.insert x (n+1) map- in acum map' xs-+ -XTypeFamilies + -XTypeOperators + -XOverloadedStrings + -XTemplateHaskell + -XNoMonomorphismRestriction + +#-} + +{- | +MFlow run stateful server processes. This version is the first stateful web framework +that is as RESTful as a web framework can be. + +The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links +point to alternative routes within this monadic computation just like a textual menu +in a console application. Any GET page is directly reachable by means of a RESTful URL. + +At any moment the flow can respond to the back button or to any RESTful path that the user may paste in the navigation bar. +If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match +. From this position the execution goes forward until the rest of the path match. This way the +statelessness is optional. However, it is possible to store a session state, which may backtrack or +not when the navigation goes back and forth. It is upto the programmer. + + +All the flow of requests and responses are coded by the programmer in a single procedure. +Allthoug single request-response flows are possible. Therefore, the code is +more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for +handling the back button. Back button state syncronization is supported out-of-the-box + +The MFlow architecture is scalable, since the state is serializable and small + +The processes are stopped and restarted by the +application server on demand, including the execution state (if the Wokflow monad is used). +Therefore session management is automatic. State consistence and transactions are given by the TCache package. + +The processes interact trough widgets, that are an extension of formlets with +additional applicative combinators, formatting, link management, callbacks, modifiers, caching, +byteString conversion and AJAX. All is coded in pure haskell. + +The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString +, Hack and WAI but it can be extended to non Web based architectures. + +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 + +It is designed for applications that can be run with no deployment with runghc in order +to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html> + +This module implement stateful processes (flows) that are optionally persistent. +This means that they automatically store and recover his execution state. They are executed by the MFlow app server. +defined in the "MFlow" module. + +These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to +the calling process. Because flows are stateful, not request-response, the code is more understandable, because +all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug +single request-response flows and callbacks are possible. + +This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an +instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" . +To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here. + +`ask` is the only method for user interaction. It run in the @MFlow view m@ monad, with @m@ the monad chosen by the user, usually IO. +It send user interfaces (in the @View view m@ monad) and return statically +typed responses. The user interface definitions are based on a extension of +formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes, + extra combinators, callbaks and modifiers. +The interaction with the user is stateful. In the same computation there may be many +request-response interactions, in the same way than in the case of a console applications. + +* APPLICATION SERVER + +Therefore, session and state management is simple and transparent: it is in the haskell +structures in the scope of the computation. `transient` (normal) procedures have no persistent session state +and `stateless` procedures accept a single request and return a single response. + +`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that +remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally. +This state management is transparent. There is no programer interface for session management. + +The programmer set the process timeout and the session timeout with `setTimeouts`. +If the procedure has been stopped due to the process timeout or due to a system shutdowm, +the procedure restart in the last state when a request for this procedure arrives +(if the procedure uses the `step` monad transformer) + +* WIDGETS + +The correctness of the web responses is assured by the use of formLets. +But unlike formLets in its current form, it permits the definition of widgets. +/A widget is a combination of formLets and links within its own formatting template/, all in +the same definition in the same source file, in plain declarative Haskell style. + +The formatting is abstract. It has to implement the 'FormInput' class. +There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP") +and ByteString. So widgets +can use any formatting that is instance of `FormInput`. +It is possible to use more than one format in the same widget. + +Links defined with `wlink` are treated the same way than forms. They are type safe and return values + to the same flow of execution. +It is posssible to combine links and forms in the same widget by using applicative combinators but also +additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can +be combined as such. + +* NEW IN THIS RELEASE + +[@Runtime templates@] 'template', 'edTemplate', 'witerate' and 'dField' permit the edition of +the widget content at runtime, and the management of placeholders with input fields and data fields +within the template with no navigation in the client, little bandwidth usage and little server load. Enven less +than using 'autoRefresh'. + +* IN PREVIOUS RELEASES + +{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page + +[@Push@] With `push` a widget can push new content to the browser when something in the server happens + +[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace. + + +[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession +of links clicked to reach such page and such point in the procedure. Just what you would expect. + +[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can +refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a +subpage flow by adding a well know indetifier prefix for links and form parameters. + +[@Modal Dialogs@] 'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic +widget-formlet can add different form elements depending on the user responses, 'wcallback' can +substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples) + +[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog' + +[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it. + +[@blaze-html support@] see <http://hackage.haskell.org/package/blaze-html> import "MFlow.Forms.Blaze.Html" or "MFlow.Wai.Blaze.Html.All" to use Blaze-Html + +[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead +of a single request-response (see 'ajaxSend'). + +[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the +server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others. + +[@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes + and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements' + +[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField' + +[@multilanguage@] see 'mField' and 'mFieldEd' + +[@URLs to internal states@] if the web navigation is trough GET forms or links, + an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users. +Just like in the case of an ordinary stateless application. + + +[@Back Button@] This is probably the first implementation in any language where the navigation +can be expressed procedurally and still it works well with the back button, thanks +to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>) + + +[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) +, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if +the widget content comes from a database and it is shared by all users. + + +[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated. +The callback may initate a flow of interactions with the user or simply executes an internal computation. +Callbacks are necessary for the creation of abstract container +widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes. + + +[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a +login form and substitute it by the username if already logged. + +Example: + +@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@ + + +[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator + + +[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the + ByteString level, and to permit many formatring styles +in the same page, there are operators that combine different formats which are converted to ByteStrings. +For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml. + +[@File Server@] With file caching. See "MFlow.FileServer" + + +-} + +module MFlow.Forms( + +-- * Basic definitions +-- FormLet(..), +FlowM, View(..), FormElm(..), FormInput(..) + +-- * Users +, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName +,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout +,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin, +userName, +-- * User interaction +ask, page, askt, clearEnv, wstateless, pageFlow, +-- * formLets +-- | They usually produce the HTML form elements (depending on the FormInput instance used) +-- It is possible to modify their attributes with the `<!` operator. +-- They are combined with applicative ombinators and some additional ones +-- formatting can be added with the formatting combinators. +-- modifiers change their presentation and behaviour +getString,getInt,getInteger, getTextBox +,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+-- * FormLet modifiers +,validate, noWidget, stop, waction, wcallback, clear, wmodify, + +-- * Caching widgets +cachedWidget, wcached, wfreeze, + +-- * 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` +,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.), + +-- * Formatting combinators +(<<<),(++>),(<++),(<!), + +-- * Normalized (convert to ByteString) formatting combinators +-- | Some combinators that convert the formatting of their arguments to lazy byteString +(.<<.),(.<++.),(.++>.) + +-- * ByteString tags +,btag,bhtml,bbody + +-- * Normalization +,flatten, normalize + +-- * Running the flow monad +,runFlow, transientNav, runFlowOnce, runFlowIn +,runFlowConf,MFlow.Forms.Internals.step +-- * controlling backtracking +,goingBack,returnIfForward, breturn, preventGoingBack, compensate, onBacktrack, retry + +-- * Setting parameters+,setHttpHeader +,setHeader +,addHeader +,getHeader +,setSessionData +,getSessionData +,delSessionData +,setTimeouts + +-- * Cookies +,setCookie +,setParanoidCookie +,setEncryptedCookie +-- * Ajax +,ajax +,ajaxSend +,ajaxSend_ +-- * Requirements +,Requirements(..) +,WebRequirement(..) +,requires +-- * Utility+,getSessionId +,getLang +,genNewId +,getNextId +,changeMonad +,FailBack +,fromFailBack +,toFailBack + +) +where + +import Data.RefSerialize hiding ((<|>)) +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.UTF8 hiding (length, take)+import qualified Data.String as S +import qualified Data.Text as T +import Data.Text.Encoding +import Data.List +--import qualified Data.CaseInsensitive as CI +import Data.Typeable +import Data.Monoid +import Control.Monad.State.Strict +import Data.Maybe +import Control.Applicative +import Control.Exception +import Control.Concurrent +import Control.Workflow as WF +import Control.Monad.Identity +import Unsafe.Coerce +import Data.List(intersperse) +import Data.IORef +import qualified Data.Map as M +import System.IO.Unsafe +import Data.Char(isNumber,toLower) +import Network.HTTP.Types.Header + + +-- | Validates a form or widget result against a validating procedure +-- +-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@ +validate + :: (FormInput view, Monad m) => + View view m a + -> (a -> WState view m (Maybe view)) + -> View view m a +validate formt val= View $ do + FormElm form mx <- runView formt + case mx of + Just x -> do + me <- val x + modify (\s -> s{inSync= True}) + case me of + Just str -> + return $ FormElm ( form ++ [inred str]) Nothing + Nothing -> return $ FormElm form mx + _ -> return $ FormElm form mx + +-- | Actions are callbacks that are executed when a widget is validated. +-- A action may be a complete flow in the flowM monad. It takes complete control of the navigation +-- while it is executed. At the end it return the result to the caller and display the original +-- calling page. +-- It is useful when the widget is inside widget containers that may treat it as a black box. +-- +-- It returns a result that can be significative or, else, be ignored with '<**' and '**>'. +-- An action may or may not initiate his own dialog with the user via `ask` +waction + :: (FormInput view, Monad m) + => View view m a + -> (a -> FlowM view m b) + -> View view m b +waction f ac = do + x <- f + s <- get + let env = mfEnv s + let seq = mfSequence s + put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True} + r <- flowToView $ ac x + modify $ \s-> s{mfSequence= seq, mfEnv= env} + return r + where + flowToView x= + View $ do + r <- runSup $ runFlowM x + case r of + NoBack x -> + return (FormElm [] $ Just x) + BackPoint x-> + return (FormElm [] $ Just x) + GoBack-> do + modify $ \s ->s{notSyncInAction= True} + return (FormElm [] 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)) + -> View v m b +wmodify formt act = View $ do + FormElm f mx <- runView formt + (f',mx') <- act f mx + return $ FormElm f' mx' + +-- | Display a text box and return a non empty String +getString :: (FormInput view,Monad m) => + Maybe String -> View view m String +getString ms = getTextBox ms + `validate` + \s -> if null s then return (Just $ fromStr "") + else return Nothing + +-- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation) +getInteger :: (FormInput view, MonadIO m) => + Maybe Integer -> View view m Integer +getInteger = getTextBox + +-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation) +getInt :: (FormInput view, MonadIO m) => + Maybe Int -> View view m Int +getInt = getTextBox + +-- | Display a password box +getPassword :: (FormInput view, + Monad m) => + View view m String +getPassword = getParam Nothing "password" Nothing + +newtype Radio a= Radio a + +-- | Implement a radio button that perform a submit when pressed. +-- the parameter is the name of the radio group +setRadioActive :: (FormInput view, MonadIO m, + Read a, Typeable a, Eq a, Show a) => + a -> String -> View view m (Radio a) +setRadioActive v n = View $ do + st <- get + put st{needForm= HasElems} + let env = mfEnv st + 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()")] + (fmap Radio $ valToMaybe mn) + + +-- | Implement a radio button +-- the parameter is the name of the radio group +setRadio :: (FormInput view, MonadIO m, + Read a, Typeable a, Eq a, Show a) => + a -> String -> View view m (Radio a) +setRadio v n= View $ do + st <- get + put st{needForm= HasElems} + let env = mfEnv st + 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] + (fmap Radio $ valToMaybe mn) + +-- | encloses a set of Radio boxes. Return the option selected +getRadio + :: (Monad m, Functor m, FormInput view) => + [String -> View view m (Radio a)] -> View view m a +getRadio rs= do + id <- genNewId + Radio r <- firstOf $ map (\r -> r id) rs + return r + +data CheckBoxes = CheckBoxes [String] + +instance Monoid CheckBoxes where + mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys + mempty= CheckBoxes [] + +--instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where +-- mappend x y= mappend <$> x <*> y +-- mempty= return (CheckBoxes []) + + +-- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation) +setCheckBox :: (FormInput view, MonadIO m) => + Bool -> String -> View view m CheckBoxes +setCheckBox checked v= View $ do + n <- genNewId + st <- get + put st{needForm= HasElems} + let env = mfEnv st + strs= map snd $ filter ((==) n . fst) env + mn= if null strs then Nothing else Just $ head strs + val = inSync st + let ret= case val of -- !> show val of + True -> Just $ CheckBoxes strs -- !> show strs + False -> Nothing + return $ FormElm + ( [ finput n "checkbox" v + ( checked || (isJust mn && v== fromJust mn)) Nothing]) + ret + +-- | Read the checkboxes dinamically created by JavaScript within the view parameter +-- see for example `selectAutocomplete` in "MFlow.Forms.Widgets" +genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes +genCheckBoxes v= View $ do + n <- genNewId + st <- get + put st{needForm= HasElems} + let env = mfEnv st + strs= map snd $ filter ((==) n . fst) env + mn= if null strs then Nothing else Just $ head strs + + val <- gets inSync + let ret= case val of + True -> Just $ CheckBoxes strs + False -> Nothing + 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 + n <- genNewId + env <- gets mfEnv + let showx= case cast x of + Just x' -> x' + Nothing -> show x + r <- getParam1 n env + 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] + mr <- getParam1 n env + + let env = mfEnv st + modify $ \st -> st{needForm= HasElems} + FormElm form2 mr2 <- runView boxes + return $ FormElm (form ++ form2) $ + case (mr `asTypeOf` Validated ("" :: String),mr2) of + (NoParam,_) -> Nothing + (Validated _,Nothing) -> Just [] + (Validated _, Just (CheckBoxes rs)) -> Just rs + + + + + +getTextBox + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe a -> View view m a +getTextBox ms = getParam Nothing "text" ms + + +getParam + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe String -> String -> Maybe a -> View view m a +getParam look type1 mvalue = View $ do + tolook <- case look of + Nothing -> genNewId + Just n -> return n + let nvalue x = case x of + Nothing -> "" + Just v -> + case cast v of + Just v' -> v' + Nothing -> show v + st <- get + let env = mfEnv st + 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 + + + +--getCurrentName :: MonadState (MFlowState view) m => m String +--getCurrentName= do +-- st <- get +-- let parm = mfSequence st +-- return $ "p"++show parm + + +-- | Display a multiline text box and return its content +getMultilineText :: (FormInput view + , Monad m) + => T.Text + -> View view m T.Text +getMultilineText nvalue = View $ do + tolook <- genNewId + 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 + + +--instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where +-- digest mv = getBool b "True" "False" +-- where +-- b= case mv of +-- Nothing -> Nothing +-- Just bool -> Just $ case bool of +-- True -> "True" +-- False -> "False" + +-- | Display a dropdown box with the two values (second (true) and third parameter(false)) +-- . With the value of the first parameter selected. +getBool :: (FormInput view, + Monad m, Functor m) => + Bool -> String -> String -> View view m Bool +getBool mv truestr falsestr= do + r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else []) + <|> 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, + Monad m,Typeable a, Read a) => + View view m (MFOption a) -> View view m a +getSelect opts = View $ do + tolook <- genNewId + st <- get + let env = mfEnv st + put st{needForm= HasElems} + r <- getParam1 tolook env + setSessionData $ fmap MFOption $ valToMaybe r + FormElm form mr <- (runView opts) + + return $ FormElm [fselect tolook $ mconcat form] $ valToMaybe r + + +newtype MFOption a= MFOption a deriving Typeable + +instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where + mappend = (<|>) + mempty = Control.Applicative.empty + +-- | Set the option for getSelect. Options are concatenated with `<|>` +setOption + :: (Monad m, Show a, Eq a, Typeable a, FormInput view) => + a -> view -> View view m (MFOption a) +setOption n v = do + mo <- getSessionData + case mo of + Nothing -> setOption1 n v False + Just Nothing -> setOption1 n v False + Just (Just (MFOption o)) -> setOption1 n v $ n == o + +-- | Set the selected option for getSelect. Options are concatenated with `<|>` +setSelectedOption + :: (Monad m, Show a, Eq a, Typeable a, FormInput view) => + a -> view -> View view m (MFOption a) +setSelectedOption n v= do + mo <- getSessionData + case mo of + Nothing -> setOption1 n v True + Just Nothing -> setOption1 n v True + Just (Just o) -> setOption1 n v $ n == o + + +setOption1 :: (FormInput view, + Monad m, Typeable a, Eq a, Show a) => + a -> view -> Bool -> View view m (MFOption a) +setOption1 nam val check= View $ do + st <- get + let env = mfEnv st + put st{needForm= HasElems} + let n = if typeOf nam == typeOf(undefined :: String) + then unsafeCoerce nam + else show 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++ +-- | Enclose Widgets within some formating. +-- @view@ is intended to be instantiated to a particular format +-- +-- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate, +-- unless the we want to enclose all the widgets in the right side. +-- Most of the type errors in the DSL are due to the low priority of this operator. +-- +-- This is a widget, which is a table with some links. it returns an Int +-- +-- > import MFlow.Forms.Blaze.Html +-- > +-- > tableLinks :: View Html Int +-- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto" +-- > <<< caption << text "choose an item" +-- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen") +-- > ++> (tbody +-- > <<< tr ! rowspan "2" << td << linkHome +-- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0))) +-- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1))) +-- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2)))) +-- > ) +(<<<) :: (Monad m, Monoid view) + => (view ->view) + -> View view m a + -> View view m a +(<<<) v form= View $ do + FormElm f mx <- runView form + return $ FormElm [v $ mconcat f] mx + + +infixr 5 <<< + + + + + + +-- | Append formatting code to a widget +-- +-- @ getString "hi" <++ H1 << "hi there"@ +-- +-- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators +(<++) :: (Monad m) + => View v m a + -> v + -> View v m a +(<++) form v= View $ do + FormElm f mx <- runView form + return $ FormElm ( f ++ [ v]) mx + +infixr 6 ++> , .++>. +infixr 6 <++ , .<++. +-- | Prepend formatting code to a widget +-- +-- @bold << "enter name" ++> getString Nothing @ +-- +-- 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 + + + + +-- | Add attributes to the topmost tag of a widget +-- +-- it has a fixity @infix 8@ +infixl 8 <! +widget <! attribs= View $ do + FormElm fs mx <- runView widget + return $ FormElm (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 + + +-- | Is an example of login\/register validation form needed by 'userWidget'. In this case +-- the form field appears in a single line. it shows, in sequence, entries for the username, +-- password, a button for loging, a entry to repeat password necesary for registering +-- and a button for registering. +-- The user can build its own user login\/validation forms by modifying this example +-- +-- @ userFormLine= +-- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\") +-- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\" +-- @ +userFormLine :: (FormInput view, Functor m, Monad m) + => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr) +userFormLine= + ((,) <$> getString (Just "enter user") <! [("size","5")] + <*> getPassword <! [("size","5")] + <** submitButton "login") + <+> (fromStr " password again" ++> getPassword <! [("size","5")] + <* submitButton "register") + +-- | Example of user\/password form (no validation) to be used with 'userWidget' +userLogin :: (FormInput view, Functor m, Monad m) + => View view m (Maybe (UserStr,PasswdStr), Maybe String) +userLogin= + ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")] + <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")] + <** submitButton "login") + <+> (noWidget + <* noWidget) + + + +-- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets. +-- +-- It returns a non valid value. +noWidget :: (FormInput view, + Monad m) => + View view m a +noWidget= View . return $ FormElm [] Nothing ++-- | a sinonym of noWidget that can be used in a monadic expression in the View monad does not continue+stop :: (FormInput view, + Monad m) => + View view m a+stop= noWidget+ +-- | Render a Show-able value and return it +wrender + :: (Monad m, Functor m, Show a, FormInput view) => + a -> View view m a +wrender x = (fromStr $ show x) ++> return x + +-- | Render raw view formatting. It is useful for displaying information. +wraw :: Monad m => view -> View view m () +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 + +-- | Wether the user is logged or is anonymous +isLogged :: MonadState (MFlowState v) m => m Bool +isLogged= do + rus <- return . tuser =<< gets mfToken + return . not $ rus == anonymous + +-- | return the result if going forward +-- +-- 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 x = do + back <- goingBack + if back then noWidget else return x + +-- | forces backtracking if the widget validates, because a previous page handle this widget response +-- . This is useful for recurrent cached widgets that are present in multiple pages. For example +-- in the case of menus or common options. The active elements of this widget must be cached with no timeout. +retry :: Monad m => View v m a -> View v m () +retry w = View $ do + FormElm v mx <- runView w + when (isJust mx) $ modify $ \st -> st{inSync = False} + return $ FormElm v Nothing + +-- | It creates a widget for user login\/registering. If a user name is specified +-- in the first parameter, it is forced to login\/password as this specific user. +-- If this user was already logged, the widget return the user without asking. +-- If the user press the register button, the new user-password is registered and the +-- user logged. + +userWidget :: ( MonadIO m, Functor m + , FormInput view) + => Maybe String + -> View view m (Maybe (UserStr,PasswdStr), Maybe String) + -> View view m String +userWidget muser formuser = userWidget' muser formuser login1 + +-- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie. + +paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1 + +-- | Uses a single key to encrypt the MFlow cookie. + +encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1 + +userWidget' muser formuser login1Func = do + user <- getCurrentUser + if muser== Just user || isNothing muser && user/= anonymous + then returnIfForward user + else formuser `validate` val muser `wcallback` login1Func + where + val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register" + + val mu (Just us, Nothing)= + if isNothing mu || isJust mu && fromJust mu == fst us + then userValidate us + else return . Just $ fromStr "This user has no permissions for this task" + + val mu (Just us, Just p)= + if isNothing mu || isJust mu && fromJust mu == fst us + then if Data.List.length p > 0 && snd us== p + then return Nothing + else return . Just $ fromStr "The passwords do not match" + else return . Just $ fromStr "wrong user for the operation" + +-- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register" + +login1 + :: (MonadIO m, MonadState (MFlowState view) m) => + (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr +login1 uname = login1' uname login + +paranoidLogin1 uname = login1' uname paranoidLogin + +encryptedLogin1 uname = login1' uname encryptedLogin + +login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname +login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed + userRegister u p + loginFunc u + return u + +-- | change the user +-- +-- It is supposed that the user has been validated + +login uname = login' uname setCookie + +paranoidLogin uname = login' uname setParanoidCookie + +encryptedLogin uname = login' uname setEncryptedCookie + +login' + :: (Num a1, S.IsString a, MonadIO m, + MonadState (MFlowState view) m) => + String -> (String -> String -> a -> Maybe a1 -> m ()) -> m () +login' uname setCookieFunc = do + back <- goingBack + if back then return () else do + st <- get + let t = mfToken st + u = tuser t + when (u /= uname) $ do + let t'= t{tuser= uname} + -- moveState (twfname t) t t' + put st{mfToken= t'} + liftIO $ deleteTokenInList t + liftIO $ addTokenToList t' + setCookieFunc cookieuser uname "/" (Just $ 365*24*60*60) + +logout = logout' setCookie + +paranoidLogout = logout' setParanoidCookie + +encryptedLogout = logout' setEncryptedCookie + + +-- | logout. The user is reset to the `anonymous` user +logout' + :: (Num a1,S.IsString a, MonadIO m, + MonadState (MFlowState view) m) => + (String -> [Char] -> a -> Maybe a1 -> m ()) -> m () +logout' setCookieFunc = do + back <- goingBack + if back then return () else do + st <- get + let t = mfToken st + t'= t{tuser= anonymous} + when (tuser t /= anonymous) $ do +-- moveState (twfname t) t t' + put st{mfToken= t'} +-- liftIO $ deleteTokenInList t + liftIO $ addTokenToList t' + setCookieFunc cookieuser anonymous "/" (Just $ -1000) + +-- | If not logged, perform login. otherwise return the user +-- +-- @getUserSimple= getUser Nothing userFormLine@ +getUserSimple :: ( FormInput view, Typeable view) + => FlowM view IO String +getUserSimple= getUser Nothing userFormLine + +-- | Very basic user authentication. The user is stored in a cookie. +-- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed +-- user-password combination. +-- The user-password combination is only asked if the user has not logged already +-- otherwise, the stored username is returned. +-- +-- @getUser mu form= ask $ userWidget mu form@ +getUser :: ( FormInput view, Typeable view) + => Maybe String + -> View view IO (Maybe (UserStr,PasswdStr), Maybe String) + -> FlowM view IO String +getUser mu form= ask $ userWidget mu form + +-- | Authentication against `userRegister`ed users. +-- to be used with `validate` +userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view) +userValidate (u,p) = liftIO $ do + 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 +-- +-- > askt v w= ask w +-- +-- hide one or the other +askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a +askt v w = ask w + + +-- | It is the way to interact with the user. +-- It takes a widget and return the input result. If the widget is not validated (return @Nothing@) +-- , the page is presented again +-- +-- If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction, +-- it will not ask to the user and return the result. +-- To force asking in any case, add an `clearEnv` statement before. +-- It also handles ajax requests +-- +-- 'ask' also synchronizes the execution of the flow with the user page navigation by + +-- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between +-- get and post parameters and what is expected by the widgets +-- until a total or partial match is found. +-- +-- * Advancing in the flow by matching a single requests with one or more sucessive ask statements +-- +-- Backtracking and advancing can occur in a single request, so the flow in any state can reach any +-- 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 + st1 <- get + if not . null $ mfTrace st1 then fail "" else do + -- AJAX + let env= mfEnv st1 + mv1= lookup "ajax" env + majax1= mfAjax st1 + + case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of + (Just ajaxl,Just v1,Just f, Just v2) -> do + FlowM . lift $ (unsafeCoerce f) v2 + FlowM $ lift nextMessage + ask w + -- END AJAX + + _ -> do + let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False} + put st + + FormElm forms mx <- FlowM . lift $ runView w + + st' <- get + if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w + + else + case mx of + Just x -> do + put st'{newAsk= True, mfEnv=[]} + breturn x -- !> "BRETURN" + + Nothing -> + if not (inSync st') && not (newAsk st') +-- !> ("pageIndex="++ show (mfPageIndex st')) +-- !> ("insync="++show (inSync st')) +-- !> ("newask="++show (newAsk st')) +-- !> ("mfPIndex="++ show( mfPIndex st')) + then do +-- let index = mfPIndex st' +-- nindex= if index== 0 then 1 else index - 1 +-- put st'{mfPIndex= nindex} -- !> "BACKTRACK" + fail "" -- !> "FAIL**********" + else if mfAutorefresh st' then do + resetState st st' + FlowM $ lift nextMessage + ask w -- !> "EN AUTOREFRESH" + else do + 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 + + let HttpData ctype c s= toHttpData cont + liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s + + + resetState st st'+ let path= mfPath st + FlowM $ lift nextMessage -- !> "NEXTMESSAGE"+ st <- get+ let path' = mfPath st+ env' = mfEnv st + if isJust(lookup "ajax" env') then ask w+ else if not $ path `isPrefixOf` path'+ then fail ""+ else ask w + where + resetState st st'= + put st{mfCookies=[] + -- ,mfHttpHeaders=[] + ,newAsk= False + ,mfToken= mfToken st' + ,mfPageIndex= mfPageIndex st' + ,mfAjax= mfAjax st' + ,mfSeqCache= mfSeqCache st' + ,mfData= mfData st' } + + +-- | A synonym of ask. +-- +-- Maybe more appropiate for pages with long interactions with the user +-- while the result has little importance. +page + :: (FormInput view) => + View view IO a -> FlowM view IO a +page= ask + +nextMessage :: MonadIO m => WState view m () +nextMessage = do + st <- get + let t= mfToken st + t1= mfkillTime st + t2= mfSessionTime st + msg <- liftIO ( receiveReqTimeout t1 t2 t) + let req= getParams msg + env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow) + npath= pwfPath msg + path= mfPath st + inPageFlow= case (comparep,mfPageIndex st) of + (n, Just n') -> if n < n' then Nothing else Just n' + _ -> Nothing + comparep= comparePaths (mfPIndex st) 1 path npath + put st{ mfPath= npath +-- , mfPIndex= min (mfPIndex st) comparep + + , mfPageIndex= inPageFlow -- !> ("pageflow="++ (show $ mfPageIndex st)+ -- ++ " "++show inPageFlow) + + , mfEnv= env } + + + where + + comparePaths _ n [] xs= n + comparePaths o n _ [] = o + comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath + | otherwise= n + + updateParams :: Maybe Int -> Params -> Params -> Params + updateParams Nothing _ req= req + updateParams (Just _) env req= + let params= takeWhile isparam env + fs= fst $ head req + parms= (case findIndex (\p -> fst p == fs) params of + Nothing -> params + Just i -> Data.List.take i params) + ++ req + in parms +-- !> "IN PAGE FLOW" !> ("parms=" ++ show parms ) +-- !> ("env=" ++ show env) +-- !> ("req=" ++ show req) + + + +isparam ('p': r:_,_)= isNumber r +isparam ('c': r:_,_)= isNumber r +isparam _= False + +-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a +-- higuer level form of the latter +wstateless + :: (Typeable view, FormInput view) => + View view IO () -> Flow +wstateless w = transient . runFlow . ask $ w **> stop -- loop +-- where +-- loop= do +-- ask w +-- env <- get +-- put $ env{ mfSequence= 0} +-- loop + + +---- 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 + + + + +-- | Wrap a widget with form element within a form-action element. +-- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless +-- there are more than one form in the page. +wform :: (Monad m, FormInput view) + => View view m b -> View view m b +wform x = View $ do + FormElm form mr <- (runView $ x ) + st <- get + form1 <- formPrefix st form True + put st{needForm=HasForm} + 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 () + +submitButton :: (FormInput view, Monad m) => String -> View view m String +submitButton label= getParam Nothing "submit" $ Just label + +newtype AjaxSessionId= AjaxSessionId String deriving Typeable + +-- | Install the server code and return the client code for an AJAX interaction. +-- It is very lightweight, It does no t need jQuery. +-- +-- This example increases the value of a text box each time the box is clicked +-- +-- > ask $ do +-- > let elemval= "document.getElementById('text1').value" +-- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'" +-- > b << text "click the box" +-- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)] +ajax :: (MonadIO m, FormInput v) + => (String -> View v m ByteString) -- ^ user defined procedure, executed in the server.Receives the value of the javascript expression and must return another javascript expression that will be executed in the web browser + -> View v m (String -> String) -- ^ returns a function that accept a javascript expression and return a javascript event handler expression that invokes the ajax server procedure +ajax f = do + requires[JScript ajaxScript] + t <- gets mfToken + id <- genNewId + installServerControl id $ \x-> do + setSessionData $ AjaxSessionId id + r <- f x + liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r ) + return () + +installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String) +installServerControl id f= do + t <- gets mfToken + st <- get + let ajxl = fromMaybe M.empty $ mfAjax st + let ajxl'= M.insert id (unsafeCoerce f ) ajxl + put st{mfAjax=Just ajxl'} + return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")" + +-- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back +-- +-- 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 +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 + (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 + (Just id, Just v2) -> do + return $ FormElm [] . 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 () +ajaxSend_ = ajaxSend + +wlabel + :: (Monad m, FormInput view) => view -> View view m a -> View view m a +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.+-- It points to the page that created it. +wlink :: (Typeable a, Show a, MonadIO m, FormInput view) + => a -> view -> View view m a +wlink x v= View $ do + verb <- getWFName + st <- get + let + name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String) + then unsafeCoerce x + else show x) + index' = mfPIndex st + + if linkMatched st then -1 else 0 + + + index = if index'== 0 then 1 else index' + lpath = mfPath st + + path= currentPath True index lpath verb ++ ('/':name) + -- !> (show $ mfPath st) + toSend = flink path v + + + r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page + else + case index < Data.List.length lpath && name== lpath !! index of + True -> do + modify $ \s -> s{inSync= True + ,linkMatched= True+ ,mfPIndex= index+1 } + + return $ Just x -- !> (name ++ "<-" ++show index++ " " ++ show (mfPIndex st) ++ "lpath=" ++show lpath) + False -> return Nothing -- !> ( "NOT MATCHED "++name++"<-" ++show index++ " LP= "++show lpath) + + length path `seq` return $ FormElm [toSend] 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+-- in the flow that inserted it. It is useful for creating a backtracking point in combination with `retry`+--+-- > page $ absLink "here" << p << "here link"+-- > page $ p << "second page" ++> wlink () << p << "click here"+-- > page $ p << "third page" ++> retry (absLink "here" << p << "will go back")+-- > page $ p << "fourth page" ++> wlink () << p << "will not reach here"+--+-- After navigating to the third page, when+-- ckicking in the link, will backtrack to the first, and will validate the first link as if the click+-- where done in the first page. Then the second page would be displayed.+--+-- In monadic widgets, it also backtrack to the statement where the absLink is located without the+-- need of retry:+--+-- > page $ do+-- > absLink "here" << p << "here link"+-- > p << "second statement" ++> wlink () << p << "click here"+-- > p << "third statement" ++> (absLink "here" << p << "will present the first statement alone")+-- > p << "fourth statement" ++> wlink () << p << "will not reach here"+absLink x = wcached (show x) 0 . wlink x+ ++ +-- | When some user interface return some response to the server, but it is not produced by +-- a form or a link, but for example by an script, @returning@ convert this code into a +-- widget. +-- +-- At runtime the parameter is read from the environment and validated. +-- +-- . The parameter is the visualization code, that accept a serialization function that generate +-- the server invocation string, used by the visualization to return the value by means +-- of an script, usually. +returning :: (Typeable a, Read a, Show a,Monad m, FormInput view) + => ((a->String) ->view) -> View view m a +returning expr=View $ do + verb <- getWFName + name <- genNewId + env <- gets mfEnv + let string x= + let showx= case cast x of + Just x' -> x' + _ -> show x + in (verb ++ "?" ++ name ++ "=" ++ showx) + toSend= expr string + r <- getParam1 name env + return $ FormElm [toSend] $ valToMaybe r + + + + + +--instance (Widget a b m view, Monoid view) => Widget [a] b m view where +-- widget xs = View $ do +-- forms <- mapM(\x -> (runView $ widget x )) xs +-- let vs = concatMap (\(FormElm v _) -> v) forms +-- res = filter isJust $ map (\(FormElm _ r) -> r) forms +-- res1= if null res then Nothing else head res +-- return $ FormElm [mconcat vs] res1 + +-- | Concat a list of widgets of the same type, return a the first validated result +firstOf :: (Monoid view, Monad m, Functor m)=> [View view m a] -> View view m a +firstOf xs= View $ do + forms <- mapM runView xs + let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms + res = filter isJust $ map (\(FormElm _ r) -> r) forms + res1= if null res then Nothing else head res + return $ FormElm vs res1 + +-- | from a list of widgets, it return the validated ones. +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 + res1= catMaybes $ map (\(FormElm _ r) -> r) forms + return . FormElm vs $ Just res1) ++-- | like manyOf, but does not validate if one or more of the widgets does not validate+allOf xs= manyOf xs `validate` \rs ->+ if length rs== length xs+ then return Nothing+ else return $ Just mempty+ +(>:>) :: Monad m => 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) + $ case( mx,mxs) of + (Just x, Just xs) -> Just $ x:xs + (Nothing, mxs) -> mxs + (Just x, _) -> Just [x] + +-- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types. +-- +-- it has a infix priority @infixr 5@ +(|*>) :: (MonadIO m, Functor m,Monoid view) + => 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) + $ case (rx,rxs) of + (Nothing, Nothing) -> Nothing + other -> Just other + + + +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. + +-- It has a low infix priority: @infixr 1@ +(|+|) :: (Functor m, Monoid view, MonadIO m) + => View view m r + -> View view m r' + -> View view m (Maybe r, Maybe r') +(|+|) w w'= w |*> [w'] + +infixr 1 |+|, .|+|. + + +-- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator +-- into a single tuple with the same elements in the same order. +-- This is useful for easing matching. For example: +-- +-- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@ +-- +-- @res@ has type: +-- +-- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@ +-- +-- but @flatten res@ has type: +-- +-- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@ + +flatten :: Flatten (Maybe tree) list => tree -> list +flatten res= doflat $ Just res + +class Flatten tree list where + doflat :: tree -> list + + +type Tuple2 a b= Maybe (Maybe a, Maybe b) +type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c) +type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d) +type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e) +type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f) + +instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where + doflat (Just(ma,mb))= (ma,mb) + doflat Nothing= (Nothing,Nothing) + +instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where + doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc) + doflat Nothing= (Nothing,Nothing,Nothing) + +instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where + doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc) + doflat Nothing= (Nothing,Nothing,Nothing,Nothing) + +instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where + doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc) + doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing) + +instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where + 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 + + +instance FormInput ByteString where + toByteString= id + toHttpData = HttpData [contentHtml ] [] + ftag x= btag x [] + inred = btag "b" [("style", "color:red")] + finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else [] + ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) "" + ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text] + + fselect name options= btag "select" [("name", name)] options + + foption value content msel= btag "option" ([("value", value)] ++ selected msel) content + where + selected msel = if msel then [("selected","true")] else [] + + attrs = addAttrs + + + formAction action form = btag "form" [("action", action),("method", "post")] form + fromStr = fromString + fromStrNoEncode= fromString + + flink v str = btag "a" [("href", v)] str + +------ page Flows ---- + +-- | Prepares the state for a page flow. It add a prefix to every form element or link identifier for the formlets and also +-- keep the state of the links clicked and form imput entered within the widget. +-- If the computation within the widget has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier. +-- See <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html> +pageFlow + :: (Monad m, Functor m, FormInput view) => + String -> View view m a -> View view m a +pageFlow str widget=do + s <- get + + if isNothing $ mfPageIndex s + then do + put s{mfPrefix= str ++ mfPrefix s + ,mfSequence=0 + ,mfPageIndex= Just $ mfPIndex s+ } -- !> ("PARENT pageflow. prefix="++ str) + + r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s + ,mfPrefix= mfPrefix s+-- ,mfPageIndex=Nothing+ })) + modify (\s -> s{mfPageIndex=Nothing} )+ return r -- !> ("END PARENT pageflow. prefix="++ str)) + + + else do + put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("CHILD pageflow. prefix="++ str) + + widget <** (modify (\s' -> s'{mfSequence= mfSequence s + ,mfPrefix= mfPrefix s})) + -- !> ("END CHILD pageflow. prefix="++ str)) + + + +--acum map []= map +--acum map (x:xs) = +-- let map' = case M.lookup x map of +-- Nothing -> M.insert x 1 map +-- Just n -> M.insert x (n+1) map +-- in acum map' xs +
src/MFlow/Forms/Admin.hs view
@@ -69,14 +69,18 @@ -- | execute the process and wait for its finalization. -- then it synchronizes the cache -wait f= do +wait f= do+ putStrLn "Using configuration: "+ print config mv <- newEmptyMVar forkIO (f1 >> putMVar mv True) putStrLn "wait: ready" - takeMVar mv + takeMVar mv+ return () `E.catch` (\(e:: E.SomeException) ->do ssyncCache error $ "Signal: "++ show e) + where f1= do mv <- newEmptyMVar @@ -97,7 +101,7 @@ adminMFlow :: FlowM Html IO () adminMFlow= do - admin <- getAdminName + let admin = getAdminName u <- getUser (Just admin) $ p << bold << "Please login as Administrator" ++> userLogin op <- ask $ p <<< wlink "sync" (bold << "sync") <|> p <<< wlink "flush" (bold << "flush") @@ -140,7 +144,7 @@ users= do users <- liftIO $ atomically $ return . map fst =<< indexOf userName - showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<-users] 0 10 + showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<- users] 0 10 showFormList :: [[View Html IO ()]]
src/MFlow/Forms/Blaze/Html.hs view
@@ -11,18 +11,19 @@ import MFlow import MFlow.Forms import MFlow.Cookies(contentHtml)-import Data.ByteString.Lazy.Char8-+import Data.ByteString.Lazy.UTF8+import qualified Data.String as S import Text.Blaze.Html import qualified Text.Blaze.Internal as I import Text.Blaze.Html5 as St import Text.Blaze.Html5.Attributes as At-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.Blaze.Html.Renderer.Utf8 -- (renderHtml) import Control.Monad.Trans import Data.Typeable-import Data.String import Data.Monoid-import Unsafe.Coerce+--import Data.Text.Encoding+--import Data.Text as T+import Text.Blaze.Internal -- | used to insert html elements within a tag with the appropriate infix priority for the -- other operators used in MFlow. Also it can be used for adding markup to@@ -32,37 +33,40 @@ infixr 7 << +--fromUtf8 = toValue . encodeUtf8 . T.pack++ instance FormInput Html where toByteString = renderHtml- toHttpData = HttpData [contentHtml ] [] . toByteString- ftag x= I.Parent (fromString x) (fromString $ "<"++x) (fromString $ "</"++ x ++">")+ toHttpData = HttpData [contentHtml] [] . toByteString+ ftag x= I.Parent (S.fromString x) (S.fromString $ "<" ++ x) (S.fromString $ "</"++ x ++">") -- (mempty :: I.MarkupM () ) - inred = b ! At.style (fromString "color:red")+ inred = b ! At.style "color:red" finput n t v f c= let- tag= input ! type_ (fromString t) ! name (fromString n) !value (fromString v)- tag1= if f then tag ! checked (fromString "") else tag- in case c of Just s -> tag1 ! onclick (fromString s) ; _ -> tag1+ tag= input ! type_ (toValue t) ! name (toValue n) !value (toValue v)+ tag1= if f then tag ! checked (toValue ("" ::String)) else tag+ in case c of Just s -> tag1 ! onclick (toValue s) ; _ -> tag1 - ftextarea nam text= textarea ! name (fromString nam) << text+ ftextarea nam text= textarea ! name (toValue nam) << text - fselect nam list = select ! name (fromString nam) << list+ fselect nam list = select ! name (toValue nam) << list foption name v msel=- let tag= option ! value (fromString name) << v- in if msel then tag ! selected (fromString "") else tag+ let tag= option ! value (toValue name) << v+ in if msel then tag ! selected (toValue ("" ::String)) else tag - formAction action form = St.form ! At.action (fromString action) ! method (fromString "post") $ form+ formAction action form = St.form ! acceptCharset "UTF-8" ! At.action (toValue action) ! method (toValue ("post" :: String)) $ form fromStr= toMarkup fromStrNoEncode = preEscapedToMarkup- flink v str = a ! href (fromString v) << str+ flink v str = a ! href (toValue v) << str attrs tag [] = tag attrs tag ((n,v):attribs) =- let tag'= tag ! (customAttribute $ stringTag n) (fromString v)+ let tag'= tag ! (customAttribute $ stringTag n) (toValue v) in attrs tag' attribs
src/MFlow/Forms/Internals.hs view
@@ -31,8 +31,8 @@ import Data.Monoid import Control.Monad.Trans import Control.Monad.State -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Data.ByteString.Char8 as SB +import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take) +import qualified Data.ByteString.UTF8 as SB import Data.Typeable import Data.RefSerialize hiding((<|>)) import Data.TCache @@ -47,14 +47,16 @@ import Data.List import System.IO.Unsafe import Control.Concurrent.MVar -import qualified Data.Text as T - +import qualified Data.Text as T+import Data.Char+import Control.Concurrent.STM+--import Data.String -- ---- for traces -- import Control.Exception as CE -import Control.Concurrent +import Control.Concurrent import Control.Monad.Loc --import Debug.Trace @@ -65,9 +67,9 @@ instance (Serialize a) => Serialize (FailBack a ) where - showp (BackPoint x)= insertString (B.pack iCanFailBack) >> showp x - showp (NoBack x) = insertString (B.pack noFailBack) >> showp x - showp GoBack = insertString (B.pack repeatPlease) + showp (BackPoint x)= insertString (fromString iCanFailBack) >> showp x + showp (NoBack x) = insertString (fromString noFailBack) >> showp x + showp GoBack = insertString (fromString repeatPlease) readp = choice [icanFailBackp,repeatPleasep,noFailBackp] where @@ -88,9 +90,8 @@ supervise :: m (FailBack a) -> m (FailBack a) supervise= id ---instance Monad m => Supervise () m where --- handle= const $ return () + instance (Supervise s m)=> Monad (Sup m) where fail _ = Sup . return $ GoBack return x = Sup . return $ NoBack x @@ -112,8 +113,8 @@ fromFailBack (NoBack x) = x fromFailBack (BackPoint x)= x toFailBack x= NoBack x --+ + -- | the FlowM monad executes the page navigation. It perform Backtracking when necessary to syncronize -- when the user press the back button or when the user enter an arbitrary URL. The instruction pointer -- is moved to the right position within the procedure to handle the request. @@ -121,7 +122,7 @@ -- However this is transparent to the programmer, who codify in the style of a console application. newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,Functor,MonadState(MFlowState v)) flowM= FlowM ---runFlowM= runView+--runFlowM= runView {-# NOINLINE breturn #-} @@ -208,25 +209,14 @@ supBack st= do MFlowState{..} <- get put st{ mfEnv= mfEnv,mfToken=mfToken - , mfPath=mfPath,mfPIndex= mfPIndex + , mfPath=mfPath -- ,mfPIndex= mfPIndex , mfData=mfData , mfTrace= mfTrace , inSync=False,newAsk=False} ---instance CMT.MonadCatchIO (FlowM v IO) where --- catch f hand = FlowM . Sup $ do --- s <- get --- (r,s') <- lift $ execMF f s `CE.catch` \e -> execMF (hand e) s --- --- put s' --- return r --- where --- execMF f s= runStateT (runSup (runFlowM f) ) s - - instance MonadLoc (FlowM v IO) where withLoc loc f = FlowM . Sup $ do withLoc loc $ do @@ -263,7 +253,7 @@ -- handler1 loc s (e :: SomeException)= -- return (GoBack, s{mfTrace= Just ["exception: " ++show e]}) -instance MonadLoc (View v IO) where +instance FormInput v => MonadLoc (View v IO) where withLoc loc f = View $ do withLoc loc $ do s <- get @@ -319,23 +309,30 @@ g >>= \(FormElm form2 x) -> return $ FormElm (form1 ++ form2) (k <*> x) -instance (Functor m, Monad m) => Alternative (View view m) where +instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where empty= View $ return $ FormElm [] Nothing View f <|> View g= View $ do - FormElm form1 k <- f - FormElm form2 x <- g - return $ FormElm (form1 ++ form2) (k <|> x) + FormElm form1 k <- f+ s1 <- get + FormElm form2 x <- g+ s2 <- get+ (mix,hasform) <- controlForms s1 s2 form1 form2+ when hasform $ put s2{needForm= HasForm} + return $ FormElm mix (k <|> x) -instance (Monad m) => Monad (View view m) where +instance (FormInput view, Monad m) => Monad (View view m) where View x >>= f = View $ do FormElm form1 mk <- x case mk of Just k -> do st <- get put st{linkMatched = False} - FormElm form2 mk <- runView $ f k - return $ FormElm (form1 ++ form2) mk + FormElm form2 mk <- runView $ f k+ st' <- get+ (mix, hasform) <- controlForms st st' form1 form2+ when hasform $ put st'{needForm= HasForm} + return $ FormElm mix mk Nothing -> return $ FormElm form1 Nothing @@ -343,11 +340,11 @@ return = View . return . FormElm [] . Just --- fail msg= View . return $ FormElm [fromStr msg] Nothing +-- fail msg= View . return $ FormElm [inRed msg] Nothing -instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where +instance (FormInput v,Monad m, Functor m, Monoid a) => Monoid (View v m a) where mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum mempty= return mempty @@ -368,53 +365,28 @@ FormElm form1 mk <- x case mk of Just k -> do - modify $ \st -> st{linkMatched= False, needForm=False} + modify $ \st -> st{linkMatched= False, needForm=NoElems} runView (f k) Nothing -> return $ FormElm form1 Nothing ---clear :: Monad m => View v m () ---clear= View $ do--- modify $ \s -> s{mfClear= True}--- return . FormElm [] $ Just ()--clear :: Monad m => View v m ()+ + +clear :: (FormInput v,Monad m) => View v m () clear = wcallback (return()) (const $ return()) ---incLink :: MonadState (MFlowState view) m => m() ---incLink= modify $ \st -> st{mfPIndex= if linkMatched st then mfPIndex st + 1 else mfPIndex st --- ,linkMatched= False} -- !> "<-inc" ---incLinkDepth --- :: MFlowState v -> Int ---incLinkDepth s= --- --- let depth= mfLinkDepth s --- in if mfLinkSelected s --- then --- depth +1 --- else --- depth ---instance (Monad m) => Monad (FlowM view m) where --- --View view m a-> (a -> View view m b) -> View view m b --- FlowM x >>= f = FlowM $ do --- FormElm _ mk <- x --- case mk of --- Just k -> do --- FormElm _ mk <- runFlowM $ f k --- return $ FormElm [] mk --- Nothing -> return $ FormElm [] Nothing --- --- return= FlowM . return . FormElm [] . Just + + instance MonadTrans (View view) where lift f = View $ (lift f) >>= \x -> return $ FormElm [] $ Just x instance MonadTrans (FlowM view) where lift f = FlowM $ lift (lift f) -- >>= \x -> return x -instance (Monad m)=> MonadState (MFlowState view) (View view m) where +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 @@ -423,8 +395,8 @@ -- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x -instance (MonadIO m) => MonadIO (View view m) where - liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad +instance (FormInput view,MonadIO m) => MonadIO (View view m) where + liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO on the Identity monad -- | Execute the widget in a monad and return the result in another. changeMonad :: (Monad m, Executable m1) @@ -494,12 +466,57 @@ clearEnv modify $ \s -> s{newAsk= True} msg - +-- | executes the first computation when going forward and the second computation when backtracking. +-- Depending on how the second computation finishes, the flow will resume forward or backward. +onBacktrack :: Monad m => m a -> FlowM v m a -> FlowM v m a +onBacktrack doit onback= do + back <- goingBack + case back of + False -> (lift doit) >>= breturn + True -> onback -type Lang= String +-- | less powerflul version of `onBacktrack`: The second computation simply undo the effect of +-- the first one, and the flow continues backward ever. It can be used as a rollback mechanism in +-- the context of long running transactions. +compensate :: Monad m => m a -> m a -> FlowM v m a +compensate doit undoit= doit `onBacktrack` ( (lift undoit) >> fail "") +++--orElse :: FormInput v => FlowM v IO a -> FlowM v IO a -> FlowM v IO a+--orElse mx my= do+-- s <- get+-- let tk = mfToken s+-- (r,s) <- liftIO $ do+-- ref1 <- atomically $ newTVar Nothing+-- ref2 <- atomically $ newTVar Nothing+-- t1 <- forkIO $ (runFlowOnceReturn s mx tk) >>= atomically . writeTVar ref1 . Just+-- t2 <- forkIO $ (runFlowOnceReturn s my tk) >>= atomically . writeTVar ref2 . Just+-- r <- atomically $ readFrom ref1 `Control.Concurrent.STM.orElse` readFrom ref2+-- killThread t1+-- killThread t2+-- flushResponse tk+-- flushRec tk+-- return r+-- put s+-- FlowM . Sup $ return r+-- where+-- readFrom ref = do+-- mr <- readTVar ref+-- case mr of+-- Nothing -> retry+-- Just v -> return v +type Lang= String++needForm1 st= case needForm st of+ HasForm -> False+ HasElems -> True+ NoElems -> False ++data NeedForm= HasForm | HasElems | NoElems deriving Show+ data MFlowState view= MFlowState{ mfSequence :: Int, mfCached :: Bool, @@ -507,7 +524,7 @@ inSync :: Bool, mfLang :: Lang, mfEnv :: Params, - needForm :: Bool, + needForm :: NeedForm, mfToken :: Token, mfkillTime :: Int, mfSessionTime :: Integer, @@ -527,8 +544,8 @@ mfPIndex :: Int, mfPageIndex :: Maybe Int, linkMatched :: Bool, - mfLinks :: M.Map String Int, + mfAutorefresh :: Bool, mfTrace :: [String], mfClear :: Bool @@ -539,8 +556,8 @@ mFlowState0 :: (FormInput view) => MFlowState view mFlowState0 = MFlowState 0 False True True "en" - [] False (error "token of mFlowState0 used") - 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] "" 1 Nothing False M.empty False [] False + [] NoElems (error "token of mFlowState0 used") + 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] "" 1 Nothing False False [] False -- | Set user-defined data in the context of the session. @@ -573,6 +590,10 @@ Nothing -> return $ Nothing typeResp :: m (Maybe x) -> x typeResp= undefined ++-- | Return the session identifier+getSessionId :: MonadState (MFlowState v) m => m String+getSessionId= gets mfToken >>= return . key -- | Return the user language. Now it is fixed to "en" getLang :: MonadState (MFlowState view) m => m String @@ -628,7 +649,7 @@ -- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append` -- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c -- @ - +-- setHeader :: MonadState (MFlowState view) m => (view -> view) -> m () setHeader header= do fs <- get @@ -644,7 +665,7 @@ addHeader new= do fhtml <- getHeader setHeader $ fhtml . new - + -- | Set an HTTP cookie setCookie :: MonadState (MFlowState view) m => String -- ^ name @@ -652,16 +673,32 @@ -> String -- ^ path -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie -> m () -setCookie n v p me= do - modify $ \st -> st{mfCookies= (SB.pack n,SB.pack v,SB.pack p, fmap (SB.pack . show) me):mfCookies st } +setCookie n v p me= + modify $ \st -> st{mfCookies= (UnEncryptedCookie + ( SB.fromString n, + SB.fromString v, + SB.fromString p, + fmap (SB.fromString . show) me)):mfCookies st } +setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie + +setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie + +setEncryptedCookie' n v p me encFunc= + modify $ \st -> st{mfCookies = + (unsafePerformIO $ encFunc + ( SB.fromString n, + SB.fromString v, + SB.fromString p, + fmap (SB.fromString . show) me)):mfCookies st } + -- | Set an HTTP Response header setHttpHeader :: MonadState (MFlowState view) m => SB.ByteString -- ^ name -> SB.ByteString -- ^ value -> m () -setHttpHeader n v = do - modify $ \st -> st{mfHttpHeaders= (n,v):mfHttpHeaders st } +setHttpHeader n v = + modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st } -- | Set @@ -708,9 +745,8 @@ -- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic -- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an --- instance of this class --- --- See "MFlow.Forms.Blaze.Html for the instance for blaze-html. "MFlow.Forms.XHtml" for the instance +-- instance of this class. +-- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance -- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages. class (Monoid view,Typeable view) => FormInput view where toByteString :: view -> B.ByteString @@ -773,19 +809,20 @@ -> View view Identity a -- ^ The cached widget, in the Identity monad -> View view m a -- ^ The cached result cachedWidget key t mf = View . StateT $ \s -> do - let((FormElm form _), sec)= execute $ cachedByKey key t $ proc mf s{mfCached=True} + let((FormElm form _), sec)= execute $! cachedByKey key t $ proc mf s{mfCached=True} let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True} let s''= s{inSync = inSync s2 ,mfRequirements=mfRequirements s2 - ,mfPath= mfPath s2+ ,mfPath= mfPath s2 ,needForm= needForm s2 ,mfPIndex= mfPIndex s2 ,mfPageIndex= mfPageIndex s2 - ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec} - return $ (mfSeqCache s'') `seq` ((FormElm form mx2), s'') + ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec}+ return $ (mfSeqCache s'') `seq` form `seq` ((FormElm form mx2), s'')+ -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2)) where - proc mf s= runStateT (runView mf) s >>= \(r,_) ->mfSeqCache s `seq` return (r,mfSeqCache s ) + proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s ) -- | A shorter name for `cachedWidget` wcached :: (MonadIO m,Typeable view @@ -833,53 +870,63 @@ runFlow :: (FormInput view, MonadIO m) => FlowM view m () -> Token -> m () runFlow f t= - loop (runFlowOnce1 f) t --evalStateT (runSup . runFlowM $ breturn() >> f) mFlowState0{mfToken=t,mfEnv= tenv t} >> return () -- >> return () + loop (startState t) f t where - loop f t = do - t' <- f t + loop s f t = do + (mt,s) <- runFlowOnce2 s f + let t'= fromFailBack mt let t''= t'{tpath=[twfname t']} liftIO $ do flushRec t'' - sendToMF t'' t'' -- !> "SEND" - loop f t'' -- !> "LOOPAGAIN" + sendToMF t'' t'' -- !> "SEND" + loop s{mfPIndex=0,mfPath=[],mfEnv=[]} f t''{tpath=[]} -- !> "LOOPAGAIN" -runFlowOnce :: (MonadIO m, FormInput view, Monad m) +runFlowOnce :: (MonadIO m, FormInput view) => FlowM view m () -> Token -> m () runFlowOnce f t= runFlowOnce1 f t >> return () -runFlowOnce1 f t = - evalStateT (runSup . runFlowM $ do - backInit - f - getToken) - mFlowState0{mfToken=t +runFlowOnce1 f t = runFlowOnce2 (startState t) f + +startState t= mFlowState0{mfToken=t ,mfPath= tpath t - ,mfEnv= tenv t} >>= return . fromFailBack + ,mfEnv= tenv t} ++runFlowOnce2 s f = + runStateT (runSup . runFlowM $ do + backInit + f + getToken) s + where backInit= do - s <- get -- !> "BackInit" + s <- get -- !> "BackInit" case mfTrace s of [] -> do - modify $ \s -> s{mfEnv=[], newAsk= True} - breturn () - tr -> do - - error $ disp tr + modify $ \s -> s{{-mfEnv=[],-} newAsk= True} + breturn ()+ + tr -> error $ disp tr where disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr) -- to restart the flow in case of going back before the first page of the flow ++runFlowOnceReturn+ :: FormInput v => MFlowState v -> FlowM v m a -> Token -> m (FailBack a, MFlowState v)+runFlowOnceReturn s f t = + runStateT (runSup $ runFlowM f) (startState t) + -- | Run a persistent flow inside the current flow. It is identified by the procedure and -- the string identifier. -- unlike the normal flows, that run within infinite loops, runFlowIn executes once. -- In subsequent executions, the flow will get the intermediate responses from te log --- and will return the result --- without asking again. This is useful for asking/storing/retrieving user defined configurations by --- means of web formularies. +-- and will return the result without asking again.+-- This is useful for asking once, storing in the log and subsequently retrieving user+-- defined configurations by means of persistent flows with web formularies. runFlowIn :: (MonadIO m, FormInput view) @@ -898,73 +945,10 @@ where runFlow1 st f t= runStateT (runSup . runFlowM $ f) st ---exec1bnc :: String -> Workflow IO a -> IO a ---exec1bnc wf f= liftIO $ do --- ei <- getState wf f () --- case ei of --- Left err -> CE.throw err --- Right (name, _, stat) -> do --- let vers = reverse $ dropWhile isback $ reverse $ S.versions stat !> (unpack $ runW $ showp (S.versions stat)) --- stat'= stat{S.versions= vers, S.state= length vers} !> (unpack $ runW $ showp vers) --- atomically $ writeDBRef (S.self stat) stat' --- writeResource stat' --- runWF1 name f stat' False --- `CE.catch` --- (\(e :: CE.SomeException) -> liftIO $ do ----- let name= keyWF wf () --- clearRunningFlag name --`debug` ("exception"++ show e) --- CE.throw e ) --- `finally` --- (liftIO . atomically . --- when(S.recover stat) $ do --- let ref= S.self stat --- s <- readDBRef ref `onNothing` error ("step: not found: "++ S.wfName stat) --- writeDBRef ref s{S.recover= False,S.versions= reverse $ S.versions s}) --- --- where --- --- ---isback x= serializedEqual x (pack "G ") --- --- ---dropBacks _ []= [] ---dropBacks nbacks (x:xs)= --- case isback x of --- True -> dropBacks (nbacks+1) xs --- False -> if nbacks== 0 then x:dropBacks 0 xs --- else dropBacks 0 xs ---switchWF --- :: (MonadIO m, --- FormInput view) --- => String --- -> FlowM view (Workflow IO) b --- -> FlowM view m b ---switchWF wf f= FlowM . Sup $ do --- st <- get --- let t = mfToken st --- (r,st') <- liftIO $ WF.exec1 wf $ runFlow1 st f t --- put st{mfPath= mfPath st'} --- return r ---switchWF wf f= do --- liftIO $ addMessageFlows [(wf,runFlow f)] --- transfer wf --- --- where --- runFlow1 st f t= runStateT (runSup . runFlowM $ f) st - --- | transfer control to another flow. (experimental) ---transfer :: MonadIO m => String -> FlowM v m () ---transfer flowname = do --- t <- gets mfToken --- let t'= t{twfname= flowname} --- liftIO $ do --- (r,_) <- msgScheduler t' --- sendFlush t r - -- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn -- outside of the web flow (FlowM) monad -runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a +runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a runFlowConf f = do q <- liftIO newEmptyMVar -- `debug` (i++w++u) qr <- liftIO newEmptyMVar @@ -995,16 +979,17 @@ s <- get flowM $ Sup $ do (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s - + -- when recovery of a workflow, the MFlow state is not considered when( mfSequence s' /= -1) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True} - return r + return r -- | to execute transient flows as if they were persistent --- it can be used instead of step, but it does not log the response. it ever executes the computation +-- it can be used instead of step, but it does log nothing.+-- Thus, it is faster and convenient when no session state must be stored beyond the lifespan of+-- the server process. -- -- > transient $ runFlow f === runFlow $ transientNav f - transientNav :: (Serialize a, Typeable view, @@ -1012,14 +997,12 @@ Typeable a) => FlowM view IO a -> FlowM view (Workflow IO) a -transientNav= MFlow.Forms.Internals.step - ---transientNav f= do --- s <- get --- flowM $ Sup $ do --- (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s --- put s' --- return r +transientNav f= do + s <- get + flowM $ Sup $ do + (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s + put s' + return r --stepWFRef -- :: (Serialize a, @@ -1078,54 +1061,80 @@ data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show) --valToMaybe (Validated x)= Just x-valToMaybe _= Nothing--isValidated (Validated x)= True-isValidated _= False--fromValidated (Validated x)= x-fromValidated NoParam= error $ "fromValidated : NoParam"-fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s+ +valToMaybe (Validated x)= Just x +valToMaybe _= Nothing + +isValidated (Validated x)= True +isValidated _= False + +fromValidated (Validated x)= x +fromValidated NoParam= error $ "fromValidated : NoParam" +fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s + getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) => String -> Params -> m (ParamResult v a) getParam1 par req = case lookup par req of - Just x1 -> readParam x1 - Nothing -> return NoParam+ Just x -> readParam x + Nothing -> return NoParam -readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)- => String -> m (ParamResult v a)-readParam x1 = r- where+-- Read a segment in the REST path. if it does not match with the type requested+-- or if there is no remaining segment, it returns Nothing +getRestParam :: (Read a, Typeable a,Monad m,Functor m, MonadState (MFlowState v) m, FormInput v) => m (Maybe a) +getRestParam= do + st <- get + let lpath = mfPath st + index' = mfPIndex st -- + if Just (mfPIndex st)== mfPageIndex st then 1 else 0 + index = if index'== 0 then 1 else index'+ name = lpath !! index + if linkMatched st+ then return Nothing + else case index < length lpath of + True -> do + modify $ \s -> s{inSync= True + ,linkMatched= True+ ,mfPIndex= index+1 } + fmap valToMaybe $ readParam name + False -> return Nothing++-- | return the value of a post or get param in the form ?param=value¶m2=value2...+getKeyValueParam par= do+ st <- get+ r <- getParam1 par $ mfEnv st+ return $ valToMaybe r+ +readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) + => String -> m (ParamResult v a) +readParam x1 = r + where r= do modify $ \s -> s{inSync= True} - maybeRead x1+ maybeRead x1 getType :: m (ParamResult v a) -> a getType= undefined x= getType r maybeRead str= do let typeofx = typeOf x - if typeofx == typeOf ( undefined :: String) then return . Validated $ unsafeCoerce str - else if typeofx == typeOf (undefined :: T.Text) then return . Validated . unsafeCoerce $ T.pack str + if typeofx == typeOf ( undefined :: String) then+ return . Validated $ unsafeCoerce str+ else if typeofx == typeOf (undefined :: T.Text) then+ return . Validated . unsafeCoerce $ T.pack str else case readsPrec 0 $ str of [(x,"")] -> return $ Validated x _ -> do - let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) return $ NotValidated str err - ---- Requirements -- | Requirements are javascripts, Stylesheets or server processes (or any instance of the 'Requirement' class) that are included in the -- Web page or in the server when a widget specifies this. @requires@ is the -- procedure to be called with the list of requirements. --- Varios widgets in the page can require the same element, MFlow will install it once. +-- Various widgets in the page can require the same element, MFlow will install it once. requires rs =do st <- get let l = mfRequirements st @@ -1225,8 +1234,8 @@ let s = jsRequirements $ sort rs return $ ftag "script" (fromStrNoEncode s) - + jsRequirements []= "" @@ -1279,8 +1288,10 @@ " };" ++ "" -formPrefix index verb st form anchored= do - let path = currentPath False index (mfPath st) verb +formPrefix st form anchored= do + let index= mfPIndex st+ verb= twfname $ mfToken st+ path = currentPath False index (mfPath st) verb (anchor,anchorf) <- case anchored of True -> do @@ -1288,25 +1299,37 @@ return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)]) False -> return (mempty,mempty) return $ formAction (path ++ anchor ) $ mconcat ( anchorf:form) -- !> anchor ---- | insert a form tag if the widget has form input fields. If not, it does nothing-insertForm w=View $ do- FormElm forms mx <- runView w- st <- get- cont <- case needForm st of- True -> do- frm <- formPrefix (mfPIndex st) (twfname $ mfToken st ) st forms False- put st{needForm= False}- return frm- _ -> return $ mconcat forms+ +-- | insert a form tag if the widget has form input fields. If not, it does nothing +insertForm w=View $ do + FormElm forms mx <- runView w + st <- get + cont <- case needForm1 st of + True -> do + frm <- formPrefix st forms False + put st{needForm= HasForm} + return frm + _ -> return $ mconcat 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)+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, False) currentPath insInBackTracking index lpath verb = - (if null lpath then verb + (if null lpath then '/':verb else case insInBackTracking of - True -> concat $ take index ['/':v | v <- lpath] -- !> ("index= " ++ show index) + True -> concat $ take index ['/':v | v <- lpath] -- !> ("index= " ++ show index) False -> concat ['/':v| v <- lpath]) -- | Generate a new string. Useful for creating tag identifiers and other attributes. @@ -1321,7 +1344,7 @@ prefseq= mfPrefix st put $ st{mfSequence= n+1} - return $ 'p':show n++prefseq + return $ 'p':show n++prefseq True -> do let n = mfSeqCache st put $ st{mfSeqCache=n+1} @@ -1339,4 +1362,4 @@ True -> do let n = mfSeqCache st return $ 'c' : (show n) -+
+ src/MFlow/Forms/WebApi.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+--+-- A haskell formlet is the combination of a parameter parser plus a writer to generate HTTP+-- output+--+-- I use this similarity to create parsec-like combinators that use the formlet monad in MFlow+--(the View monad) to parse the web service parameters and to generate the output.+--+-- This service below implements a service that sum or multiply two Int-egers.+--+-- > 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/api/sum?t1=[Int]&t2=[Int]"+-- > h3 << "http://server/api/prod?t1=[Int]&t2=[Int]"+-- > where+-- > asks w= ask $ w >> stop+-- > wint p= wparam p :: View Html IO Int+--+-- Can be called with:+--+-- > mainParser = runNavigation "apiparser" . step . asks (parserService >> stop)+--+-- or+--+-- > mainParser =do+-- > addMessageFlows[("apiparser",wstateless parserService)]+-- > wait $ run 80 waiMessageFlow+-----------------------------------------------------------------------------++module MFlow.Forms.WebApi (+restp, rest, wparam, disp,(<?>)+) where+import MFlow.Forms.Internals+import MFlow.Forms(stop,(++>))+import Control.Monad.State+import Data.Typeable++-- | 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++++-- | check that the next rest segment has a certain value. It return invalid otherwise.+-- therefore a monadic sequence in the View monad will not continue+rest v= do+ r <- restp+ if r==v then return v else modify (\s -> s{mfPIndex= mfPIndex s-1}) >> stop++-- | get a parameter from a GET or POST key-value input.+wparam par= View $ do+ mr <- getKeyValueParam par+ return $ FormElm [] mr++-- | append to the output the result of an expression+dispv :: (Monad m, FormInput v) => View v m v -> View v m ()+dispv w= View $ do+ FormElm f mx <- runView w+ case mx of+ Nothing -> return $ FormElm f Nothing+ justx@(Just x) -> return $ FormElm (f++[x]) $ return ()+++-- | append to the output the result of an expression+disp :: (Monad m, FormInput v, Show a) => View v m a -> View v m ()+disp w= View $ do+ FormElm f mx <- runView w+ case mx of+ Nothing -> return $ FormElm f Nothing+ justx@(Just x) -> return $ FormElm (f++[fromStr $ show x]) $ return ()++-- | error message when a applicative expression do not match+infixl 3 <?>+(<?>) w v= View $ do+ r@(FormElm f mx) <- runView w+ case mx of+ Nothing -> runView $ v ++> stop+ Just _ -> return r+++
src/MFlow/Forms/Widgets.hs view
@@ -1,1304 +1,1282 @@--{- |-Some dynamic widgets, widgets that dynamically edit content in other widgets,-widgets for templating, content management and multilanguage. And some primitives-to create other active widgets.--}--{-# LANGUAGE UndecidableInstances,ExistentialQuantification- , FlexibleInstances, OverlappingInstances, FlexibleContexts- , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables- , TemplateHaskell #-}-----module MFlow.Forms.Widgets (--- * Ajax refreshing of widgets-autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..)---- * JQueryUi widgets-,datePicker, getSpinner, wautocomplete, wdialog,---- * User Management-userFormOrName,maybeLogout, wlogin,---- * Active widgets-wEditList,wautocompleteList-, wautocompleteEdit,---- * Editing widgets-delEdited, getEdited,prependWidget,appendWidget,setWidget---- * Content Management-,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey---- * Multilanguage-,mFieldEd, mField---- * utility-,insertForm---) where-import MFlow-import MFlow.Forms-import MFlow.Forms.Internals-import Data.Monoid-import qualified Data.ByteString.Lazy.Char8 as B-import Control.Monad.Trans-import Data.Typeable-import Data.List-import System.IO.Unsafe--import Control.Monad.State-import Data.TCache-import Data.TCache.Defs-import Data.TCache.Memoization-import Data.RefSerialize hiding ((<|>))-import qualified Data.Map as M-import Data.IORef-import MFlow.Cookies-import Data.Maybe-import Data.Char-import Control.Monad.Identity-import Control.Workflow(killWF)-import Unsafe.Coerce-import Control.Exception---readyJQuery="ready=function(){if(!window.jQuery){return setTimeout(ready,100)}};"--jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"-jqueryScript1="//code.jquery.com/jquery-1.9.1.js"--jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"-jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"--jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"-jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"--------- User Management ---------- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.--- The paremeters and the behaviour are the same as 'userWidget'.--- Only the display is different-userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout- where- f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"- f felem Nothing = do- us <- getCurrentUser -- getEnv cookieuser- if us == anonymous- then return (felem, Nothing)- else return([fromStr us], Just us)---- | Display a logout link if the user is logged. Nothing otherwise-maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()-maybeLogout= do- us <- getCurrentUser- if us/= anonymous- then do- cmd <- ajax $ const $ return "window.location=='/'" --refresh- fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout- 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---- | If not logged, it present a page flow which askm 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. -wlogin :: (MonadIO m,Functor m,FormInput v) => View v m () -wlogin= insertForm $ do - username <- getCurrentUser - if username /= anonymous - then return username - else do - name <- getString Nothing <! hint "login name" <! size 9 <++ ftag "br" mempty - pass <- getPassword <! hint "password" <! size 9- <++ ftag "br" mempty- <** submitButton "login" - val <- userValidate (name,pass) - case val of - Just msg -> notValid msg - Nothing -> login name >> return name - - `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name) - ++> wlink ("logout" :: String) (ftag "b" $ fromStr " logout")) - `wcallback` const (logout >> wlogin) - -focus = [("onload","this.focus()")]-hint s= [("placeholder",s)]-size n= [("size",show n)]--getEdited1 id= do- Medit stored <- getSessionData `onNothing` return (Medit M.empty)- return $ fromMaybe [] $ M.lookup id stored---- | Return the list of edited widgets (added by the active widgets) for a given identifier-getEdited- :: (Typeable v, Typeable a, MonadState (MFlowState view) m) =>- B.ByteString -> m [View v m1 a]-getEdited id= do- r <- getEdited1 id- let (_,ws)= unzip r- return ws---- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter-delEdited- :: (Typeable v, Typeable a, MonadIO m,- MonadState (MFlowState view) m)- => B.ByteString -- ^ identifier- -> [View v m1 a] -> m () -- ^ withess-delEdited id witness=do- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))- let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored-- return $ ws `asTypeOf` witness- liftIO $ mapM flushCached ks- let stored'= M.delete id stored- setSessionData . Medit $ stored'------ setEdited id ([] `asTypeOf` (zip (repeat "") witness))--setEdited id ws= do- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))- let stored'= M.insert id ws stored- setSessionData . Medit $ stored'---addEdited id w= do- ws <- getEdited1 id- setEdited id (w:ws)---modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)- => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString-modifyWidget selector modifier w = View $ do- ws <- getEdited selector- let n = length (ws `asTypeOf` [w])- let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w)- let cw = wcached key 0 w- addEdited selector (key,cw)- FormElm form _ <- runView cw- let elem= toByteString $ mconcat form- return . FormElm [] . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"- where- typ :: View v Identity a -> a- typ = undefined---- | Return the javascript to be executed on the browser to prepend a widget to the location--- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression--- . It stores the added widgets in the edited list, that is accessed with 'getEdited'------ The resulting string can be executed in the browser. 'ajax' will return the code to--- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler.------ This example will insert a widget in the div when the element with identifier--- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned--- and the list of edited widgets are deleted.------ > id1<- genNewId--- > let sel= "$('#" <> B.pack id1 <> "')"--- > callAjax <- ajax . const $ prependWidget sel wn--- > let installevents= "$(document).ready(function(){\--- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"--- >--- > requires [JScriptFile jqueryScript [installevents] ]--- > ws <- getEdited sel--- > r <- (div <<< manyOf ws) <! [("id",id1)]--- > delEdited sel ws'--- > return r--prependWidget- :: (Typeable a, MonadIO m, Executable m, FormInput v)- => B.ByteString -- ^ jquery selector- -> View v Identity a -- ^ widget to prepend- -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser-prependWidget sel w= modifyWidget sel "prepend" w---- | Like 'prependWidget' but append the widget instead of prepend.-appendWidget- :: (Typeable a, MonadIO m, Executable m, FormInput v) =>- B.ByteString -> View v Identity a -> View v m B.ByteString-appendWidget sel w= modifyWidget sel "append" w---- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element-setWidget- :: (Typeable a, MonadIO m, Executable m, FormInput v) =>- B.ByteString -> View v Identity a -> View v m B.ByteString-setWidget sel w= modifyWidget sel "html" w----- | Inside a tag, it add and delete widgets of the same type. When the form is submitted--- or a wlink is pressed, this widget return the list of validated widgets.--- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/--- that the user will choose.------ This example add or delete editable text boxes, with two initial boxes with--- /hi/, /how are you/ as values. Tt uses blaze-html:------ > r <- ask $ addLink--- > ++> br--- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"--- > <++ br--- > <** submitButton "send"--- >--- > ask $ p << (show r ++ " returned")--- > ++> wlink () (p << text " back to menu")--- > mainmenu--- > where--- > addLink = a ! At.id "addid"--- > ! href "#"--- > $ text "add"--- > delBox = input ! type_ "checkbox"--- > ! checked ""--- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"--- > getString1 mx= El.div <<< delBox ++> getString mx <++ br--wEditList :: (Typeable a,Read a- ,FormInput view- ,Functor m,MonadIO m, Executable m)- => (view ->view) -- ^ The holder tag- -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string- -> [String] -- ^ The initial list of values.- -> String -- ^ The id of the button or link that will create a new list element when clicked- -> View view m [a]-wEditList holderview w xs addId = do- let ws= map (w . Just) xs- wn= w Nothing- id1<- genNewId- let sel= "$('#" <> B.pack id1 <> "')"- callAjax <- ajax . const $ prependWidget sel wn- let installevents= "$(document).ready(function(){\- \$('#"++addId++"').click(function(){"++callAjax "''"++"});})"-- requires [JScriptFile jqueryScript [installevents] ]-- ws' <- getEdited sel-- r <- (holderview <<< (manyOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]- delEdited sel ws'- return r----wpush--- :: (Typeable a,--- FormInput v) =>--- (v -> v)--- -> String--- -> String--- -> String--- -> (String -> View v IO a)--- -> View v IO a---wpush holder modifier addId expr w = do--- id1 <- genNewId--- let sel= "$('#" <> B.pack id1 <> "')"--- callAjax <- ajax $ \s -> appendWidget sel ( changeMonad $ w s)--- let installevents= "$(document).ready(function(){\--- \$('#"++addId++"').click(function(){"++callAjax expr ++ "});})"------ requires [JScriptFile jqueryScript [installevents] ]------ ws <- getEdited sel------ r <- holder <<< firstOf ws <! [("id",id1)]--- delEdited sel ws--- return r------ | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.-wautocomplete- :: (Show a, MonadIO m, FormInput v)- => Maybe String -- ^ Initial value- -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings- -> View v m String-wautocomplete mv autocomplete = do- text1 <- genNewId- ajaxc <- ajax $ \u -> do- r <- liftIO $ autocomplete u- return $ jaddtoautocomp text1 r--- requires [JScriptFile jqueryScript [] -- [events]- ,CSSFile jqueryCSS- ,JScriptFile jqueryUI []]--- getString mv <! [("type", "text")- ,("id", text1)- ,("oninput",ajaxc $ "$('#"++text1++"').attr('value')" )- ,("autocomplete", "off")]--- where- jaddtoautocomp text1 us= "$('#"<>B.pack text1<>"').autocomplete({ source: " <> B.pack( show us) <> " });"----- | Produces a text box. It gives a autocompletion list to the textbox. When return--- is pressed in the textbox, the box content is used to create a widget of a kind defined--- by the user, which will be situated above of the textbox. When submitted, the result is the content--- of the created widgets (the validated ones).------ 'wautocompleteList' is an specialization of this widget, where--- the widget parameter is fixed, with a checkbox that delete the eleement when unselected--- . This fixed widget is as such (using generic 'FormElem' class tags):------ > ftag "div" <<< ftag "input" mempty--- > `attrs` [("type","checkbox")--- > ,("checked","")--- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]--- > ++> ftag "span" (fromStr $ fromJust x )--- > ++> whidden( fromJust x)-wautocompleteEdit- :: (Typeable a, MonadIO m,Functor m, Executable m- , FormInput v)- => String -- ^ the initial text of the box- -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options.- -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box- -> [String] -- ^ initial set of values- -> View v m [a] -- ^ resulting widget-wautocompleteEdit phold autocomplete elem values= do- id1 <- genNewId- let textx= id1++"text"- let sel= "$('#" <> B.pack id1 <> "')"- ajaxc <- ajax $ \(c:u) ->- case c of- 'f' -> prependWidget sel (elem $ Just u)- _ -> do- r <- liftIO $ autocomplete u- return $ jaddtoautocomp textx r--- requires [JScriptFile jqueryScript [events textx ajaxc]- ,CSSFile jqueryCSS- ,JScriptFile jqueryUI []]-- ws' <- getEdited sel-- r<- (ftag "div" mempty `attrs` [("id", id1)]- ++> manyOf (ws' ++ (map (changeMonad . elem . Just) values)))- <++ ftag "input" mempty- `attrs` [("type", "text")- ,("id", textx)- ,("placeholder", phold)- ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )- ,("autocomplete", "off")]- delEdited sel ws'- return r- 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;" ++- ajaxc "'f'+v"++";"++- " $('#"++textx++"').val('');\- \ }\- \ });\- \});"-- jaddtoautocomp textx us= "$('#"<>B.pack textx<>"').autocomplete({ source: " <> B.pack( show us) <> " });"---- | A specialization of 'wutocompleteEdit' which make appear each chosen option with--- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements.-wautocompleteList- :: (Functor m, MonadIO m, Executable m, FormInput v) =>- String -> (String -> IO [String]) -> [String] -> View v m [String]-wautocompleteList phold serverproc values=- wautocompleteEdit phold serverproc wrender1 values- where- wrender1 x= ftag "div" <<< ftag "input" mempty- `attrs` [("type","checkbox")- ,("checked","")- ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]- ++> ftag "span" (fromStr $ fromJust x )- ++> whidden( fromJust x)--------- Templating and localization -----------data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)--instance Indexable TField where- key (TField k _)= k- defPath _= "texts/"---instance Serializable TField where- 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 (B.pack 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---readtField text k= atomically $ do- let ref = getDBRef k- mr <- readDBRef ref- case mr of- Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ B.unpack v else return text- Nothing -> return text---htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a-htmlEdit buttons jsuser w = do- 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\- \})};\n"- install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"-- requires [JScriptFile nicEditUrl [installHtmlField,install]]- w <! [("id",id)]--nicEditUrl= "//js.nicedit.com/nicEdit-latest.js"----- | A widget that display the content of an html, But if the user has edition privileges,--- it permits to edit it in place. So the editor could see the final appearance--- of what he writes.------ When the user click the save, the content is saved and--- identified by the key. Then, from now on, all the users will see the saved--- content instead of the code content.------ The content is saved in a file by default (/texts/ in this versions), but there is--- a configurable version (`tFieldGen`). The content of the element and the formatting--- is cached in memory, so the display is, theoretically, very fast.-----tFieldEd- :: (Functor m, MonadIO m, Executable m,- FormInput v) =>- UserStr -> Key -> v -> View v m ()-tFieldEd muser k text= wfreeze k 0 $ do- content <- liftIO $ readtField text k- nam <- genNewId- let ipanel= nam++"panel"- name= nam++"-"++k- install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"- getTexts :: (Token -> IO ())- getTexts token = do- let (k,s):_ = tenv token- liftIO $ do- writetField k $ (fromStrNoEncode s `asTypeOf` text)- flushCached k- sendFlush token $ HttpData [] [] ""- return()-- requires [JScriptFile nicEditUrl [install]- ,JScript ajaxSendText- ,JScript installEditField--- ,JScriptFile jqueryScript []- ,ServerProc ("_texts", transient getTexts)]-- (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\- \})};\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\- \};\n"---- | a text field. Read the cached field value and present it without edition.-tField :: (MonadIO m,Functor m, Executable m, FormInput v)- => Key- -> View v m ()-tField k = wfreeze k 0 $ do- content <- liftIO $ readtField (fromStrNoEncode "not found") k- notValid content---- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the--- two characters of the language used.-mFieldEd muser k content= do- lang <- getLang- tFieldEd muser (k ++ ('-':lang)) content------ | A multilanguage version of tField-mField k= do- lang <- getLang- tField $ k ++ ('-':lang)--newtype IteratedId= IteratedId String deriving Typeable---- | Permits to iterate the presentation of data and//or input fields and widgets within--- a web page that does not change. The placeholders are created with dField. Both are widget--- modifiers: The latter gets a widget and create a placeholder in the page that is updated--- via ajax. The content of the update is the rendering of the widget at each iteration.--- The former gets a wider widget which contains dField elements and permit the iteration.--- Whenever a link or a form within the witerate widget is activated, the result is the--- placeholders filled with the new html content. This content can be data, a input field,--- a link or a widget. No navigation happens.------ This permits even faster updates than autoRefresh. since the latter refresh the whole--- widget and it does not permits modifications of the layout at runtime.------ When edTemplate or template is used on top of witerate, the result is editable at runtime,--- and the span placeholders generated, that are updated via ajax can be relocated within--- the layout of the template.------ Additionally, contrary to some javascript frameworks, the pages generated with this--- mechanism are searchable by web crawlers.--witerate- :: (MonadIO m, Functor m, FormInput v) =>- View v m a -> View v m a-witerate w= do- name <- genNewId- setSessionData $ IteratedId name- st <- get- let index= mfPIndex st- let t= mfkillTime st- let installAutoEval=- "$(document).ready(function(){\n\- \autoEvalLink('"++name++"','"++ show index ++"');\- \autoEvalForm('"++name++"');\- \})\n"- let r = lookup ("auto"++name) $ mfEnv st- ret <- case r of- Nothing -> do- requires [JScript autoEvalLink- ,JScript autoEvalForm- ,JScript setId- ,JScript $ timeoutscript t- ,JScriptFile jqueryScript [installAutoEval]]-- (ftag "div" <<< insertForm w) <! [("id",name)]--- Just sind -> View $ do- let t= mfToken st- let index= read sind- put st{mfPIndex= index}- modify $ \s -> s{mfRequirements=[]}-- FormElm _ mr <- runView w-- reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements- let js = jsRequirements reqs- liftIO . sendFlush t $ HttpData- (("Cache-Control", "no-cache, no-store"):mfHttpHeaders st)- (mfCookies st) (B.pack js)- modify $ \st -> st{mfAutorefresh=True,inSync=True}- return $ FormElm [] mr-- delSessionData $ IteratedId name- return ret--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+'?bustcache='+ new Date().getTime()+'&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\- \}\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"---- Present a widget via AJAX if it is within a 'witerate' context. In the first iteration it present the--- widget surrounded by a placeholder. subsequent iterations will send just the javascript code--- necessary for the refreshing of the placeholder.-dField- :: (Monad m, FormInput view) =>- View view m b -> View view m b-dField w= View $ do- id <- genNewId- FormElm vs mx <- runView w- let render = mconcat vs- 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++"','" ++ B.unpack (toByteString $ render)++"')});\n"]]- return $ FormElm[(ftag "span" render) `attrs` [("id",id)]] mx- else do- requires [JScript $ "setId('"++id++"','" ++ B.unpack (toByteString $ render)++"');\n"]- return $ FormElm mempty mx--noid= "noid"----edTemplateList--- :: (MonadIO m, Functor m, Typeable b, FormInput view) =>--- UserStr -> String -> (a ->View view m b) -> [a] -> View view m b---edTemplateList user name w xs= View $ do--- id <- genNewId--- let ws= Prelude.map w xs--- FormElm vx mx <- runView $--- edTemplate user name ( Prelude.head ws) <|>--- firstOf [template name w | w <- Prelude.tail ws]------ let render = mconcat vx--- st <- get--- let t= mfkillTime st--- let env = mfEnv st--- let insertResults= "insert('" ++ id ++ "',"++ show (B.unpack $ toByteString render) ++");"--- IteratedId name <- getSessionData `onNothing` return (IteratedId noid)--- let r = lookup ("auto"++name) env -- !> ("TIMEOUT="++ show t)--- if r == Nothing || (name == noid && newAsk st== True)--- then do--- requires[JScript autoEvalLink--- ,JScript $ timeoutscript t--- ,JScript jsInsertList--- ,JScriptFile jqueryScript [insertResults]]--- return $ FormElm[(ftag "span" render) `attrs` [("id",id)]] mx !> "NOPARAM edTemplateList"--- else do--- modify $ \st -> st{mfRequirements= [],mfAutorefresh=True,inSync=True}--- requires[JScript insertResults]--- !> "VALIDATED edTemplateList"--- return $ FormElm mempty mx------- | load a template with the name equal to the second parameter in the texts folder. If no template--- exist, it uses the widget rendering. If the first parameter match the name of the logged user,--- the template will be editable at runtime. edTemplate will present an edition bar on the top of--- the template. The changes in the template will be effective inmediately for all the users.------ The return value is the one returned by the internal widget each time it is executed.------ edTemplate can be used to enrich the content and layout of a widget, for example, by adding--- extra links, text and formatting. Widgets with form fields work well with an 'edTemplate' mask--- as long as the tags created by the widget are not deleted, but the validation messages will not appear------ To add dynamic elements to the template for data presentation and//or input field validation--- messages, combine it with 'witerate' and 'dField'-edTemplate- :: (MonadIO m, FormInput v, Typeable a) =>- UserStr -> Key -> View v m a -> View v m a-edTemplate muser k w= View $ do- nam <- genNewId-- let ipanel= nam++"panel"- name= nam++"-"++k- install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"--- requires [JScriptFile nicEditUrl [install]- ,JScript ajaxSendText- ,JScript installEditField- ,JScriptFile jqueryScript []- ,ServerProc ("_texts", transient getTexts)]-- FormElm text mx <- runView w- content <- liftIO $ readtField (mconcat text) k-- return $ FormElm [ftag "div" mempty `attrs` [("id",ipanel)]- ,ftag "span" content `attrs` [("id", name)]]- mx- where- getTexts :: (Token -> IO ())- getTexts token= do- let (k,s):_ = tenv token- liftIO $ do- writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)- flushCached k- sendFlush token $ HttpData [] [] ""- return()-- viewFormat :: View v m a -> v- viewFormat= undefined -- is a type function---- | Does the same than template but without the edition facility-template k w= View $ do- FormElm text mx <- runView w- let content= unsafePerformIO $ readtField (mconcat text) k- return $ FormElm [content] mx----edTemplateList--- :: (Typeable a,FormInput view) =>--- UserStr -> String -> [View view Identity a] -> View view IO a---edTemplateList user templ ws= do--- let id = templ--- let wrapid= "wrapper-" ++ id--- text <- liftIO $ readtField (ftag "div" mempty `attrs` [("id",wrapid)]) wrapid--- let vwrtext= B.unpack $ toByteString (text `asTypeOf` witness ws)-------- wrapperEd wrapid vwrtext **>--- (ftag "div" <<< elems id wrapid vwrtext) <! [("id",wrapid)]--- where--- witness :: [View view Identity a] -> view--- witness = undefined------ elems id wrapid vwrtext= View $ do--- let holder= ftag "span" (fromStr "holder") `attrs` [("_holder",id)]------ FormElm fedit _ <- runView $ tFieldEd user templ holder--- frest <- liftIO $ readtField holder templ------ forms <- mapM (runView . changeMonad) ws--- let vs = map (\(FormElm v _) -> mconcat v) forms--- requires [JScriptFile jqueryScript--- [----- replacewrap----- ,"replacewrap('"++ wrapid ++ "','" ++ vwrtext ++ "')",--- jsInsertList--- ,"$(document).ready(function() {\--- \insert('" ++ id ++ "',"++ show (map ( B.unpack . toByteString) vs) ++");\n\--- \});"]]------ let res = filter isJust $ map (\(FormElm _ r) -> r) forms --- res1= if null res then Nothing else head res------ return $ FormElm (mconcat fedit: take (length vs -1) (repeat frest)) res1----jsInsertList =- "\nfunction insert(id,vs){\n\- \$('[_holder=\"'+id+'\"]').each(function(n,it) {\n\- \ $(it).html(vs[n]);\n\- \})};\n"---- wrapperEd :: (FormInput view) => String -> view -> View view IO ()--- wrapperEd wrapid wrtext = do -- autoRefresh . pageFlow "wrap" $ do--- vwrtext <- liftIO $ readtField (ftag "div" mempty `attrs` [("id",wrapid)]) wrapid--- let wrtext= B.unpack $ toByteString (vwrtext `asTypeOf` witness)--- nwrtext<- getString (Just wrtext)--- <! [("id", wrapid++"-ed")]--- <** submitButton "OK"------ liftIO $ writetField wrapid (fromStr nwrtext `asTypeOf` witness ws) !> nwrtext----- replacewrap = "\nfunction replacewrap(id,wrapcode){\n\--- \ var selector= '#'+id;\n\--- \ var children = $(selector).children();\n\--- \ var nchildren;\n\--- \ $(selector).replaceWith(wrapcode);\n\--- \ $(selector).html(children);\n\--- \ if(wrapcode.search('table') != -1)\n\--- \ $(children[1].children).wrap('<tr><td></td></tr>')\n\--- \};\n"---- \ if(wrapcode.search('xx') != -1){\n\--- \ children.each(function(n,it){\n\--- \ $(it).wrap('<li></li>')});\n\---- \ })\n\----------------------- JQuery widgets ---------------------- | present the JQuery datepicker calendar to choose a date.--- The second parameter is the configuration. Use \"()\" by default.--- See http://jqueryui.com/datepicker/-datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)-datePicker conf jd= do- id <- genNewId- let setit= "$(document).ready(function() {\- \$( '#"++id++"' ).datepicker "++ conf ++";\- \});"-- requires- [CSSFile jqueryCSS- ,JScriptFile jqueryScript []- ,JScriptFile jqueryUI [setit]]-- s <- getString jd <! [("id",id)]- let (month,r) = span (/='/') s- let (day,r2)= span(/='/') $ tail r- return (read day,read month, read $ tail r2)---- | present a jQuery dialog with a widget. When a button is pressed it return the result.--- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see "http://jqueryui.com/dialog/" for--- the available configurations.------ As in the case of 'autoRefresh' the enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.--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\- \});"-- modify $ \st -> st{needForm= False}- requires- [CSSFile jqueryCSS- ,JScriptFile jqueryScript []- ,JScriptFile jqueryUI [setit]]-- (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]-------- | Capture the form submissions and the links of the enclosed widget and send them via jQuery AJAX.--- The response is the new presentation of the widget, that is updated. No new page is generated--- but the functionality is equivalent. Only the activated widget is executed in the server and updated--- in the client, so a widget with autoRefresh can be used in heavyweight pages.--- If AJAX/JavaScript are not available, the widget is refreshed normally, via a new page.--- If has form elements, the enclosed widget must be a complete form and it must include the form action tag.--- For this purpose, autoRefresh encloses the widget in a form tag if there are form elements on it--- and the programmer has not enclosed them in a 'wform' element.-autoRefresh- :: (MonadIO m,- FormInput v)- => View v m a- -> View v m a-autoRefresh w= update "html" w---- | In some cases, it is neccessary that a link or form inside a 'autoRefresh' or 'update' block--- should not be autorefreshed, since it produces side effects in the rest of the page that--- affect to the rendering of the whole. If you like to refresh the whole page, simply add--- noAutoRefresh attribute to the widget to force the refresh of the whole page when it is activated.------ That behaviour is common at the last sentence of the 'autoRefresh' block.------ This is a cascade menu example.------ > r <- page $ autoRefresh $ ul <<< do--- > li <<< wlink OptionA << "option A"--- > ul <<< li <<< (wlink OptionA1 << "Option A1" <! noAutoRefresh)--- > <|> li <<< (wlink OptionA2 << "Option A2" <! noAutoRefresh)--- > <|>...--- > maybe other content--- >--- > case r of--- > OptionA1 -> pageA1--- > OptionA2 -> pageA2------ when @option A@ is clicked, the two sub-options appear with autorefresh. Only the two--- lines are returned by the server using AJAX. but when Option A1-2 is pressed we want to--- present other pages, so we add the noAutorefresh attribute.------ NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.-noAutoRefresh= [("class","_noAutoRefresh")]---- | does the same than autoRefresh but append the result of each request to the bottom of the widget-appendUpdate :: (MonadIO m,- FormInput v)- => View v m a- -> View v m a-appendUpdate= update "append"---- | does the same than autoRefresh but prepend the result of each request before the current widget content-prependUpdate :: (MonadIO m,- FormInput v)- => View v m a- -> View v m a-prependUpdate= update "prepend"--update :: (MonadIO m,- FormInput v)- => B.ByteString- -> View v m a- -> View v m a-update method w= do- id <- genNewId- st <- get- let t = mfkillTime st -1-- let installscript=- "$(document).ready(function(){\n"- ++ "ajaxGetLink('"++id++"');"- ++ "ajaxPostForm('"++id++"');"- ++ "})\n"-- let r= lookup ("auto"++id) $ mfEnv st -- !> ("TIMEOUT="++ show t)- case r of- Nothing -> do- requires [JScript $ timeoutscript t- ,JScript ajaxGetLink- ,JScript ajaxPostForm- ,JScriptFile jqueryScript [installscript]]- (ftag "div" <<< insertForm w) <! [("id",id)] -- Just sind -> View $ do- let t= mfToken st- FormElm form mr <- runView $ insertForm w- st <- get- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString (mconcat 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-- where--- -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal- 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+'?bustcache='+ new Date().getTime()+'&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\- \ },\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\- \}\n"-- 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 = $form.serialize();\n\- \$.ajax({\n\- \type: 'POST',\n\- \url: url,\n\- \data: 'auto'+id+'=true&'+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\- \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"---data UpdateMethod= Append | Prepend | Html deriving Show---- | continously execute a widget and update the content.--- The update method specify how the update is done. 'Html' means a substitution of content.--- The second parameter is the delay for the next retry in case of disconnection, in milliseconds.------ It can be used to show data updates in the server. The widget is executed in a different process than--- the one of the rest of the page. Although the process is initiated with the session context,--- updates in the session context are not seen by the push widget--- To communicate with te widget, use DBRef's or TVar and the--- STM semantics for waiting updates using 'retry'.------ Widgets in a push can have links and forms, but since they are asunchonous, they can not--- return inputs. but they can modify the server state.--- push ever return an invalid response to the calling widget, so it never--- triggers the advance of the navigation.--------- This example is a counter increased each second:------ > pushIncrease= do--- > tv <- liftIO $ newTVarIO 0--- > page $ push 0 Html $ do--- > n <- atomic $ readTVar tv--- > atomic $ writeTVar tv $ n + 1--- > liftIO $ threadDelay 1000000--- > b << (show n) ++> noWidget--------- This other simulates a console output that echoes what is entered in a text box--- below. It has two widgets: a push output in append mode and a text box input.--- The communication it uses a TVar. The push widget wait for updates in the TVar.--- because the second widget uses autoRefresh, all happens in the same page.------ It is recommended to add a timeout to the push widget, like in the example:------ > pushSample= do--- > tv <- liftIO $ newTVarIO $ Just "init"--- > page $ push Append 1000 (disp tv) <** input tv--- >--- > where--- > disp tv= do--- > setTimeouts 100 0--- > line <- tget tv--- > p << line ++> noWidget--- >--- > input tv= autoRefresh $ do--- > line <- getString Nothing <** submitButton "Enter" --- > tput tv line--- >--- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"--- >--- > tget tv= atomic $ do--- > mr <- readTVar tv--- > case mr of--- > Nothing -> retry--- > Just r -> do--- > writeTVar tv Nothing--- > return r--push :: FormInput v- => UpdateMethod- -> Int- -> View v IO ()- -> View v IO ()-push method' wait w= push' . map toLower $ show method'- where- push' method= do- id <- genNewId- st <- get- let token= mfToken st- dat= mfData st- procname= "_push" ++ tind token ++ id- installscript=- "$(document).ready(function(){\n"- ++ "ajaxPush('"++id++"',"++show wait++");"- ++ "})\n"-- new <- gets newAsk-- when new $ do- killWF procname token{twfname= procname}- let proc= transient . runFlow . ask $ w' dat- requires [ServerProc (procname, proc),- JScript $ ajaxPush procname,- JScriptFile jqueryScript [installscript]]-- (ftag "div" <<< noWidget) <! [("id",id)]- <++ ftag "div" mempty `attrs` [("id",id++"status")]-- where- w' dat= do- modify $ \s -> s{inSync= True,newAsk=True,mfData=dat}- w--- 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\- \}"---- let r= lookup ("auto"++id) $ mfEnv st -- !> ("TIMEOUT="++ show t)--- case r of--- Nothing -> do--- requires [--- JScript $ ajaxPush method,--- JScriptFile jqueryScript [installscript]]--- (ftag "div" <<< insertForm w) <! [("id",id)] ------ Just sind -> View $ do--- let t= mfToken st--- FormElm form mr <- runView $ insertForm w--- st <- get--- let HttpData ctype c s= toHttpData $ B.pack method <> " " <> toByteString (mconcat 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------ ajaxPush method =" function ajaxPush(id,verb,waititime){\n\--- \var cnt=0; \n\--- \var id1= $('#'+id);\n\--- \var idstatus= $('#'+id+'status');\n\--- \var ida= $('#'+id+' a');\n\--- \var actionurl = './';\n\--- \var dialogOpts = {\n\--- \ cache: false,\n\--- \ type: 'GET',\n\--- \ url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\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\--- \}"--------- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.--- See http://jqueryui.com/spinner-getSpinner- :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>- 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\- \});"- requires- [CSSFile jqueryCSS- ,JScriptFile jqueryScript []- ,JScriptFile jqueryUI [setit]]-- getTextBox mv <! [("id",id)]----+ +{- | +Some dynamic widgets, widgets that dynamically edit content in other widgets, +widgets for templating, content management and multilanguage. And some primitives +to create other active widgets. +-} + +{-# LANGUAGE UndecidableInstances,ExistentialQuantification + , FlexibleInstances, OverlappingInstances, FlexibleContexts + , OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables + , TemplateHaskell #-} + + + + +module MFlow.Forms.Widgets ( +-- * Ajax refreshing of widgets +autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..) + +-- * JQueryUi widgets +,datePicker, getSpinner, wautocomplete, wdialog, + +-- * User Management +userFormOrName,maybeLogout, wlogin, + +-- * Active widgets +wEditList,wautocompleteList +, wautocompleteEdit, + +-- * Editing widgets +delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget + +-- * Content Management +,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey + +-- * Multilanguage +,mFieldEd, mField + +-- * utility +,insertForm, readtField, writetField + + +) where +import MFlow +import MFlow.Forms +import MFlow.Forms.Internals +import Data.Monoid +import Data.ByteString.Lazy.UTF8 as B hiding (length,span) +import Control.Monad.Trans +import Data.Typeable +import Data.List +import System.IO.Unsafe + +import Control.Monad.State +import Data.TCache +import Data.TCache.Defs +import Data.TCache.Memoization +import Data.RefSerialize hiding ((<|>)) +import qualified Data.Map as M +import Data.IORef +import MFlow.Cookies +import Data.Maybe +import Data.Char +import Control.Monad.Identity +import Control.Workflow(killWF) +import Unsafe.Coerce +import Control.Exception + + + +--jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js" +--jqueryScript1="//code.jquery.com/jquery-1.9.1.js" +-- +--jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css" +--jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css" +-- +--jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js" +--jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js" + +jqueryScript= cjqueryScript config +jqueryCSS= cjqueryCSS config +jqueryUI= cjqueryUI config +nicEditUrl= cnicEditUrl config +------- User Management ------ + +-- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented. +-- The paremeters and the behaviour are the same as 'userWidget'. +-- Only the display is different +userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout + where + f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input" + f felem Nothing = do + us <- getCurrentUser -- getEnv cookieuser + if us == anonymous + then return (felem, Nothing) + else return([fromStr us], Just us) + +-- | Display a logout link if the user is logged. Nothing otherwise +maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m () +maybeLogout= do + us <- getCurrentUser + if us/= anonymous + then do + cmd <- ajax $ const $ return "window.location=='/'" --refresh + fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout + 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 + +-- | If not logged, it present a page flow which askm 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. +wlogin :: (MonadIO m,Functor m,FormInput v) => View v m () +wlogin= do + username <- getCurrentUser + if username /= anonymous + then return username + else do + name <- getString Nothing <! hint "login name" <! size 9 <++ ftag "br" mempty + pass <- getPassword <! hint "password" <! size 9 + <++ ftag "br" mempty + <** submitButton "login" + val <- userValidate (name,pass) + case val of + Just msg -> notValid msg + Nothing -> login name >> (return name) + + `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ") + ++> submitButton "logout") -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout")) + `wcallback` const (logout >> wlogin) + +focus = [("onload","this.focus()")] +hint s= [("placeholder",s)] +size n= [("size",show n)] + +getEdited1 id= do + Medit stored <- getSessionData `onNothing` return (Medit M.empty) + return $ fromMaybe [] $ M.lookup id stored + +-- | Return the list of edited widgets (added by the active widgets) for a given identifier +getEdited + :: (Typeable v, Typeable a, MonadState (MFlowState view) m) => + B.ByteString -> m [View v m1 a] +getEdited id= do + r <- getEdited1 id + let (_,ws)= unzip r + return ws + +-- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter +delEdited + :: (Typeable v, Typeable a, MonadIO m, + MonadState (MFlowState view) m) + => B.ByteString -- ^ identifier + -> [View v m1 a] -> m () -- ^ withess +delEdited id witness=do + Medit stored <- getSessionData `onNothing` return (Medit (M.empty)) + let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored + + return $ ws `asTypeOf` witness + liftIO $ mapM flushCached ks + let stored'= M.delete id stored + setSessionData . Medit $ stored' + + + +-- setEdited id ([] `asTypeOf` (zip (repeat "") witness)) + +setEdited id ws= do + Medit stored <- getSessionData `onNothing` return (Medit (M.empty)) + let stored'= M.insert id ws stored + setSessionData . Medit $ stored' + + +addEdited id w= do + ws <- getEdited1 id + setEdited id (w:ws) + + +modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v) + => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString +modifyWidget selector modifier w = View $ do + ws <- getEdited selector + let n = length (ws `asTypeOf` [w]) + let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w) + let cw = wcached key 0 w + addEdited selector (key,cw) + FormElm form _ <- runView cw + let elem= toByteString $ mconcat form + return . FormElm [] . Just $ selector <> "." <> modifier <>"('" <> elem <> "');" + where + typ :: View v Identity a -> a + typ = undefined + +-- | Return the javascript to be executed on the browser to prepend a widget to the location +-- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression +-- . It stores the added widgets in the edited list, that is accessed with 'getEdited' +-- +-- The resulting string can be executed in the browser. 'ajax' will return the code to +-- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler. +-- +-- This example will insert a widget in the div when the element with identifier +-- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned +-- and the list of edited widgets are deleted. +-- +-- > id1<- genNewId +-- > let sel= "$('#" <> fromString id1 <> "')" +-- > callAjax <- ajax . const $ prependWidget sel wn +-- > let installevents= "$(document).ready(function(){\ +-- > \$('#clickelem').click(function(){"++callAjax "''"++"});})" +-- > +-- > requires [JScriptFile jqueryScript [installevents] ] +-- > ws <- getEdited sel +-- > r <- (div <<< manyOf ws) <! [("id",id1)] +-- > delEdited sel ws' +-- > return r + +prependWidget + :: (Typeable a, MonadIO m, Executable m, FormInput v) + => B.ByteString -- ^ jquery selector + -> View v Identity a -- ^ widget to prepend + -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser +prependWidget sel w= modifyWidget sel "prepend" w + +-- | Like 'prependWidget' but append the widget instead of prepend. +appendWidget + :: (Typeable a, MonadIO m, Executable m, FormInput v) => + B.ByteString -> View v Identity a -> View v m B.ByteString +appendWidget sel w= modifyWidget sel "append" w + +-- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element +setWidget + :: (Typeable a, MonadIO m, Executable m, FormInput v) => + B.ByteString -> View v Identity a -> View v m B.ByteString +setWidget sel w= modifyWidget sel "html" w + + +-- | Inside a tag, it add and delete widgets of the same type. When the form is submitted +-- or a wlink is pressed, this widget return the list of validated widgets. +-- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/ +-- that the user will choose. +-- +-- This example add or delete editable text boxes, with two initial boxes with +-- /hi/, /how are you/ as values. Tt uses blaze-html: +-- +-- > r <- ask $ addLink +-- > ++> br +-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid" +-- > <++ br +-- > <** submitButton "send" +-- > +-- > ask $ p << (show r ++ " returned") +-- > ++> wlink () (p << text " back to menu") +-- > mainmenu +-- > where +-- > addLink = a ! At.id "addid" +-- > ! href "#" +-- > $ text "add" +-- > delBox = input ! type_ "checkbox" +-- > ! checked "" +-- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)" +-- > getString1 mx= El.div <<< delBox ++> getString mx <++ br + +wEditList :: (Typeable a,Read a + ,FormInput view + ,Functor m,MonadIO m, Executable m) + => (view ->view) -- ^ The holder tag + -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string + -> [String] -- ^ The initial list of values. + -> String -- ^ The id of the button or link that will create a new list element when clicked + -> View view m [a] +wEditList holderview w xs addId = do + let ws= map (w . Just) xs + wn= w Nothing + id1<- genNewId + let sel= "$('#" <> fromString id1 <> "')" + callAjax <- ajax . const $ prependWidget sel wn + let installevents= "$(document).ready(function(){\ + \$('#"++addId++"').click(function(){"++callAjax "''"++"});})" + + requires [JScriptFile jqueryScript [installevents] ] + + ws' <- getEdited sel + + r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)] + 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 + + + +-- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box. +wautocomplete + :: (Show a, MonadIO m, FormInput v) + => Maybe String -- ^ Initial value + -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings + -> View v m String +wautocomplete mv autocomplete = do + text1 <- genNewId + ajaxc <- ajax $ \u -> do + r <- liftIO $ autocomplete u + return $ jaddtoautocomp text1 r + + + requires [JScriptFile jqueryScript [] -- [events] + ,CSSFile jqueryCSS + ,JScriptFile jqueryUI []] + + + getString mv <! [("type", "text") + ,("id", text1) + ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" ) + ,("autocomplete", "off")] + + + where + jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });" + + +-- | Produces a text box. It gives a autocompletion list to the textbox. When return +-- is pressed in the textbox, the box content is used to create a widget of a kind defined +-- by the user, which will be situated above of the textbox. When submitted, the result is the content +-- of the created widgets (the validated ones). +-- +-- 'wautocompleteList' is an specialization of this widget, where +-- the widget parameter is fixed, with a checkbox that delete the eleement when unselected +-- . This fixed widget is as such (using generic 'FormElem' class tags): +-- +-- > ftag "div" <<< ftag "input" mempty +-- > `attrs` [("type","checkbox") +-- > ,("checked","") +-- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")] +-- > ++> ftag "span" (fromStr $ fromJust x ) +-- > ++> whidden( fromJust x) +wautocompleteEdit + :: (Typeable a, MonadIO m,Functor m, Executable m + , FormInput v) + => String -- ^ the initial text of the box + -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options. + -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box + -> [String] -- ^ initial set of values + -> View v m [a] -- ^ resulting widget +wautocompleteEdit phold autocomplete elem values= do + id1 <- genNewId + let textx= id1++"text" + let sel= "$('#" <> fromString id1 <> "')" + ajaxc <- ajax $ \(c:u) -> + case c of + 'f' -> prependWidget sel (elem $ Just u) + _ -> do + r <- liftIO $ autocomplete u + return $ jaddtoautocomp textx r + + + requires [JScriptFile jqueryScript [events textx ajaxc] + ,CSSFile jqueryCSS + ,JScriptFile jqueryUI []] + + ws' <- getEdited sel + + r<- (ftag "div" mempty `attrs` [("id", id1)] + ++> allOf (ws' ++ (map (changeMonad . elem . Just) values))) + <++ ftag "input" mempty + `attrs` [("type", "text") + ,("id", textx) + ,("placeholder", phold) + ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" ) + ,("autocomplete", "off")] + delEdited sel ws' + return r + 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;" ++ + ajaxc "'f'+v"++";"++ + " $('#"++textx++"').val('');\ + \ }\ + \ });\ + \});" + + jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });" + +-- | A specialization of 'wutocompleteEdit' which make appear each chosen option with +-- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements. +wautocompleteList + :: (Functor m, MonadIO m, Executable m, FormInput v) => + String -> (String -> IO [String]) -> [String] -> View v m [String] +wautocompleteList phold serverproc values= + wautocompleteEdit phold serverproc wrender1 values + where + wrender1 x= ftag "div" <<< ftag "input" mempty + `attrs` [("type","checkbox") + ,("checked","") + ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")] + ++> ftag "span" (fromStr $ fromJust x ) + ++> whidden( fromJust x) + +------- Templating and localization --------- + +data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable) + +instance Indexable TField where + key (TField k _)= k + defPath _= "texts/" + + +instance Serializable TField where + 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 + + +readtField text k= atomically $ do + let ref = getDBRef k + mr <- readDBRef ref + case mr of + Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text + Nothing -> return text + +-- | Creates a rich text editor aroun a text field or a text area widget.+-- This code:+--+-- > page $ p "Insert the text"+-- > ++> htmlEdit ["bold","italic"] ""+-- > (getMultilineText "" <! [("rows","3"),("cols","80")]) <++ br+-- > <** submitButton "enter"+--+-- Creates a rich text area with bold and italic buttons. The buttons are the ones alled+-- in the nicEdit editor. +htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a +htmlEdit buttons jsuser w = do + 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\ + \})};\n" + install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n" + + requires [JScriptFile nicEditUrl [installHtmlField,install]] + w <! [("id",id)] + + + + +-- | A widget that display the content of an html, But if the user has edition privileges, +-- it permits to edit it in place. So the editor could see the final appearance +-- of what he writes. +-- +-- When the user click the save, the content is saved and +-- identified by the key. Then, from now on, all the users will see the saved +-- content instead of the code content. +-- +-- The content is saved in a file by default (/texts/ in this versions), but there is +-- a configurable version (`tFieldGen`). The content of the element and the formatting +-- is cached in memory, so the display is, theoretically, very fast. +-- + +tFieldEd + :: (Functor m, MonadIO m, Executable m, + FormInput v) => + UserStr -> Key -> v -> View v m () +tFieldEd muser k text= wfreeze k 0 $ do + content <- liftIO $ readtField text k + nam <- genNewId + let ipanel= nam++"panel" + name= nam++"-"++k + install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n" + getTexts :: (Token -> IO ()) + getTexts token = do + let (k,s):_ = tenv token + liftIO $ do + writetField k $ (fromStrNoEncode s `asTypeOf` text) + flushCached k + sendFlush token $ HttpData [] [] "" + return() + + requires [JScriptFile nicEditUrl [install] + ,JScript ajaxSendText + ,JScript installEditField +-- ,JScriptFile jqueryScript [] + ,ServerProc ("_texts", transient getTexts)] + + (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\ + \})};\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\ + \};\n" + +-- | a text field. Read the cached field value and present it without edition. +tField :: (MonadIO m,Functor m, Executable m, FormInput v) + => Key + -> View v m () +tField k = wfreeze k 0 $ do + content <- liftIO $ readtField (fromStrNoEncode "not found") k + notValid content + +-- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the +-- two characters of the language used. +mFieldEd muser k content= do + lang <- getLang + tFieldEd muser (k ++ ('-':lang)) content + + + +-- | A multilanguage version of tField +mField k= do + lang <- getLang + tField $ k ++ ('-':lang) + +newtype IteratedId= IteratedId String deriving Typeable + +-- | Permits to iterate the presentation of data and//or input fields and widgets within +-- a web page that does not change. The placeholders are created with dField. Both are widget +-- modifiers: The latter gets a widget and create a placeholder in the page that is updated +-- via ajax. The content of the update is the rendering of the widget at each iteration. +-- The former gets a wider widget which contains dField elements and permit the iteration. +-- Whenever a link or a form within the witerate widget is activated, the result is the +-- placeholders filled with the new html content. This content can be data, a input field, +-- a link or a widget. No navigation happens. +-- +-- This permits even faster updates than autoRefresh. since the latter refresh the whole +-- widget and it does not permits modifications of the layout at runtime. +-- +-- When edTemplate or template is used on top of witerate, the result is editable at runtime, +-- and the span placeholders generated, that are updated via ajax can be relocated within +-- the layout of the template. +-- +-- Additionally, contrary to some javascript frameworks, the pages generated with this +-- mechanism are searchable by web crawlers. + +witerate + :: (MonadIO m, Functor m, FormInput v) => + View v m a -> View v m a +witerate w= do + name <- genNewId + setSessionData $ IteratedId name + st <- get + let index= mfPIndex st + let t= mfkillTime st + let installAutoEval= + "$(document).ready(function(){\n\ + \autoEvalLink('"++name++"','"++ show index ++"');\ + \autoEvalForm('"++name++"');\ + \})\n" + let r = lookup ("auto"++name) $ mfEnv st + ret <- case r of + Nothing -> do + requires [JScript autoEvalLink + ,JScript autoEvalForm + ,JScript setId + ,JScript $ timeoutscript t + ,JScriptFile jqueryScript [installAutoEval]] + + (ftag "div" <<< w) <! [("id",name)] + + + Just sind -> View $ do + let t= mfToken st +-- let index= read sind +-- put st{mfPIndex= index} + modify $ \s -> s{mfRequirements=[]} + + FormElm _ mr <- runView w + + reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements + let js = jsRequirements reqs + liftIO . sendFlush t $ HttpData + (("Cache-Control", "no-cache, no-store"):mfHttpHeaders st) + (mfCookies st) (fromString js) + modify $ \st -> st{mfAutorefresh=True,inSync=True} + return $ FormElm [] mr + + delSessionData $ IteratedId name + 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\ + \}\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\+ \\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\ + \}"++--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" + +-- | Present a widget via AJAX if it is within a 'witerate' context. In the first iteration it present the +-- widget surrounded by a placeholder. subsequent iterations will send just the javascript code +-- necessary for the refreshing of the placeholder. +dField + :: (Monad m, FormInput view) => + View view m b -> View view m b +dField w= View $ do + id <- genNewId + FormElm vs mx <- runView w + let render = mconcat vs + 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 + else do + requires [JScript $ "setId('"++id++"','" ++ toString (toByteString $ render)++"');\n"] + return $ FormElm mempty mx + +noid= "noid" + + +edTemplate + :: (MonadIO m, FormInput v, Typeable a) => + UserStr -> Key -> View v m a -> View v m a +edTemplate muser k w= View $ do + nam <- genNewId + + let ipanel= nam++"panel" + name= nam++"-"++k + install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n" + + + requires [JScriptFile nicEditUrl [install] + ,JScript ajaxSendText + ,JScript installEditField + ,JScriptFile jqueryScript [] + ,ServerProc ("_texts", transient getTexts)] + + FormElm text mx <- runView w + content <- liftIO $ readtField (mconcat text) k + + return $ FormElm [ftag "div" mempty `attrs` [("id",ipanel)] + ,ftag "span" content `attrs` [("id", name)]] + mx + where + getTexts :: (Token -> IO ()) + getTexts token= do + let (k,s):_ = tenv token + liftIO $ do + writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w) + flushCached k + sendFlush token $ HttpData [] [] "" + return() + + viewFormat :: View v m a -> v + viewFormat= undefined -- is a type function + +-- | Does the same than template but without the edition facility +template k w= View $ do + FormElm text mx <- runView w + let content= unsafePerformIO $ readtField (mconcat text) k + return $ FormElm [content] mx + + + +------------------- JQuery widgets ------------------- +-- | present the JQuery datepicker calendar to choose a date. +-- The second parameter is the configuration. Use \"()\" by default. +-- See http://jqueryui.com/datepicker/ +datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int) +datePicker conf jd= do + id <- genNewId + let setit= "$(document).ready(function() {\ + \$( '#"++id++"' ).datepicker "++ conf ++";\ + \});" + + requires + [CSSFile jqueryCSS + ,JScriptFile jqueryScript [] + ,JScriptFile jqueryUI [setit]] + + s <- getString jd <! [("id",id)] + let (month,r) = span (/='/') s + let (day,r2)= span(/='/') $ tail r + return (read day,read month, read $ tail r2) + +-- | present a jQuery dialog with a widget. When a button is pressed it return the result. +-- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see <http://jqueryui.com/dialog/> for +-- the available configurations. +-- +-- The enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.f +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\ + \});" + + modify $ \st -> st{needForm= HasForm} + requires + [CSSFile jqueryCSS + ,JScriptFile jqueryScript [] + ,JScriptFile jqueryUI [setit]] + + (ftag "div" <<< insertForm w) <! [("id",id),("title", title)] + + + + + +-- | Capture the form or link submissions and send them via jQuery AJAX. +-- The response is the new presentation of the widget, that is updated. No new page is generated +-- but the functionality is equivalent. Only the activated widget rendering is updated +-- in the client, so a widget with autoRefresh can be used in heavyweight pages. +-- If AJAX/JavaScript are not available, the widget is refreshed normally, via a new page. +-- +-- autoRefresh encloses the widget in a form tag if it includes form elements. +-- +-- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements +autoRefresh + :: (MonadIO m, + FormInput v) + => View v m a + -> View v m a +autoRefresh = update "html" + +-- | In some cases, it is neccessary that a link or form inside a 'autoRefresh' or 'update' block +-- should not be autorefreshed, since it produces side effects in the rest of the page that +-- affect to the rendering of the whole. If you like to refresh the whole page, simply add +-- noAutoRefresh attribute to the widget to force the refresh of the whole page when it is activated. +-- +-- That behaviour is common at the last sentence of the 'autoRefresh' block. +-- +-- This is a cascade menu example. +-- +-- > r <- page $ autoRefresh $ ul <<< do +-- > li <<< wlink OptionA << "option A" +-- > ul <<< li <<< (wlink OptionA1 << "Option A1" <! noAutoRefresh) +-- > <|> li <<< (wlink OptionA2 << "Option A2" <! noAutoRefresh) +-- > <|>... +-- > maybe other content +-- > +-- > case r of +-- > OptionA1 -> pageA1 +-- > OptionA2 -> pageA2 +-- +-- when @option A@ is clicked, the two sub-options appear with autorefresh. Only the two +-- lines are returned by the server using AJAX. but when Option A1-2 is pressed we want to +-- present other pages, so we add the noAutorefresh attribute. +-- +-- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags. +noAutoRefresh= [("class","_noAutoRefresh")] + +-- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget +-- +-- all the comments and remarks of `autoRefresh` apply here +appendUpdate :: (MonadIO m, + FormInput v) + => View v m a + -> View v m a +appendUpdate= update "append" + +-- | does the same than `autoRefresh` but prepend the result of each request before the current widget content +-- +-- all the comments and remarks of `autoRefresh` apply here +prependUpdate :: (MonadIO m, + FormInput v) + => View v m a + -> View v m a +prependUpdate= update "prepend" + +update :: (MonadIO m, FormInput v) + => B.ByteString + -> View v m a + -> View v m a +update method w= View $ 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+ st <- get+ let insync = inSync st + let r= lookup ("auto"++id) $ mfEnv st + if r == Nothing || insync == False+ 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 + + let HttpData ctype c s= toHttpData $ method <> " " <> toByteString (mconcat 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 + + 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\ + \}\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\+ \\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\ + \};" + ++ +-- 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\ + \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n" + + +data UpdateMethod= Append | Prepend | Html deriving Show + +-- | continously execute a widget and update the content. +-- The update method specify how the update is done. 'Html' means a substitution of content. +-- The second parameter is the delay for the next retry in case of disconnection, in milliseconds. +-- +-- It can be used to show data updates in the server. The widget is executed in a different process than +-- the one of the rest of the page. +-- Updates in the session context are not seen by the push widget. It has his own context. +-- To communicate with te widget, use DBRef's or TVar and the +-- STM semantics for waiting updates using 'retry'. +-- +-- Widgets in a push can have links and forms, but since they are asunchonous, they can not +-- return inputs. but they can modify the server state. +-- push ever return an invalid response to the calling widget, so it never +-- triggers the advance of the navigation. +-- +-- +-- This example is a counter increased each second: +-- +-- > pushIncrease= do +-- > tv <- liftIO $ newTVarIO 0 +-- > page $ push 0 Html $ do +-- > n <- atomic $ readTVar tv +-- > atomic $ writeTVar tv $ n + 1 +-- > liftIO $ threadDelay 1000000 +-- > b << (show n) ++> noWidget +-- +-- +-- This other simulates a console output that echoes what is entered in a text box +-- below. It has two widgets: a push output in append mode and a text box input. +-- The communication uses a TVar. The push widget wait for updates in the TVar. +-- because the second widget uses autoRefresh, all happens in the same page. +-- +-- It is recommended to add a timeout to the push widget, like in the example: +-- +-- > pushSample= do +-- > tv <- liftIO $ newTVarIO $ Just "init" +-- > page $ push Append 1000 (disp tv) <** input tv +-- > +-- > where +-- > disp tv= do +-- > setTimeouts 100 0 +-- > line <- tget tv +-- > p << line ++> noWidget +-- > +-- > input tv= autoRefresh $ do +-- > line <- getString Nothing <** submitButton "Enter" +-- > tput tv line +-- > +-- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE" +-- > +-- > tget tv= atomic $ do +-- > mr <- readTVar tv +-- > case mr of +-- > Nothing -> retry +-- > Just r -> do +-- > writeTVar tv Nothing +-- > return r + +push :: FormInput v + => UpdateMethod + -> Int + -> View v IO () + -> View v IO () +push method' wait w= push' . map toLower $ show method' + where + push' method= do + id <- genNewId + st <- get + let token= mfToken st + + procname= "_push" ++ tind token ++ id + installscript= + "$(document).ready(function(){\n" + ++ "ajaxPush('"++id++"',"++show wait++");" + ++ "})\n" + + new <- gets newAsk + + when new $ do + killWF procname token{twfname= procname} + let proc= transient . runFlow . ask $ w' + requires [ServerProc (procname, proc), + JScript $ ajaxPush procname, + JScriptFile jqueryScript [installscript]] + + (ftag "div" <<< noWidget) <! [("id",id)] + <++ ftag "div" mempty `attrs` [("id",id++"status")] + + where + w' = do + modify $ \s -> s{inSync= True,newAsk=True} + w + + + + 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\ + \}" + + + + +-- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default. +-- See http://jqueryui.com/spinner +getSpinner + :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) => + 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\ + \});" + requires + [CSSFile jqueryCSS + ,JScriptFile jqueryScript [] + ,JScriptFile jqueryUI [setit]] + + getTextBox mv <! [("id",id)] + + + +
src/MFlow/Wai.hs view
@@ -5,7 +5,7 @@ , DeriveDataTypeable , FlexibleInstances , OverloadedStrings #-} - + module MFlow.Wai( module MFlow.Cookies ,module MFlow @@ -21,7 +21,8 @@ import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail) import Data.ByteString.Lazy(fromChunks) -import qualified Data.ByteString.Char8 as SB +import Data.ByteString.UTF8 hiding (span)+import qualified Data.ByteString as SB hiding (pack, unpack) import Control.Concurrent(ThreadId(..)) import System.IO.Unsafe import Control.Concurrent.MVar @@ -29,7 +30,7 @@ import Control.Monad.Trans import Control.Exception import qualified Data.Map as M -import Data.Maybe +import Data.Maybe import Data.TCache import Data.TCache.DefaultPersistence import Control.Workflow hiding (Indexable(..)) @@ -45,7 +46,7 @@ import qualified Data.Conduit.List as CList import Data.CaseInsensitive import System.Time -import qualified Data.Text as T +import qualified Data.Text as T --import Debug.Trace @@ -60,25 +61,22 @@ p'= reverse p in case p' of [] -> [] - p' -> if T.null $ head p' then reverse(tail p') else p + p' -> if T.null $ head p' then reverse(tail p') else p - - puser env = fromMaybe anonymous $ fmap SB.unpack $ lookup ( mk $SB.pack cookieuser) $ requestHeaders env - - pind env= fromMaybe (error ": No FlowID") $ fmap SB.unpack $ lookup (mk flow) $ requestHeaders env + + puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env + + pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env getParams= mkParams1 . requestHeaders where mkParams1 = Prelude.map mkParam1 - mkParam1 ( x,y)= (SB.unpack $ original x, SB.unpack y) + mkParam1 ( x,y)= (toString $ original x, toString y) -- getServer env= serverName env -- getPath env= pathInfo env -- getPort env= serverPort env - - - splitPath ""= ("","","") splitPath str= let @@ -90,7 +88,7 @@ waiMessageFlow :: Application waiMessageFlow req1= do - let httpreq1= requestHeaders req1 + let httpreq1= requestHeaders req1 let cookies = getCookies httpreq1 @@ -98,9 +96,9 @@ Just fl -> return (fl, []) Nothing -> do fl <- liftIO $ newFlow - return (fl, [(flow, fl, "/",Nothing):: Cookie]) - -{- for state persistence in cookies + return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie]) + +{- for state persistence in cookies putStateCookie req1 cookies let retcookies= case getStateCookie req1 of Nothing -> retcookies1 @@ -109,26 +107,19 @@ input <- case parseMethod $ requestMethod req1 of Right POST -> do -#if MIN_VERSION_wai(2, 0, 0) + inp <- liftIO $ requestBody req1 $$ CList.consume -#else - inp <- liftIO $ runResourceT (requestBody req1 $$ CList.consume) -#endif + return . parseSimpleQuery $ SB.concat inp - - + + Right GET -> - let tail1 s | s==SB.empty =s - tail1 xs= SB.tail xs - in return . Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1 - - let req = case retcookies of - [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ" @@ -168,16 +159,16 @@ - + {- persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} where - writeResource stat= modifyMVar_ tvresources $ \mmap -> + writeResource stat= modifyMVar_ tvresources $ \mmap -> case mmap of Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] readResource stat= do - mstr <- withMVar tvresources $ \mmap -> + mstr <- withMVar tvresources $ \mmap -> case mmap of Just map -> return $ M.lookup (keyResource stat) map Nothing -> return Nothing @@ -185,7 +176,7 @@ Nothing -> return Nothing Just str -> return $ deserialize str - deleteResource stat= modifyMVar_ tvresources $ \mmap-> + deleteResource stat= modifyMVar_ tvresources $ \mmap-> case mmap of Just map -> return $ Just $ M.delete (keyResource stat) map Nothing -> return $ Nothing
src/MFlow/Wai/Blaze/Html/All.hs view
@@ -24,6 +24,7 @@ ,module Text.Blaze.Html5.Attributes ,module Control.Monad.IO.Class ,runNavigation +,runSecureNavigation ) where import MFlow @@ -43,12 +44,13 @@ import Control.Workflow (Workflow, unsafeIOtoWF) -import Control.Applicative-import Control.Monad(when) +import Control.Applicative +import Control.Monad(when, unless) import Control.Monad.IO.Class import System.Environment import Data.Maybe(fromMaybe) import Data.Char(isNumber) +import Network.Wai.Handler.WarpTLS as TLS -- | The port is read from the first exectution parameter. -- If no parameter, it is read from the PORT environment variable. @@ -66,14 +68,25 @@ print porti return porti --- | run a persistent flow. It uses `getPort` to get the port--- The first parameter is the first element in the URL path.+-- | run a persistent flow. It uses `getPort` to get the port +-- The first parameter is the first element in the URL path. -- It also set the home page -runNavigation :: String -> FlowM Html (Workflow IO) () -> IO Bool -runNavigation n f= do- when(not $ null n) $ setNoScript n - addMessageFlows[(n, runFlow f)] - porti <- getPort - wait $ run porti waiMessageFlow+runNavigation :: String -> FlowM Html (Workflow IO) () -> IO () +runNavigation n f= do + unless (null n) $ setNoScript n + addMessageFlows[(n, runFlow f)] + porti <- MFlow.Wai.Blaze.Html.All.getPort + wait $ run porti waiMessageFlow --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. + +runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings + +runSecureNavigation' :: TLSSettings -> Settings -> String -> FlowM Html (Workflow IO) () -> IO () +runSecureNavigation' t s n f = do + unless (null n) $ setNoScript n + addMessageFlows[(n, runFlow f)] + porti <- getPort + wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
src/MFlow/Wai/Response.hs view
@@ -4,8 +4,8 @@ import Network.Wai import MFlow.Cookies -import Data.ByteString.Char8 as SB -import Data.ByteString.Lazy.Char8 as B + +import Data.ByteString.Lazy.UTF8 import MFlow import Data.Typeable import Data.Monoid @@ -14,7 +14,7 @@ import Data.CaseInsensitive import Network.HTTP.Types import Control.Workflow(WFErrors(..)) -import Data.String +--import Data.String --import Debug.Trace -- --(!>)= flip trace @@ -46,11 +46,11 @@ instance ToResponse Response where toResponse = id -instance ToResponse B.ByteString where +instance ToResponse ByteString where toResponse x= responseLBS status200 [mkparam contentHtml] x instance ToResponse String where - toResponse x= responseLBS status200 [mkparam contentHtml] $ B.pack x + toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x instance ToResponse HttpData where toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs <> cookieHeaders cookies)) x