diff --git a/Demos/demos.blaze.hs b/Demos/demos.blaze.hs new file mode 100644 --- /dev/null +++ b/Demos/demos.blaze.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, NoMonomorphismRestriction #-} +module Main where +import MFlow.Wai.Blaze.Html.All +import MFlow.Forms.Internals +import Text.Blaze.Html5 as El +import Text.Blaze.Html5.Attributes as At hiding (step) +import Data.String +import Data.List +import MFlow +import MFlow.FileServer +import Data.TCache +import Data.TCache.Memoization +import Data.Typeable +import Control.Monad.Trans +import Control.Concurrent +import Control.Exception as E +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Maybe +import Data.Monoid + +--test= runTest [(15,"shop")] + +main= do + setAdminUser "admin" "admin" + syncWrite SyncManual + setFilesPath "" + addFileServerWF + addMessageFlows [("" ,transient $ runFlow mainmenu) + ,("shop" ,runFlow shopCart)] + wait $ run 80 waiMessageFlow + +-- adminLoop + +stdheader c= html << El.head << body << (p << text "You can press the back button" <> c) + +data Options= CountI | CountS | Radio + | Login | TextEdit |Grid | Autocomp | AutocompList + | ListEdit |Shop | Action | Ajax | Select + | CheckBoxes deriving (Bounded, Enum,Read, Show,Typeable) + +mainmenu= do + setHeader stdheader + r <- ask $ br ++> wlink CountI (b << text "increase an Int") + <|> br ++> wlink CountS (b << text "increase a String") + <|> br ++> wlink Action (b << text "Example of action, executed when a widget is validated") + <|> br ++> wlink Select (b << text "select options") + <|> br ++> wlink CheckBoxes (b << text "checkboxes") + <|> br ++> wlink Radio (b << text "Radio buttons") + <++ br <> br <> b << text "DYNAMIC WIDGETS" + <|> br ++> wlink Ajax (b << text "AJAX example") + <|> br ++> wlink Autocomp (b << text "autocomplete") + <|> br ++> wlink AutocompList (b << text "autocomplete List") + <|> br ++> wlink ListEdit (b << text "list edition") + <|> br ++> wlink Grid (b << text "grid") + <|> br ++> wlink TextEdit (b << text "Content Management") + + <++ br <> br <> b << text "OTHERS" + <|> br ++> wlink Shop (b << text "example of transfer to another flow (shopping)") + <|> br ++> wlink Login (b << text "login/logout") + <++ (br <> a ! href "shop" << text "shopping") -- ordinary Blaze.Html link + + + case r of + CountI -> clickn 0 + CountS -> clicks "1" + Action -> actions 1 + Ajax -> ajaxsample + Select -> options + CheckBoxes -> checkBoxes + TextEdit -> textEdit + Grid -> grid + Autocomp -> autocomplete1 + AutocompList -> autocompList + ListEdit -> wlistEd + Radio -> radio + Login -> login + Shop -> transfer "shop" + + + +options= do + r <- ask $ getSelect (setSelectedOption ("" :: String) (p << text "select a option") <|> + setOption "blue" (b << text "blue") <|> + setOption "Red" (b << text "red") ) wlink () (p << text " menu") + + mainmenu -- breturn() would do it as well + where + dosummit= [("onchange","this.form.submit()")] + +checkBoxes= do + r <- ask $ getCheckBoxes( (setCheckBox False "Red" <++ b << text "red") + <> (setCheckBox False "Green" <++ b << text "green") + <> (setCheckBox False "blue" <++ b << text "blue")) + <** submitButton "submit" + + ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu") + mainmenu + +autocomplete1= do + r <- ask $ wautocomplete (Just "red,green,blue") filter1 + <** submitButton "submit" + ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu") + mainmenu + where + filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] + +autocompList= do + r <- ask $ wautocompleteList "red,green,blue" filter1 ["red"] + <** submitButton "submit" + ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu") + mainmenu + where + filter1 s = return $ filter (isPrefixOf s) ["red","reed rose","green","green grass","blue","blues"] + +grid = do + let row _= tr <<< ( (,) <$> tdborder <<< getInt (Just 0) + <*> tdborder <<< getString (Just "text") + <++ tdborder << delLink) + addLink= a ! href "#" + ! At.id "wEditListAdd" + << text "add" + delLink= a ! href "#" + ! onclick "this.parentNode.parentNode.parentNode.removeChild(this.parentNode.parentNode)" + << text "delete" + tdborder= td ! At.style "border: solid 1px" + + r <- ask $ addLink ++> ( wEditList table row ["",""]) <** submitButton "submit" + ask $ p << (show r ++ " returned") + ++> wlink () (p << text " back to menu") + + mainmenu + +wlistEd= do + r <- ask $ addLink + ++> br + ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) + <++ br + <** submitButton "send" + + ask $ p << (show r ++ " returned") + ++> wlink () (p << text " back to menu") + mainmenu + where + addLink = a ! At.id "wEditListAdd" + ! href "#" + $ text "add" + delBox = input ! type_ "checkbox" + ! checked "" + ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)" + getString1 mx= El.div <<< delBox ++> getString mx <++ br + +clickn (n :: Int)= do + setHeader stdheader + r <- ask $ wlink ("menu" :: String) (p << text "menu") + |+| getInt (Just n) <* submitButton "submit" + case r of + (Just _,_) -> mainmenu + (_, Just n') -> clickn $ n'+1 + + +clicks s= do + setHeader stdheader + s' <- ask $ (getString (Just s) + <* submitButton "submit") + `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) + clicks $ s'++ "1" + +radio = do + r <- ask $ getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]] + ask $ p << ( show r ++ " selected") ++> wlink () (p << text " menu") + mainmenu + + +-- +--askr :: (Read a,Show a,FormInput v,MonadIO m) +-- => String -> a -> (a -> View v m b) -> FlowM v m b +--askr id param w = do +-- let key= addrStr w +-- w'= do +-- env <- getEnv +-- let link= "param="++show param +-- requires[JScript $ "document.getElementById('"++id++"').outerHtml="] +-- let par = fromMaybe param $ fmap read $ lookup "param" env +-- w par +-- +---- liftIO $ addMessageFlows [(key, wstateless w')] +-- ask w' + + +ajaxsample= do + r <- 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) wlink () (p << text " menu") + mainmenu + + +--actions n=do +-- ask $ wlink () (p << text "exit from action") +-- <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) + + +actions n= do + r<- ask $ (getString $ Just "widget1") `waction` action + <+> (getString $ Just "widget2") `waction` action + <** submitButton "submit" + ask $ p << ( show r ++ " returned") ++> wlink () (p << text " menu") + mainmenu + where + action n= ask $ getString (Just $ n ++ " action")<** submitButton "submit action" + +data ShopOptions= IPhone | IPod | IPad deriving (Bounded, Enum,Read, Show, Typeable) + +-- A persistent flow (uses step). The process is killed after 10 seconds of inactivity +-- but it is restarted automatically. if you restart the program, it remember the shopping cart +-- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow. +shopCart = do + setTimeouts 10 0 + shopCart1 (V.fromList [0,0,0:: Int]) + where + shopCart1 cart= do + o <- step . ask $ + 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)))) + <++ tr << td << linkHome + ) + let i =fromEnum o + let newCart= cart V.// [(i, cart V.! i + 1 )] + shopCart1 newCart + + where + linkHome= a ! href (fromString noScript) << b << text "home" + + +login= do + ask $ p << text "Please login with admin/admin" + ++> userWidget (Just "admin") userLogin + user <- getCurrentUser + ask $ b << text ("user logged as " <> T.pack user) ++> wlink () (p << text " logout and go to menu") + logout + mainmenu + +-- an example of content management +textEdit= do + setHeader $ \t -> html << body << t + + let first= p << i << + (El.span << text "this is a page with" + <> b << text " two " <> El.span << text "paragraphs") + + second= p << i << text "This is the original text of the second paragraph" + + pageEditable = (tFieldEd "first" first) + **> (tFieldEd "second" second) + + ask $ first + ++> second + ++> wlink () (p << text "click here to edit it") + + + ask $ p << text "Please login with admin/admin to edit it" + ++> userWidget (Just "admin") userLogin + + ask $ p << text "now you can click the field and edit them" + ++> p << b << text "to save the edited field, double click on it" + ++> pageEditable + **> wlink () (p << text "click here to see it as a normal user") + + logout + + ask $ p << text "the user sees the edited content. He can not edit" + ++> pageEditable + **> wlink () (p << text "click to continue") + + ask $ p << text "When text 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 << text "End of edit field demo" ++> wlink () (p << text "click here to go to menu") + diff --git a/Demos/demos.hs b/Demos/demos.hs --- a/Demos/demos.hs +++ b/Demos/demos.hs @@ -1,111 +1,185 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -module Main where -import MFlow.Wai.XHtml.All -import Data.TCache -import Control.Monad.Trans -import Data.Typeable -import Control.Concurrent -import Control.Exception as E -import qualified Data.ByteString.Char8 as SB -import qualified Data.Vector as V -import Data.Maybe - - - -data Ops= Ints | Strings | Actions | Ajax | Opt deriving(Typeable,Read, Show) -main= do - setFilesPath "" - addFileServerWF - addMessageFlows [("" ,transient $ runFlow mainf) - ,("shop" ,runFlow shopCart)] - forkIO $ run 80 waiMessageFlow - adminLoop - -stdheader c= p << "you can press the back button to go to the menu"+++ c - -mainf= do - setHeader stdheader - r <- ask $ wlink Ints (bold << "increase an Int") - <|> br ++> wlink Strings (bold << "increase a String") - <|> br ++> wlink Actions (bold << "Example of a string widget with an action") - <|> br ++> wlink Ajax (bold << "Simple AJAX example") - <|> br ++> wlink Opt (bold << "select options") - <++ (br +++ linkShop) -- this is an ordinary XHtml link - - case r of - Ints -> clickn 0 - Strings -> clicks "1" - Actions -> actions 1 - Ajax -> ajaxsample - Opt -> options - mainf - where - linkShop= toHtml $ hotlink "shop" << "shopping" - -options= do - r <- ask $ getSelect (setSelectedOption "" (p <<"select a option") <|> - setOption "blue" (bold << "blue") <|> - setOption "Red" (bold << "red") ) wlink () (p<< " menu") - breturn() - where - dosummit= [("onchange","this.form.submit()")] - -clickn (n :: Int)= do - setHeader stdheader - r <- ask $ wlink "menu" (p << "menu") - |+| getInt (Just n) <* submitButton "submit" - case r of - (Just _,_) -> breturn () - (_, Just n') -> clickn $ n'+1 - - -clicks s= do - setHeader stdheader - s' <- ask $ (getString (Just s) - <* submitButton "submit") - `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) - clicks $ s'++ "1" - - -ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html - - - -ajaxsample= do - setHeader ajaxheader - let ajaxf n= return $ "document.getElementById('text1').value='"++show(read n +1)++"'" - ajaxc <- ajaxCommand "document.getElementById('text1').value" ajaxf - - ask $ (getInt (Just 0) thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] - ++> (tbody - <<< tr ! [rowspan 2] << td << linkHome - ++> (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) - <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) - <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2))) - <++ tr << td << linkHome - ) - - let newCart= cart V.// [(i, cart V.! i + 1 )] - shopCart1 newCart - where - linkHome= (toHtml $ hotlink noScript << bold << "home") +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, NoMonomorphismRestriction #-} +module Main where +<<<<<<< HEAD +import MFlow.Wai.XHtml.All -- hiding (ask) +======= +import MFlow.Hack.XHtml.All -- hiding (ask) +>>>>>>> 393fb07bfb3f14b6557dff6fb36fedfcbb786ac6 +--import MFlow.Forms.Test +import MFlow +import MFlow.FileServer +import MFlow.Forms.Ajax +import MFlow.Forms.Admin +import MFlow.Forms +<<<<<<< HEAD +import Text.XHtml +======= +>>>>>>> 393fb07bfb3f14b6557dff6fb36fedfcbb786ac6 +import Data.TCache +import Control.Monad.Trans +import Data.Typeable + +import Control.Concurrent +import Control.Exception as E +import qualified Data.ByteString.Char8 as SB +import qualified Data.Vector as V +import Data.Maybe + +--test= runTest [(15,"shop")] + +main= do + syncWrite SyncManual + setFilesPath "" + addFileServerWF + addMessageFlows [("" ,transient $ runFlow mainf), + ("shop" ,runFlow shopCart)] +<<<<<<< HEAD + wait $ run 80 waiMessageFlow +-- adminLoop -- for debug + +stdheader c= thehtml << body << (p << "you can press the back button to go to the menu"+++ c) +======= + run 80 hackMessageFlow + + adminLoop + +stdheader c= thehtml << body << (p << "you can press the back button"+++ c) +>>>>>>> 393fb07bfb3f14b6557dff6fb36fedfcbb786ac6 + +data Options= CountI | CountS | TextEdit |Shop | Action | Ajax | Select deriving (Bounded, Enum,Read, Show,Typeable) + +mainf= do + setHeader stdheader + r <- ask $ br ++> wlink TextEdit (bold << "Content Management") + <|> br ++> wlink Shop (bold << "example of transfer to another flow (shopping)") + <|> br ++> wlink CountI (bold << "increase an Int") + <|> br ++> wlink CountS (bold << "increase a String") + <|> br ++> wlink Action (bold << "Example of a string widget with an action") + <|> br ++> wlink Ajax (bold << "Simple AJAX example") + <|> br ++> wlink Select (bold << "select options") + <++ (br +++ linkShop) -- this is an ordinary XHtml link + + + case r of + CountI -> clickn 0 + CountS -> clicks "1" + Action -> actions 1 + Ajax -> ajaxsample + Select -> options + TextEdit -> textEdit + Shop -> transfer "shop" + mainf + + where + linkShop= toHtml $ hotlink "shop" << "shopping" + +options= do + r <- ask $ getSelect (setSelectedOption "" (p <<"select a option") <|> + setOption "blue" (bold << "blue") <|> + setOption "Red" (bold << "red") ) wlink () (p<< " menu") + breturn() + where + dosummit= [("onchange","this.form.submit()")] + +clickn (n :: Int)= do + setHeader stdheader + r <- ask $ wlink "menu" (p << "menu") + |+| getInt (Just n) <* submitButton "submit" + case r of + (Just _,_) -> breturn () + (_, Just n') -> clickn $ n'+1 + + +clicks s= do + setHeader stdheader + s' <- ask $ (getString (Just s) + <* submitButton "submit") + `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) + clicks $ s'++ "1" + + + +ajaxsample= do + let ajaxf n= return $ "document.getElementById('text1').value='"++show(read n +1)++"'" + ajaxc <- ajaxCommand "document.getElementById('text1').value" ajaxf + + ask $ requires[JScript ajaxScript] + >> getInt (Just 0) thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] + ++> (tbody + <<< tr ! [rowspan 2] << td << linkHome + ++> (tr <<< td <<< wlink IPhone (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) + <|> tr <<< td <<< wlink IPad (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) + <|> tr <<< td <<< wlink IPod (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2))) + <++ tr << td << linkHome + ) + let i =fromEnum o + let newCart= cart V.// [(i, cart V.! i + 1 )] + shopCart1 newCart + + where + linkHome= (toHtml $ hotlink noScript << bold << "home") + + + + +-- an example of content management +textEdit= do + setHeader $ \html -> thehtml << body << html + + let first= p << italics << + (thespan << "this is a page with" + +++ bold << " two " +++ thespan << "paragraphs") + + second= p << italics << "This is the original text of the second paragraph" + + pageEditable = (tFieldEd "first" first) + **> (tFieldEd "second" second) + + ask $ first + ++> second + ++> wlink () (p << "click here to edit it") + + setAdminUser "admin" "admin" + + ask $ p << "Please login with admin/admin to edit it" + ++> userWidget (Just "admin") userLogin + + ask $ p << "now you can click the field and edit them" + ++> p << bold << "to save the edited field, double click on it" + ++> pageEditable + **> wlink () (p << "click here to see it as a normal user") + + logout + + ask $ p << "the user sees the edited content. He can not edit" + ++> pageEditable + **> wlink () (p << "click to continue") + + ask $ p << "When text 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") + breturn () diff --git a/MFlow.cabal b/MFlow.cabal --- a/MFlow.cabal +++ b/MFlow.cabal @@ -1,17 +1,16 @@ name: MFlow -version: 0.1.5.5 -cabal-version: >= 1.6 +version: 0.2.0.0 +cabal-version: >=1.6 build-type: Simple license: BSD3 license-file: LICENSE maintainer: agocorona@gmail.com stability: experimental synopsis: Web app server for stateful processes with safe, composable user interfaces. - description: A Web framework with some unique features thanks to the power of the Haskell language. MFlow run stateful server processes; All the flow of request and responses are coded by the programmer in a single function. Allthoug single request-response flows and callbacks are possible. Therefore, the code is - more understandable. + more understandable.f . These processes are stopped and restarted by the application server on demand, including its execution state. Therefore session management @@ -42,36 +41,34 @@ . -Clustering . - category: Web, Application Server author: Alberto Gómez Corona data-dir: "" -extra-source-files: src/MFlow/Forms/HSP.hs - , src/MFlow/Hack/Response.hs, src/MFlow/Hack.hs - , src/MFlow/Hack/XHtml.hs, src/MFlow/Hack/XHtml/All.hs - , Demos/ShoppingCart.hs, Demos/ShoppingCart.Wai.hs - , Demos/demos.hs +extra-source-files: Demos/ShoppingCart.hs Demos/ShoppingCart.Wai.hs + Demos/demos.hs Demos/demos.blaze.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 - - exposed-modules: MFlow.Forms - MFlow.Forms.Admin MFlow MFlow.FileServer - MFlow.Forms.Ajax MFlow.Cookies - MFlow.Wai.Response, MFlow.Wai, MFlow.Wai.XHtml.All - MFlow.Forms.XHtml - + 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, fay -any, + random -any, hsp == 0.7.1, hack -any, hack-handler-simpleserver -any, + blaze-html -any, blaze-markup -any + exposed-modules: MFlow.Wai.Blaze.Html.All + MFlow.Forms MFlow.Forms.Admin MFlow MFlow.FileServer + MFlow.Cookies MFlow.Wai + MFlow.Wai.XHtml.All MFlow.Forms.XHtml MFlow.Forms.HSP + MFlow.Hack MFlow.Hack.XHtml + MFlow.Hack.XHtml.All MFlow.Forms.Blaze.Html MFlow.Forms.Test + MFlow.Forms.Widgets + other-modules: MFlow.Forms.Internals MFlow.Wai.Response MFlow.Hack.Response exposed: True buildable: True hs-source-dirs: src . - other-modules: -source-repository head - type: git - location: http://github.com/agocorona/MFlow diff --git a/src/MFlow.hs b/src/MFlow.hs --- a/src/MFlow.hs +++ b/src/MFlow.hs @@ -4,7 +4,8 @@ the source identification and the verb invoked. The scheduler executed the appropriate workflow (using the workflow package). The workflow may send additional messages to the source, identified by a 'Token' -. The computation state is optionally logged and recovered. +. The computation state is optionally logged. on timeout, the process is killed. When invoked again +the execution state is recovered as if no interruption took place. The message communication is trough polimorphic, monoidal queues. There is no asumption about message codification, so instantiations @@ -20,17 +21,24 @@ "MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format +"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html + "MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format +There are some @*.All@ packages thant contain a mix of these instantiations. +For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with +Wai and +Blaze-html + + In order to manage resources, there are primitives that kill the process and its state after a timeout. All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface. -Fragment based streaming 'sendFragment' 'sendEndFragment' are provided only at this level. +Fragment based streaming 'sendFragment' are provided only at this level. -'stateless' and 'transient' server processeses are also possible. `stateless` are request-response - with no intermediate messaging dialog. `transient` processes have no persistent - state, so they restart anew after a timeout or a crash. +'stateless' and 'transient' server processeses are also possible. the first are request-response + . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash. -} @@ -43,9 +51,10 @@ ,FlexibleContexts ,RecordWildCards ,OverloadedStrings + ,ScopedTypeVariables #-} module MFlow ( -Params, Workflow, HttpData(..),Processable(..), ToHttpData(..) +Flow, Params, HttpData(..),Processable(..) , Token(..), ProcList -- * low level comunication primitives. Use `ask` instead ,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment @@ -55,7 +64,7 @@ ,noScript,hlog, setNotFoundResponse,getNotFoundResponse, -- * ByteString tags -- | very basic but efficient tag formatting -btag, bhtml, bbody,Attribs +btag, bhtml, bbody,Attribs, addAttrs -- * internal use ,addTokenToList,deleteTokenInList, msgScheduler) @@ -78,25 +87,27 @@ import Data.TCache.DefaultPersistence hiding(Indexable(..)) import Data.ByteString.Lazy.Char8 as B (ByteString, concat,pack, unpack,empty,append,cons,fromChunks) - +import Data.ByteString.Lazy.Internal (ByteString(Chunk)) import qualified Data.Map as M import System.IO import System.Time import Control.Workflow import MFlow.Cookies import Control.Monad.Trans +import qualified Control.Exception as CE + --import Debug.Trace --(!>)= flip trace +type Flow= (Token -> Workflow IO ()) ---type Header= (String,String) data HttpData = HttpData Params [Cookie] ByteString | Error WFErrors ByteString deriving (Typeable, Show) -instance ToHttpData HttpData where - toHttpData= id - -instance ToHttpData ByteString where - toHttpData bs= HttpData [] [] bs +--instance ToHttpData HttpData where +-- toHttpData= id +-- +--instance ToHttpData ByteString where +-- toHttpData bs= HttpData [] [] bs instance Monoid HttpData where mempty= HttpData [] [] empty @@ -106,7 +117,7 @@ type ProcList = WorkflowList IO Token () -data Req = forall a.( Processable a,Typeable a)=> Req a deriving Typeable +data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable type Params = [(String,String)] @@ -119,6 +130,11 @@ -- getPath :: a -> String -- getPort :: a -> Int +instance Processable Token where + pwfname = twfname + puser = tuser + pind = tind + getParams = tenv instance Processable Req where pwfname (Req x)= pwfname x @@ -141,10 +157,10 @@ -- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable` -- message that arrives and send the mesage to the appropriate flow. -data Token = Token{twfname,tuser, tind :: String , q :: MVar Req, qr :: MVar Resp} deriving Typeable +data Token = Token{twfname,tuser, tind :: String , tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable instance Indexable Token where - key (Token w u i _ _ )= + key (Token w u i _ _ _ )= if u== anonymous then u++ i -- ++ "@" ++ w else u -- ++ "@" ++ w @@ -153,8 +169,8 @@ instance Read Token where readsPrec _ ('T':'o':'k':'e': 'n':' ':str1) - | anonymous `isPrefixOf` str1= [(Token w anonymous i (newVar 0) (newVar 0), tail str2)] - | otherwise = [(Token w ui "0" (newVar 0) (newVar 0), tail str2)] + | anonymous `isPrefixOf` str1= [(Token w anonymous i [] (newVar 0) (newVar 0), tail str2)] + | otherwise = [(Token w ui "0" [] (newVar 0) (newVar 0), tail str2)] where @@ -182,13 +198,13 @@ getToken msg= do qmap <- readMVar iorefqmap - let u= puser msg ; w= pwfname msg ; i=pind msg + let u= puser msg ; w= pwfname msg ; i=pind msg; penv= getParams msg let mqs = M.lookup ( i ++ w ++ u) qmap case mqs of Nothing -> do q <- newEmptyMVar -- `debug` (i++w++u) qr <- newEmptyMVar - let token= Token w u i q qr + let token= Token w u i penv q qr addTokenToList token return token @@ -202,30 +218,31 @@ return $ debug x (str++" => Workflow "++ show x) -} -- | send a complete response -send :: ToHttpData a => Token -> a -> IO() -send (Token _ _ _ queue qresp) msg= do - putMVar qresp . Resp $ toHttpData msg +send :: Token -> HttpData -> IO() +send t@(Token _ _ _ _ _ qresp) msg= do + ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ thread t) sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush " -- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' -sendFragment :: ToHttpData a => Token -> a -> IO() -sendFragment (Token _ _ _ _ qresp) msg= putMVar qresp . Fragm $ toHttpData msg - -sendEndFragment :: ToHttpData a => Token -> a -> IO() -sendEndFragment (Token _ _ _ _ qresp ) msg= putMVar qresp . EndFragm $ toHttpData msg +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 --emptyReceive (Token queue _ _)= emptyQueue queue receive :: Typeable a => Token -> IO a receive t= receiveReq t >>= return . fromReq -flushRec t@(Token _ _ _ queue _)= do +flushRec t@(Token _ _ _ _ queue _)= do empty <- isEmptyMVar queue when (not empty) $ takeMVar queue >> return () receiveReq :: Token -> IO Req -receiveReq (Token _ _ _ queue _)= readMVar queue -- !> "receiveReqSTM" +receiveReq t@(Token _ _ _ _ queue _)= readMVar queue -- !> (">>>>>> receive "++ thread t) fromReq :: Typeable a => Req -> a fromReq (Req x) = x' where @@ -244,32 +261,40 @@ let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t) -delMsgHistory t = do - +delMsgHistory t = do let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t - delWFHistory1 statKey -- `debug` "delWFHistory" + delWFHistory1 statKey -- `debug` "delWFHistory" -- | executes a simple monadic computation that receive the params and return a response -- --- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow` -stateless :: (ToHttpData b) => (Params -> IO b) -> (Token -> Workflow IO ()) -stateless f = transient $ \tk ->do - req <- receiveReq tk +-- It is used with `addMessageFlows` +-- +-- There is a higuer level version @wstateless@ in "MFLow.Forms" +stateless :: (Params -> IO HttpData) -> Flow +stateless f = transient proc + where + proc t@(Token _ _ _ _ queue qresp) = loop t queue qresp + loop t queue qresp=do + req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t) resp <- f (getParams req) - sendFlush tk resp + (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t) + loop t queue qresp -- !> ("enviado stateless " ++ thread t) +-- + + -- | Executes a monadic computation that send and receive messages, but does -- not store its state in permanent storage. The process once stopped, will restart anew -- ---- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow` -transient :: (Token -> IO ()) -> (Token -> Workflow IO ()) +transient :: (Token -> IO ()) -> Flow transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) ) -_messageFlows :: MVar (M.Map String (Token-> Workflow IO ())) -_messageFlows= unsafePerformIO $ newMVar M.empty -- [(String,Token -> Workflow IO ())]) +_messageFlows :: MVar (M.Map String Flow) +_messageFlows= unsafePerformIO $ newMVar M.empty -- | add a list of flows to be scheduled. Each entry in the list is a pair @(path, flow)@ addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union ms (M.fromList $ map flt wfs)) @@ -279,28 +304,25 @@ -- | return the list of the scheduler getMessageFlows = readMVar _messageFlows -class ToHttpData a where - toHttpData :: a -> HttpData +--class ToHttpData a where +-- toHttpData :: a -> HttpData - +thread t= show(unsafePerformIO myThreadId) ++ " "++ show (twfname t) --tellToWF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c -tellToWF (Token _ _ _ queue qresp ) msg = do - putMVar queue $ Req msg - m <- takeMVar qresp -- !> ("********antes de recibir" ++ show(unsafePerformIO myThreadId)) +tellToWF t@(Token _ _ _ _ queue qresp ) msg = do + putMVar queue (Req msg) -- !> (">>>>> telltowf"++ thread t) + m <- takeMVar qresp -- !> ("<<<<<< tellTowf"++ thread t) case m of - Resp r -> return r -- !> ("*********** RECIBIDO"++ show(unsafePerformIO myThreadId)) + Resp r -> return r -- !> ("recibido tellTowf"++ thread t) Fragm r -> do result <- getStream r return result - - + where - getStream r = do mr <- takeMVar qresp - case mr of - Resp _ -> error "\"send\" used instead of \"sendFragment\" or \"sendEndFragment\"" + case mr of Fragm h -> do rest <- unsafeInterleaveIO $ getStream h let result= mappend r rest @@ -309,15 +331,17 @@ let result= mappend r h return result - + Resp h -> do + let result= mappend r h + return result --data Error= Error String deriving (Read, Show, Typeable) -instance ToHttpData String where - toHttpData= HttpData [] [] . pack +--instance ToHttpData String where +-- toHttpData= HttpData [] [] . pack -- | The scheduler creates a Token with every `Processable` -- message that arrives and send the mesage to the appropriate flow, get the response @@ -326,19 +350,21 @@ :: (Typeable a,Processable a) => a -> IO (HttpData, ThreadId) msgScheduler x = do - token <- getToken x - + token <- getToken x th <- startMessageFlow (pwfname x) token - r<- tellToWF token x + r <- tellToWF token x +-- liftIO $ print $ let HttpData _ _ r1=r in unpack r1 return (r,th) where - + --start the flow if not started yet startMessageFlow wfname token = forkIO $ do wfs <- getMessageFlows r <- startWF wfname token wfs -- !>( "init wf " ++ wfname) case r of - Left NotFound -> sendFlush token (Error NotFound $ "Not found: " <> pack wfname) + Left NotFound -> do + sendFlush token (Error NotFound $ "Not found: " <> pack wfname) + deleteTokenInList token Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname) Left Timeout -> return() -- !> "Timeout in msgScheduler" Left (WFException e)-> do @@ -347,9 +373,10 @@ logError user wfname e moveState wfname token token{tuser= "error/"++tuser token} - case user of - "admin" -> sendFlush token (show e) -- !> ("WF error: "++ show e) - _ -> sendFlush token ("An Error has ocurred." :: ByteString) + sendFlush token $ HttpData [("Content-Type", "text/plain")] [] $ + case user of + "admin" -> pack $ show e + _ -> "An Error has ocurred." Right _ -> do -- let msg= "finished Flow "++ wfname++ " restarting" @@ -385,7 +412,7 @@ setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f getNotFoundResponse= unsafePerformIO $ readIORef notFoundResponse --- basic bytestring XML tags +-- basic bytestring tags type Attribs= [(String,String)] -- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For -- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP". @@ -394,13 +421,21 @@ where pt= pack t attrs []= B.empty - attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs + attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs + -- | -- > bhtml ats v= btag "html" ats v bhtml :: Attribs -> ByteString -> ByteString bhtml ats v= btag "html" ats v + -- | -- > bbody ats v= btag "body" ats v bbody :: Attribs -> ByteString -> ByteString bbody ats v= btag "body" ats v + +addAttrs :: ByteString -> Attribs -> ByteString +addAttrs (Chunk "<" (Chunk tag(Chunk ">" rest))) rs= + Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> ">" <> rest + +addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ unpack other diff --git a/src/MFlow/Cookies.hs b/src/MFlow/Cookies.hs --- a/src/MFlow/Cookies.hs +++ b/src/MFlow/Cookies.hs @@ -1,7 +1,7 @@ {-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-} module MFlow.Cookies -(Cookie,ctype,urlDecode,cookieuser,cookieHeaders,getCookies) +(Cookie,contentHtml,urlDecode,cookieuser,cookieHeaders,getCookies) where import Control.Monad(MonadPlus(..), guard, replicateM_, when) import Data.Char @@ -19,7 +19,7 @@ import Control.Monad.Identity --import Text.Parsec.Token -ctype= ("Content-Type", "text/html") +contentHtml= ("Content-Type", "text/html") type Cookie= (String,String,String,Maybe String) @@ -35,12 +35,13 @@ cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs showCookie :: Cookie -> String -showCookie (n,v,p,me) = n <> "=" <> v <> "; path=" - <> p <> showMaxAge me <> "\n" +showCookie (n,v,p,me) = n <> "=" <> v <> + ";path=" <> p <> + showMaxAge me where showMaxAge Nothing = "" - showMaxAge (Just e) = "; Max-age=" <> e + showMaxAge (Just e) = ";Max-age=" <> e --showCookie :: Cookie -> String diff --git a/src/MFlow/FileServer.hs b/src/MFlow/FileServer.hs --- a/src/MFlow/FileServer.hs +++ b/src/MFlow/FileServer.hs @@ -1,331 +1,334 @@ -{- | A file server for frequently accessed files, such are static web pages and image decorations, icons etc -that are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of -the efficient GHC threads by frequent IO calls.So it enhances the performance -in the context of heavy concurrence. -It uses 'Data.TCache.Memoization'. -The caching-uncaching follows the `setPersist` criteria. --} ------------------------------------------------------------------------------ --- --- Module : FileServer --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- --- ------------------------------------------------------------------------------ -{-# OPTIONS -XScopedTypeVariables #-} -module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath - -) where - -import MFlow -import Control.Monad.State -import Data.TCache.Memoization -import MFlow.Forms.XHtml -import System.Directory -import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty) - -import Control.Exception as CE -import Data.Char -import Data.List -import System.IO.Unsafe -import Data.IORef -import Data.Monoid - ---import Debug.Trace ---(!>)= flip trace - -rfilesPath= unsafePerformIO $ newIORef "files/" - --- | Set the path of the files in the web server. The links to the files are relative to it -setFilesPath :: String -> IO () -setFilesPath path= writeIORef rfilesPath path - -pathPrm= "path" -fileServe ::(Token -> Workflow IO ()) -fileServe = stateless $ \env -> do - case lookup pathPrm env of - Nothing -> error " no file specified" - Just path' ->do - when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm - when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm - filesPath <- readIORef rfilesPath - let path= filesPath ++ path' - isDirectory <- doesDirectoryExist path -- !> path - case isDirectory of - True -> directory1 $ path ++ "/" - False -> do - isFile <- doesFileExist path - case isFile of - True -> servefile path - False -> return . pack $ "path not found" - - where - dropBack ".."= ".." - - dropBack path - - | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath - | otherwise= path - where - revpath= reverse path --- maybetail ""= "." - maybetail xs= tail xs - noperm= "no permissions" - ioerr x= \(e :: CE.IOException) -> x - servefile path= do - mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing) - case mr of - Nothing -> return . pack $ "no permissions" - Just r -> return r --- let ext = reverse . takeWhile (/='.') $ reverse path --- mmime= lookup (map toLower ext) mimeTable --- mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" --- mimet= [("Content-Type",mime)] --- in return r -- $ HttpData mimet [] r - --- | Is the flow to be added to the list in order to stream any file from the filesystem --- for example, images --- --- This app includes the fileServe flow: --- --- @ --- main= do --- addFileServerWF --- addMessageFlows messageFlows --- run 80 hackMessageFlow --- adminLoop --- where --- messageFlows= [(\"noscript\" , transient $ runFlow showStories) --- ,("\admin\" , transient $ runFlow admin) --- ,("\mail\" , transient $ runFlow mail)]@ --- --- Add the fileServer to the list of server flows -addFileServerWF= addMessageFlows [("file", fileServe)] - - - --- | Creates the url of file path. To be used in ordinary links to files. --- in Text.XHtml, a image would be embeded as --- --- > image ![src $ linkFile imagepath] --- --- in HSP: --- --- > - --- | Given the relative path of a file, it return the content of the @href@ element in a html link -linkFile :: String -> String -linkFile path= "file?path=" <> path - -directory :: Token -> Workflow IO () -directory = stateless $ \_ -> do - path <- readIORef rfilesPath - directory1 path - -directory1 path = do - fs <- getDirectoryContents path - return $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs] - -{- -mimeTable=[ - ("html", "text/html"), - ("htm", "text/html"), - ("txt", "text/plain"), - ("jpeg", "image/jpeg"), - ("pdf", "application/pdf"), - ("js", "application/x-javascript"), - ("gif", "image/gif"), - ("bmp", "image/bmp"), - ("ico", "image/x-icon"), - ("doc", "application/msword"), - ("jpg", "image/jpeg"), - ("eps", "application/postscript"), - ("zip", "application/zip"), - ("exe", "application/octet-stream"), - ("tif", "image/tiff"), - ("tiff", "image/tiff"), - ("mov", "video/quicktime"), - ("movie", "video/x-sgi-movie"), - ("mp2", "video/mpeg"), - ("mp3", "audio/mpeg"), - ("mpa", "video/mpeg"), - ("mpe", "video/mpeg"), - ("mpeg", "video/mpeg"), - ("mpg", "video/mpeg"), - ("mpp", "application/vnd.ms-project"), - ("323", "text/h323"), - ("*", "application/octet-stream"), - ("acx", "application/internet-property-stream"), - ("ai", "application/postscript"), - ("aif", "audio/x-aiff"), - ("aifc", "audio/x-aiff"), - ("aiff", "audio/x-aiff"), - ("asf", "video/x-ms-asf"), - ("asr", "video/x-ms-asf"), - ("asx", "video/x-ms-asf"), - ("au", "audio/basic"), - ("avi", "video/x-msvideo"), - ("axs", "application/olescript"), - ("bas", "text/plain"), - ("bcpio", "application/x-bcpio"), - ("bin", "application/octet-stream"), - ("c", "text/plain"), - ("cat", "application/vnd.ms-pkiseccat"), - ("cdf", "application/x-cdf"), - ("cdf", "application/x-netcdf"), - ("cer", "application/x-x509-ca-cert"), - ("class", "application/octet-stream"), - ("clp", "application/x-msclip"), - ("cmx", "image/x-cmx"), - ("cod", "image/cis-cod"), - ("cpio", "application/x-cpio"), - ("crd", "application/x-mscardfile"), - ("crl", "application/pkix-crl"), - ("crt", "application/x-x509-ca-cert"), - ("csh", "application/x-csh"), - ("css", "text/css"), - ("dcr", "application/x-director"), - ("der", "application/x-x509-ca-cert"), - ("dir", "application/x-director"), - ("dll", "application/x-msdownload"), - ("dms", "application/octet-stream"), - ("dot", "application/msword"), - ("dvi", "application/x-dvi"), - ("dxr", "application/x-director"), - ("eps", "application/postscript"), - ("etx", "text/x-setext"), - ("evy", "application/envoy"), - ("fif", "application/fractals"), - ("flr", "x-world/x-vrml"), - ("gtar", "application/x-gtar"), - ("gz", "application/x-gzip"), - ("h", "text/plain"), - ("hdf", "application/x-hdf"), - ("hlp", "application/winhlp"), - ("hqx", "application/mac-binhex40"), - ("hta", "application/hta"), - ("htc", "text/x-component"), - ("htt", "text/webviewhtml"), - ("ief", "image/ief"), - ("iii", "application/x-iphone"), - ("ins", "application/x-internet-signup"), - ("isp", "application/x-internet-signup"), - ("jfif", "image/pipeg"), - ("jpe", "image/jpeg"), - ("latex", "application/x-latex"), - ("lha", "application/octet-stream"), - ("lsf", "video/x-la-asf"), - ("lsx", "video/x-la-asf"), - ("lzh", "application/octet-stream"), - ("m13", "application/x-msmediaview"), - ("m14", "application/x-msmediaview"), - ("m3u", "audio/x-mpegurl"), - ("man", "application/x-troff-man"), - ("mdb", "application/x-msaccess"), - ("me", "application/x-troff-me"), - ("mht", "message/rfc822"), - ("mhtml", "message/rfc822"), - ("mid", "audio/mid"), - ("mny", "application/x-msmoney"), - ("mpv2", "video/mpeg"), - ("ms", "application/x-troff-ms"), - ("msg", "application/vnd.ms-outlook"), - ("mvb", "application/x-msmediaview"), - ("nc", "application/x-netcdf"), - ("nws", "message/rfc822"), - ("oda", "application/oda"), - ("p10", "application/pkcs10"), - ("p12", "application/x-pkcs12"), - ("p7b", "application/x-pkcs7-certificates"), - ("p7c", "application/x-pkcs7-mime"), - ("p7m", "application/x-pkcs7-mime"), - ("p7r", "application/x-pkcs7-certreqresp"), - ("p7s", "application/x-pkcs7-signature"), - ("pbm", "image/x-portable-bitmap"), - ("pfx", "application/x-pkcs12"), - ("pgm", "image/x-portable-graymap"), - ("pko", "application/ynd.ms-pkipko"), - ("pma", "application/x-perfmon"), - ("pmc", "application/x-perfmon"), - ("pml", "application/x-perfmon"), - ("pmr", "application/x-perfmon"), - ("pmw", "application/x-perfmon"), - ("pnm", "image/x-portable-anymap"), - ("pot", "application/vnd.ms-powerpoint"), - ("ppm", "image/x-portable-pixmap"), - ("pps", "application/vnd.ms-powerpoint"), - ("ppt", "application/vnd.ms-powerpoint"), - ("prf", "application/pics-rules"), - ("ps", "application/postscript"), - ("pub", "application/x-mspublisher"), - ("qt", "video/quicktime"), - ("ra", "audio/x-pn-realaudio"), - ("ram", "audio/x-pn-realaudio"), - ("ras", "image/x-cmu-raster"), - ("rgb", "image/x-rgb"), - ("rmi", "audio/mid"), - ("roff", "application/x-troff"), - ("rtf", "application/rtf"), - ("rtx", "text/richtext"), - ("scd", "application/x-msschedule"), - ("sct", "text/scriptlet"), - ("setpay", "application/set-payment-initiation"), - ("setreg", "application/set-registration-initiation"), - ("sh", "application/x-sh"), - ("shar", "application/x-shar"), - ("sit", "application/x-stuffit"), - ("snd", "audio/basic"), - ("spc", "application/x-pkcs7-certificates"), - ("spl", "application/futuresplash"), - ("src", "application/x-wais-source"), - ("sst", "application/vnd.ms-pkicertstore"), - ("stl", "application/vnd.ms-pkistl"), - ("stm", "text/html"), - ("sv4cpio", "application/x-sv4cpio"), - ("sv4crc", "application/x-sv4crc"), - ("svg", "image/svg+xml"), - ("swf", "application/x-shockwave-flash"), - ("t", "application/x-troff"), - ("tar", "application/x-tar"), - ("tcl", "application/x-tcl"), - ("tex", "application/x-tex"), - ("texi", "application/x-texinfo"), - ("texinfo", "application/x-texinfo"), - ("tgz", "application/x-compressed"), - ("tr", "application/x-troff"), - ("trm", "application/x-msterminal"), - ("tsv", "text/tab-separated-values"), - ("uls", "text/iuls"), - ("ustar", "application/x-ustar"), - ("vcf", "text/x-vcard"), - ("vrml", "x-world/x-vrml"), - ("wav", "audio/x-wav"), - ("wcm", "application/vnd.ms-works"), - ("wdb", "application/vnd.ms-works"), - ("wks", "application/vnd.ms-works"), - ("wmf", "application/x-msmetafile"), - ("wps", "application/vnd.ms-works"), - ("wri", "application/x-mswrite"), - ("wrl", "x-world/x-vrml"), - ("wrz", "x-world/x-vrml"), - ("xaf", "x-world/x-vrml"), - ("xbm", "image/x-xbitmap"), - ("xla", "application/vnd.ms-excel"), - ("xlc", "application/vnd.ms-excel"), - ("xlm", "application/vnd.ms-excel"), - ("xls", "application/vnd.ms-excel"), - ("xlt", "application/vnd.ms-excel"), - ("xlw", "application/vnd.ms-excel"), - ("xof", "x-world/x-vrml"), - ("xpm", "image/x-xpixmap"), - ("xwd", "image/x-xwindowdump"), - ("z", "application/x-compress") - - ] --} +{- | A file server for frequently accessed files, such are static web pages and image decorations, icons etc +that are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of +the efficient GHC threads by frequent IO calls.So it enhances the performance +in the context of heavy concurrence. +It uses 'Data.TCache.Memoization'. +The caching-uncaching follows the `setPersist` criteria. +-} +----------------------------------------------------------------------------- +-- +-- Module : FileServer +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- +-- +----------------------------------------------------------------------------- +{-# OPTIONS -XScopedTypeVariables #-} +module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath + +) where + +import MFlow +import MFlow.Cookies(contentHtml) +import Control.Monad.State +import Data.TCache.Memoization +import MFlow.Forms.XHtml +import System.Directory +import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty) + +import Control.Exception as CE +import Data.Char +import Data.List +import System.IO.Unsafe +import Data.IORef +import Data.Monoid + + +rfilesPath= unsafePerformIO $ newIORef "files/" + +-- | Set the path of the files in the web server. The links to the files are relative to it +setFilesPath :: String -> IO () +setFilesPath path= writeIORef rfilesPath path + +pathPrm= "path" +fileServe :: Flow +fileServe = stateless $ \env -> do + case lookup pathPrm env of + Nothing -> error " no file specified" + Just path' ->do + when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm + when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm + filesPath <- readIORef rfilesPath + let path= filesPath ++ path' + servefile path + -- isDirectory <- doesDirectoryExist path -- !> path + +-- case isDirectory of +-- True -> do +-- dir <- directory1 $ path ++ "/" +-- return $ HttpData (setMime "text/html") [] dir +-- False -> servefile path + + + where + setMime x= ("Content-Type",x) + + dropBack ".."= ".." + dropBack path + | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath + | otherwise= path + where + revpath= reverse path +-- maybetail ""= "." + maybetail xs= tail xs + noperm= "no permissions" + ioerr x= \(e :: CE.IOException) -> x + servefile path= do + mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing) + case mr of + Nothing -> return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible" + Just r -> + let ext = reverse . takeWhile (/='.') $ reverse path + mmime= lookup (map toLower ext) mimeTable + mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" + + in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r + +stringServer mime str= stateless +-- | Is the flow to be added to the list in order to stream any file from the filesystem +-- for example, images +-- +-- This app includes the fileServe flow: +-- +-- @ +-- main= do +-- addFileServerWF +-- addMessageFlows messageFlows +-- run 80 hackMessageFlow +-- adminLoop +-- where +-- messageFlows= [(\"noscript\" , transient $ runFlow showStories) +-- ,("\admin\" , transient $ runFlow admin) +-- ,("\mail\" , transient $ runFlow mail)]@ +-- +-- | Add the fileServer to the list of server flows +-- it is mandatory if you want to use the file service +addFileServerWF= addMessageFlows [("file", fileServe)] + + + +-- | Creates the url of file path. To be used in ordinary links to files. +-- in Text.XHtml, a image would be embeded as +-- +-- > image ![src $ linkFile imagepath] +-- +-- in HSP: +-- +-- > + +-- | Given the relative path of a file, it return the content of the @href@ element in a html link +linkFile :: String -> String +linkFile path= "file?path=" <> path + +directory :: Flow +directory = stateless $ \_ -> do + path <- readIORef rfilesPath + directory1 path + +directory1 path = do + fs <- getDirectoryContents path + return $ HttpData [contentHtml][] $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs] + + +mimeTable=[ + ("html", "text/html"), + ("htm", "text/html"), + ("txt", "text/plain"), + ("jpeg", "image/jpeg"), + ("pdf", "application/pdf"), + ("js", "application/x-javascript"), + ("gif", "image/gif"), + ("bmp", "image/bmp"), + ("ico", "image/x-icon"), + ("doc", "application/msword"), + ("jpg", "image/jpeg"), + ("eps", "application/postscript"), + ("zip", "application/zip"), + ("exe", "application/octet-stream"), + ("tif", "image/tiff"), + ("tiff", "image/tiff"), + ("mov", "video/quicktime"), + ("movie", "video/x-sgi-movie"), + ("mp2", "video/mpeg"), + ("mp3", "audio/mpeg"), + ("mpa", "video/mpeg"), + ("mpe", "video/mpeg"), + ("mpeg", "video/mpeg"), + ("mpg", "video/mpeg"), + ("mpp", "application/vnd.ms-project"), + ("323", "text/h323"), + ("*", "application/octet-stream"), + ("acx", "application/internet-property-stream"), + ("ai", "application/postscript"), + ("aif", "audio/x-aiff"), + ("aifc", "audio/x-aiff"), + ("aiff", "audio/x-aiff"), + ("asf", "video/x-ms-asf"), + ("asr", "video/x-ms-asf"), + ("asx", "video/x-ms-asf"), + ("au", "audio/basic"), + ("avi", "video/x-msvideo"), + ("axs", "application/olescript"), + ("bas", "text/plain"), + ("bcpio", "application/x-bcpio"), + ("bin", "application/octet-stream"), + ("c", "text/plain"), + ("cat", "application/vnd.ms-pkiseccat"), + ("cdf", "application/x-cdf"), + ("cdf", "application/x-netcdf"), + ("cer", "application/x-x509-ca-cert"), + ("class", "application/octet-stream"), + ("clp", "application/x-msclip"), + ("cmx", "image/x-cmx"), + ("cod", "image/cis-cod"), + ("cpio", "application/x-cpio"), + ("crd", "application/x-mscardfile"), + ("crl", "application/pkix-crl"), + ("crt", "application/x-x509-ca-cert"), + ("csh", "application/x-csh"), + ("css", "text/css"), + ("dcr", "application/x-director"), + ("der", "application/x-x509-ca-cert"), + ("dir", "application/x-director"), + ("dll", "application/x-msdownload"), + ("dms", "application/octet-stream"), + ("dot", "application/msword"), + ("dvi", "application/x-dvi"), + ("dxr", "application/x-director"), + ("eps", "application/postscript"), + ("etx", "text/x-setext"), + ("evy", "application/envoy"), + ("fif", "application/fractals"), + ("flr", "x-world/x-vrml"), + ("gtar", "application/x-gtar"), + ("gz", "application/x-gzip"), + ("h", "text/plain"), + ("hdf", "application/x-hdf"), + ("hlp", "application/winhlp"), + ("hqx", "application/mac-binhex40"), + ("hta", "application/hta"), + ("htc", "text/x-component"), + ("htt", "text/webviewhtml"), + ("ief", "image/ief"), + ("iii", "application/x-iphone"), + ("ins", "application/x-internet-signup"), + ("isp", "application/x-internet-signup"), + ("jfif", "image/pipeg"), + ("jpe", "image/jpeg"), + ("latex", "application/x-latex"), + ("lha", "application/octet-stream"), + ("lsf", "video/x-la-asf"), + ("lsx", "video/x-la-asf"), + ("lzh", "application/octet-stream"), + ("m13", "application/x-msmediaview"), + ("m14", "application/x-msmediaview"), + ("m3u", "audio/x-mpegurl"), + ("man", "application/x-troff-man"), + ("mdb", "application/x-msaccess"), + ("me", "application/x-troff-me"), + ("mht", "message/rfc822"), + ("mhtml", "message/rfc822"), + ("mid", "audio/mid"), + ("mny", "application/x-msmoney"), + ("mpv2", "video/mpeg"), + ("ms", "application/x-troff-ms"), + ("msg", "application/vnd.ms-outlook"), + ("mvb", "application/x-msmediaview"), + ("nc", "application/x-netcdf"), + ("nws", "message/rfc822"), + ("oda", "application/oda"), + ("p10", "application/pkcs10"), + ("p12", "application/x-pkcs12"), + ("p7b", "application/x-pkcs7-certificates"), + ("p7c", "application/x-pkcs7-mime"), + ("p7m", "application/x-pkcs7-mime"), + ("p7r", "application/x-pkcs7-certreqresp"), + ("p7s", "application/x-pkcs7-signature"), + ("png", "image/png"), + ("pbm", "image/x-portable-bitmap"), + ("pfx", "application/x-pkcs12"), + ("pgm", "image/x-portable-graymap"), + ("pko", "application/ynd.ms-pkipko"), + ("pma", "application/x-perfmon"), + ("pmc", "application/x-perfmon"), + ("pml", "application/x-perfmon"), + ("pmr", "application/x-perfmon"), + ("pmw", "application/x-perfmon"), + ("pnm", "image/x-portable-anymap"), + ("pot", "application/vnd.ms-powerpoint"), + ("ppm", "image/x-portable-pixmap"), + ("pps", "application/vnd.ms-powerpoint"), + ("ppt", "application/vnd.ms-powerpoint"), + ("prf", "application/pics-rules"), + ("ps", "application/postscript"), + ("pub", "application/x-mspublisher"), + ("qt", "video/quicktime"), + ("ra", "audio/x-pn-realaudio"), + ("ram", "audio/x-pn-realaudio"), + ("ras", "image/x-cmu-raster"), + ("rgb", "image/x-rgb"), + ("rmi", "audio/mid"), + ("roff", "application/x-troff"), + ("rtf", "application/rtf"), + ("rtx", "text/richtext"), + ("scd", "application/x-msschedule"), + ("sct", "text/scriptlet"), + ("setpay", "application/set-payment-initiation"), + ("setreg", "application/set-registration-initiation"), + ("sh", "application/x-sh"), + ("shar", "application/x-shar"), + ("sit", "application/x-stuffit"), + ("snd", "audio/basic"), + ("spc", "application/x-pkcs7-certificates"), + ("spl", "application/futuresplash"), + ("src", "application/x-wais-source"), + ("sst", "application/vnd.ms-pkicertstore"), + ("stl", "application/vnd.ms-pkistl"), + ("stm", "text/html"), + ("sv4cpio", "application/x-sv4cpio"), + ("sv4crc", "application/x-sv4crc"), + ("svg", "image/svg+xml"), + ("swf", "application/x-shockwave-flash"), + ("t", "application/x-troff"), + ("tar", "application/x-tar"), + ("tcl", "application/x-tcl"), + ("tex", "application/x-tex"), + ("texi", "application/x-texinfo"), + ("texinfo", "application/x-texinfo"), + ("tgz", "application/x-compressed"), + ("tr", "application/x-troff"), + ("trm", "application/x-msterminal"), + ("tsv", "text/tab-separated-values"), + ("uls", "text/iuls"), + ("ustar", "application/x-ustar"), + ("vcf", "text/x-vcard"), + ("vrml", "x-world/x-vrml"), + ("wav", "audio/x-wav"), + ("wcm", "application/vnd.ms-works"), + ("wdb", "application/vnd.ms-works"), + ("wks", "application/vnd.ms-works"), + ("wmf", "application/x-msmetafile"), + ("wps", "application/vnd.ms-works"), + ("wri", "application/x-mswrite"), + ("wrl", "x-world/x-vrml"), + ("wrz", "x-world/x-vrml"), + ("xaf", "x-world/x-vrml"), + ("xbm", "image/x-xbitmap"), + ("xla", "application/vnd.ms-excel"), + ("xlc", "application/vnd.ms-excel"), + ("xlm", "application/vnd.ms-excel"), + ("xls", "application/vnd.ms-excel"), + ("xlt", "application/vnd.ms-excel"), + ("xlw", "application/vnd.ms-excel"), + ("xof", "x-world/x-vrml"), + ("xpm", "image/x-xpixmap"), + ("xwd", "image/x-xwindowdump"), + ("z", "application/x-compress") + + ] + diff --git a/src/MFlow/Forms.hs b/src/MFlow/Forms.hs --- a/src/MFlow/Forms.hs +++ b/src/MFlow/Forms.hs @@ -11,1771 +11,1333 @@ -XIncoherentInstances -XTypeFamilies -XTypeOperators - -XOverloadedStrings -#-} - -{- | 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 function. 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 () 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 () 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: - -[@Back Button@] This is probably the first implementation of an stateful Web framework that works well with the back button thanks -to monad magic. (See ) - -[@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 execute an internal computation. -Callbacks are necessary for the creation of abstract container -widgets that may not know the behaviour of its content. 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@] it is not only possible to add Html formatting, but also to add atributes to a formlet element. -This example has three formLet elements with the attribute "size" added, and a string prepended to the second password box. - -> userFormLine= -> (User <$> getString (Just "enter user") <*> getPassword <+> submitButton "login") -> <+> fromString " password again" ++> getPassword <* submitButton "register" - - -[@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. - - -[@AJAX@] See "MFlow.Forms.Ajax" - - -[@File Server@] With file caching. See "MFlow.FileServer" - -This is a complete example, that can be run with runghc, which show some of these features: - -> {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -> module Main where -> import MFlow.Wai.XHtml.All -> import Data.TCache -> import Control.Monad.Trans -> import Data.Typeable -> import Control.Concurrent -> import Control.Exception as E -> import qualified Data.ByteString.Char8 as SB -> import qualified Data.Vector as V -> import Data.Maybe -> -> data Ops= Ints | Strings | Actions | Ajax | Opt deriving(Typeable,Read, Show) -> main= do -> setFilesPath "" -> addFileServerWF -> addMessageFlows [("" ,transient $ runFlow mainf) -> ,("shop" ,runFlow shopCart)] -> forkIO $ run 80 waiMessageFlow -> adminLoop -> -> stdheader c= p << "you can press the back button to go to the menu"+++ c -> -> mainf= do -> setHeader stdheader -> r <- ask $ wlink Ints (bold << "increase an Int") -> <|> br ++> wlink Strings (bold << "increase a String") -> <|> br ++> wlink Actions (bold << "Example of a string widget with an action") -> <|> br ++> wlink Ajax (bold << "Simple AJAX example") -> <|> br ++> wlink Opt (bold << "select options") -> <++ (br +++ linkShop) -- this is an ordinary XHtml link -> -> case r of -> Ints -> clickn 0 -> Strings -> clicks "1" -> Actions -> actions 1 -> Ajax -> ajaxsample -> Opt -> options -> mainf -> where -> linkShop= toHtml $ hotlink "shop" << "shopping" -> -> options= do -> r <- ask $ getSelect (setOption "blue" (bold << "blue") <|> -> setSelectedOption "Red" (bold << "red") ) ask $ p << (r ++ " selected") ++> wlink () (p<< " menu") -> breturn() -> where -> dosummit= [("onchange","this.form.submit()")] -> -> clickn (n :: Int)= do -> setHeader stdheader -> r <- ask $ wlink "menu" (p << "menu") -> |+| getInt (Just n) <* submitButton "submit" -> case r of -> (Just _,_) -> breturn () -> (_, Just n') -> clickn $ n'+1 -> -> -> clicks s= do -> setHeader stdheader -> s' <- ask $ (getString (Just s) -> <* submitButton "submit") -> `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) -> clicks $ s'++ "1" -> -> -> ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html -> -> ajaxsample= do -> setHeader ajaxheader -> ajaxc <- ajaxCommand "document.getElementById('text1').value" -> (\n -> return $ "document.getElementById('text1').value='"++show(read n +1)++"'") -> ask $ (getInt (Just 0) breturn() -> -> actions n=do -> ask $ wlink () (p << "exit from action") -> <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) -> breturn () -> -> -- A persistent flow (uses step). The process is killed after 10 seconds of inactivity -> -- but it is restarted automatically. if you restart the program, it remember the shopping cart -> -- defines a table with links enclosed that return ints and a link to the menu, that abandon this flow. -> shopCart = do -> setTimeouts 10 0 -> shopCart1 (V.fromList [0,0,0:: Int]) -> where -> shopCart1 cart= do -> i <- step . ask $ -> table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] -> <<< caption << "choose an item" -> ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] -> ++> (tbody -> <<< tr ! [rowspan 2] << td << linkHome -> ++> (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) -> <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) -> <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2))) -> <++ tr << td << linkHome -> ) -> -> let newCart= cart V.// [(i, cart V.! i + 1 )] -> shopCart1 newCart -> where -> linkHome= (toHtml $ hotlink noScript << bold << "home") - --} - -module MFlow.Forms( - --- * Basic definitions -FormLet(..), -FlowM,View, FormInput(..) - --- * Users -,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName -,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin, userWidget, --- * User interaction -ask, clearEnv, --- * formLets --- | they mimic the HTML form elements. --- It is possible to modify their attributes with the `),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>), - --- * 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 -(<<<),(<++),(++>),(.) - --- * ByteString tags -,btag,bhtml,bbody - --- * Normalization -, flatten, normalize, ToByteString(..) - --- * Running the flow monad -,runFlow,runFlowIn,MFlow.Forms.step, goingBack,breturn - --- * Setting parameters -,setHeader -,getHeader -,setTimeouts - --- * Cookies -,setCookie - -) -where -import Data.TCache -import Data.TCache.DefaultPersistence -import Data.TCache.Memoization -import MFlow -import MFlow.Cookies -import Data.RefSerialize hiding((<|>)) -import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) - -import qualified Data.CaseInsensitive as CI -import Data.Typeable -import Data.Monoid -import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import Data.Maybe -import Control.Applicative -import Control.Exception - -import Control.Workflow as WF -import Control.Monad.Identity -import Unsafe.Coerce -import Data.List(intersperse) -import Data.IORef - -import System.IO.Unsafe -import Data.Char(isNumber) -import Network.HTTP.Types.Header - ---import Debug.Trace ---import System.IO (hFlush,stdout) ---(!>)= flip trace - - -instance Serialize a => Serializable a where - serialize= runW . showp - deserialize= runR readp - -data User= User - { userName :: String - , upassword :: String - } deriving (Read, Show, Typeable) - -eUser= User (error1 "username") (error1 "password") - -error1 s= error $ s ++ " undefined" - -userPrefix= "User#" -instance Indexable User where - key User{userName= user}= keyUserName user - --- | return the key name of an user -keyUserName n= userPrefix++n - --- | Register an user/password -userRegister :: MonadIO m => String -> String -> m (DBRef User) -userRegister user password = liftIO . atomically $ newDBRef $ User user password - - - --- | Authentication against `userRegister`ed users. --- to be used with `validate` -userValidate :: MonadIO m => (UserStr,PasswdStr) -> m (Maybe String) -userValidate (u,p) = - let user= eUser{userName=u} - in liftIO $ atomically - $ withSTMResources [user] - $ \ mu -> case mu of - [Nothing] -> resources{toReturn= err } - [Just (User _ pass )] -> resources{toReturn= - case pass==p of - True -> Nothing - False -> err - } - - where - err= Just "Username or password invalid" - -data Config = Config UserStr deriving (Read, Show, Typeable) - -keyConfig= "MFlow.Config" -instance Indexable Config where key _= keyConfig -rconf= getDBRef keyConfig - -setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m () -setAdminUser user password= liftIO $ atomically $ do - newDBRef $ User user password - writeDBRef rconf $ Config user - -getAdminName :: MonadIO m => m UserStr -getAdminName= liftIO $ atomically ( readDBRef rconf `onNothing` error "admin user not set" ) >>= \(Config u) -> return u - - ---test= runBackT $ do --- liftRepeat $ print "hola" --- n2 <- lift $ getLine --- lift $ print "n3" --- --- n3 <- lift $ getLine --- if n3 == "back" --- then fail "" --- else lift $ print $ n2++n3 - - -data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable) - - -instance (Serialize a) => Serialize (FailBack a ) where - showp (BackPoint x)= insertString (pack iCanFailBack) >> showp x - showp (NoBack x)= insertString (pack noFailBack) >> showp x - showp GoBack = insertString (pack repeatPlease) - - readp = choice [icanFailBackp,repeatPleasep,noFailBackp] - where - noFailBackp = {-# SCC "deserialNoBack" #-} symbol noFailBack >> readp >>= return . NoBack - icanFailBackp = {-# SCC "deserialBackPoint" #-} symbol iCanFailBack >> readp >>= return . BackPoint - repeatPleasep = {-# SCC "deserialbackPlease" #-} symbol repeatPlease >> return GoBack - -iCanFailBack= "B" -repeatPlease= "G" -noFailBack= "N" - -newtype BackT m a = BackT { runBackT :: m (FailBack a ) } - ---instance Monad m => Monad (BackT m) where --- fail _ = BackT $ return GoBack --- return x = BackT . return $ NoBack x --- x >>= f = BackT $ loop --- where --- loop = do --- res<- do --- v <- runBackT x -- !> "loop" --- case v of --- NoBack y -> runBackT (f y) >>= return . Right -- !> "runback" --- BackPoint y -> do --- z <- runBackT (f y) -- !> "BACK" --- case z of --- GoBack -> return $ Left () -- !> "GoBack" --- other -> return $ Right other --- GoBack -> return $ Right GoBack --- case res of --- Left _ -> loop --- Right r -> return r - -instance Monad m => Monad (BackT m) where - fail _ = BackT . return $ GoBack - return x = BackT . return $ NoBack x - x >>= f = BackT $ loop - where - loop = do - v <- runBackT x -- !> "loop" - case v of - NoBack y -> runBackT (f y) -- !> "runback" - BackPoint y -> do - z <- runBackT (f y) -- !> "BACK" - case z of - GoBack -> loop -- !> "GoBack" - other -> return other - GoBack -> return $ GoBack - ---instance Monad m => Monad (BackT m) where --- fail _ = BackT $ return GoBack --- return x = BackT . return $ NoBack x --- x >>= f = BackT $ do --- v <- runBackT x --- case v of --- NoBack y -> runBackT (f y) --- BackPoint y -> loop --- where --- loop= do --- z <- runBackT (f y) --- case z of --- GoBack -> loop --- other -> return other --- GoBack -> return GoBack - - -{-# NOINLINE breturn #-} - --- | Use this instead of return to return from a computation with an ask statement --- --- This way when the user press the back button, the computation will execute back, to --- the returned code, according with the user navigation. -breturn x= BackT . return $ BackPoint x -- !> "breturn" - - -instance (MonadIO m) => MonadIO (BackT m) where - liftIO f= BackT $ liftIO f >>= \ x -> return $ NoBack x - -instance (Monad m,Functor m) => Functor (BackT m) where - fmap f g= BackT $ do - mr <- runBackT g - case mr of - BackPoint x -> return . BackPoint $ f x - NoBack x -> return . NoBack $ f x - GoBack -> return $ GoBack - -{-# NOINLINE liftBackT #-} -liftBackT f = BackT $ f >>= \x -> return $ NoBack x -instance MonadTrans BackT where - lift f = BackT $ f >>= \x -> return $ NoBack x - - -instance MonadState s m => MonadState s (BackT m) where - get= lift get -- !> "get" - put= lift . put - -type WState view m = StateT (MFlowState view) m -type FlowM view m= BackT (WState view m) - -data FormElm view a = FormElm [view] (Maybe a) deriving Typeable - -newtype View v m a = View { runView :: WState v m (FormElm v a) } - - -instance (FormInput v, Monoid v,Serialize a) - => Serialize (a,MFlowState v) where - showp (x,s)= case mfDebug s of - False -> showp x - True -> showp(x, mfEnv s) - readp= choice[nodebug, debug] - where - nodebug= readp >>= \x -> return (x, mFlowState0) - debug= do - (x,env) <- readp - return (x,mFlowState0{mfEnv= env}) - - -instance Functor (FormElm view ) where - fmap f (FormElm form x)= FormElm form (fmap f x) - -instance (Monad m,Functor m) => Functor (View view m) where - fmap f x= View $ fmap (fmap f) $ runView x - - -instance (Functor m, Monad m) => Applicative (View view m) where - pure a = View $ return (FormElm [] $ Just a) - View f <*> View g= View $ - f >>= \(FormElm form1 k) -> - g >>= \(FormElm form2 x) -> - return $ FormElm (form1 ++ form2) (k <*> x) - -instance (Functor m, Monad m) => Alternative (View view m) where - empty= View $ return $ FormElm [] Nothing - View f <|> View g= View $ - f >>= \(FormElm form1 k) -> - g >>= \(FormElm form2 x) -> - return $ FormElm (form1 ++ form2) (k <|> x) - - -instance (Monad m, Functor m) => Monad (View view m) where - --View view m a-> (a -> View view m b) -> View view m b - View x >>= f = View $ do - FormElm form1 mk <- x - case mk of - Just k -> do - FormElm form2 mk <- runView $ f k - return $ FormElm (form1++ form2) mk - Nothing -> return $ FormElm form1 Nothing - - return= View . return . FormElm [] . Just - - -instance MonadTrans (View view) where - lift f = View $ lift f >>= \x -> return $ FormElm [] $ Just x - -instance (Functor m, 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 - - -instance (MonadIO m, Functor m) => MonadIO (View view m) where - liftIO= lift . liftIO - ---instance Executable (View v m) where --- execute = runView - - ---instance (Monad m, Executable m, Monoid view, FormInput view) --- => Executable (StateT (MFlowState view) m) where --- execute f= execute $ evalStateT f mFlowState0 - --- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance --- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose --- such is caching. This is defined in "Data.TCache.Memoization". The user can create his --- own instance for his monad. --- --- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) ---, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases. --- --- @ --- import MFlow.Wai.XHtm.All --- import Some.Time.Library --- addMessageFlows [(noscript, time)] --- main= run 80 waiMessageFlow --- time=do ask $ cachedWidget \"time\" 5 --- $ wlink () bold << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\" --- time --- @ --- --- this pseudocode would update the time every 5 seconds. The execution of the IO computation --- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions. - -cachedWidget ::(Show a,MonadIO m,Typeable view, Monoid view - , FormInput view, Typeable a, Functor m, Executable m ) - => String -- ^ The key of the cached object for the retrieval - -> Int -- ^ Timeout of the caching. Zero means sessionwide - -> 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 _, seq)= execute $ cachedByKey key 0 $ proc mf s{mfCached=True} - let(FormElm _ mx2, s2) = execute $ runStateT (runView mf) s{mfSequence= seq,mfCached=True} -- !> ("mfSequence s1="++ show(mfSequence s1)) !> ("mfSequence s="++ show(mfSequence s)) !> ("mfSequence s'="++ show(mfSequence s')) - let s''= s{validated = validated s2} - return (FormElm form mx2, s'') - where - proc mf s= runStateT (runView mf) s>>= \(r,_) -> return (r,mfSequence s) - - --- | A FormLet instance -class (Functor m, MonadIO m) => FormLet a m view where - digest :: Maybe a - -> View view m a - ---wrender --- :: Widget a1 a m v => a1 -> StateT (MFlowState v) m ([v], Maybe a) --- ---wrender x =do --- (FormElm frm x) <- runView (widget x) --- return (frm, x) - --- Minimal definition: either (wrender and wget) or widget ---class (Functor m, MonadIO m) => Widget a b m view | a -> b view where --- wrender :: a -> WState view m [view] --- wrender x =do --- (FormElm frm (_ :: Maybe b)) <- runView (widget x) --- return frm --- wget :: a -> WState view m (Maybe b) --- wget x= runView (widget x) >>= \(FormElm _ mx) -> return mx - --- widget :: a -> View view m b --- widget x = View $ do --- form <- wrender x --- got <- wget x --- return $ FormElm form got - - ---instance FormLet a m view => Widget (Maybe a) a m view where --- widget = digest - -{- | Execute the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow` -`waiMessageFlow` or `addMessageFlows` - -@main= do - addMessageFlows [(\"noscript\",transient $ runFlow mainf)] - forkIO . run 80 $ waiMessageFlow - adminLoop -@ --} -runFlow :: (FormInput view, Monoid view, Monad m) - => FlowM view m a -> Token -> m a -runFlow f = \ t -> evalStateT (runBackT $ backp >> f) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return () - where - -- to restart the flow in case of going back before the first page of the flow - backp = breturn() - fromFailBack (NoBack x)= x - fromFailBack (BackPoint x)= x - --- | run a persistent flow inside the current flow. It is identified by the procedure and --- the string identifier. --- unlike the normal flows, that are infinite loops, runFlowIn executes finite flows --- once executed, in subsequent executions the flow will return the stored result --- without asking again. This is useful for asking/storing/retrieving user defined configurations. -runFlowIn - :: (MonadIO m, - FormInput view) - => String - -> FlowM view (Workflow IO) b - -> FlowM view m b -runFlowIn wf f= do - t <- gets mfToken - liftIO $ WF.exec1nc wf $ runFlow f t - - -step - :: (Serialize a, - Typeable view, - FormInput view, - Monoid view, - MonadIO m, - Typeable a) => - FlowM view m a - -> FlowM view (Workflow m) a - -step f= do - s <- get - BackT $ do - (r,s') <- lift . WF.step $ runStateT (runBackT f) s - -- when recovery of a workflow, the MFlow state is not considered - when( mfSequence s' >0) $ put s' - return r - - - ---stepDebug --- :: (Serialize a, --- Typeable view, --- FormInput view, --- Monoid view, --- MonadIO m, --- Typeable a) => --- FlowM view m a --- -> FlowM view (Workflow m) a ---stepDebug f= BackT $ do --- s <- get --- (r, s') <- lift $ do --- (r',stat)<- do --- rec <- isInRecover --- case rec of --- True ->do (r', s'') <- getStep 0 --- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)}) --- False -> return (undefined,s) --- (r'', s''') <- WF.stepDebug $ runStateT (runBackT f) stat >>= \(r,s)-> return (r, s) --- return $ (r'' `asTypeOf` r', s''' ) --- put s' --- return r - - - -getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) - => String -> Params -> [v] -> m (FormElm v a) -getParam1 par req form= r - where - r= case lookup par req of - Just x -> do - modify $ \s -> s{validated= True} - maybeRead x -- !> x - Nothing -> return $ FormElm form Nothing - getType :: m (FormElm v a) -> a - getType= undefined - x= getType r - maybeRead str= do - - if typeOf x == (typeOf ( undefined :: String)) - then return . FormElm form . Just $ unsafeCoerce str - else case readsPrec 0 $ str of - [(x,"")] -> return . FormElm form $ Just x - _ -> do - - let err= inred . fromString $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) - return $ FormElm (err:form) Nothing - --- | 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 String)) - -> 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{validated= True}) - case me of - Just str -> - --FormElm form mx' <- generateForm [] (Just x) noValidate - return $ FormElm ( inred (fromString str) : form) Nothing - Nothing -> return $ FormElm [] mx - _ -> return $ FormElm form mx - --- | Actions are callbacks that are executed when a widget is validated. --- It is useful when the widget is inside widget containers that know nothing about his content. --- 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 formt act= View $ do - FormElm form mx <- (runView formt) - case mx of - Just x -> do - modify (\s -> s{validated= True}) - clearEnv - br <- runBackT $ act x - case br of - GoBack -> do - modify (\s -> s{validated= False}) - return $ FormElm form Nothing - NoBack r -> return . FormElm form $ Just r - BackPoint r -> return . FormElm form $ Just r -- bad. no backpoints - - _ -> return $ FormElm form Nothing - --- | A modifier get the result and the rendering of a widget and change them. --- --- This modifier, when logged, changes a login-password-register widget with a display username. --- --- @userFormOrName= `userWidget` Nothing `userFormLine` \`wmodify\` f --- where --- f _ justu\@(Just u) = return ([`fromString` u], justu) -- user validated, display and return user --- f felem Nothing = do --- us <- `getCurrentUser` --- if us == `anonymous` --- then return (felem, Nothing) -- user not logged, present the form --- else return([`fromString` us], Just us) -- already logged, display and return user@ -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' - - - -instance (FormInput view, FormLet a m view , FormLet b m view ) - => FormLet (a,b) m view where - digest mxy = do - let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y) - (,) <$> digest x <*> digest y - -instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view ) - => FormLet (a,b,c) m view where - digest mxy = do - let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z) - (,,) <$> digest x <*> digest y <*> digest z - --- | display a text box and return a String -getString :: (FormInput view,Monad m) => - Maybe String -> View view m String -getString = getTextBox - --- | display a text box and return an Integer (if the value entered is not an Integer, fails the validation) -getInteger :: (FormInput view, Functor m, 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, Functor m, 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 - --- | implement a radio button that perform a submit when pressed. --- the parameter is the name of the radio group -getRadioActive :: (FormInput view, Functor m, MonadIO m) => - String -> String -> View view m String -getRadioActive n v= View $ do - st <- get - put st{needForm= True} - let env = mfEnv st - FormElm form mn <- getParam1 n env [] - return $ FormElm [finput n "radio" v - ( isJust mn && v== fromJust mn) (Just "this.form.submit()")] - mn - - - --- | implement a radio button --- the parameter is the name of the radio group -getRadio :: (FormInput view, Functor m, MonadIO m) => - String -> String -> View view m String -getRadio n v= View $ do - st <- get - put st{needForm= True} - let env = mfEnv st - FormElm f mn <- getParam1 n env [] - return $ FormElm - (f++[finput n "radio" v - ( isJust mn && v== fromJust mn) Nothing]) - mn - -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 []) - -instance (Monad m, Functor m, Monoid a) => Monoid (View v m a) where - mappend x y = mappend <$> x <*> y - mempty= return mempty - --- | display a text box and return the value entered if it is readable( Otherwise, fail the validation) -setCheckBox :: (FormInput view, Functor m, MonadIO m) => - String -> Bool -> View view m CheckBoxes -setCheckBox v checked= View $ do - n <- getNewName - st <- get - put st{needForm= True} - let env = mfEnv st - FormElm f mn <- getParam1 n env [] - val <- gets validated - let ret= case val of - True -> Just . CheckBoxes $ maybeToList mn - False -> Nothing - return $ FormElm - (f ++ [ finput n "checkbox" v - ( checked || (isJust mn && v== fromJust mn)) Nothing]) - ret - -getCheckBoxes ::(FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String] -getCheckBoxes boxes = View $ do - n <- getNewName - env <- gets mfEnv - FormElm form (mr :: Maybe String) <- getParam1 n env [finput n "hidden" "" False Nothing] - st <- get - let env = mfEnv st - put st{needForm= True} - FormElm form2 mr2 <- runView boxes - return $ FormElm (form ++ form2) $ - case (mr,mr2) of - (Nothing,_) -> Nothing - (Just _,Nothing) -> Just [] - (Just _, Just (CheckBoxes rs)) -> Just rs - - - - --- get a parameter form the las received response -getEnv :: MonadState (MFlowState view) m => String -> m(Maybe String) -getEnv n= gets mfEnv >>= return . lookup n - -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 -> getNewName - Just n -> return n - let nvalue= case mvalue of - Nothing -> "" - Just v -> - let typev= typeOf v - in if typev==typeOf (undefined :: String) then unsafeCoerce v - else if typev==typeOf (undefined :: String) then unsafeCoerce v - else if typev==typeOf (undefined :: ByteString) then unsafeCoerce v - else show v - form= [finput tolook type1 nvalue False Nothing] - st <- get - let env = mfEnv st - put st{needForm= True} - getParam1 tolook env form - - -getNewName :: MonadState (MFlowState view) m => m String -getNewName= do - st <- get - let n= mfSequence st - put $ st{mfSequence= n+1} - let pref= if mfCached st then 'c' else 'p' - return $ pref : (show n) - -getCurrentName :: MonadState (MFlowState view) m => m String -getCurrentName= do - st <- get - let parm = mfSequence st - return $ if mfCached st then "c" else "p"++show parm - - --- | display a multiline text box and return its content -getMultilineText :: (FormInput view, - Monad m) => - String -> View view m String -getMultilineText nvalue = View $ do - tolook <- getNewName - env <- gets mfEnv - let form= [ftextarea tolook nvalue] - getParam1 tolook env form - ---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) => - Bool -> String -> String -> View view m Bool -getBool mv truestr falsestr= View $ do - tolook <- getNewName - st <- get - let env = mfEnv st - put st{needForm= True} - r <- getParam1 tolook env $ [fselect tolook(foption1 truestr mv `mappend` foption1 falsestr (not mv))] - return $ fmap fromstr r --- case mx of --- Nothing -> return $ FormElm f Nothing --- Just x -> return . FormElm f $ fromstr x - 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 <- getNewName - st <- get - let env = mfEnv st - put st{needForm= True} - FormElm form mr <- (runView opts) - getParam1 tolook env [fselect tolook $ mconcat form] - -data MFOption a= MFOption - -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 n v = setOption1 n v False - --- | set the selected option for getSelect. Options are concatenated with `<|>` -setSelectedOption n v= setOption1 n v True - -setOption1 :: (FormInput view, - Monad m, Typeable 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 - - --- | Enclose Widgets in some formating. --- @view@ is intended to be instantiated to a particular format --- --- This is a widget, which is table with some links. it returns an Int --- --- > import MFlow.Forms.XHtml --- > --- > tableLinks :: View Html Int --- > tableLinks= table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] --- > <<< caption << "choose an item" --- > ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] --- > ++> (tbody --- > <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << "One") --- > <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << "Two") --- > <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << "Three")) --- > ) -(<<<) :: (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 <<< - - - --- | Useful for the creation of pages using two or more views. --- For example 'HSP' and 'Html'. --- Because both have ConvertTo instances to ByteString, then it is possible --- to mix them via 'normalize': --- --- > normalize widget <+> normalize widget' --- --- is equivalent to --- --- > widget .<+>. widget' - -normalize ::(Monad m, ToByteString v) => View v m a -> View ByteString m a -normalize f= View $ StateT $ \s ->do - (FormElm fs mx, s') <- runStateT (runView f) $ unsafeCoerce s - -- the only diference between the states of the two views is mfHeader - -- which don't affect to runState - return $ (FormElm (map toByteString fs ) mx,unsafeCoerce s') - -class ToByteString a where - toByteString :: a -> ByteString - -instance ToByteString a => ToHttpData a where - toHttpData = toHttpData . toByteString - -instance ToByteString ByteString where - toByteString= id - - - --- | Append formatting code to a widget --- --- @ getString "hi" <++ H1 << "hi there"@ -(<++) :: (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 @ - -(++>) :: (Monad m, Monoid view) - => view -> View view m a -> View view m a -html ++> digest = (html `mappend`) <<< digest - - - - -type Name= String -type Type= String -type Value= String -type Checked= Bool -type OnClick= Maybe String - - --- | Minimal interface for defining the basic form combinators in a concrete rendering. --- defined in this module. see "MFlow.Forms.XHtml" for the instance for @Text.XHtml@ and MFlow.Forms.HSP for an instance --- form Haskell Server Pages. -class Monoid view => FormInput view where - inred :: view -> view - fromString :: String -> view - flink :: String -> view -> view - flink1:: String -> view - flink1 verb = flink verb (fromString verb) - finput :: Name -> Type -> Value -> Checked -> OnClick -> view - ftextarea :: String -> String -> view - fselect :: String -> view -> view - foption :: String -> view -> Bool -> view - foption1 :: String -> Bool -> view - foption1 val msel= foption val (fromString val) msel - formAction :: String -> view -> view - addAttributes :: view -> Attribs -> view - --- | add attributes to the form element --- if the view has more than one element, it is applied to the first -infix 8 FormLet User m view where --- digest muser= --- (User <$> getString ( userName <$> muser) --- <*> getPassword) --- `validate` userValidate - - -newtype Lang= Lang String - -data MFlowState view= MFlowState{ - mfSequence :: Int, - mfCached :: Bool, - prevSeq :: [Int], - onInit :: Bool, - validated :: Bool, --- mfUser :: String, - mfLang :: Lang, - mfEnv :: Params, - needForm :: Bool, - hasForm :: Bool, --- mfServer :: String, --- mfPath :: String, --- mfPort :: Int, - - mfToken :: Token, - mfkillTime :: Int, - mfSessionTime :: Integer, - mfCookies :: [Cookie], - mfHeader :: view -> view, - mfDebug :: Bool - } - deriving Typeable - -stdHeader v = v - - -mFlowState0 :: (FormInput view, Monoid view) => MFlowState view -mFlowState0= MFlowState 0 False [] True False (Lang "en") [] False False (error "token of mFlowState0 used") 0 0 [] stdHeader False - --- | Set the header-footer that will enclose the widgets. It must be provided in the --- same formatting than them, altrough with normalization to byteStrings can be used any formatting --- --- This header uses XML trough Haskell Server Pages () --- --- @ --- setHeader $ \c -> --- \ --- \ --- \ my title \ --- \) --- \ --- \ --- \<% c %\> --- \ --- \ --- @ --- --- This header uses "Text.XHtml" --- --- @ --- setHeader $ \c -> --- `thehtml` --- << (`header` --- << (`thetitle` << title +++ --- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++ --- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c --- @ --- --- This header uses both. It uses byteString tags --- --- @ --- setHeader $ \c -> --- `bhtml` [] $ --- `btag` "head" [] $ --- (`toByteString` (thetitle << title) `append` --- `toByteString` ) `append` --- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c --- @ - -setHeader :: Monad m => (view -> view) -> FlowM view m () -setHeader header= do - fs <- get - put fs{mfHeader= header} - - - --- | return the current header -getHeader :: Monad m => FlowM view m (view -> view) -getHeader= gets mfHeader - --- | Set an HTTP cookie -setCookie :: MonadState (MFlowState view) m - => String -- ^ name - -> String -- ^ value - -> String -- ^ path - -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie - -> m () -setCookie n v p me= do - modify $ \st -> st{mfCookies= (n,v,p,fmap show me):mfCookies st } - --- | Set 1) the timeout of the flow execution since the last user interaction. --- Once passed, the flow executes from the begining. 2). In persistent flows --- it set the session state timeout for the flow, that is persistent. If the --- flow is not persistent, it has no effect. --- --- `transient` flows restart anew. --- persistent flows (that use `step`) restart at the las saved execution point, unless --- the session time has expired for the user. -setTimeouts :: Monad m => Int -> Integer -> FlowM view m () -setTimeouts kt st= do - fs <- get - put fs{ mfkillTime= kt, mfSessionTime= st} - - -getWFName :: MonadState (MFlowState view) m => m String -getWFName = do - fs <- get - return . twfname $ mfToken fs - -getCurrentUser :: MonadState (MFlowState view) m=> m String -getCurrentUser = return . tuser =<< gets mfToken - -type UserStr= String -type PasswdStr= String --- | 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\") --- \<\+\> fromString \" password again\" \+\> getPassword \<\* submitButton \"register\" --- @ -userFormLine :: (FormInput view, Monoid view, Functor m, Monad m) - => View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) -userFormLine= - ((,) <$> getString (Just "enter user") getPassword submitButton "login") - <+> fromString " password again" ++> getPassword View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) -userLogin= - ((,) <$> fromString "Enter User: " ++> getString Nothing fromString " Enter Pass: " ++> getPassword submitButton "login") - <+> noWidget - <* noWidget - - - --- | empty widget that return Nothing. May be used as \"empty boxes\" inside larger widgets -noWidget :: (FormInput view, - Monad m) => - View view m a -noWidget= View . return $ FormElm [] Nothing - --- | render the Show instance of the parameter and return it. It is useful --- for displaying information -wrender :: (Monad m, Show a, FormInput view) => a -> View view m a -wrender x= View . return $ FormElm [fromString $ show x] (Just x) - --- | 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 - --- | 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. --- Otherwise, if the user is already logged, the widget does not appear --- If the user press the register button, the user/password is registered and the --- user -userWidget :: ( MonadIO m, Functor m - , FormInput view, Monoid view ) - => Maybe String - -> View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) - -> View view m String -userWidget muser formuser= wform formuser `validate` val muser `waction` login - where - val _ (Nothing,_) = return $ Just "Plese fill in the user/passwd to login, or user/passwd/passwd to register" - val mu (Just (Just us , Just _), Nothing)= - if isNothing mu || isJust mu && fromJust mu == fst us - then userValidate us - else return $ Just "wrong user for the operation" - val mu (Just (Just us , Just _), 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 "The passwords do not match" - else return $ Just "wrong user for the operation" - - val _ _ = return $ Just "Please fill in the fields for login or register" - - login (Just (Just (u,p) , Just _), Nothing)= do - - let uname= u - st <- get - let t = mfToken st - t'= t{tuser= uname} - moveState (twfname t) t t' - put st{mfToken= t'} - liftIO $ deleteTokenInList t - liftIO $ addTokenToList t' - setCookie cookieuser uname "/" Nothing -- !> "setcookie" - return uname - - login (Just (Just us@(u,p) , Just _), Just _)= do - userRegister u p - login (Just (Just us , Just p), Nothing) - - --- | If not logged, perform login. otherwise return the user --- --- @getUserSimple= getUser Nothing userFormLine@ -getUserSimple :: ( FormInput view, Monoid view, Typeable view - , ToHttpData view - , MonadIO m, Functor m) - => FlowM view m 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, Monoid view, Typeable view - , ToHttpData view - , MonadIO m, Functor m) - => Maybe String - -> View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) - -> FlowM view m String -getUser mu form= ask $ userWidget mu form - - ---instance (MonadIO m, Functor m, m1 ~ m, b ~ a) --- => Widget(View view m1 b) a m view where --- widget = id - --- | Join two widgets in the same page --- the resulting widget, when `ask`ed with it, returns a either one or the other --- --- > r <- ask widget widget1 <+> widget 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 - - -infixr 3 <**, **>, .**>., .<**. --- | 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 in the case of '*>' -(**>) :: (Functor m, Monad m) - => View view m a -> View view m b -> View view m b -(**>) form1 form2 = valid form1 *> form2 - - --- | 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 first element is displayed however, as in the case of '<*' -(<**) - :: (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 - - - --- | It is the way to interact with the user. --- It takes a widget and return the user result. --- If the environment has the result, ask don't ask to the user. --- To force asking in any case, put an `clearEnv` statement before -ask - :: ( - ToHttpData view, - FormInput view, - Monoid view, - MonadIO m, - Typeable view) => - View view m b -> FlowM view m b -ask x = do - st1 <- get - let st= st1{hasForm= False, needForm= False,validated= False} - put st - FormElm forms mx <- lift $ runView x -- !> "runWidget" - st' <- get - case mx of - Just x -> do - put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]} - breturn x -- !> "just x" - - _ -> - if not (validated st') && not (onInit st') && hasParams (mfSequence st') ( mfEnv st') -- !> (show $ validated st') !> (show $ onInit st') - then do - put st'{mfSequence= head1 $ prevSeq st' - ,prevSeq= tail1 $ prevSeq st' } - fail "" -- !> "repeatPlease" - else do - let header= mfHeader st' - t= mfToken st' - cont = case (needForm st', hasForm st') of - (True, False) -> header $ formAction (twfname t) $ mconcat forms - _ -> header $ mconcat forms - - let HttpData ctype c s= toHttpData cont - liftIO . sendFlush t $ HttpData ctype (mfCookies st' ++ c) s - put st{mfCookies=[], onInit= False, mfToken= t } -- !> ("after "++show ( mfSequence st')) - receiveWithTimeouts - ask x - where - head1 []=0 - head1 xs= head xs - tail1 []=[] - tail1 xs= tail xs - - hasParams seq= not . null . filter (\(p,_) -> - - let tailp = tail p in - (head p== 'p' || head p == 'c') - && and (map isNumber tailp) - && read tailp <= seq) - --- | True if the flow is going back (as a result of the back button pressed in the web browser). --- Usually this chech is nos necessary unless conditional code make it necessary --- --- @menu= do --- mop <- getGoStraighTo --- case mop of --- Just goop -> goop --- Nothing -> do --- r \<- `ask` option1 \<|> option2 --- case r of --- op1 -> setGoStraighTo (Just goop1) >> goop1 --- op2 -> setGoStraighTo (Just goop2) >> goop2@ --- --- This pseudocode below would execute the ask of the menu once. But the user will never have --- the possibility to see the menu again. To let him choose other option, the code --- has to be change to --- --- @menu= do --- mop <- getGoStraighTo --- back <- `goingBack` --- case (mop,back) of --- (Just goop,False) -> goop --- _ -> do --- r \<- `ask` option1 \<|> option2 --- case r of --- op1 -> setGoStraighTo (Just goop1) >> goop1 --- op2 -> setGoStraighTo (Just goop2) >> goop2@ --- --- However this is very specialized. normally the back button detection is not necessary. --- In a persistent flow (with step) even this default entry option would be completely automatic, --- since the process would restar at the last page visited. No setting is necessary. -goingBack :: MonadState (MFlowState view) m => m Bool -goingBack = do - st <- get - return $ not (validated st) && not (onInit st) - --- | Clears the environment -clearEnv :: MonadState (MFlowState view) m => m () -clearEnv= do - st <- get - put st{ mfEnv= []} - -receiveWithTimeouts :: MonadIO m => FlowM view m () -receiveWithTimeouts= do - st <- get - let t= mfToken st - t1= mfkillTime st - t2= mfSessionTime st - req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t) - put st{mfEnv= req} - - - - --- | wrap a widget of form element within a form-action element. ----- Usually it is done automatically by the @Wiew@ monad. -wform :: (Monad m, FormInput view, Monoid view) - => View view m b -> View view m b - -wform x = View $ do - FormElm form mr <- (runView $ x ) - st <- get - let t = mfToken st - put st{hasForm= True} - let form1= formAction ( twfname t) $ mconcat form - - 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 - - ---insertView view= View $ return $ FormElm [view] $ Just () --- ---infix 3 +> ---view +> widget= (insertView view) *> widget --- ---infix 3 <+ ---widget <+ view = widget <* insertView view - - - --- | creates a link wiget. A link can be composed with other widget elements, -wlink :: (Typeable a, Read a, Show a, MonadIO m, Functor m, FormInput view) - => a -> view -> View view m a -wlink x v= View $ do - verb <- getWFName - name <- getNewName - env <- gets mfEnv - let - showx= if typeOf x== typeOf (undefined :: String) then unsafeCoerce x else show x - toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v - getParam1 name env [toSend] - - - - ---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, MonadIO m, Functor m)=> [View view m a] -> View view m a -firstOf xs= View $ do - forms <- mapM(\x -> (runView x )) 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 - - - --- | intersperse a widget in a list of widgets. the results is a 2-tuple of both types -(|*>) :: (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 above and below other. Useful for navigation links in a page. -(|+|) :: (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) - - --- | > (.<<.) w x = w $ toByteString x -(.<<.) :: (ToByteString view) => (ByteString -> ByteString) -> view -> ByteString -(.<<.) w x = w $ toByteString x - --- | > (.<+>.) x y = normalize x <+> normalize y -(.<+>.) - :: (Monad m, ToByteString v, ToByteString 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, ToByteString v, ToByteString 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, ToByteString v, ToByteString 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, ToByteString v, ToByteString 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, ToByteString v, ToByteString 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, ToByteString v, ToByteString 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, ToByteString v, ToByteString v') => View v m a -> v' -> View ByteString m a -(.<++.) x v= normalize x <++ toByteString v - --- | > (.++>.) v x= toByteString v ++> normalize x -(.++>.) :: (Monad m, ToByteString v, ToByteString v') => v -> View v' m a -> View ByteString m a -(.++>.) v x= toByteString v ++> normalize x - - -instance FormInput ByteString where - - 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)] $ pack 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 [] - - addAttributes tag attrs = error "addAttributes not implemented for ByteString" - - - formAction action form = btag "form" [("action", action),("method", "post")] form - fromString = pack - + -XOverloadedStrings + +#-} + +{- | 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 function. 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 () 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 () 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 + +[@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 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. + +* NEW IN PREVIOUS RELEASE: + +[@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 ) + + +[@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 '),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>) + +-- * 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 +(<<<),(<++),(++>),(.) + +-- * ByteString tags +,btag,bhtml,bbody + +-- * Normalization +, flatten, normalize + +-- * Running the flow monad +,runFlow,runFlowIn,MFlow.Forms.Internals.step, goingBack,breturn + +-- * Setting parameters +,setHeader +,setSessionData +,getSessionData +,getHeader +,setTimeouts + +-- * Cookies +,setCookie +-- * Ajax +,ajax +,ajaxSend +,ajaxSend_ +-- * Requirements +,Requirements(..) +,WebRequirement(..) +,requires +-- * Utility +,genNewId +,changeMonad +) +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 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) +import Network.HTTP.Types.Header + + +import Debug.Trace +(!>)= flip trace + + + +-- | 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 String)) + -> 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 -> + --FormElm form mx' <- generateForm [] (Just x) noValidate + return $ FormElm ( inred (fromStr str) : form) Nothing + Nothing -> return $ FormElm [] mx + _ -> return $ FormElm form mx + +-- | Actions are callbacks that are executed when a widget is validated. +-- It is useful when the widget is inside widget containers that know nothing about his content. +-- +-- 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=[]} + r <- flowToView $ ac x !> "ACTION" + modify $ \s-> s{mfSequence= seq, mfEnv= env} + return r + where + flowToView x= + View $ do + r <- runBackT $ 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) + +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' + + +-- +--instance (FormInput view, FormLet a m view , FormLet b m view ) +-- => FormLet (a,b) m view where +-- digest mxy = do +-- let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y) +-- (,) <$> digest x <*> digest y +-- +--instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view ) +-- => FormLet (a,b,c) m view where +-- digest mxy = do +-- let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z) +-- (,,) <$> digest x <*> digest y <*> digest z + +-- | Display a text box and return a String +getString :: (FormInput view,Monad m) => + Maybe String -> View view m String +getString = getTextBox + +-- | 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 + +data Radio= Radio String +-- | Implement a radio button that perform a submit when pressed. +-- the parameter is the name of the radio group +setRadioActive :: (FormInput view, MonadIO m) => + String -> String -> View view m Radio +setRadioActive v n = View $ do + st <- get + put st{needForm= True} + let env = mfEnv st + FormElm form mn <- getParam1 n env [] + return $ FormElm [finput n "radio" v + ( isJust mn && v== fromJust mn) (Just "this.form.submit()")] + (fmap Radio mn) + + +-- | Implement a radio button +-- the parameter is the name of the radio group +setRadio :: (FormInput view, MonadIO m) => + String -> String -> View view m Radio +setRadio v n= View $ do + st <- get + put st{needForm= True} + let env = mfEnv st + FormElm f mn <- getParam1 n env [] + return $ FormElm + (f++[finput n "radio" v + ( isJust mn && v== fromJust mn) Nothing]) + (fmap Radio mn) + +getRadio + :: (Monad m, Functor m, FormInput view) => + [String -> View view m Radio] -> View view m String +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 []) + +instance (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 + +-- | 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 <- gets inSync + let ret= case val of + True -> Just $ CheckBoxes 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 + getParam1 n env [finput n "hidden" showx False Nothing] + +getCheckBoxes ::(FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String] +getCheckBoxes boxes = View $ do + n <- genNewId + env <- gets mfEnv + FormElm form (mr :: Maybe String) <- getParam1 n env [finput n "hidden" "" False Nothing] + st <- get + let env = mfEnv st + put st{needForm= True} + FormElm form2 mr2 <- runView boxes + return $ FormElm (form ++ form2) $ + case (mr,mr2) of + (Nothing,_) -> Nothing + (Just _,Nothing) -> Just [] + (Just _, 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= case mvalue of + Nothing -> "" + Just v -> + case cast v of + Just v' -> v' + Nothing -> show v +-- let typev= typeOf v +-- in if typev==typeOf (undefined :: String) then unsafeCoerce v +-- else if typev==typeOf (undefined :: String) then unsafeCoerce v +-- else if typev==typeOf (undefined :: ByteString) then unsafeCoerce v +-- else show v + form= [finput tolook type1 nvalue False Nothing] + st <- get + let env = mfEnv st + put st{needForm= True} + getParam1 tolook env form + +-- | Generate a new string. Useful for creating tag identifiers and other attributes +genNewId :: MonadState (MFlowState view) m => m String +genNewId= do + st <- get + case mfCached st of + False -> do + let n= mfSequence st + put $ st{mfSequence= n+1} + return $ 'p':(show n) + True -> do + let n = mfSeqCache st + put $ st{mfSeqCache=n+1} + return $ 'c' : (show n) + + +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) => + String -> View view m String +getMultilineText nvalue = View $ do + tolook <- genNewId + env <- gets mfEnv + let form= [ftextarea tolook nvalue] + getParam1 tolook env form + +--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) => + Bool -> String -> String -> View view m Bool +getBool mv truestr falsestr= View $ do + tolook <- genNewId + st <- get + let env = mfEnv st + put st{needForm= True} + r <- getParam1 tolook env $ [fselect tolook(foption1 truestr mv `mappend` foption1 falsestr (not mv))] + return $ fmap fromstr r +-- case mx of +-- Nothing -> return $ FormElm f Nothing +-- Just x -> return . FormElm f $ fromstr x + 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} + FormElm form mr <- (runView opts) + getParam1 tolook env [fselect tolook $ mconcat form] + +data MFOption a= MFOption + +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 n v = setOption1 n v False + +-- | Set the selected option for getSelect. Options are concatenated with `<|>` +setSelectedOption n v= setOption1 n v True + +setOption1 :: (FormInput view, + Monad m, Typeable 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 + + +-- | Enclose Widgets in some formating. +-- @view@ is intended to be instantiated to a particular format +-- +-- This is a widget, which is table with some links. it returns an Int +-- +-- > import MFlow.Forms.XHtml +-- > +-- > tableLinks :: View Html Int +-- > tableLinks= table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] +-- > <<< caption << "choose an item" +-- > ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] +-- > ++> (tbody +-- > <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << "One") +-- > <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << "Two") +-- > <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << "Three")) +-- > ) +(<<<) :: (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 <<< + + + +-- | Useful for the creation of pages using two or more views. +-- For example 'HSP' and 'Html'. +-- Because both have ConvertTo instances to ByteString, then it is possible +-- to mix them via 'normalize': +-- +-- > normalize widget <+> normalize widget' +-- +-- is equivalent to +-- +-- > widget .<+>. widget' + + + + +-- | Append formatting code to a widget +-- +-- @ getString "hi" <++ H1 << "hi there"@ +(<++) :: (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 @ + +(++>) :: (Monad m, Monoid view) + => view -> View view m a -> View view m a +html ++> digest = (html `mappend`) <<< digest + + + + +-- | Add attributes to the form element +-- if the view has more than one element, it is applied to the first +infix 8 FormLet User m view where +-- digest muser= +-- (User <$> getString ( userName <$> muser) +-- <*> getPassword) +-- `validate` userValidate + + + + + + +-- | 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") getPassword (fromStr " password again" ++> getPassword View view m (Maybe (UserStr,PasswdStr), Maybe String) +userLogin= + ((,) <$> fromStr "Enter User: " ++> getString Nothing fromStr " Enter Pass: " ++> getPassword (noWidget + <* noWidget) + + + +-- | Empty widget that return Nothing. May be used as \"empty boxes\" inside larger widgets +noWidget :: (FormInput view, + Monad m) => + View view m a +noWidget= View . return $ FormElm [] Nothing + +-- | Render a value and return it +wrender + :: (Monad m, Functor m, Show a, FormInput view) => + a -> View view m a +wrender x = (wraw . 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 () + + +-- | 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 + +-- | 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 + then return user + else formuser `validate` val muser `waction` login + where + val _ (Nothing,_) = return $ Just "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 "wrong user for the operation" + + 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 "The passwords do not match" + else return $ Just "wrong user for the operation" + +-- val _ _ = return $ Just "Please fill in the fields for login or register" + + login (Just (u,p), Nothing)= do + let uname= u + st <- get + let t = mfToken st + 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) + return uname + + login (Just us@(u,p), Just _)= do + userRegister u p + login (Just us , Nothing) + +-- | logout. The user is resetted to the `anonymous` user +logout :: (MonadIO m, MonadState (MFlowState view) m) => m () +logout= do + st <- get + let t = mfToken st + t'= t{tuser= anonymous} + 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 + , MonadIO m, Functor m) + => FlowM view m 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 + , MonadIO m, Functor m) + => Maybe String + -> View view m (Maybe (UserStr,PasswdStr), Maybe String) + -> FlowM view m String +getUser mu form= ask $ userWidget mu form + + +--instance (MonadIO m, Functor m, m1 ~ m, b ~ a) +-- => Widget(View view m1 b) a m view where +-- widget = id + +-- | Join two widgets in the same page +-- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results +-- +-- > 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 + + +infixr 1 **> , .**>. , <** , .<**. +-- | 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 +-- + + +(**>) :: (Functor m, Monad m) + => View view m a -> View view m b -> View view m b +(**>) form1 form2 = valid form1 *> form2 + + +-- | 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 +(<**) + :: (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 + + +-- | It is the way to interact with the user. +-- It takes a widget and return the user result. +-- If the environment has the result, ask don't ask to the user. +-- To force asking in any case, put an `clearEnv` statement before +ask + :: ( + FormInput view, + MonadIO m, + Typeable view) => + View view m b -> FlowM view m b +ask w = do + st1 <- get + let env= mfEnv st1 + case (mfAjax st1,lookup "ajax" env, lookup "val" env) of + ( Just ajaxl,Just v1, Just v2) -> do + let f = fromMaybe (error $ "not found Ajax handler for: "++ v1) $ M.lookup v1 ajaxl + FlowM . lift $ (unsafeCoerce f) v2 + FlowM $ lift receiveWithTimeouts + ask w + + _ -> do + let st= st1{needForm= False, inSync= False, mfRequirements= []} + 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'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]} + breturn x -- BackT . return $ BackPoint x -- !> "just x" + + Nothing -> + if not (inSync st') && not (onInit st') && hasParams (mfSequence st') (mfSeqCache st') ( mfEnv st') -- !> (show $ inSync st') !> (show $ onInit st') + then do + put st'{mfSequence= head1 $ prevSeq st' + ,prevSeq= tail1 $ prevSeq st' } + fail "" + else do + reqs <- FlowM $ lift installAllRequirements + let header= mfHeader st' + t= mfToken st' + cont = case (needForm st') of + True -> header $ reqs <> (formAction (twfname t ) $ mconcat forms) + _ -> header $ reqs <> mconcat forms + + HttpData ctype c s= toHttpData cont + liftIO . sendFlush t $ HttpData (ctype++mfHttpHeaders st') (mfCookies st' ++ c) s + put st{mfCookies=[],mfHttpHeaders=[], onInit= False, mfToken= t, mfAjax= mfAjax st', mfSeqCache= mfSeqCache st' } -- !> ("after "++show ( mfSequence st')) + FlowM $ lift receiveWithTimeouts + ask w + where + head1 []=0 + head1 xs= head xs + tail1 []=[] + tail1 xs= tail xs + + hasParams seq cseq= not . null . filter (\(p,_) -> + let tailp = tail p + in and (map isNumber tailp) && + let rt= read tailp + in case head p of + 'p' -> rt <= seq + 'c' -> rt <= cseq + _ -> False) +-- (head p== 'p' || head p == 'c') +-- && and (map isNumber tailp) +-- && read tailp <= seq) + +-- | True if the flow is going back (as a result of the back button pressed in the web browser). +-- Usually this chech is nos necessary unless conditional code make it necessary +-- +-- @menu= do +-- mop <- getGoStraighTo +-- case mop of +-- Just goop -> goop +-- Nothing -> do +-- r \<- `ask` option1 \<|> option2 +-- case r of +-- op1 -> setGoStraighTo (Just goop1) >> goop1 +-- op2 -> setGoStraighTo (Just goop2) >> goop2@ +-- +-- This pseudocode below would execute the ask of the menu once. But the user will never have +-- the possibility to see the menu again. To let him choose other option, the code +-- has to be change to +-- +-- @menu= do +-- mop <- getGoStraighTo +-- back <- `goingBack` +-- case (mop,back) of +-- (Just goop,False) -> goop +-- _ -> do +-- r \<- `ask` option1 \<|> option2 +-- case r of +-- op1 -> setGoStraighTo (Just goop1) >> goop1 +-- op2 -> setGoStraighTo (Just goop2) >> goop2@ +-- +-- However this is very specialized. normally the back button detection is not necessary. +-- In a persistent flow (with step) even this default entry option would be completely automatic, +-- since the process would restar at the last page visited. No setting is necessary. +goingBack :: MonadState (MFlowState view) m => m Bool +goingBack = do + st <- get + return $ not (inSync st) && not (onInit st) + +-- | Clears the environment +clearEnv :: MonadState (MFlowState view) m => m () +clearEnv= do + st <- get + put st{ mfEnv= []} + +receiveWithTimeouts :: MonadIO m => WState view m () +receiveWithTimeouts= do + st <- get + let t= mfToken st + t1= mfkillTime st + t2= mfSessionTime st + req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t) + put st{mfEnv= req} + +-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget +wstateless + :: (Typeable view, FormInput view) => + View view IO a -> Flow +wstateless w = transient $ runFlow loop + where + loop= do + ask w + env <- get + put $ env{ mfSequence= 0,prevSeq=[]} + loop + +---- | it creates a stateless flow (see `stateless`) whose behaviour is defined as a widget +---- +---- 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 + +-- | transfer control to another flow. +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 + + +-- | Wrap a widget of form element within a form-action element. +---- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad. +wform :: (Monad m, FormInput view) + => View view m b -> View view m b + +wform x = View $ do + FormElm form mr <- (runView $ x ) + st <- get + let t = mfToken st + anchor <- genNewId + put st{needForm=False} + let anchorf= (ftag "a") mempty `attrs` [("name",anchor)] + let form1= formAction (twfname t {-++"#"++anchor-}) $ mconcat ( anchorf:form) -- !> anchor + + 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. +-- +-- 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) (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 invoques 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 "''" + receiveWithTimeouts + 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 + + + +-- | Creates a link wiget. A link can be composed with other widget elements, +wlink :: (Typeable a, Read a, Show a, MonadIO m, Functor m, FormInput view) + => a -> view -> View view m a +wlink x v= View $ do + verb <- getWFName + name <- genNewId + env <- gets mfEnv + let + showx= if typeOf x== typeOf (undefined :: String) then unsafeCoerce x else show x + toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v + getParam1 name env [toSend] + +-- | When some HTML produces a parameter in response, but it is not produced by +-- a form or a link, but for example by an script, returning notify the type checker +-- and the parameter extractor about this fact. +-- +-- . 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 a link or a @window.location@ statement in javasCript +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 + getParam1 name env [toSend] + + + + + +--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 + +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 +(|*>) :: (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 above and below other. Useful for navigation links in a page. +(|+|) :: (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)] $ pack 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 diff --git a/src/MFlow/Forms/Admin.hs b/src/MFlow/Forms/Admin.hs --- a/src/MFlow/Forms/Admin.hs +++ b/src/MFlow/Forms/Admin.hs @@ -2,7 +2,7 @@ -XScopedTypeVariables #-} -module MFlow.Forms.Admin(adminLoop,addAdminWF) where +module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where import MFlow.Forms import MFlow.Forms.XHtml import MFlow @@ -24,6 +24,8 @@ import Data.Map as M (keys) import System.Exit import Control.Exception as E +import Control.Concurrent +import Control.Concurrent.MVar @@ -50,27 +52,42 @@ putStrLn "" putStrLn "Commands: sync, flush, end, abort" adminLoop1 + `E.catch` (\(e:: E.SomeException) ->do + ssyncCache + error $ "\nException: "++ show e) adminLoop1= do putStr ">"; hFlush stdout op <- getLine case op of - "sync" -> ssyncCache + "sync" -> ssyncCache "flush" -> atomically flushAll >> putStrLn "flushed cache" - "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess + "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess "abort" -> exitWith ExitSuccess - _ -> return() + _ -> return() adminLoop1 - `E.catch` (\(e:: E.SomeException) ->do - ssyncCache - error $ "\nException: "++ show e) +-- | execute the process and wait for its finalization. +-- then it synchronizes the cache +wait f= do + mv <- newEmptyMVar + forkIO (f1 >> putMVar mv True) + takeMVar mv + `E.catch` (\(e:: E.SomeException) ->do + ssyncCache + error $ "Signal: "++ show e) + where + f1= f +-- do +-- n <- getNumProcessors +-- setNumCapabilities n +-- f -- | Install the admin flow in the list of flows handled by `HackMessageFlow` -- this gives access to an administrator page. It is necessary to -- create an admin user with `setAdminUser`. -- --- The administration page is reached with the path \"adminserv"\ +-- The administration page is reached with the path \"adminserv\" addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)] @@ -106,7 +123,7 @@ log <- liftIO $ hGetNonBlocking hlog (fromIntegral size) let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]" - let rows= [wlink (head e) (bold << head e) `waction` optionsUser : map (\x ->noWidget <++ fromString x) (Prelude.tail e) | e <- ls] + let rows= [wlink (head e) (bold << head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls] showFormList rows 0 10 breturn() @@ -138,8 +155,7 @@ optionsUser us = do wfs <- liftIO $ return . M.keys =<< getMessageFlows - - stats <- liftIO $ mapM (\wf -> getWFHistory wf Token{twfname= wf,tuser=us}) wfs + stats <- liftIO $ mapM (\wf -> getWFHistory wf Token{twfname= wf,tuser=us}) wfs let wfss= filter (isJust . snd) $ zip wfs stats if null wfss then ask $ bold << " not logs for this user" ++> wlink () (bold << "Press here") diff --git a/src/MFlow/Forms/Ajax.hs b/src/MFlow/Forms/Ajax.hs deleted file mode 100644 --- a/src/MFlow/Forms/Ajax.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# OPTIONS -XFlexibleContexts #-} - --- | A very simple (but effective) support for AJAX. --- The value of a javaScript variable is sent to the server. --- The server must return a valid sequence of javaScript statements --- that are evaluated in the client. --- --- This example increase the value, from 0 on, in a text box trough AJAX: --- --- @ --- import Text.XHtml --- import MFlow.Forms --- import MFlow.Forms.Ajax --- ajaxsample= do --- ajaxheader html= thehtml << `ajaxHead` << html --- setHeader ajaxheader --- ajaxc \<- `ajaxCommand` \"document.getElementById(\'text1\').value\" --- (\n -> return $ \"document.getElementById(\'text1\').value='\"++show(read n +1)++\"'\") --- ask $ (getInt (Just 0) \)= flip trace - -context= unsafePerformIO newContext - --- | Install the server code and return the client code for an AJAX interaction. -ajaxCommand :: MonadIO m - => String -- ^ The javScript variable whose value will be sent to the server - -> (String -> IO String) -- ^ The server procedure to be executed with the - -- variable value as parameter. It must return a string with valid - -- javaScript code to be executed in the client - -> m (String) -- ^ return the javascript of the event handler, to be inserted in - -- the HTML to be sent to the client -ajaxCommand jsparam serverProc = do - r <- liftIO $ addrHash context serverProc - servname <- case r of - Left h -> do - let servname= "ajax"++ show h - liftIO $ addMessageFlows [( servname, serverp)] - return servname - Right h -> return $ "ajax"++ show h --- liftIO $ getMessageFlows >>= return . keys >>= print - return $ "doServer("++"'" ++ servname++"',"++jsparam++")" - where - serverp = stateless $ \env -> do - let c = lookup "ajax" env `justify` (error "not found ajax command") -- :: String - serverProc c - justify = flip fromMaybe - - - - --- | @ajaxHead@ must be used instead of `header` when using ajax(see example). --- --- Although it produces code form "Text.XHtml" rendering (package xhtml), --- it can be converted to byteString, so that any rendering can be used trough normalization --- . see `setHeader` -ajaxHead :: Html -> Html -ajaxHead html= - (header << (script ![thetype "text/javascript"] << ( - "function loadXMLObj()\n" ++ - "{\n" ++ - "var xmlhttp;\n" ++ - "if (window.XMLHttpRequest)\n" ++ - " {\n// code for IE7+, Firefox, Chrome, Opera, Safari\n" ++ - " xmlhttp=new XMLHttpRequest();\n" ++ - " }\n" ++ - "else\n" ++ - " {\n// code for IE6, IE5\n\n" ++ - " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');\n" ++ - " }\n" ++ - "return xmlhttp\n" ++ - "}\n" ++ - - " xmlhttp= loadXMLObj()\n" ++ - " noparam= ''\n"++ - "\n"++ - "function doServer (servproc,param){\n" ++ - " xmlhttp.open('GET',servproc+'?ajax='+param,true);\n" ++ - " xmlhttp.send();}\n" ++ - "\n"++ - "xmlhttp.onreadystatechange=function()\n" ++ - " {\n" ++ - " if (xmlhttp.readyState + xmlhttp.status==204)\n" ++ - " { \n" ++ - " eval(xmlhttp.responseText);\n" ++ - " }\n" ++ - " }\n" ++ - "\n" ))) - +++ body << html - - - diff --git a/src/MFlow/Forms/Blaze/Html.hs b/src/MFlow/Forms/Blaze/Html.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/Blaze/Html.hs @@ -0,0 +1,69 @@ +{-# OPTIONS -XOverloadedStrings -XFlexibleInstances -XTypeSynonymInstances + #-} +{- | +Instantiation of the 'FormInput' class for blaze-html + +This package is included in "MFlow.Wai.Blaze.Hml.All". + +Use it to create applicaitons with this kind of formatting. +-} +module MFlow.Forms.Blaze.Html where +import MFlow +import MFlow.Forms +import MFlow.Cookies(contentHtml) +import Data.ByteString.Lazy.Char8 + +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 Control.Monad.Trans +import Data.Typeable +import Data.String +import Data.Monoid +import Unsafe.Coerce + +(<<) tag v= tag $ toMarkup v + +infixr 7 << + +instance FormInput Html where + toByteString = renderHtml + toHttpData = HttpData [contentHtml ] [] . toByteString + ftag x= I.Parent (fromString x) (fromString $ "<"++x) (fromString $ "") + -- (mempty :: I.MarkupM () ) + + inred = b ! At.style (fromString "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 + + ftextarea nam text= textarea ! name (fromString nam) << text + + fselect nam list = select ! name (fromString nam) << list + foption name v msel= + let tag= option ! value (fromString name) << v + in if msel then tag ! selected (fromString "") else tag + + + formAction action form = St.form ! At.action (fromString action) ! method (fromString "post") $ form + + fromStr= toMarkup + fromStrNoEncode = preEscapedToMarkup + flink v str = a ! href (fromString v) << str + + attrs tag [] = tag + attrs tag ((n,v):attribs) = + let tag'= tag ! (customAttribute $ stringTag n) (fromString v) + in attrs tag' attribs + + + + + + + diff --git a/src/MFlow/Forms/HSP.hs b/src/MFlow/Forms/HSP.hs --- a/src/MFlow/Forms/HSP.hs +++ b/src/MFlow/Forms/HSP.hs @@ -1,21 +1,24 @@ {-# OPTIONS -F -pgmFtrhsx -XUndecidableInstances -XOverlappingInstances -XTypeSynonymInstances -XFlexibleInstances #-} -{- | Instantiation of "MFlow.Forms" for the hsp package -it includes additional features for embedding widgets within HTML formatting +{- | +Instantiation of the 'FormInput' class for the HSP package + for embedding widgets within HTML-XML formatting -} module MFlow.Forms.HSP where - +import MFlow +import MFlow.Cookies(contentHtml) import MFlow.Forms import Control.Monad.Trans import Data.Typeable import HSP import Data.Monoid import Control.Monad(when) -import Data.ByteString.Lazy.Char8(unpack) +import Data.ByteString.Lazy.Char8(unpack,pack) +import System.IO.Unsafe @@ -24,11 +27,18 @@ mappend x y= <% x %> <% y %> mconcat xs= <% [<% x %> | x <- xs] %> -instance FormInput (HSP XML) where - - fromString s = <% s %> +instance Typeable (HSP XML) where + typeOf= \_ -> mkTyConApp(mkTyCon "HSP XML") [] +instance FormInput (HSP XML) where + toByteString x= unsafePerformIO $ do + (_,r) <- evalHSP Nothing x + return . pack $ renderXML r + toHttpData = HttpData [contentHtml ] [] . toByteString + ftag t = \e -> genElement (toName t) [] [asChild e] + fromStr s = <% s %> + fromStrNoEncode s= pcdataToChild s finput typ name value checked onclick= <% form %> - addAttributes tag attrs= tag <<@ map (\(n,v)-> n:=v) attrs + attrs tag attrs= tag <<@ map (\(n,v)-> n:=v) attrs diff --git a/src/MFlow/Forms/Internals.hs b/src/MFlow/Forms/Internals.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/Internals.hs @@ -0,0 +1,942 @@ +----------------------------------------------------------------------------- +-- +-- Module : MFlow.Forms.Internals +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- +{-# OPTIONS -XDeriveDataTypeable + -XExistentialQuantification + -XScopedTypeVariables + -XFlexibleInstances + -XUndecidableInstances + -XMultiParamTypeClasses + -XGeneralizedNewtypeDeriving + -XFlexibleContexts + -XOverlappingInstances +#-} + +module MFlow.Forms.Internals where +import MFlow +import MFlow.Cookies +import Control.Applicative +import Data.Monoid +import Control.Monad.Trans +import Control.Monad.State +import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) +import Data.Typeable +import Data.RefSerialize hiding((<|>)) +import Data.TCache +import Data.TCache.Memoization +import Data.TCache.DefaultPersistence +import Data.Dynamic +import qualified Data.Map as M +import Unsafe.Coerce +import Control.Workflow as WF +import Control.Monad.Identity +import Data.List +import System.IO.Unsafe +instance Serialize a => Serializable a where + serialize= runW . showp + deserialize= runR readp + +type UserStr= String +type PasswdStr= String + +data User= User + { userName :: String + , upassword :: String + } deriving (Read, Show, Typeable) + +eUser= User (error1 "username") (error1 "password") + +error1 s= error $ s ++ " undefined" + +userPrefix= "User/" +instance Indexable User where + key User{userName= user}= keyUserName user + +-- | Return the key name of an user +keyUserName n= userPrefix++n + +-- | Register an user/password +userRegister :: MonadIO m => String -> String -> m (DBRef User) +userRegister user password = liftIO . atomically $ newDBRef $ User user password + + + +-- | Authentication against `userRegister`ed users. +-- to be used with `validate` +userValidate :: MonadIO m => (UserStr,PasswdStr) -> m (Maybe String) +userValidate (u,p) = + let user= eUser{userName=u} + in liftIO $ atomically + $ withSTMResources [user] + $ \ mu -> case mu of + [Nothing] -> resources{toReturn= err } + [Just (User _ pass )] -> resources{toReturn= + case pass==p of + True -> Nothing + False -> err + } + + where + err= Just "Username or password invalid" + +data Config = Config UserStr deriving (Read, Show, Typeable) + +keyConfig= "MFlow.Config" +instance Indexable Config where key _= keyConfig +rconf= getDBRef keyConfig + +setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m () +setAdminUser user password= liftIO $ atomically $ do + newDBRef $ User user password + writeDBRef rconf $ Config user + +getAdminName :: MonadIO m => m UserStr +getAdminName= liftIO $ atomically ( readDBRef rconf `onNothing` error "admin user not set" ) >>= \(Config u) -> return u + + +data Action m a= Backward Dynamic | Forward (Maybe (Handle m a)) a | Abort String + +data Handle m a= forall b.Typeable b => Handle(b -> m(Action m a)) + +data Sup m a= Sup {runSup :: m (Action m a)} + +instance Monad m => Monad(Sup m) where + fail msg = Sup . return $ Backward $ toDyn msg + return x = Sup . return $ Forward Nothing x + x >>= f = Sup $ loop Nothing + where + loop mmsg= do + v <- runSup x -- !> "loop" + case v of + Forward Nothing y -> runSup (f y) + Forward (Just (Handle h)) y -> + case mmsg of + Just dmsg -> + case fromDynamic dmsg of + Just msg -> do + r <- h msg + case r of + Forward _ y -> continueWith y + Backward msg -> loop $ Just msg + Abort text-> return $ Abort text + Nothing -> loop mmsg + Nothing -> continueWith y + + + Backward msg -> return $ Backward msg + + continueWith y=do + z <- runSup (f y) + case z of + Backward msg -> loop $ Just msg -- !> "GoBack" + other -> return other + +instance MonadTrans Sup where + lift mx= Sup $ mx >>= return . Forward Nothing + +returnSup :: Monad m => Handle m a -> a -> Sup m a +returnSup hand x= Sup . return $ Forward (Just hand) x + +liftSup :: Monad m => Handle m a -> m a -> Sup m a +liftSup h mx= Sup $ do + x <- mx + return $ Forward (Just h) x + + + +instance MonadState s m => MonadState s (Sup m) where + get= lift get -- !> "get" + put= lift . put + +--handleString = Handle $ \(s ::String) -> do +-- putStrLn $"repeat "++s +-- return $ Forward Nothing () +-- +--test= runSup $ do +-- liftSup handleString $ print "hola" +-- n2 <- lift $ getLine +-- lift $ print "n3" +-- n3 <- lift $ getLine +-- if n3 == "back" +-- then fail "again" +-- else lift $ print $ n2++n3 +-- + +data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable) + + +instance (Serialize a) => Serialize (FailBack a ) where + showp (BackPoint x)= insertString (pack iCanFailBack) >> showp x + showp (NoBack x)= insertString (pack noFailBack) >> showp x + showp GoBack = insertString (pack repeatPlease) + + readp = choice [icanFailBackp,repeatPleasep,noFailBackp] + where + noFailBackp = {-# SCC "deserialNoBack" #-} symbol noFailBack >> readp >>= return . NoBack + icanFailBackp = {-# SCC "deserialBackPoint" #-} symbol iCanFailBack >> readp >>= return . BackPoint + repeatPleasep = {-# SCC "deserialbackPlease" #-} symbol repeatPlease >> return GoBack + +iCanFailBack= "B" +repeatPlease= "G" +noFailBack= "N" + +newtype BackT m a = BackT { runBackT :: m (FailBack a ) } + +instance Monad m => Monad (BackT m) where + fail _ = BackT . return $ GoBack + return x = BackT . return $ NoBack x + x >>= f = BackT $ loop + where + loop = do + v <- runBackT x -- !> "loop" + case v of + NoBack y -> runBackT (f y) -- !> "runback" + BackPoint y -> do + z <- runBackT (f y) -- !> "BACK" + case z of + GoBack -> loop -- !> "GoBack" + other -> return other + GoBack -> return $ GoBack + + + + +{-# NOINLINE breturn #-} + +-- | Use this instead of return to return from a computation with an ask statement +-- +-- This way when the user press the back button, the computation will execute back, to +-- the returned code, according with the user navigation. +breturn :: (Monad m) => a -> FlowM v m a +breturn = flowM . BackT . return . BackPoint -- !> "breturn" + + +instance (MonadIO m) => MonadIO (BackT m) where + liftIO f= BackT $ liftIO f >>= \ x -> return $ NoBack x + +instance (Monad m,Functor m) => Functor (BackT m) where + fmap f g= BackT $ do + mr <- runBackT g + case mr of + BackPoint x -> return . BackPoint $ f x + NoBack x -> return . NoBack $ f x + GoBack -> return $ GoBack + + +liftBackT f = BackT $ f >>= \x -> return $ NoBack x +instance MonadTrans BackT where + lift f = BackT $ f >>= \x -> return $ NoBack x + + +instance MonadState s m => MonadState s (BackT m) where + get= lift get -- !> "get" + put= lift . put + +type WState view m = StateT (MFlowState view) m +type FlowMM view m= BackT (WState view m) + +data FormElm view a = FormElm [view] (Maybe a) deriving Typeable + +instance Serialize a => Serialize (FormElm view a) where + showp (FormElm _ x)= showp x + readp= readp >>= \x -> return $ FormElm [] x + + +newtype View v m a = View { runView :: WState v m (FormElm v a)} + + +newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,MonadState(MFlowState v)) +flowM= FlowM +--runFlowM= runView + + +instance (FormInput v,Serialize a) + => Serialize (a,MFlowState v) where + showp (x,s)= case mfDebug s of + False -> showp x + True -> showp(x, mfEnv s) + readp= choice[nodebug, debug] + where + nodebug= readp >>= \x -> return (x, mFlowState0) + debug= do + (x,env) <- readp + return (x,mFlowState0{mfEnv= env}) + + +instance Functor (FormElm view ) where + fmap f (FormElm form x)= FormElm form (fmap f x) + +instance (Monad m,Functor m) => Functor (View view m) where + fmap f x= View $ fmap (fmap f) $ runView x + + +instance (Functor m, Monad m) => Applicative (View view m) where + pure a = View $ return (FormElm [] $ Just a) + View f <*> View g= View $ + f >>= \(FormElm form1 k) -> + g >>= \(FormElm form2 x) -> + return $ FormElm (form1 ++ form2) (k <*> x) + +instance (Functor m, Monad m) => Alternative (View view m) where + empty= View $ return $ FormElm [] Nothing + View f <|> View g= View $ + f >>= \(FormElm form1 k) -> + g >>= \(FormElm form2 x) -> + return $ FormElm (form1 ++ form2) (k <|> x) + + +instance (Monad m) => Monad (View view m) where + View x >>= f = View $ do + FormElm form1 mk <- x + case mk of + Just k -> do + FormElm form2 mk <- runView $ f k + return $ FormElm (form1++ form2) mk + Nothing -> return $ FormElm form1 Nothing + + return= View . return . FormElm [] . Just + +--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 + get = View $ get >>= \x -> return $ FormElm [] $ Just x + put st = View $ put st >>= \x -> return $ FormElm [] $ Just x + +--instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where +-- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x +-- 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 + +-- | Execute the widget in a monad and return the result in another. +changeMonad :: (Monad m, Executable m1) + => View v m1 a -> View v m a +changeMonad w= View . StateT $ \s -> + let (r,s')= execute $ runStateT ( runView w) s + in mfSequence s' `seq` return (r,s') + + +type Lang= String + +data MFlowState view= MFlowState{ + mfSequence :: Int, + mfCached :: Bool, + prevSeq :: [Int], + onInit :: Bool, + inSync :: Bool, + + mfLang :: Lang, + mfEnv :: Params, + needForm :: Bool, + + mfToken :: Token, + mfkillTime :: Int, + mfSessionTime :: Integer, + mfCookies :: [Cookie], + mfHttpHeaders :: Params, + mfHeader :: view -> view, + mfDebug :: Bool, + mfRequirements :: [Requirement], + mfData :: M.Map TypeRep Void, + mfAjax :: Maybe (M.Map String Void), + mfSeqCache :: Int, + notSyncInAction :: Bool + } + deriving Typeable + +type Void = Char + +mFlowState0 :: (FormInput view) => MFlowState view +mFlowState0 = MFlowState 0 False [] True False "en" + [] False (error "token of mFlowState0 used") + 0 0 [] [] stdHeader False [] M.empty Nothing 0 False + + +-- | Set user-defined data in the context of the session. +-- +-- The data is indexed by type in a map. So the user can insert-retrieve different kinds of data +-- in the session context. +-- +-- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow: +-- +-- > newtype History = History ( Html) deriving Typeable +-- > setHistory html= setSessionData $ History html +-- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h +-- > addHistory html= do +-- > html' <- getHistory +-- > setHistory $ html' `mappend` html + +setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a ->m () +setSessionData x= do + modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)} + +-- | Get the session data of the desired type if there is any. +getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a) +getSessionData = resp where + resp= gets mfData >>= \list -> + case M.lookup ( typeOf $ typeResp resp ) list of + Just x -> return . Just $ unsafeCoerce x + Nothing -> return $ Nothing + typeResp :: m (Maybe x) -> x + typeResp= undefined + +-- | Return the user language. Now it is fixed to "en" +getLang :: MonadState (MFlowState view) m => m String +getLang= gets mfLang + +getToken :: MonadState (MFlowState view) m => m Token +getToken= gets mfToken + + +-- get a parameter form the las received response +getEnv :: MonadState (MFlowState view) m => m Params +getEnv = gets mfEnv + +stdHeader v = v + + +-- | Set the header-footer that will enclose the widgets. It must be provided in the +-- same formatting than them, altrough with normalization to byteStrings any formatting can be used +-- +-- This header uses XML trough Haskell Server Pages () +-- +-- @ +-- setHeader $ \c -> +-- \ +-- \ +-- \ my title \ +-- \) +-- \ +-- \ +-- \<% c %\> +-- \ +-- \ +-- @ +-- +-- This header uses "Text.XHtml" +-- +-- @ +-- setHeader $ \c -> +-- `thehtml` +-- << (`header` +-- << (`thetitle` << title +++ +-- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++ +-- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c +-- @ +-- +-- This header uses both. It uses byteString tags +-- +-- @ +-- setHeader $ \c -> +-- `bhtml` [] $ +-- `btag` "head" [] $ +-- (`toByteString` (thetitle << title) `append` +-- `toByteString` ) `append` +-- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c +-- @ + +setHeader :: MonadState (MFlowState view) m => (view -> view) -> m () +setHeader header= do + fs <- get + put fs{mfHeader= header} + + + +-- | Return the current header +getHeader :: (Monad m) => FlowM view m (view -> view) +getHeader= gets mfHeader + +-- | Set an HTTP cookie +setCookie :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> String -- ^ path + -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie + -> m () +setCookie n v p me= do + modify $ \st -> st{mfCookies= (n,v,p,fmap show me):mfCookies st } + +-- | Set an HTTP Response header +setHttpHeader :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> m () +setHttpHeader n v = do + modify $ \st -> st{mfHttpHeaders= (n,v):mfHttpHeaders st } + + +-- | Set 1) the timeout of the flow execution since the last user interaction. +-- Once passed, the flow executes from the begining. 2). In persistent flows +-- it set the session state timeout for the flow, that is persistent. If the +-- flow is not persistent, it has no effect. +-- +-- `transient` flows restart anew. +-- persistent flows (that use `step`) restart at the las saved execution point, unless +-- the session time has expired for the user. +setTimeouts :: Monad m => Int -> Integer -> FlowM view m () +setTimeouts kt st= do + fs <- get + put fs{ mfkillTime= kt, mfSessionTime= st} + + +getWFName :: MonadState (MFlowState view) m => m String +getWFName = do + fs <- get + return . twfname $ mfToken fs + +getCurrentUser :: MonadState (MFlowState view) m=> m String +getCurrentUser = return . tuser =<< gets mfToken + +type Name= String +type Type= String +type Value= String +type Checked= Bool +type OnClick= Maybe String + +normalize ::(Monad m, FormInput v) => View v m a -> View ByteString m a +normalize f= View . StateT $ \s ->do + (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s + return (FormElm (map toByteString fs ) mx,unsafeCoerce s') +-- +--class ToByteString a where +-- toByteString :: a -> ByteString +-- +--instance ToByteString a => ToHttpData a where +-- toHttpData = toHttpData . toByteString +-- +--instance ToByteString ByteString where +-- toByteString= id +-- +--instance ToByteString String where +-- toByteString = pack + +-- | Minimal interface for defining the basic form combinators in a concrete rendering. +-- defined in this module. see "MFlow.Forms.XHtml" for the instance for @Text.XHtml@ and MFlow.Forms.HSP for an instance +-- form Haskell Server Pages. +class (Monoid view,Typeable view) => FormInput view where + toByteString :: view -> ByteString + toHttpData :: view -> HttpData + fromStr :: String -> view + fromStrNoEncode :: String -> view + ftag :: String -> view -> view + inred :: view -> view + flink :: String -> view -> view + flink1:: String -> view + flink1 verb = flink verb (fromStr verb) + finput :: Name -> Type -> Value -> Checked -> OnClick -> view + ftextarea :: String -> String -> view + fselect :: String -> view -> view + foption :: String -> view -> Bool -> view + foption1 :: String -> Bool -> view + foption1 val msel= foption val (fromStr val) msel + formAction :: String -> view -> view + attrs :: view -> Attribs -> view + + + +--instance (MonadIO m) => MonadIO (FlowM view m) where +-- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad + +--instance Executable (View v m) where +-- execute f = execute $ evalStateT f mFlowState0 + + +--instance (Monad m, Executable m, Monoid view, FormInput view) +-- => Executable (StateT (MFlowState view) m) where +-- execute f= execute $ evalStateT f mFlowState0 + +-- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance +-- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose +-- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his +-- own instance for his monad. +-- +-- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) +--, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases. +-- +-- @ +-- import MFlow.Wai.XHtm.All +-- import Some.Time.Library +-- addMessageFlows [(noscript, time)] +-- main= run 80 waiMessageFlow +-- time=do ask $ cachedWidget \"time\" 5 +-- $ wlink () bold << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\" +-- time +-- @ +-- +-- this pseudocode would update the time every 5 seconds. The execution of the IO computation +-- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions. +-- +-- NOTE: cached widgets are shared by all users +cachedWidget ::(MonadIO m,Typeable view + , FormInput view, Typeable a, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> 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 _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True} + let s''= s{inSync = inSync s2 + ,mfRequirements=mfRequirements s2 + ,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec} + return $ (mfSeqCache s'') `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 ) + +-- | A shorter name for `cachedWidget` +wcached ::(MonadIO m,Typeable view + , FormInput view, Typeable a, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> View view Identity a -- ^ The cached widget, in the Identity monad + -> View view m a -- ^ The cached result +wcached= cachedWidget + +-- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@ +-- cache also the user response. This is useful for pseudo-widgets which just show information +-- while the controls are in other non freezed widgets. A freezed widget ever return the first user response +-- It is faster than `cachedWidget`. +-- It is not restricted to the Identity monad. +-- +-- NOTE: cached widgets are shared by all users +wfreeze ::(MonadIO m,Typeable view + , FormInput view, Typeable a, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> View view m a -- ^ The cached widget + -> View view m a -- ^ The cached result +wfreeze key t mf = View . StateT $ \s -> do + ((FormElm f mx), req,seq) <- cachedByKey key t $ proc mf s{mfCached=True} + return ((FormElm f mx), s{mfRequirements=req,mfSeqCache= seq}) + where + proc mf s= do + (r,s) <- runStateT (runView mf) s + return (r,mfRequirements s, mfSeqCache s) + +-- +---- | FormLet class +--class (Functor m, MonadIO m) => FormLet a m view where +-- digest :: Maybe a +-- -> View view m a + +--wrender +-- :: Widget a1 a m v => a1 -> StateT (MFlowState v) m ([v], Maybe a) +-- +--wrender x =do +-- (FormElm frm x) <- runView (widget x) +-- return (frm, x) + +-- Minimal definition: either (wrender and wget) or widget +--class (Functor m, MonadIO m) => Widget a b m view | a -> b view where +-- wrender :: a -> WState view m [view] +-- wrender x =do +-- (FormElm frm (_ :: Maybe b)) <- runView (widget x) +-- return frm +-- wget :: a -> WState view m (Maybe b) +-- wget x= runView (widget x) >>= \(FormElm _ mx) -> return mx + +-- widget :: a -> View view m b +-- widget x = View $ do +-- form <- wrender x +-- got <- wget x +-- return $ FormElm form got + + +--instance FormLet a m view => Widget (Maybe a) a m view where +-- widget = digest + +{- | Execute the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow` +`waiMessageFlow` or `addMessageFlows` + +@main= do + addMessageFlows [(\"noscript\",transient $ runFlow mainf)] + forkIO . run 80 $ waiMessageFlow + adminLoop +@ +-} +runFlow :: (FormInput view, Monad m) + => FlowM view m a -> Token -> m a +runFlow f = \t -> evalStateT (runBackT . runFlowM $ breturn() >> f) mFlowState0{mfToken=t,mfEnv= tenv t} >>= return . fromFailBack -- >> return () + where + -- to restart the flow in case of going back before the first page of the flow + + fromFailBack (NoBack x) = x + fromFailBack (BackPoint x)= x + +-- | Run a persistent flow inside the current flow. It is identified by the procedure and +-- the string identifier. +-- unlike the normal flows, that are infinite loops, runFlowIn executes a finite flow +-- once executed, in subsequent executions the flow will return the stored result +-- without asking again. This is useful for asking/storing/retrieving user defined configurations. +runFlowIn + :: (MonadIO m, + FormInput view) + => String + -> FlowM view (Workflow IO) b + -> FlowM view m b +runFlowIn wf f= do + t <- gets mfToken + liftIO $ WF.exec1nc wf $ runFlow f t + + + +step + :: (Serialize a, + Typeable view, + FormInput view, + MonadIO m, + Typeable a) => + FlowM view m a + -> FlowM view (Workflow m) a + +step f= do + s <- get + flowM $ BackT $ do + (r,s') <- lift . WF.step $ runStateT (runBackT $ runFlowM f) s + -- when recovery of a workflow, the MFlow state is not considered + when( mfSequence s' >0) $ put s' + return r + +--stepDebug +-- :: (Serialize a, +-- Typeable view, +-- FormInput view, +-- Monoid view, +-- MonadIO m, +-- Typeable a) => +-- FlowM view m a +-- -> FlowM view (Workflow m) a +--stepDebug f= BackT $ do +-- s <- get +-- (r, s') <- lift $ do +-- (r',stat)<- do +-- rec <- isInRecover +-- case rec of +-- True ->do (r', s'') <- getStep 0 +-- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)}) +-- False -> return (undefined,s) +-- (r'', s''') <- WF.stepDebug $ runStateT (runBackT f) stat >>= \(r,s)-> return (r, s) +-- return $ (r'' `asTypeOf` r', s''' ) +-- put s' +-- return r + + + +getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) + => String -> Params -> [v] -> m (FormElm v a) +getParam1 par req form= r + where + r= case lookup par req of + Just x -> do + modify $ \s -> s{inSync= True} + maybeRead x -- !> x + Nothing -> return $ FormElm form Nothing + getType :: m (FormElm v a) -> a + getType= undefined + x= getType r + maybeRead str= do + + if typeOf x == (typeOf ( undefined :: String)) + then return . FormElm form . Just $ unsafeCoerce str + else case readsPrec 0 $ str of + [(x,"")] -> return . FormElm form $ Just x + _ -> do + + let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) + return $ FormElm (err:form) Nothing + + +---- 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. +requires rs =do + st <- get + let l = mfRequirements st +-- let rs'= map Requirement rs \\ l + put st {mfRequirements= l ++ map Requirement rs} + + + +data Requirement= forall a.(Typeable a,Requirements a) => Requirement a deriving Typeable + +class Requirements a where + installRequirements :: (Monad m,FormInput view) => [a] -> m view + + + +installAllRequirements ::( Monad m, FormInput view) => WState view m view +installAllRequirements= do + rs <- gets mfRequirements + installAllRequirements1 mempty rs + where + + installAllRequirements1 v []= return v + installAllRequirements1 v rs= do + let typehead= case head rs of {Requirement r -> typeOf r} + (rs',rs'')= partition1 typehead rs + v' <- installRequirements2 rs' + installAllRequirements1 (v `mappend` v') rs'' + where + installRequirements2 []= return $ fromStrNoEncode "" + installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs + unmap []=[] + unmap (Requirement r:rs)= unsafeCoerce r:unmap rs + partition1 typehead xs = foldr select ([],[]) xs + where + select x ~(ts,fs)= + let typer= case x of Requirement r -> typeOf r + in if typer== typehead then ( x:ts,fs) + else (ts, x:fs) + +-- Web requirements --- +loadjsfile filename lcallbacks= + "var fileref=document.createElement('script');\ + \fileref.setAttribute('type','text/javascript');\ + \fileref.setAttribute('src',\'" ++ filename ++ "\');\ + \document.getElementsByTagName('head')[0].appendChild(fileref);" + ++ onload + where + onload= case lcallbacks of + [] -> "" + cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};" + + +loadjs content= content + + +loadcssfile filename= + "var fileref=document.createElement('link');\ + \fileref.setAttribute('rel', 'stylesheet');\ + \fileref.setAttribute('type', 'text/css');\ + \fileref.setAttribute('href', \'"++filename++"\');\ + \document.getElementsByTagName('head')[0].appendChild(fileref);" + + +loadcss content= + "var fileref=document.createElement('link');\ + \fileref.setAttribute('rel', 'stylesheet');\ + \fileref.setAttribute('type', 'text/css');\ + \fileref.innerText=\""++content++"\";\ + \document.getElementsByTagName('head')[0].appendChild(fileref);" + + + + + + +data WebRequirement= JScriptFile + String + [String] -- ^ Script URL and the list of scripts to be executed when loaded + | CSSFile String -- ^ a CSS file URL + | CSS String -- ^ a String with a CSS description + | JScript String -- ^ a string with a valid JavaScript + | ServerProc (String, Flow) -- ^ a server procedure + deriving(Typeable,Eq,Ord,Show) + +instance Eq (String, Flow) where + (x,_) == (y,_)= x == y + +instance Ord (String, Flow) where + compare(x,_) (y,_)= compare x y +instance Show (String, Flow) where + show (x,_)= show x + +instance Requirements WebRequirement where + installRequirements= installWebRequirements + + + +installWebRequirements :: (Monad m,FormInput view) =>[WebRequirement] -> m view +installWebRequirements rs= do + let s = aggregate $ sort rs + + return $ ftag "script" (fromStrNoEncode s) + where + aggregate []= "" + + + aggregate (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs) + | f==f'= aggregate $ JScriptFile f (nub c++c'):rs + | otherwise= strRequirement r++aggregate (r':rs) + + aggregate (r:r':rs) + | r== r' = aggregate $ r:rs + | otherwise= strRequirement r ++ aggregate (r':rs) + + aggregate (r:rs)= strRequirement r++aggregate rs + + strRequirement (CSSFile s') = loadcssfile s' + strRequirement (CSS s') = loadcss s' + strRequirement (JScriptFile s' call) = loadjsfile s' call + strRequirement (JScript s') = loadjs s' + strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` "" + + +--- AJAX ---- +ajaxScript= + "function loadXMLObj()" ++ + "{" ++ + "var xmlhttp;" ++ + "if (window.XMLHttpRequest)" ++ + "{"++ + " xmlhttp=new XMLHttpRequest();" ++ + " }" ++ + "else" ++ + "{"++ + " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++ + " }" ++ + "return xmlhttp" ++ + "};" ++ + + " xmlhttp= loadXMLObj();" ++ + " noparam= '';"++ + ""++ + "function doServer (servproc,param,param2){" ++ + " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++ + " xmlhttp.send();};" ++ + ""++ + "xmlhttp.onreadystatechange=function()" ++ + " {" ++ + " if (xmlhttp.readyState + xmlhttp.status==204)" ++ + " { " ++ + " eval(xmlhttp.responseText);" ++ + " }" ++ + " };" ++ + "" + diff --git a/src/MFlow/Forms/Test.hs b/src/MFlow/Forms/Test.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/Test.hs @@ -0,0 +1,287 @@ +----------------------------------------------------------------------------- +-- +-- Module : MFlow.Forms.Test +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- +{-# OPTIONS + -XOverlappingInstances + -XFlexibleInstances + -XUndecidableInstances + -XPatternGuards + -XRecordWildCards + #-} + +module MFlow.Forms.Test (Response(..),runTest,ask) where +import MFlow.Forms hiding(ask) +import qualified MFlow.Forms (ask) +import MFlow.Forms(FormInput(..)) +import MFlow.Forms.Admin +import Control.Workflow as WF +import Control.Concurrent +import Control.Monad +import MFlow +import qualified Data.Map as M +import Control.Monad.Trans +import System.IO.Unsafe +import System.Random +import Data.Char(chr, ord) +import Data.List +import Data.Typeable +import qualified Data.ByteString.Lazy.Char8 as B +import Control.Concurrent.MVar +import Data.TCache.Memoization +import Control.Monad.State +import Data.Monoid +import Data.Maybe +import Data.IORef +import MFlow.Cookies(cookieuser) + + +class Response a where + response :: IO a + +instance Response a => Response (Maybe a) where + response= do + b <- randomRIO(0,1 :: Int) + case b of 0 -> response >>= return . Just ; _ -> return Nothing + +instance Response String where + response= replicateM 5 $ randomRIO ('a','z') + +instance Response Int where + response= randomRIO(1,1000) + +instance Response Integer where + response= randomRIO(1,1000) + + +instance (Response a, Response b) => Response (a,b) where + response= fmap (,) response `ap` response + + +instance (Response a, Response b) => Response (Maybe a,Maybe b) where + response= do + r <- response + case r of + (Nothing,Nothing) -> response + other -> return other + + +instance (Bounded a, Enum a) => Response a where + response= mx + where + mx= do + let x= typeOfIO mx + n <- randomRIO ( fromEnum $ minBound `asTypeOf` x + , fromEnum $ maxBound `asTypeOf` x) + return $ toEnum n + where + typeOfIO :: IO a -> a + typeOfIO = error $ "typeOfIO not defined" + +-- | run a list of flows with a number of simultaneous threads +runTest :: [(Int, Flow)] -> IO () +runTest ps=do + mapM_ (forkIO . run1) ps + + putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads" + adminLoop + +run1 (nusers, proc) = replicateM_ nusers $ randomFlow proc + where + randomFlow f = do + name <- response + x <- response + y <- response + z <- response + r1<- liftIO newEmptyMVar + r2<- liftIO newEmptyMVar + let t = Token x y z [] r1 r2 + forkIO . WF.exec1 name $ f t + +-- | a simulated ask that generate simulated user responses of the type expected +-- +-- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes. + +-- execute 'runText' to initiate threads under different load conditions. +ask :: (Response a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a +ask w = do + w `MFlow.Forms.wmodify` (\v x -> consume v >> return (v,x)) + `seq` rest + where + consume= liftIO . B.writeFile "NULL" . B.concat . map toByteString + rest= do + bool <- liftIO $ response + case bool of + False -> fail "" + True -> do + b <- liftIO response + r <- liftIO $ response + case (b,r) of + (True,x) -> breturn x + _ -> ask w + + +-- +--match form=do +-- marches <- readIORef matches +-- return $ head map (m s) matches +-- where +-- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of +-- True -> Just ps +-- False -> Nothing +-- +--composeParams (Gen ps) form= zip (getParams form) ps +-- where +-- getParams form= +-- let search name form +-- | null form = mempty +-- | isPrefix name form = drop (length name) form +-- | otherwise= search name $ tail form +-- +-- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s +-- getPar= par $ search "name" +-- in getPar form +-- +{- +waction ::(Functor m, MonadIO m,Response a, FormInput view) + => View view m a + -> (a -> FlowM view m b) + -> View view m b +waction w f= do + x <- liftIO response + MFlow.Forms.waction (return x) f + + +--wmodify +-- :: (Functor m, MonadIO m, FormInput v, Response (Maybe a)) => +-- View v m a1 +-- -> ([v] -> Maybe a -> WState v m ([v], Maybe b)) +-- -> View v m b +wmodify formt act = do + x <- liftIO response + formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act +-} + +{- +type Var= String +data Test= Test{tflink:: [(Var,String)] + ,selectOptions :: [(Var,[String])] + ,tfinput :: [(Var, String)] + ,tftextarea :: [(Var, String)] + } + deriving(Read,Show) + +type TestM = Test -> Test + +instance Monoid TestM where + mempty= id + mappend= (.) + +instance FormInput TestM where + ftag = const id + inred = const id + fromStr = const id + flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t} + finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t} + ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t} + fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t} + foption o _ _= \t -> + let (n,opts)= head $ selectOptions t + in t{selectOptions=(n,o:opts):tail (selectOptions t)} + formAction _ _= id + addAttributes _ _= id + +generateResponse Test{..}= do + b <- response + case b of + True -> genLink + False -> genForm + + where + genForm= do + -- one on every response is incomplete + n <- randomRIO(0,10) :: IO Int + case n of + 0 -> do + genInput + + _ -> do + r1 <- genInput + r2 <- genSelect + r3 <- genTextArea + return $ r1++r2++r3 + genLink= do + let n = length tflink + if n == 0 then genForm + else do + r <- randomRIO(0,n ) + return [tflink !! r] + + genSelect=do + let n = length selectOptions + if n== 0 + then return [] + else mapM gen selectOptions + where + gen(s,os)= do + let m = length os + j <- randomRIO(0,m) + return (s, os !! j) + + genInput= do + let n = length tftextarea + if n==0 + then return [] + else mapM gen tfinput + where gen(n,_)= do + str <- response + return $ (n,str) + + genTextArea= do + let n = length tfinput + if n==0 + then return [] + else mapM gen tftextarea + where + gen(n,_)= do + str <- response + return $ (n,str) + +pwf= "pwf" +ind= "ind" +instance Processable Params where + pwfname = fromMaybe noScript . lookup pwf + puser= fromMaybe anonymous . lookup cookieuser + pind = fromMaybe "0" . lookup ind + getParams = id + + + +runTest nusers = do + wfs <- getMessageFlows + replicateM nusers $ gen wfs + where + gen wfs = do + u <- response + mapM (genTraffic u) $ M.toList wfs + + genTraffic u (n,_)= forkIO $ iterateresponses [(pwf,n),(cookieuser,u)] [] + + iterateresponses ident msg= iterate [] msg + where + iterate cs msg= do + (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg + let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks + resp <- generateResponse . read $ B.unpack test + iterate cs' resp + + -} diff --git a/src/MFlow/Forms/Widgets.hs b/src/MFlow/Forms/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/Widgets.hs @@ -0,0 +1,483 @@ + +{- | +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 #-} + + + + +module MFlow.Forms.Widgets ( +-- * User Management +userFormOrName,maybeLogout, +-- * Active widgets +wEditList,wautocomplete,wautocompleteList +, wautocompleteEdit, + +-- * Editing widgets +delEdited, getEdited +,prependWidget,appendWidget,setWidget +-- * Content Management +,tField, tFieldEd, tFieldGen + +-- * Multilanguage +,mFieldEd, mField + +) 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 Control.Monad.Identity + + +readyJQuery="ready=function(){if(!window.jQuery){return setTimeout(ready,100)}};" + +jqueryScript= "http://ajax.googleapis.com/ajax/libs/jquery/1.8.0/jquery.min.js" + +jqueryCSS= "http://code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css" + +jqueryUi= "http://code.jquery.com/ui/1.9.1/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 fromStr " " ++> wlink () (fromStr "logout") `waction` const logout + else noWidget + +--- active widgets + +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 (mkTyCon "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 + +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 (k,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 + (ks,ws) <- return . unzip =<< getEdited1 id + return $ ws `asTypeOf` witness + mapM (liftIO . flushCached) ks + 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 + 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 <> "');" + +-- | 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 code 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) 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: +-- +-- > wlistEd= do +-- > r <- ask $ addLink +-- > ++> br +-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) +-- > <++ br +-- > <** submitButton "send" +-- > +-- > ask $ p << (show r ++ " returned") +-- > ++> wlink () (p << text " back to menu") +-- > mainmenu +-- > where +-- > addLink = a ! At.id "wEditListAdd" +-- > ! 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. + -> View view m [a] +wEditList holderview w xs = 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(){\ + \$('#wEditListAdd').click(function(){"++callAjax "''"++"});})" + + requires [JScriptFile jqueryScript [installevents] ] + + ws' <- getEdited sel + + r <- (holderview <<< (manyOf $ ws' ++ map changeMonad ws)) 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 + ajaxc <- ajax $ \(u) -> do + r <- liftIO $ autocomplete u + return $ jaddtoautocomp r + + + requires [JScriptFile jqueryScript [] -- [events] + ,CSSFile jqueryCSS + ,JScriptFile jqueryUi []] + + + getString mv 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 of this widget 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 sel= "$('#" <> B.pack id1 <> "')" + ajaxc <- ajax $ \(c:u) -> + case c of + 'f' -> prependWidget sel (elem $ Just u) + _ -> do + r <- liftIO $ autocomplete u + return $ jaddtoautocomp r + + + requires [JScriptFile jqueryScript [events ajaxc] -- [events] + ,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", "text1") + ,("placeholder", phold) + ,("oninput",ajaxc "'n'+$('#text1').attr('value')" ) + ,("autocomplete", "off")] + delEdited sel ws' + return r + where + events ajaxc= + "$(document).ready(function(){ \ + \ $('#text1').keydown(function(){ \ + \ if(event.keyCode == 13){ \ + \ var v= $('#text1').attr('value'); \ + \ event.preventDefault();" ++ + ajaxc "'f'+v"++";"++ + " $('#text1').val('');\ + \ }\ + \ });\ + \});" + + jaddtoautocomp us= "$('#text1').autocomplete({ source: " <> B.pack( show us) <> " });" + +-- | A specialization of 'selectAutocompleteEdit' which make appear each option choosen 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 --------- + +writetField k s= atomically $ writetFieldSTM k s + +writetFieldSTM k s= do + phold <- readDBRef tFields `onNothing` return (M.fromList []) + let r= M.insert k (toByteString s) phold + writeDBRef tFields r + +readtField text k= atomically $ do + hs<- readDBRef tFields `onNothing` return (M.fromList []) + let mp= M.lookup k hs + case mp of + Just c -> return $ fromStrNoEncode $ B.unpack c + Nothing -> writetFieldSTM k text >> return text + +type TFields = M.Map String B.ByteString +instance Indexable TFields where + key _= "texts" + defPath _= "texts/" + +tFields :: DBRef TFields +tFields = getDBRef "texts" + +type Key= String + +-- | A widget that display the content of an html, But if logged as administrator, +-- it permits to edit it in place. So the editor could see the final appearance +-- of what he write in the page. +-- +-- When the administrator double click in the paragraph, 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. +-- +-- THis is an example of how to use the content management primitives (in demos.blaze.hs): +-- +-- > textEdit= do +-- > setHeader $ \t -> html << body << t +-- > +-- > let first= p << i << +-- > (El.span << text "this is a page with" +-- > <> b << text " two " <> El.span << text "paragraphs") +-- > +-- > second= p << i << text "This is the original text of the second paragraph" +-- > +-- > pageEditable = (tFieldEd "first" first) +-- > **> (tFieldEd "second" second) +-- > +-- > ask $ first +-- > ++> second +-- > ++> wlink () (p << text "click here to edit it") +-- > +-- > ask $ p << text "Please login with admin/admin to edit it" +-- > ++> userWidget (Just "admin") userLogin +-- > +-- > ask $ p << text "now you can click the field and edit them" +-- > ++> p << b << text "to save the edited field, double click on it" +-- > ++> pageEditable +-- > **> wlink () (p << text "click here to see it as a normal user") +-- > +-- > logout +-- > +-- > ask $ p << text "the user sees the edited content. He can not edit" +-- > ++> pageEditable +-- > **> wlink () (p << text "click to continue") +-- > +-- > ask $ p << text "When text 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 << text "End of edit field demo" ++> wlink () (p << text "click here to go to menu") +tFieldEd + :: (Functor m, MonadIO m, Executable m, + FormInput v) => + Key -> v -> View v m () +tFieldEd k text= + tFieldGen k (readtField text) writetField + + +-- | Like 'tFieldEd' with user-configurable storage. +tFieldGen :: (MonadIO m,Functor m, Executable m + ,FormInput v) + => Key + -> (Key -> IO v) -- ^ the read procedure, user defined + -> (Key ->v -> IO()) -- ^ the write procedure, user defiend + -> View v m () +tFieldGen k getcontent create = wfreeze k 0 $ do + content <- liftIO $ getcontent k + admin <- getAdminName + attribs <- do + name <- genNewId + let useradmin= "if(document.cookie.search('"++cookieuser++"="++admin++"') != -1)" + nikeditor= "var myNicEditor = new nicEditor();" + callback=useradmin ++ + "bkLib.onDomLoaded(function() {\ + \ myNicEditor.addInstance('"++name++"');\ + \});" + param= ("'"++k++ "'+','+ document.getElementById('"++name++"').innerHTML") + ajaxjs <- ajax + $ \str -> do + let (k,s)= break (==',') str + liftIO . create k $ fromStrNoEncode (tail s) + liftIO $ flushCached k + return "alert('saved');" + + requires + [JScriptFile "http://js.nicedit.com/nicEdit-latest.js" [nikeditor, callback] + ,JScript ajaxScript] + + return [("id", name),("ondblclick", useradmin++ajaxjs param)] + + wraw $ (ftag "span" content `attrs` attribs) + +-- | Read the 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 + wraw content + +-- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the +-- two characters of the language used. +mFieldEd k content= do + lang <- getLang + tFieldEd (k ++ ('-':lang)) content + +-- | A multilanguage version of tField +mField k= do + lang <- getLang + tField $ k ++ ('-':lang) diff --git a/src/MFlow/Forms/XHtml.hs b/src/MFlow/Forms/XHtml.hs --- a/src/MFlow/Forms/XHtml.hs +++ b/src/MFlow/Forms/XHtml.hs @@ -22,28 +22,24 @@ module MFlow.Forms.XHtml where - +import MFlow (HttpData(..)) import MFlow.Forms +import MFlow.Cookies(contentHtml) import Data.ByteString.Lazy.Char8(pack,unpack) -import Text.XHtml as X +import Text.XHtml.Strict as X import Control.Monad.Trans import Data.Typeable - instance Monad m => ADDATTRS (View Html m a) where widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx) --- View $ do --- FormElm fs mx <- runView widget --- return $ FormElm [head fs ! atrs] mx -instance ToByteString Html where - toByteString = pack. showHtml - instance FormInput Html where - + toByteString = pack. showHtmlFragment + toHttpData = HttpData [contentHtml] [] . toByteString + ftag t= tag t inred = X.bold ![X.thestyle "color:red"] finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else [] ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] ) @@ -54,13 +50,13 @@ where selected msel = if msel then [X.selected] else [] - addAttributes tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs) + attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs) formAction action form = X.form ! [X.action action, method "post"] << form - fromString = stringToHtml - + fromStr = stringToHtml + fromStrNoEncode= primHtml flink v str = toHtml $ hotlink ( v) << str diff --git a/src/MFlow/Hack.hs b/src/MFlow/Hack.hs --- a/src/MFlow/Hack.hs +++ b/src/MFlow/Hack.hs @@ -3,7 +3,12 @@ , MultiParamTypeClasses , DeriveDataTypeable , FlexibleInstances #-} - + +{- | Instantiation of the "MFlow" server for the Hack interface + +see +-} + module MFlow.Hack( module MFlow.Cookies ,module MFlow @@ -35,10 +40,11 @@ import MFlow.Hack.Response import Data.Monoid import Data.CaseInsensitive +import System.Time -import Debug.Trace -(!>)= flip trace +import System.Time + flow= "flow" instance Processable Env where @@ -54,33 +60,27 @@ -- getPort env= serverPort env -data Flow= Flow !Int deriving (Read, Show, Typeable) +data NFlow= NFlow !Integer deriving (Read, Show, Typeable) -instance Serializable Flow where +instance Serializable NFlow where serialize= B.pack . show deserialize= read . B.unpack -instance Indexable Flow where - key _= "Flow" +instance Indexable NFlow where + key _= "NFlow" -rflow= getDBRef . key $ Flow undefined - -newFlow= do - fl <- atomically $ do - m <- readDBRef rflow - case m of - Just (Flow n) -> do - writeDBRef rflow . Flow $ n+1 - return n - - Nothing -> do - writeDBRef rflow $ Flow 1 - return 0 - - - return $ show fl +rflow= getDBRef . key $ NFlow undefined +newFlow= do + TOD t _ <- getClockTime + atomically $ do + NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) + writeDBRef rflow . NFlow $ n+1 + return . show $ t + n + + + --------------------------------------------- @@ -105,9 +105,9 @@ -- -> IO (TResp, ThreadId) --webScheduler = msgScheduler ---theDir= unsafePerformIO getCurrentDirectory +--theDir= unsafePerformIO getCurrentDirectory -wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) +wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message" -- | An instance of the abstract "MFlow" scheduler to the Hack interface @@ -160,7 +160,7 @@ Just fl -> return (fl, []) Nothing -> do fl <- newFlow - return ( fl, [( flow, fl, "/",Nothing)]) + return ( fl, [( flow, fl, "/",(Just $ show $ 365*24*60*60))]) {- for state persistence in cookies putStateCookie req1 cookies @@ -184,7 +184,7 @@ let resp''= toResponse resp' - let headers1= case retcookies of [] -> headers resp''; _ -> ctype : (cookieHeaders retcookies) + let headers1= case retcookies of [] -> headers resp''; _ -> (cookieHeaders retcookies) let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} return resp diff --git a/src/MFlow/Hack/Response.hs b/src/MFlow/Hack/Response.hs --- a/src/MFlow/Hack/Response.hs +++ b/src/MFlow/Hack/Response.hs @@ -35,24 +35,24 @@ instance ToResponse TResp where - toResponse (TResp x)= toResponse x + toResponse (TResp x)= toResponse x toResponse (TRespR r)= toResponse r instance ToResponse Response where toResponse = id instance ToResponse ByteString where - toResponse x= Response{status=200, headers=[ctype {-,("Content-Length",show $ B.length x) -}], body= x} + toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x} instance ToResponse String where - toResponse x= Response{status=200, headers=[ctype{-,("Content-Length",show $ B.length x) -}], body= B.pack x} + toResponse x= Response{status=200, headers=[contentHtml{-,("Content-Length",show $ B.length x) -}], body= B.pack x} instance ToResponse HttpData where toResponse (HttpData hs cookies x)= (toResponse x) {headers= hs++ cookieHeaders cookies} toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str} instance Typeable Env where - typeOf = \_-> mkTyConApp (mkTyCon "Hack.Env") [] + typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") [] -instance Typeable Response where - typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[] +--instance Typeable Response where +-- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[] diff --git a/src/MFlow/Hack/XHtml/All.hs b/src/MFlow/Hack/XHtml/All.hs --- a/src/MFlow/Hack/XHtml/All.hs +++ b/src/MFlow/Hack/XHtml/All.hs @@ -19,8 +19,8 @@ ,module MFlow.Forms ,module MFlow.Forms.XHtml ,module MFlow.Forms.Admin -,module MFlow.Forms.Ajax ,module MFlow.Hack.XHtml +,module MFlow.Forms.Widgets ,module Hack ,module Hack.Handler.SimpleServer ,module Text.XHtml.Strict @@ -33,7 +33,7 @@ import MFlow.Forms import MFlow.Forms.XHtml import MFlow.Forms.Admin -import MFlow.Forms.Ajax +import MFlow.Forms.Widgets import MFlow.Hack.XHtml import Hack(Env) diff --git a/src/MFlow/Wai.hs b/src/MFlow/Wai.hs --- a/src/MFlow/Wai.hs +++ b/src/MFlow/Wai.hs @@ -1,116 +1,109 @@ -{-# LANGUAGE UndecidableInstances - , TypeSynonymInstances - , MultiParamTypeClasses - , DeriveDataTypeable - , FlexibleInstances - , OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances + , TypeSynonymInstances + , MultiParamTypeClasses + , DeriveDataTypeable + , FlexibleInstances + , OverloadedStrings #-} -module MFlow.Wai( - module MFlow.Cookies - ,module MFlow - ,waiMessageFlow) -where +module MFlow.Wai( + module MFlow.Cookies + ,module MFlow + ,waiMessageFlow) +where import Data.Typeable import Network.Wai - + import Control.Concurrent.MVar(modifyMVar_, readMVar) import Control.Monad(when) -import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail) -import Data.ByteString.Lazy(fromChunks) +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 Control.Concurrent(ThreadId(..)) import System.IO.Unsafe -import Control.Concurrent.MVar -import Control.Concurrent +import Control.Concurrent.MVar +import Control.Concurrent import Control.Monad.Trans import Control.Exception -import qualified Data.Map as M +import qualified Data.Map as M import Data.Maybe -import Data.TCache +import Data.TCache import Data.TCache.DefaultPersistence import Control.Workflow hiding (Indexable(..)) import MFlow -import MFlow.Cookies -import Data.Monoid -import MFlow.Wai.Response -import Network.Wai -import Network.HTTP.Types hiding (urlDecode) -import Data.Conduit -import Data.Conduit.Lazy -import qualified Data.Conduit.List as CList -import Data.CaseInsensitive - ---import Debug.Trace ---(!>)= flip trace - -flow= "flow" ---ciflow= mk flow +import MFlow.Cookies +import Data.Monoid +import MFlow.Wai.Response +import Network.Wai +import Network.HTTP.Types hiding (urlDecode) +import Data.Conduit +import Data.Conduit.Lazy +import qualified Data.Conduit.List as CList +import Data.CaseInsensitive +import System.Time +--import Debug.Trace +--(!>)= flip trace + +flow= "flow" +--ciflow= mk flow + instance Processable Request where pwfname env= if SB.null sc then noScript else SB.unpack sc where - sc= SB.tail $ rawPathInfo env - + sc= SB.tail $ rawPathInfo env + 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 $ SB.pack flow) $ requestHeaders env - getParams= mkParams1 . requestHeaders - where - mkParams1 = Prelude.map mkParam1 - mkParam1 ( x,y)= (SB.unpack $ original x, SB.unpack y) - --- getServer env= serverName env --- getPath env= pathInfo env --- getPort env= serverPort env + pind env= fromMaybe (error ": No FlowID") $ fmap SB.unpack $ lookup (mk $ SB.pack flow) $ requestHeaders env + getParams= mkParams1 . requestHeaders + where + mkParams1 = Prelude.map mkParam1 + mkParam1 ( x,y)= (SB.unpack $ original x, SB.unpack y) + +-- getServer env= serverName env +-- getPath env= pathInfo env +-- getPort env= serverPort env -data Flow= Flow !Int deriving (Read, Show, Typeable) - -instance Serializable Flow where - serialize= B.pack . show +data NFlow= NFlow !Integer deriving (Read, Show, Typeable) + +instance Serializable NFlow where + serialize= B.pack . show deserialize= read . B.unpack -instance Indexable Flow where +instance Indexable NFlow where key _= "Flow" - -rflow= getDBRef . key $ Flow undefined +rflow= getDBRef . key $ NFlow undefined + newFlow= liftIO $ do - fl <- atomically $ do - m <- readDBRef rflow - case m of - Just (Flow n) -> do - writeDBRef rflow . Flow $ n+1 - return n - - Nothing -> do - writeDBRef rflow $ Flow 1 - return 0 - return $ show fl + TOD t _ <- getClockTime + atomically $ do + NFlow n <- readDBRef rflow `onNothing` return (NFlow 0) + writeDBRef rflow . NFlow $ n+1 + return . show $ t + n + --------------------------------------------- - - - -- --instance ConvertTo String TResp where -- convert = TResp . pack --- +-- --instance ConvertTo ByteString TResp where --- convert = TResp --- +-- convert = TResp -- +-- --instance ConvertTo Error TResp where --- convert (Error e)= TResp . pack $ errorResponse e --- ---instance ToResponse v =>ConvertTo (HttpData v) TResp where +-- convert (Error e)= TResp . pack $ errorResponse e +-- +--instance ToResponse v =>ConvertTo (HttpData v) TResp where -- convert= TRespR - + --webScheduler :: Request -- -> ProcList -- -> IO (TResp, ThreadId) @@ -121,37 +114,37 @@ --wFMiddleware :: (Request -> Bool) -> (Request-> IO Response) -> (Request -> IO Response) --wFMiddleware filter f = \ env -> if filter env then waiWorkflow env else f env -- !> "new message" --- | An instance of the abstract "MFlow" scheduler to the interface. --- +-- | An instance of the abstract "MFlow" scheduler to the interface. +-- -- it accept the list of processes being scheduled and return a wai handler --- --- Example: --- --- @main= do --- --- putStrLn $ options messageFlows --- 'run' 80 $ 'waiMessageFlow' messageFlows --- where --- messageFlows= [(\"main\", 'runFlow' flowname ) --- ,(\"hello\", 'stateless' statelesproc) --- ,(\"trans\", 'transient' $ runflow transientflow] --- options msgs= \"in the browser choose\\n\\n\" ++ --- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] --- @ ---waiMessageFlow :: [(String, (Token -> Workflow IO ()))] +-- +-- Example: +-- +-- @main= do +-- +-- putStrLn $ options messageFlows +-- 'run' 80 $ 'waiMessageFlow' messageFlows +-- where +-- messageFlows= [(\"main\", 'runFlow' flowname ) +-- ,(\"hello\", 'stateless' statelesproc) +-- ,(\"trans\", 'transient' $ runflow transientflow] +-- options msgs= \"in the browser choose\\n\\n\" ++ +-- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] +-- @ +--waiMessageFlow :: [(String, (Token -> Workflow IO ()))] -- -> (Request -> ResourceT IO Response) --waiMessageFlow messageFlows = -- unsafePerformIO (addMessageFlows messageFlows) `seq` --- waiWorkflow -- wFMiddleware f other +-- waiWorkflow -- wFMiddleware f other --- where --- f env = unsafePerformIO $ do --- paths <- getMessageFlows >>= --- return (pwfname env `elem` paths) - +-- where +-- f env = unsafePerformIO $ do +-- paths <- getMessageFlows >>= +-- return (pwfname env `elem` paths) + -- other= (\env -> defaultResponse $ "options: " ++ opts) --- (paths,_)= unzip messageFlows --- opts= concatMap (\s -> ""++s ++", ") paths +-- (paths,_)= unzip messageFlows +-- opts= concatMap (\s -> ""++s ++", ") paths splitPath ""= ("","","") @@ -161,21 +154,19 @@ (ext, rest)= span (/= '.') strr (mod, path)= span(/='/') $ tail rest in (tail $ reverse path, reverse mod, reverse ext) - - + waiMessageFlow :: Request -> ResourceT IO Response waiMessageFlow req1= do let httpreq1= getParams req1 - - let cookies=getCookies httpreq1 + let cookies=getCookies httpreq1 (flowval , retcookies) <- case lookup flow cookies of Just fl -> return (fl, []) Nothing -> do fl <- newFlow - return (fl, [(flow, fl, "/",Nothing)::Cookie]) + return (fl, [(flow, fl, "/",Nothing)::Cookie]) {- for state persistence in cookies putStateCookie req1 cookies @@ -184,37 +175,32 @@ Just ck -> ck:retcookies1 -} - input <- - case parseMethod $ requestMethod req1 of - Right POST -> if lookup ("Content-Type") httpreq1 == Just "application/x-www-form-urlencoded" - then do - inp <- liftIO $ runResourceT (requestBody req1 $$ CList.consume) - return . urlDecode $ concatMap SB.unpack inp - else return [] + input <- case parseMethod $ requestMethod req1 of + Right POST -> if lookup ("Content-Type") httpreq1 == Just "application/x-www-form-urlencoded" + then do + inp <- liftIO $ runResourceT (requestBody req1 $$ CList.consume) + return . urlDecode $ concatMap SB.unpack inp + else return [] - Right GET -> let tail1 s | s==SB.empty =s - tail1 xs= SB.tail xs - in return . urlDecode $ SB.unpack . tail1 $ rawQueryString req1 -- !> (SB.unpack $ rawQueryString req1) + Right GET -> let tail1 s | s==SB.empty =s + tail1 xs= SB.tail xs + in return . urlDecode $ SB.unpack . tail1 $ rawQueryString req1 -- !> (SB.unpack $ rawQueryString req1) x -> return [] let req = case retcookies of - [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" - _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ" - (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req) - - let resp= case (resp',retcookies) of - (_,[]) -> resp' - (error@(Error _ _),_) -> error + (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req) + + let resp= case (resp',retcookies) of + (_,[]) -> resp' + (error@(Error _ _),_) -> error (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str - --- let resp''= toResponse resp' --- let headers1= case retcookies of [] -> headers resp''; _ -> ctype : cookieHeaders retcookies --- let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} - return $ toResponse resp - + return $ toResponse resp + ------persistent state in cookies (not tested) tvresources :: MVar (Maybe ( M.Map string string)) @@ -259,5 +245,5 @@ case mmap of Just map -> return $ Just $ M.delete (keyResource stat) map Nothing -> return $ Nothing - --} + +-} diff --git a/src/MFlow/Wai/Blaze/Html/All.hs b/src/MFlow/Wai/Blaze/Html/All.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Wai/Blaze/Html/All.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- +-- Module : MFlow.Wai.Blaze.Html.All +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module MFlow.Wai.Blaze.Html.All ( + module Data.TCache +,module MFlow.Wai +,module MFlow.FileServer +,module MFlow.Forms +,module MFlow.Forms.Widgets +,module MFlow.Forms.Blaze.Html +,module MFlow.Forms.Admin +,module Network.Wai +,module Network.Wai.Handler.Warp +,module Control.Applicative +,module Text.Blaze.Internal +,module Text.Blaze.Html5 +,module Text.Blaze.Html5.Attributes +) where + + +import MFlow.Wai +import MFlow.FileServer +import MFlow.Forms +import MFlow.Forms.Widgets +import MFlow.Forms.XHtml +import MFlow.Forms.Admin +import MFlow.Forms.Blaze.Html +import Text.Blaze.Html5 hiding (map) +import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form) +import Network.Wai +import Network.Wai.Handler.Warp +import Data.TCache +import Text.Blaze.Internal(text) + + +import Control.Applicative + + + + + + + + + diff --git a/src/MFlow/Wai/Response.hs b/src/MFlow/Wai/Response.hs --- a/src/MFlow/Wai/Response.hs +++ b/src/MFlow/Wai/Response.hs @@ -11,9 +11,10 @@ import Data.Monoid import System.IO.Unsafe import Data.Map as M -import Data.CaseInsensitive +--import Data.CaseInsensitive import Network.HTTP.Types import Control.Workflow(WFErrors(..)) +import Data.String --import Debug.Trace -- --(!>)= flip trace @@ -35,9 +36,9 @@ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) -ctype1= [mkparam ctype] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")] +contentHtml1= [mkparam contentHtml] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")] mkParams = Prelude.map mkparam -mkparam (x,y)= (mk $ SB.pack x, SB.pack y) +mkparam (x,y)= (fromString x, fromString y) instance ToResponse TResp where toResponse (TResp x)= toResponse x toResponse (TRespR r)= toResponse r @@ -46,15 +47,13 @@ toResponse = id instance ToResponse B.ByteString where - toResponse x= responseLBS status200 ctype1 {-,("Content-Length",show $ B.length x) -} x - - + toResponse x= responseLBS status200 contentHtml1 {-,("Content-Length",show $ B.length x) -} x instance ToResponse String where - toResponse x= responseLBS status200 ctype1{-,("Content-Length",show $ B.length x) -} $ B.pack x + toResponse x= responseLBS status200 contentHtml1 {-,("Content-Length",show $ B.length x) -} $ B.pack x instance ToResponse HttpData where - toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams $ hs ++ cookieHeaders cookies) x + toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs ++ cookieHeaders cookies)) x toResponse (Error NotFound str)= responseLBS status404 [] $ getNotFoundResponse str diff --git a/src/MFlow/Wai/XHtml/All.hs b/src/MFlow/Wai/XHtml/All.hs --- a/src/MFlow/Wai/XHtml/All.hs +++ b/src/MFlow/Wai/XHtml/All.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : MFloll.Wai.XHtml.All +-- Module : MFlow.Wai.XHtml.All -- Copyright : -- License : BSD3 -- @@ -19,7 +19,7 @@ ,module MFlow.Forms ,module MFlow.Forms.XHtml ,module MFlow.Forms.Admin -,module MFlow.Forms.Ajax +,module MFlow.Forms.Widgets --,module MFlow.Wai.XHtml ,module Network.Wai ,module Network.Wai.Handler.Warp @@ -33,7 +33,7 @@ import MFlow.Forms import MFlow.Forms.XHtml import MFlow.Forms.Admin -import MFlow.Forms.Ajax +import MFlow.Forms.Widgets --import MFlow.Wai.XHtml import Network.Wai