MFlow 0.0.4 → 0.0.5
raw patch · 28 files changed
+3868/−2161 lines, 28 filesdep +case-insensitivedep +conduitdep +directorydep ~RefSerializedep ~TCachedep ~Workflow
Dependencies added: case-insensitive, conduit, directory, hsp, http-types, parsec, text, utf8-string, wai, warp
Dependency ranges changed: RefSerialize, TCache, Workflow, base
Files
- Demos/ShoppingCart.Wai.hs +54/−0
- Demos/ShoppingCart.hs +48/−0
- Demos/ShoppingCart1.hs +0/−119
- Demos/demos.hs +69/−0
- MFlow.cabal +54/−106
- MFlow.hs +0/−352
- MFlow/Cookies.hs +0/−189
- MFlow/Forms.hs +0/−776
- MFlow/Forms/XHtml.hs +0/−117
- MFlow/Hack.hs +0/−328
- MFlow/Hack/Response.hs +0/−94
- MFlow/Hack/XHtml.hs +0/−35
- MFlow/Hack/XHtml/All.hs +0/−45
- src/MFlow.hs +358/−0
- src/MFlow/Cookies.hs +212/−0
- src/MFlow/FileServer.hs +326/−0
- src/MFlow/Forms.hs +1599/−0
- src/MFlow/Forms/Admin.hs +137/−0
- src/MFlow/Forms/Ajax.hs +96/−0
- src/MFlow/Forms/HSP.hs +61/−0
- src/MFlow/Forms/XHtml.hs +68/−0
- src/MFlow/Hack.hs +238/−0
- src/MFlow/Hack/Response.hs +72/−0
- src/MFlow/Hack/XHtml.hs +40/−0
- src/MFlow/Hack/XHtml/All.hs +49/−0
- src/MFlow/Wai.hs +262/−0
- src/MFlow/Wai/Response.hs +75/−0
- src/MFlow/Wai/XHtml/All.hs +50/−0
+ Demos/ShoppingCart.Wai.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS -XDeriveDataTypeable -XScopedTypeVariables #-}+module Test where++{-+A stateless flow example. Convert it into persistent by uncommenting {- step -} and see the differences.++after 10 seconds without user interaction, the process is killed (set by setTimeout)+:l demos\shoppingCart.Wai.hs+-}++import MFlow.Wai+import MFlow.Forms+import Text.XHtml+import MFlow.Forms.XHtml+import Control.Concurrent+import Network.Wai.Handler.Warp+import MFlow.Forms.Admin+import qualified Data.Vector as V++++main= do+-- syncWrite SyncManual+ putStrLn $ options messageFlows+ forkIO $ run 80 $ waiMessageFlow messageFlows+ adminLoop+++options msgs= "in the browser navigate to\n\n" +++ concat [ "http://localhost/"++ i ++ "\n" | (i,_) <- msgs]++messageFlows= [("noscript", runFlow shopCart )+ ,("stateless", stateless st)]++st _ = return "hi"++--shopCart1 :: V.Vector Int -> FlowM (Workflow IO) b+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 <<< 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)))+ )+ let newCart= cart V.// [(i, cart V.! i + 1 )]+ shopCart1 newCart+
+ Demos/ShoppingCart.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -XDeriveDataTypeable -XScopedTypeVariables #-}+module Test where++{-+A stateless flow example. Convert it into persistent by uncommenting {- step -} and see the differences.++after 10 seconds without user interaction, the process is killed (set by setTimeout)++-}++import MFlow.Hack.XHtml.All+import Control.Concurrent++import qualified Data.Vector as V++++main= do+-- syncWrite SyncManual+ putStrLn $ options messageFlows+ forkIO $ run 80 $ hackMessageFlow messageFlows+ adminLoop+++options msgs= "in the browser navigate to\n\n" +++ concat [ "http://localhost/"++ i ++ "\n" | (i,_) <- msgs]++messageFlows= [("noscript", runFlow shopCart )]+++--shopCart1 :: V.Vector Int -> FlowM (Workflow IO) b+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 <<< 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)))+ )+ let newCart= cart V.// [(i, cart V.! i + 1 )]+ shopCart1 newCart+
− Demos/ShoppingCart1.hs
@@ -1,119 +0,0 @@-{-# OPTIONS -XDeriveDataTypeable- -XMultiParamTypeClasses -XRecordWildCards-- #-}-module Main where-import MFlow.Hack.XHtml.All--import Data.Typeable-import Control.Monad.Trans-import qualified Data.Vector as V------main= do- userRegister "pepe" "pepe"- putStrLn $ options messageFlows- run 80 $ hackMessageFlow messageFlows- where- messageFlows= [("main", runFlow mainProds)- ,("hello", stateless hello)]-- options msgs= "in the browser choose\n\n" ++- concat [ "http://server/"++ i ++ "\n" | (i,_) <- msgs]------ an stateless procedure, as an example-hello :: Env -> IO String-hello env = return "hello, this is a stateless response"---data Prod= Prod{pname :: String, pprice :: Int} deriving (Typeable,Read,Show)---- formLets can have Html formatting-instance FormLet Prod IO Html where- digest mp= table <<< (- Prod <$> tr <<< (td << "enter the name" <++ td <<< getString (pname <$> mp))- <*> tr <<< (td << "enter the price" <++ td <<< getInt ( pprice <$> mp)))----- Here an example of predefined widget (`Selection`) that return an Int, combined in the same--- page with the fromLet for the introduction of a new product.--- The result of the interaction with the user is either one or the other result--shopProds :: V.Vector Int -> [Prod]- -> View Html IO (Either Int Prod)-shopProds cart products=- br- <++ -- add Html to the first widget- p << "-----Shopping List-----"- <++- widget(Selection{- stitle = bold << "choose an item",- sheader= [ bold << "item" , bold << "price", bold << "times chosen"],- sbody= [([toHtml pname, toHtml $ show pprice, toHtml $ show $ cart V.! i],i )- | (Prod{..},i ) <- zip products [1..]]})-- <+> -- operator to mix two wdigets-- br- <++ -- add Html to the second widget- p << "---Add a new product---"- <++- table <<< -- <<< encloses a widget in HTML tags- (tr <<< td ! [valign "top"]- <<< widget (Form (Nothing :: Maybe Prod) )-- ++> -- append Html after the widget-- tr << td ! [align "center"]- << hotlink "hello"- (bold << "Hello World"))---- the header--appheader user forms= thehtml- << body << dlist << (concatHtml- [dterm <<("Hi "++ user)- ,dterm << "This example contains two forms enclosed within user defined HTML formatting"- ,dterm << "The first one is defined as a Widget, the second is a formlet formatted within a table"- ,dterm << "both are defined using an extension of the FormLets concept"- ,dterm << "the form results are statically typed"- ,dterm << "The state is implicitly logged. No explicit handling of state"- ,dterm << "The program logic is written as a procedure. Not in request-response form. But request response is possible"- ,dterm << "lifespan of the serving process and the execution state defined by the programmer"- ,dterm << "user state is automatically recovered after cold re-start"- ,dterm << "transient, non persistent states possible."- ])- +++ forms---- Here the procedure. It ask for either entering a new product--- or to "buy" one of the entered products.--- There is a timeout of ten minutes before the process is stopped--- There is a timeout of one day for the whole session so after this, the--- user will see the list or prudicts erased.--- In a real application the product list should be stored out of the session--- using TCache's writeDBRef for example--- The state is user specific.--mainProds :: FlowM Html (Workflow IO) ()-mainProds = do- setTimeouts (10*60) (24*60*60)- setHeader $ \w -> bold << "Please enter user/password (pepe/pepe)" +++ br +++ w- us <- getUser-- setHeader $ appheader us- mainProds1 [] $ V.fromList [0]- where- mainProds1 prods cart= do- mr <- step . ask $ shopProds cart prods- case mr of- Right prod -> mainProds1 (prod:prods) (V.snoc cart 0)- Left i -> do- let newCart= cart V.// [(i, cart V.! i + 1 )]- mainProds1 prods newCart--
+ Demos/demos.hs view
@@ -0,0 +1,69 @@+{-# 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 Debug.Trace+(!>)= flip trace+++data Ops= Ints | Strings | Actions | Ajax deriving(Typeable,Read, Show)+main= do+ syncWrite SyncManual+ setFilesPath ""+ addFileServerWF+ forkIO $ run 80 $ waiMessageFlow [("noscript",transient $ runFlow mainf)]+ 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 << "Ints") <|>+ br ++> wlink Strings (bold << "Strings") <|>+ br ++> wlink Actions (bold << "Example of a string widget with an action") <|>+ br ++> wlink Ajax (bold << "Simple AJAX example")+ case r of+ Ints -> clickn 0+ Strings -> clicks "1"+ Actions -> actions 1+ Ajax -> ajaxsample+ mainf++clickn (n :: Int)= do+ setHeader stdheader+ r <- ask $ wlink "menu" (p << "back")+ |+| 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) <! [("id","text1"),("onclick", ajaxc)])+ breturn()++actions n=do+ ask $ wlink () (p << "exit from action")+ <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions )+ breturn ()+
MFlow.cabal view
@@ -1,121 +1,69 @@ name: MFlow-synopsis: Web application server with stateful, type safe user interactions and widget combinators.---version: 0.0.4-cabal-version: -any+version: 0.0.5+cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE-copyright: maintainer: agocorona@gmail.com-build-depends: Workflow >=0.6.0.0 && < 0.6.1, transformers -any, mtl -any,- extensible-exceptions -any, xhtml -any, base > 4.4 && < 4.6,- hack -any, hack-handler-simpleserver -any, bytestring -any,- containers -any- , RefSerialize >= 0.2.8.1 && < 0.2.9- , TCache >= 0.9.0.2 && < 0.9.1- , stm >2,- old-time -any,- vector -any stability: experimental-homepage:-package-url:-bug-reports:--description: Simple application server with stateful request-response flows, persistent- and transparent session handling. server process management, combinators for the definition of widgets- and formlets that can be mixed freely with HTML formatting and produce statically- typed web applications. Adopt and extend the best formlet/applicative Haskell traditions- Console and window oriented apps are possible.- .- MFlow (MessageFlow) was created initially as the user interface for the Workflow package- Currently is an alpha version. It has only basic authentication but I plan to inprove it for serious applications.- .- It includes Application Server features such is resource an process management- and automatic recovery- .- Resource management: The user can define process and session timeout. The- process is automatically rerun after timeout if a new request arrive with transparent- recovery of state, at the point of the interrupted dialog even after server crash.- .- The backend operation relies on the Workflow package ("http:\/\/hackage.haskell.org\/package\/Workflow/index"),- this gives transparent sessión persistence and recovery, all of this- is supported by- TCache ("http:\/\/hackage.haskell.org\/package\/TCache/index"), that gives backend-independent transactions and can be used- directly by the programmer. Persistence in files for session and data out of the box enables- very fast prototyping.- .- All the plumbing is hidden to the programmer, There are no methods for- session management, database query, recovery and so on. All of this is- transparent So the surface exposed to the programmer is minimal.- .- Includes generalized formlets that permits the mix of active widgets- in the same page while remaining statically typed and, thus the programs- can verify correctness at compilation time.- .- Includes combinators for seamless inclusion of these widgets within- user defined HTML formatting. Bindings for Text.XHtml. The widget generation may be easy- for user with familiarity with formlets/digestive functors and Text.XHtml formatting.- .- Currently it has bindings for the Hack interface- .- Streaming facilities.- .- To do:- .- Bindings for HSP- .- Clustering- .- Other bindigs for Hack alternatives-+synopsis: Web application serverfor processes with type safe, composable user interfaces. +description: It is a Web framework with some unique features thanks to the power of the Haskell language.+ MFlow run stateful server processes. Because flows are stateful, not event driven, 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.+ .+ Technically it is a Web application server for stateful processes (flows) that are optionally persistent.+ These processes interact with the user trough interfaces made of widgets that return back statically typed responses to+ the calling process. All is coded in pure haskell (with optional XML from Haskell Server Pages).+ It adopt and extend the formlet/applicative approach. It has bindings for HSP and Text.XHtml+ .+ It includes Application Server features such is process and session timeouts+ and automatic recovery of flow execution state.+ .+ This release add transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting AJAX,+ and WAI integration.+ .+ It is designed for coding an entire application in a single file to be run with runghc in order+ to speed up the prototyping process.+ .+ See "MFlow.Forms" for details+ .+ Altroug still it is experimental, it is used in at least one future commercial project. So I have te commitment to+ continue its development. There are many examples in the documentation and in the package.+ .+ To do:+ .+ -Clustering+ . category: Web, Application Server author: Alberto Gómez Corona-tested-with:-data-files: data-dir: ""-extra-source-files: Demos/ShoppingCart1.hs-extra-tmp-files:-exposed-modules:-- MFlow.Forms- MFlow.Hack- MFlow.Forms.XHtml- MFlow.Hack.XHtml- MFlow.Hack.XHtml.All+extra-source-files: Demos/ShoppingCart.hs, Demos/ShoppingCart.Wai.hs, Demos/demos.hs -other-modules: MFlow- MFlow.Cookies- MFlow.Hack.Response+library+ build-depends: Workflow -any, transformers -any, mtl -any,+ extensible-exceptions -any, xhtml -any, base >4.0 && <4.6,+ hack -any, hack-handler-simpleserver -any, bytestring -any,+ containers -any, RefSerialize -any, TCache -any, stm >2,+ old-time -any, vector -any, hsp -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 -exposed: True-buildable: True-build-tools:-cpp-options:-cc-options:-ld-options:-pkgconfig-depends:-frameworks:-c-sources:-default-language:-other-languages:-default-extensions:-other-extensions:-extensions:-extra-libraries:-extra-lib-dirs:-includes:-install-includes:-include-dirs:-hs-source-dirs: .+ MFlow.Forms.Admin MFlow MFlow.FileServer+ MFlow.Forms.Ajax MFlow.Cookies+ MFlow.Hack.Response, MFlow.Hack MFlow.Hack.XHtml MFlow.Hack.XHtml.All+ MFlow.Wai.Response, MFlow.Wai, MFlow.Wai.XHtml.All+ MFlow.Forms.XHtml+ MFlow.Forms.HSP+ exposed: True+ buildable: True+ hs-source-dirs: src .+ other-modules: -ghc-prof-options:-ghc-shared-options:-ghc-options:-hugs-options:-nhc98-options:-jhc-options:+source-repository head+ type: git+ location: http://github.com/agocorona/MFlow
− MFlow.hs
@@ -1,352 +0,0 @@-{- | Non monadic low level support stuff for the MFlow application server.-it implements an scheduler of queued 'Processable' messages that are served according with-the source identification and the verb invoked.-Ths 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 logged and can be recovered.--The message communication is trough polimorphic, monoidal queues.-There is no asumption about message codification, so instantiations-of this scheduler for many different infrastructures is possible.-"MFlow.Hack" is an instantiation for the Hack interface in a Web context.--In order to manage resources, the serving process may die after a timeout.-as well as the logged state, usually, after a longer timeout .--All these details are hidden in the monad of "MFlow.Forms" that provides-an higuer level interface. Altroug fragments streaming 'sendFragment' 'sendEndFragment'-are only provided at this level.--'stateless' and 'transient' serving processes are 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.---}---{-# LANGUAGE DeriveDataTypeable, UndecidableInstances- ,ExistentialQuantification, MultiParamTypeClasses- ,FunctionalDependencies- ,TypeSynonymInstances- ,FlexibleInstances- ,FlexibleContexts #-} -module MFlow (-Params, getParam1, Req(..), Resp(..), Workflow, HttpData(..),Processable(..), ConvertTo(..), Token(..), getToken, Error(..), ProcList-,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment, sendEndFragment-,msgScheduler, addMessageFlows,getMessageFlows, transient, stateless-)--where -import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import GHC.Conc(unsafeIOToSTM) -import Data.Typeable -import Data.Maybe(isJust, isNothing, fromMaybe, fromJust) -import Data.List(isPrefixOf, elem , span, (\\)) -import Control.Monad(when)- -import Data.Monoid -import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId) -import Control.Concurrent.MVar - -import Unsafe.Coerce-import System.IO.Unsafe-import Data.TCache.DefaultPersistence --import Data.ByteString.Lazy.Char8(pack, unpack) - -import qualified Data.Map as M --import Control.Workflow--import MFlow.Cookies--import Debug.Trace--(!>)= flip trace--data HttpData a= HttpData [Cookie] a deriving Typeable---- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname-type ProcList = WorkflowList IO Token ()---data Req = forall a.( Processable a,Typeable a)=> Req a deriving Typeable--type Params = [(String,String)]--class Processable a where - pwfname :: a -> String- puser :: a -> String- pind :: a -> String- getParams :: a -> Params--- getServer ::a -> String--- getPath :: a -> String--- getPort :: a -> Int-- -instance Processable Req where - pwfname (Req x)= pwfname x- puser (Req x)= puser x- pind (Req x)= pind x - getParams (Req x)= getParams x--- getServer (Req x)= getServer x--- getPath (Req x)= getPath x--- getPort (Req x)= getPort x - -data Resp = forall a c.( Typeable a,Typeable c, Monoid c, ConvertTo a c)=> Fragm a- | forall a c.( Typeable a,Typeable c, Monoid c, ConvertTo a c)=> EndFragm a- | forall a c.( Typeable a,Typeable c, ConvertTo a c) => Resp a- -- ---instance Typeable a => Typeable (Workflow IO a) where --- typeOf = \_ -> mkTyConApp (mkTyCon "Control.Workflow.Workflow IO") [Data.Typeable.typeOf (undefined ::a)] -- -data Token = Token{twfname,tuser, tind :: String , q :: TChan Req, qr :: TChan Resp} deriving Typeable --{-idToken (Token _ _ n)= n -instance IResource Token where - keyResource (Token w u i _ _ )= u ++ "#" ++ w ++ "#" ++ i - serialize t = "Token " ++ keyResource t - deserialize ('T':'o':'k':'e':'n':' ':str) = Token w u i undef undef - where- (w,r) = span (/= '#') str- (u,_:i)= span (/= '#') $ tail r-- undef= error "deserialize for Token undefined"--}-instance Indexable Token where - key (Token w u i _ _ )= u ++ "#" ++ w ++ "#" ++ i--instance Show Token where - show t = "Token " ++ key t--instance Read Token where - readsPrec _ ('T':'o':'k':'e':'n':' ':str1) = [(Token w u i (newChan 0) (newChan 0), tail str2)] - where- (str,str2)= span(/=' ') str- (w,r) = span (/= '#') str- (u,_:i)= span (/= '#') $ tail r- newChan _= unsafePerformIO newTChanIO- -- undef= error "deserialize for Token undefined"- readsPrec _ str= error $ "parse error in Token read from: "++ str--instance Serializable Token where- serialize= pack . show- deserialize= read . unpack--iorefqmap= unsafePerformIO . newMVar $ M.empty- -getToken msg= do- qmap <- readMVar iorefqmap- let u= puser msg ; w= pwfname msg ; i=pind msg- let mqs = M.lookup ( i ++ w ++ u) qmap- (q,qr) <- case mqs of- Nothing -> do - q <- atomically $ newTChan -- `debug` (i++w++u)- qr <- atomically $ newTChan- let qs= (q,qr)- modifyMVar_ iorefqmap $ \ map -> return $ M.insert ( i ++ w ++ u) qs map- return qs-- Just qs -> return qs- - return (Token w u i q qr ) --`debug1` "returning getToken" -{--instance (Monad m, Show a) => Traceable (Workflow m a) where - debugf iox str = do - x <- iox - return $ debug x (str++" => Workflow "++ show x) --} --- | send a complete response -send :: (Typeable a, Typeable b, ConvertTo a b) => Token -> a -> IO() -send (Token _ _ _ queue qresp) msg= atomically $ do - writeTChan qresp $ Resp msg --sendFlush t msg= flushRec t >> send t msg- --- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' -sendFragment :: ( Typeable a, Typeable b, Monoid b, ConvertTo a b) => Token -> a -> IO() -sendFragment (Token _ _ _ _ qresp) msg= atomically $ writeTChan qresp $ Fragm msg - -sendEndFragment :: ( Typeable a, Typeable b, Monoid b, ConvertTo a b) => Token -> a -> IO() -sendEndFragment (Token _ _ _ _ qresp ) msg= atomically $ writeTChan qresp $ EndFragm msg - ---emptyReceive (Token queue _ _)= emptyQueue queue -receive :: (Processable a, Typeable a) => Token -> IO a -receive t= receiveReq t >>= return . fromReq--flushRec t@(Token _ _ _ queue _)= do- empty <- atomically $ isEmptyTChan queue- if empty then return() else atomically(readTChan queue) >> flushRec t--receiveReq :: Token -> IO Req-receiveReq (Token _ _ _ queue _)= atomically $ readTChan queue--fromReq :: (Processable a, Typeable a) => Req -> a-fromReq (Req x) = x' where- x'= case cast x of- Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x') - Just y -> y- -receiveReqTimeout :: Int - -> Integer- -> Token - -> IO Req-receiveReqTimeout 0 0 t= receiveReq t -receiveReqTimeout time time2 t@(Token _ _ _ queue qresp)=do- let id= twfname t ++ "#" ++key t - flag <- transientTimeout time - r <- atomically $ (readTChan queue >>= return . Just ) - `orElse` (waitUntilSTM flag >> return Nothing) - case r of - Just r@(Req v) -> return r - Nothing -> do- clearRunningFlag id !> "killed"- forkIO $ sessionTimeout (fromIntegral time2- time) id - throw Timeout- where- sessionTimeout t id= do- - --this thread becomes now dedicated to keep the second timeout before deleting the state - flag <- transientTimeout t - - -- r <- atomically $ (waitWFActive id >> return True) - `orElse`- (waitUntilSTM flag >> return False ) -- or timeout- - case r of - False -> delWF1 id !> "state deleted" - True -> return () -- thread has been reactivated - ----transientTimeout 0= atomically $ newTVar False-transientTimeout t= do- flag <- atomically $ newTVar False - forkIO $ threadDelay (t * 1000000) >> atomically (writeTVar flag True) >> myThreadId >>= killThread - return flag-- -delMsgHistory t = do - let qnme=key t- let statKey= twfname t ++ "#" ++ qnme -- !> "wf" --let qnme= keyWF wfname t - delWFHistory1 statKey -- `debug` "delWFHistory" - where - u= undefined ----- ! to add a simple monadic computation of type (a -> IO b) to the list--- of the scheduler -stateless :: ( Typeable a, Processable a, Typeable b- , ConvertTo b c, Typeable c)- => (a -> IO b) -> (Token -> Workflow IO ()) -stateless f = transient $ \tk -> receive tk >>= f >>= send tk ---- | to add a monadic computation that send and receive messages, but does--- not store its state in permanent storage. -transient :: (Token -> IO ()) -> (Token -> Workflow IO ()) -transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) ) -- -_messageFlows :: MVar ProcList -_messageFlows= unsafePerformIO $ newMVar [] -- [(String,Token -> Workflow IO ())]) - --addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ ms ++ wfs) - -getMessageFlows = readMVar _messageFlows - -class ConvertTo a b | a -> b where - convert :: a -> b -- ----tellToWF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c-tellToWF (Token _ _ _ queue qresp ) msg = do - atomically $ writeTChan queue $ Req msg -- `debug` ("tell wf="++wf) - m <- atomically $ readTChan qresp- case m of - Resp r -> return . cast1 $ convert r - Fragm r -> do- result <- getStream $ convert r- return $ cast1 result-- - where--- cast1 :: (Typeable a, Typeable b) => a -> b- cast1 x= y where- y= case cast x of- Nothing -> error $ "cast error: " ++ show (typeOf x) ++ " to " ++ show (typeOf y)- Just y -> y- getStream :: (Typeable a, Monoid a) => a -> IO a- getStream r = do - mr <- atomically $ readTChan qresp - case mr of- Resp _ -> error "\"send\" used instead of \"sendFragment\" or \"sendEndFragment\"" - Fragm h -> do- rest <- unsafeInterleaveIO $ getStream ( convert h)- let result= mappend r (cast1 rest)- return (cast1 result ) - EndFragm h -> do- let result= mappend r $ cast1 (convert h)- return (cast1 result) ---- -- -data Error= Error String deriving (Read, Show, Typeable) --instance Indexable Error where- key _= error "Idexablew instance for Error"--msgScheduler- :: (Processable a, Typeable a, ConvertTo Error c, Typeable c)- => a -> ProcList -> IO (c, ThreadId)-msgScheduler x wfs = do - token <- getToken x -- th <- startMessageFlow (pwfname x) token wfs- r<- tellToWF token x - return (r,th)- where- - startMessageFlow wfname token wfs= - forkIO $ do - r <- startWF wfname token wfs -- `debug`( "init wf " ++ wfname) - case r of - Left NotFound -> error ( "procedure not found: "++ wfname) - Left AlreadyRunning -> return () -- `debug` ("already Running " ++ wfname)- Left Timeout -> return () -- `debug` "Timeout in webScheduler"- Left (Exception e)-> send token $ Error (show e) -- `debug` ("WF error: "++ show e) - Right _ -> do delMsgHistory token; return () -- `debug` ("finished " ++ wfname) - - ----getParam1 :: ( Typeable a, Read a) => String -> Params -> Maybe a-getParam1 str req= r- where- r= case lookup str req of- Just x -> maybeRead x- Nothing -> Nothing-- maybeRead str=- if typeOf r == (typeOf $ Just "")- then Just $ unsafeCoerce str- else case readsPrec 0 str of- [(x,"")] -> Just x- _ -> Nothing---
− MFlow/Cookies.hs
@@ -1,189 +0,0 @@-module MFlow.Cookies-(Cookie,ctype,getCookies,cookieHeaders,urlDecode)-where-import Control.Monad(MonadPlus(..), guard, replicateM_, when)-import Data.Char-import Data.Maybe(fromMaybe)-import System.IO.Unsafe-import Control.Exception(handle)-import Data.Typeable-import Data.Maybe(fromJust)-import Unsafe.Coerce--type Cookie= (String,String,String,Maybe String)--getCookies httpreq=- case lookup "Cookie" $ httpreq of- Just str -> splitCookies str- Nothing -> []--cookieHeaders cs = map (\c-> ("Set-Cookie", showCookie c)) cs--showCookie :: Cookie -> String-showCookie (n,v,p,me) =- let e= fromMaybe "" me - in showString n . showString "=" . showString v . showString "; path=" - . showString p . showExpires e . showString "\n" $ ""---showExpires [] = showString "" -showExpires e = showString "; expires=" . showString e-----ctype= ("Content-Type", "text/html")----splitCookies cookies = f cookies [] - where - f [] r = r - f xs0 r = - let- xs = dropWhile (==' ') xs0 - name = takeWhile (/='=') xs - xs1 = dropWhile (/='=') xs - xs2 = dropWhile (=='=') xs1 - val = takeWhile (/=';') xs2 - xs3 = dropWhile (/=';') xs2 - xs4 = dropWhile (==';') xs3 - xs5 = dropWhile (==' ') xs4 - in f xs5 ((name,val):r)------------------------------------------------------------------------------- --- %*************************************************************************** --- %* * --- \subsection[CGI-Parser]{Yet another combinator parser library}. chuck of code taken from Erik Meijer --- %* * --- %*************************************************************************** - --- NOTE: This is all a little bit of a sledgehammer here for the simple task --- at hand... - --- The parser monad - - -newtype Parser a = Parser (String -> [(a,String)]) - -instance Functor Parser where - -- map :: (a -> b) -> (Parser a -> Parser b) - fmap f (Parser p) = Parser (\inp -> [(f v, out) | (v, out) <- p inp]) - -instance Monad Parser where - -- return :: a -> Parser a - return v = Parser (\inp -> [(v,inp)]) - - -- >>= :: Parser a -> (a -> Parser b) -> Parser b - (Parser p) >>= f = Parser (\inp -> concat [papply (f v) out - | (v,out) <- p inp]) - -instance MonadPlus Parser where - -- zero :: Parser a - mzero = Parser (\_ -> []) - -- (++) :: Parser a -> Parser a -> Parser a - (Parser p) `mplus` (Parser q) = Parser (\inp -> (p inp ++ q inp)) - - --- Other primitive parser combinators - - -item :: Parser Char -item = Parser (\inp -> case inp of - [] -> [] - (x:xs) -> [(x,xs)]) - -force :: Parser a -> Parser a -force (Parser p) = Parser (\inp -> let x = p inp in - (fst (head x), snd (head x)) : tail x) - -first :: Parser a -> Parser a -first (Parser p) = Parser (\inp -> case p inp of - [] -> [] - (x:_) -> [x]) - -papply :: Parser a -> String -> [(a,String)] -papply (Parser p) inp = p inp - - --- Derived combinators - - -(+++) :: Parser a -> Parser a -> Parser a -p +++ q = first (p `mplus` q) - -sat :: (Char -> Bool) -> Parser Char -sat p = do {x <- item; guard (p x); return x} - -many :: Parser a -> Parser [a] -many p = force (many1 p +++ return []) - -many1 :: Parser a -> Parser [a] -many1 p = do {x <- p; xs <- many p; return (x:xs)} - -sepby :: Parser a -> Parser b -> Parser [a] -p `sepby` sep = (p `sepby1` sep) +++ return [] - -sepby1 :: Parser a -> Parser b -> Parser [a] -p `sepby1` sep = do x <- p - xs <- many (do {sep; p}) - return(x:xs) - -char :: Char -> Parser Char -char x = sat (x==) - -alphanum :: Parser Char -alphanum = sat (\c -> isAlphaNum c || c == '@' || c =='\'' ) -- Added @ as a valid character - -string :: String -> Parser String -string "" = return "" -string (x:xs) = do char x - string xs - return (x:xs) - -hexdigit :: Parser Char -hexdigit = sat isHexDigit - ----readEnv :: Parser [(String,String)] -readEnv = (do- n <- urlEncoded - string "=" - v <- urlEncoded - return (n,v)) `sepby` (string "&") - -urlEncoded :: Parser String -urlEncoded - = many ( alphanum `mplus` extra `mplus` safe - `mplus` do{ char '+' ; return ' '} - `mplus` do{ char '%' - ; d <- hexadecimal - ; return $ chr (hex2int d) - } - ) - -extra :: Parser Char -extra = sat (`elem` "!*'(),") - -safe :: Parser Char -safe = sat (`elem` "$-_.") - -hexadecimal :: Parser HexString -hexadecimal = do d1 <- hexdigit - d2 <- hexdigit - return [d1,d2] - -type HexString = String - -hex2int :: HexString -> Int -hex2int ds = foldl (\n d -> n*16+d) 0 (map (toInt . toUpper) ds) - where toInt d | isDigit d = ord d - ord '0' - toInt d | isHexDigit d = (ord d - ord 'A') + 10 - toInt d = error ("hex2int: illegal hex digit " ++ [d]) --urlDecode :: String -> [([(String, String)],String)]-urlDecode str= let Parser p= readEnv in p str-
− MFlow/Forms.hs
@@ -1,776 +0,0 @@--{-# OPTIONS -XDeriveDataTypeable- -XUndecidableInstances- -XExistentialQuantification- -XMultiParamTypeClasses- -XTypeSynonymInstances- -XFlexibleInstances- -XScopedTypeVariables- -XFunctionalDependencies- -XFlexibleContexts- -XRecordWildCards- -XIncoherentInstances--#-}--{- | This module defines an integrated way to interact with the user. `ask` is-a single method of user interaction. it send user interfaces and return statically-typed responses. The user interface definitions are based on the formLets interface--But additionally, unlike formLets in its current form, it permits the- definition of widgets. A widget is data that, when renderized-and interact with the user, return data, just like a formlet, but it hasn-to be an HTML form. it can contain JavaScript, or additional Html decoration or-it can use Ajax istead of form post for the interaction.-There is an example of widget defined (`Selection`)--widgets (and formlets) can be combined in a sigle Html page.-Here is a ready-to-run example that combines a Widget (Selection) and-a HTML decorated formLet in the same page.--@-import "MFlow.Hack.XHtml.All"--import Data.Typeable-import Control.Monad.Trans-import qualified Data.Vector as V--main= do-- putStrLn $ options messageFlows- 'run' 80 $ 'hackMessageFlow' messageFlows- where- messageFlows= [(\"main\", runFlow mainProds )- ,(\"hello\", stateless hello)]- options msgs= \"in the browser choose\\n\\n\" ++- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]---\--an stateless procedure, as an example-hello :: 'Env' -> IO String-hello env = return \"hello, this is a stateless response\"---data Prod= Prod{pname :: String, pprice :: Int} deriving (Typeable,Read,Show)--\-- formLets can have Html formatting. Additional operators \<\++ \<+\> \<\<\< ++\> to XHtml formatting--instance 'FormLet' Prod IO Html where- 'digest' mp= table \<\<\< (- Prod \<\$\> tr \<\<\< (td \<\< \"enter the name\" \<++ td \<\<\< getString (pname \<\$\> mp))- \<\*\> tr \<\<\< (td \<\< \"enter the price\" \<++ td \<\<\< getInt ( pprice \<\$\> mp)))---\-- Here an example of predefined widget (`Selection`) that return an Int, combined in the same-\-- page with the fromLet for the introduction of a product.-\-- The result of the user interaction is Either one or the other value--shopProds :: V.Vector Int -\> [Prod]- -\> 'View' Html IO (Either Int Prod)-shopProds cart products=-- p \<\< \"\--\--\--\--\--\--\--\--Shopping List\--\--\--\--\--\--\--\"- \<++- widget(Selection{- stitle = bold \<\< \"choose an item\",- sheader= [ bold \<\< \"item\" , bold \<\< \"price\", bold \<\< \"times chosen\"],- sbody= [([toHtml pname, toHtml \$ show pprice, toHtml \$ show \$ cart V.! i],i )- | (Prod{..},i ) \<- zip products [1..]]})-- \<+\>- p \<\< \"\--\--\--\--\--\--\--Add a new product \--\--\--\--\--\--\---\"- \<++- table \<\<\< (tr \<\<\< td ! [valign \"top\"]- \<\<\< widget (Form (Nothing :: Maybe Prod) )- ++\>- tr \<\< td ! [align \"center\"]- \<\< hotlink \"hello\"- (bold \<\< \"Hello World\"))--\-- the header--appheader user forms= thehtml- \<\< body \<\< dlist \<\< (concatHtml- [dterm \<\<(\"Hi \"++ user)- ,dterm \<\< \"This example contains two forms enclosed within user defined HTML formatting\"- ,dterm \<\< \"The first one is defined as a Widget, the second is a formlet formatted within a table\"- ,dterm \<\< \"both are defined using an extension of the FormLets concept\"- ,dterm \<\< \"the form results are statically typed\"- ,dterm \<\< \"The state is implicitly logged. No explicit handling of state\"- ,dterm \<\< \"The program logic is written as a procedure. Not in request-response form. But request response is possible\"- ,dterm \<\< \"lifespan of the serving process and the execution state defined by the programmer\"- ,dterm \<\< \"user state is automatically recovered after cold re-start\"- ,dterm \<\< \"transient, non persistent states possible.\"- ])- +++ forms--\-- Here the procedure. It ask for either entering a new product-\-- or to \"buy\" one of the entered products.-\-- There is a timeout of ten minutes before the process is stopped-\-- THERE IS A timeout of one day for the whole state so after this, the-\-- user will see the list erased.-\-- The state is user specific.--\--mainProds :: FlowM Html (Workflow IO) ()-mainProds = do- setTimeouts (10\*60) (24\*60\*60)- setHeader \$ \w -\> bold \<\< \"Please enter user/password (pepe/pepe)\" +++ br +++ w--- setHeader \$ appheader "user"- mainProds1 [] \$ V.fromList [0]- where- mainProds1 prods cart= do- mr \<- step . ask \$ shopProds cart prods- case mr of- Right prod -\> mainProds1 (prod:prods) (V.snoc cart 0)- Left i -\> do- let newCart= cart V.// [(i, cart V.! i + 1 )]- mainProds1 prods newCart-@---}--module MFlow.Forms(-{- basic definitions -}-Widget(..),FormLet(..), Launchable(..)-,View, FormInput(..), FormT(..),FormElm(..)-{- widget instances -}-,Form(..),Selection(..)--{- users -}-,userRegister, userAuthenticate, User(userName)-,getUser,--- * user interaction-ask,--- * getters to be used in instances of `FormLet` and `Widget` in the Applicative style.--getString,getInt,getInteger-,getMultilineText,getBool,getOption, getPassword,validate--- * formatting and combining widgets--,mix,wrap,addToForm--- * running the flow monad-,FlowM,runFlow,MFlow.Forms.step--- * setting parameters-,setHeader-,setTimeouts--- * Cookies-,setCookie-)-where-import Data.TCache---import Data.Persistent.Queue-import MFlow-import MFlow.Cookies-import Data.RefSerialize (Serialize)-import Control.Workflow as WF-import Data.Typeable-import Data.Monoid-import Control.Monad.State-import Control.Monad.Trans.Maybe-import Control.Applicative-import Control.Exception-import Control.Workflow(exec1,Workflow, waitUntilSTM, step, unsafeIOtoWF)---import Debug.Trace----(!>)= flip trace---type UserName= String--data User= User- { userName :: UserName- , 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}= userPrefix++user------maybeError err iox = runMaybeT iox >>= \x ->- case x of- Nothing -> error err- Just x -> return x---- | register an user/password combination-userRegister :: String -> String -> IO()-userRegister user password = withResources [] $ const [ User user password]-----newDBRef1 :: (IResource a, Typeable a) => a -> STM (DBRef a) ---newDBRef1 x = do--- let ref= getDBRef $ keyResource x--- mr <- readDBRef ref--- case mr of--- Nothing -> writeDBRef ref x >> return ref--- Just r -> return ref----- let u= User user password--- let ref= getDBRef $ key u--- atomically $ do--- mr <- readDBRef ref--- case mr of--- Nothing -> writeDBRef ref u -- !> (show mr)--- Just u -> return ()--- return ref---- | authentication against `userRegister`ed users.--- to be used with `validate`-userAuthenticate :: MonadIO m => User -> m (Maybe String)-userAuthenticate user@User{..} = liftIO $ atomically- $ withSTMResources [user]- $ \ mu -> case mu of- [Nothing] -> resources{toReturn= err }- [Just (User _ p )] -> resources{toReturn=- case upassword==p of- True -> Nothing- False -> err-- }-- where- err= Just "Username or password invalid"---type FlowM view = StateT (MFlowState view)--runFlow :: (FormInput view, Monoid view, Monad m)- => FlowM view m () -> Token -> m ()-runFlow f = \t -> evalStateT f mFlowState0{mfToken=t}--step- :: (Serialize a,- MonadIO m,- Typeable a) =>- FlowM view m a- -> FlowM view (Workflow m) a--step f=do- s <- get- lift . WF.step $ evalStateT f s-------cookieuser= "cookieuser"---instance (MonadIO m, Functor m, FormInput view) => FormLet User m view where- digest muser =- (User <$> getString (fmap userName muser)- <*> getPassword)- `validate` userAuthenticate---newtype Lang= Lang String--data MFlowState view= MFlowState{- mfSequence :: Int,- mfUser :: String,- mfLang :: Lang,- mfEnv :: Params,--- mfServer :: String,--- mfPath :: String,--- mfPort :: Int,-- mfToken :: Token,- mfkillTime :: Int,- mfStateTime :: Integer,- mfCookies :: [Cookie],- mfHeader :: view -> view}----stdHeader v= v--anonymous= "anonymous"---rAnonUser= getDBRef . key $ eUser{userName=anonymous} :: DBRef User--mFlowState0 :: (FormInput view, Monoid view) => MFlowState view-mFlowState0= MFlowState 0 anonymous (Lang "en") [] undefined 0 0 [] stdHeader--setHeader :: Monad m => (view -> view) -> FlowM view m ()-setHeader header= do- fs <- get- put fs{mfHeader= header}---- | set an HTTP cookie-setCookie :: Monad m- => String -- ^ name- -> String -- ^ value- -> String -- ^ path- -> Maybe String -- ^ expires- -> FlowM view m ()-setCookie n v p me= do- st <- get- put st{mfCookies= (n,v,p,me):mfCookies st }--setTimeouts :: (Monad m)=> Int -> Integer -> FlowM view m ()-setTimeouts kt st= do- fs <- get- put fs{ mfkillTime= kt, mfStateTime= st}---- | 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. It return a reference to the user.--getUser :: ( FormInput view, Monoid view, Typeable view- , ConvertTo (HttpData view) display, Typeable display- , MonadIO m, Functor m)- => FlowM view m String-getUser = do-- rus <- gets mfUser- case rus == anonymous of- False -> return rus- True -> do- env <- do- env <- gets mfEnv- if null env then receiveWithTimeouts>> gets mfEnv- else return env- ref <- case lookup cookieuser env of- Nothing -> do- us <- ask (Form (Nothing :: Maybe User))- ref <- liftIO . atomically $ newDBRef us- setCookie cookieuser (userName us) "/" Nothing- get >>= \s -> liftIO $ print (mfCookies s)- return $ userName us- Just usname -> return usname--- modify $ \s -> s{mfUser= ref}F- return ref---- | Launchable widgets create user requests. For example whatever piece containing--- a Form tag, a link with an embeeded Ajax invocation etc.------ A FormLet for an input field can not be an instance of Launchable, for example--- to invoke it with ask, make the widget an instance of Launchable-class Widget a b m view => Launchable a b m view---instance (MonadIO m, Functor m)- => Widget(View view m a) a m view where- widget = id--instance (MonadIO m, Functor m)- => Launchable (View view m a) a m view----- | join two widgets in the same pages--- the resulting widget, when `ask`ed with it, returns a either one or the other-mix :: ( FormInput view , Monad m)- => View view m a'- -> View view m b'- -> View view m (Either a' b')-mix digest1 digest2= FormT $ \env -> do- FormElm f1 mx' <- (runFormT $ digest1) env- FormElm f2 my' <- (runFormT $ digest2) env- return $ FormElm (f1++f2)- $ case (mx',my') of- (Nothing, Nothing) -> Nothing- (Just x,Nothing) -> Just $ Left x- (Nothing,Just x) -> Just $ Right x- (Just _,Just _) -> error "malformed getters in widget combination"---- | it is the way to interact with the user.--- It takes a combination of `launchable` objects and return the user result--- in the FlowM monad -ask- :: ( Launchable a b m view- , FormInput view, Monoid view- , Typeable view, ConvertTo (HttpData view) display- , Typeable display )- => a -> FlowM view m b-ask mx = do- st <- get- let t= mfToken st- FormElm forms mx' <- generateForm mx- case mx' of- Just x -> return x- _ -> do- let header= mfHeader st- liftIO . sendFlush t $ HttpData (mfCookies st) (header $ mconcat forms)- put st{mfCookies=[]}- receiveWithTimeouts- ask mx-----receiveWithTimeouts :: MonadIO m => FlowM view m ()-receiveWithTimeouts= do- st <- get- let t= mfToken st- t1= mfkillTime st- t2= mfStateTime st- req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t)- put st{mfEnv= req}---data Selection a view= Selection{stitle:: view, sheader :: [view] , sbody :: [([view],a)]}--instance (MonadIO m, Functor m, FormInput view, Typeable a, Show a, Read a, Eq a)- => Launchable (Selection a view) a m view--instance (MonadIO m, Functor m- ,FormInput view, Read a , Show a, Eq a, Typeable a)- => Widget (Selection a view) a m view where- widget Selection {..} =FormT(\env -> do- t <- fmap mfToken get- let mn = getParam1 "select" env-- toSend = fformAction (twfname t) . ftable stitle sheader $- map(\(vs,x) -> vs ++ [finput "select" "radio" (show x)- ( Just x== mn) (Just "this.form.submit()")] ) sbody- return $ FormElm [toSend] mn)-------data Link view = Link view (FlowM view (Workflow IO) ())------instance ( FormInput view, Monoid view)--- => Launchable (Link view ) () IO view------instance (FormInput view, Monoid view)--- => Widget (Link view ) () IO view where--- widget (Link v f) = FormT $ \ env -> do--- n <- getnewname------ let render= FormElm [flink (Verb n ) v]--- case getParam1 n env :: Maybe String of--- Nothing -> return ()--- Just _ -> do--- token <- liftIO $ getToken (n,env)--- liftIO $ forkIO $ exec verb (runFlow f) token--- return()--- return $ render Nothing------instance Processable (String, Params) where --- pwfname (pwfname, env)= pwfname --- puser (_,env) = case lookup "cookieuser" env of --- Nothing -> "nouser" --- Just user -> user --- pind (_,env)= case lookup "flow" env of --- Nothing -> error ": No FlowID" --- Just fl -> fl --- getParams (_,env)= env----------data LocalLink view = LocalLink view (FlowM view IO ())------------instance (MonadIO m, Functor m,FormInput view, Monoid view)--- => Launchable (LocalLink view ) String m view------instance (MonadIO m,Functor m,FormInput view, Monoid view)--- => Widget (LocalLink view ) String m view where--- widget (LocalLink v f) = FormT $ \ env -> do--- t <- fmap mfToken get--- let verb= twfname t--- widget $ Link verb v (transient f)----newtype Form a= Form a--instance (FormInput view, Monoid view, Widget a b m view)- => Launchable (Form a) b m view--instance (FormInput view, Monoid view, Widget a b m view)- => Widget (Form a) b m view- where- widget (Form x) = FormT $ \env -> do- FormElm form mr <- (runFormT $ widget x ) env- t <- fmap mfToken get- let form1= fformAction (twfname t) . mconcat- $ form- ++ [finput "reset" "reset" "Reset" False Nothing- ,finput "submit" "submit" "Submit" False Nothing]-- return $ FormElm [form1] mr----data FormElm view a = FormElm [view] (Maybe a)---newtype FormT view m a = FormT { runFormT :: Params -> m (FormElm view a) }--instance Functor (FormElm view ) where- fmap f (FormElm form x)= FormElm form (fmap f x)--instance Functor m => Functor (FormT view m) where- fmap f = FormT .(\env -> fmap (fmap f) . (runFormT env) )--instance (Functor m, Monad m) => Applicative (FormT view m) where- pure a = FormT $ \env -> return (FormElm [] $ Just a)- FormT f <*> FormT g= FormT $ \env ->- f env >>= \(FormElm form1 k) ->- g env >>= \(FormElm form2 x) ->- return (FormElm (form1 ++ form2) (k <*> x))--instance (Monad m, Functor m) => Monad (FormT view m) where- x >>= f = join $ fmap f x- return= pure--type View view m a= FormT view (FlowM view m) a---- a FormLet instance-class (Functor m, MonadIO m) => FormLet a m view where- digest :: Maybe a- -- -> Validate m a- -> View view m a---class (Functor m, MonadIO m) => Widget a b m view | a -> view where- widget :: a- -- -> Validate m b- -> View view m b----instance FormLet a m view => Widget (Maybe a) a m view where- widget = digest----- | 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 number please")--validate- :: (FormInput view,- Functor m, MonadIO m)- => View view m a- -> (a -> m (Maybe String))- -> View view m a-validate formt val= FormT $ \env -> do- FormElm form mx <- (runFormT formt) env- case mx of- Just x -> do- me <- lift $ val x- case me of- Just str ->do- --FormElm form mx' <- generateForm [] (Just x) noValidate- return $ FormElm ( inred (fromString str) : form) Nothing- Nothing -> return $ FormElm [] mx- _ -> return $ FormElm form mx--generateForm- :: (Widget a b m view, FormInput view ) =>- a -> FlowM view m (FormElm view b)-generateForm mx = do- st <- get- (runFormT $ widget mx ) $ mfEnv st--- lift $ evalStateT--- ((runFormT $ digest mx val) $ mfEnv st)--- st----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------------instance (MonadIO m, Functor m, FormInput view) => FormLet Verb m view where--- digest _ = FormT $ \env -> return $ case getParam1 "verb" env of--- Nothing -> error "digst: verb not found"--- Just x -> FormElm [] . Just $ Verb x--------- -getString :: (FormInput view,Monad m) =>- Maybe String -> View view m String-getString = getElem--getInteger :: (FormInput view, Functor m, MonadIO m) =>- Maybe Integer -> View view m Integer-getInteger = getElem--getInt :: (FormInput view, Functor m, MonadIO m) =>- Maybe Int -> View view m Int-getInt = getElem--getPassword :: (FormInput view,- Monad m) =>- View view m String-getPassword = getParam Nothing "password" (Just "enter password")---getElem- :: (FormInput view,- Monad m,- Typeable a,- Show a,- Read a) =>- Maybe a -> View view m a-getElem 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 = FormT $ \env -> do- tolook <- case look of- Nothing -> getnewname- Just n -> return n- let nvalue= case mvalue of- Nothing -> ""- Just v -> show v- form= [finput tolook type1 nvalue False Nothing]- case getParam1 tolook env of- Nothing -> return $ FormElm form Nothing- justx -> return $ FormElm form justx--- do--- me <- lift $ val justx--- case me of--- Nothing -> return $ FormElm [] justx--- Just str -> return $ FormElm [bold $ fromString str,input tolook type1 nvalue False] Nothing--getnewname :: Monad m => FlowM view m String-getnewname= do- st <- get- let n= mfSequence st- put $ st{mfSequence= n+1}- return $ "Parm"++show n--getMultilineText :: (FormInput view,- Monad m) =>- Maybe [Char] -> View view m String-getMultilineText mt = FormT $ \env -> do- tolook <- getnewname-- let nvalue= case mt of- Nothing -> ""- Just v -> show v- case (getParam1 tolook env, mt) of- (Nothing, Nothing) -> return $ FormElm [ftextarea tolook nvalue] Nothing- (Nothing, Just v) -> return $ FormElm [] $ Just v- (justx,_) -> return $ FormElm [] justx--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 $ show bool--getBool :: (FormInput view,- Monad m) =>- Maybe String -> String -> String -> View view m Bool-getBool mv truestr falsestr= FormT $ \env -> do- tolook <- getnewname- case (getParam1 tolook env, mv) of- (Nothing, Nothing) -> return $ FormElm [foption1 tolook [truestr,falsestr] mv] Nothing- (Nothing,Just x) -> return . FormElm [] . Just $ fromstr x- (Just x,_) -> return . FormElm [] . Just $ fromstr x- where- fromstr x= if x== truestr then True else False--getOption :: (FormInput view,- Monad m) =>- Maybe String ->[(String,String)] -> View view m String-getOption mv strings = FormT $ \env -> do- tolook <- getnewname- case (getParam1 tolook env, mv) of- (Nothing, Nothing) -> return $ FormElm [foption tolook strings mv] Nothing- (Nothing,Just x) -> return . FormElm [] $ Just x- (justx,_) -> return $ FormElm [] justx----- | encloses instances of `Widget` or `FormLet` in formating--- view is intended to be instantiated to a particular format--- see "MFlow.Forms.XHtml" for usage examples-wrap :: (Monad m, FormInput view, Monoid view)- => (view ->view)- -> View view m a- -> View view m a-wrap v form= FormT $ \env -> do- FormElm f mx <- runFormT form env- return $ FormElm [v $ mconcat f] mx---- | append formatting to `Widget` or `FormLet` instances--- view is intended to be instantiated to a particular format--- see "MFlow.Forms.XHtml" for usage examples-addToForm :: (Monad m, FormInput view, Monoid view)- => View view m a- -> view- -> View view m a-addToForm form v= FormT $ \env -> do- FormElm f mx <- runFormT form env- return $ FormElm (f++[v]) mx----type Name= String-type Type= String-type Value= String-type Checked= Bool-type OnClick= Maybe String----- | Minimal interface for defining the abstract basic form combinators--- defined in this module. see "MFlow.Forms.XHtml" for the instance for "Text.XHtml"--- format-class FormInput view where--- column :: [view] -> view--- column columns= table (fromString "") [] [columns]--- row :: [view] -> view-- inred :: view -> view--- fs :: view -> view--- ts :: view -> view-- ftable:: view -> [view] -> [[view]] -> view--- hsep :: view--- vsep :: view--- style :: String -> 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- foption :: String -> [(String,String)] -> Maybe String -> view- foption1 :: String -> [String] -> Maybe String -> view- foption1 name list msel= foption name (zip list list) msel-- fformAction :: String -> view -> view
− MFlow/Forms/XHtml.hs
@@ -1,117 +0,0 @@------------------------------------------------------------------------------------ Module : Control.MessageFlow.Forms.XHtml--- Copyright :--- License : BSD3------ Maintainer : agocorona@gmail.com--- Stability : experimental--- Portability :------ |----------------------------------------------------------------------------------{- Instantiation of "MFlow.Forms" for the xhtml package "Text.XHtml" module-it includes additional XHtml style operators for embedding widgets within XHtml formatting---}--{-# OPTIONS -XMultiParamTypeClasses- -XFlexibleInstances- -XUndecidableInstances- -XTypeSynonymInstances- -XFlexibleContexts- #-}---module MFlow.Forms.XHtml((<++), (<+>), (++>), (<<<))- where---import MFlow.Forms-import Text.XHtml as X-import Control.Monad.Trans-import Data.Typeable----- | encloses a widget in Html formatting------ @table <<< (--- tr <<< (td << widget widget1)--- tr <<< (td << widget widget2))@--(<<<) :: Monad m => (Html -> Html) -> View Html m a -> View Html m a-tag <<< d= wrap tag d-infixr 7 <<<--infixr 3 <++--- | prepend Html formatting to a widget------ @bold << "hi there"--- <++--- widget widget1@--(<++) :: Monad m => Html -> View Html m a -> View Html m a-html <++ digest = (html +++) <<< digest--infix 3 ++>--- | append Html to a widget------ @widget widget1--- ++>--- H1 << "hi there"@-(++>) :: Monad m => View Html m a -> Html -> View Html m a-digest ++> html = addToForm digest html----- | join two widgets in the same pages--- the resulting widget, when `ask`ed with it, returns a either one or the other------ @r <- ask widget widget1 <+> widget widget2@----infixr 2 <+>-(<+>) :: Monad m- => View Html m a'- -> View Html m b'- -> View Html m (Either a' b')-(<+>) = mix-----instance Typeable X.Html where - typeOf = \_ -> mkTyConApp (mkTyCon3 "XHtml" "Text.XHtml.Strict" "Html") [] --instance FormInput Html where--- column vs= concatHtml [tr v | v <- vs]--- row vs= concatHtml [td v | v <- vs]--- hsep = spaceHtml--- vsep = br- 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]; _ -> [] )- ftextarea name text= X.textarea ! [X.name name] << text-- foption name list msel= select ![ X.name name] << (concatHtml- $ map (\(n,v) -> X.option ! ([value n] ++ selected msel n) << v ) list)-- where- selected msel n= if Just n == msel then [X.selected] else []----- fformAction action form = X.form ! [X.action action, method "post"] << form- fromString = stringToHtml--- bold = X.bold--- fs = h3--- ts = h4--- style st content = thespan ![thestyle st] << content-- ftable title head rows=- X.table << ( - (if not . isNoHtml $ title then caption << title else noHtml ) +++ - (if not . null $ head then tr << (concatHtml [th h | h <- head]) else noHtml) +++ - (concatHtml[tr << concatHtml[td v| v <- row] | row <- rows])) -- flink v str = p << hotlink v << str
− MFlow/Hack.hs
@@ -1,328 +0,0 @@-{-# LANGUAGE UndecidableInstances- , TypeSynonymInstances- , MultiParamTypeClasses- , DeriveDataTypeable- , FlexibleInstances #-}- -module MFlow.Hack(- module MFlow.Cookies- ,module MFlow- ,hackMessageFlow)-where- -import Data.Typeable -import Hack --import Control.Concurrent.MVar(modifyMVar_, readMVar) -import Control.Monad(when) - - -import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString) -import Control.Concurrent(ThreadId(..)) -import System.IO.Unsafe -import Control.Concurrent.MVar -import Control.Exception -import qualified Data.Map as M- -import Data.TCache- -import Control.Workflow - -import MFlow -import MFlow.Cookies-import MFlow.Hack.Response-import Data.Monoid----(!>)= flip trace--assocList ->> k = getParam1 assocList k- -instance Processable Env where - pwfname env= if null sc then "noscript" else sc - where - sc= tail $ pathInfo env -- takeWhile (/= '?') $ queryString env- puser env = case lookup "cookieuser" $ http env of - Nothing -> "nouser" - Just user -> user - pind env= case lookup "flow" $ http env of - Nothing -> error ": No FlowID" - Just fl -> fl - getParams env= http env--- getServer env= serverName env--- getPath env= pathInfo env--- getPort env= serverPort env- -data Flow= Flow !Int deriving (Read, Show, Typeable) - - -instance Indexable Flow where - key _= "Flow" - --- -newFlow= do - fl <- atomically $ do - withSTMResources [Flow undefined] $ - \m -> - let - (add, ret)= case m of - [Just (Flow n)] -> ([Flow $ n+1],n) - [Nothing] -> ([Flow 1],0) - in resources{toAdd=add, toReturn= ret} - - return $ show fl - ---------------------------------------------- - - - - -instance ConvertTo String TResp where - convert = TResp . pack --instance ConvertTo ByteString TResp where - convert = TResp----instance ConvertTo Response TResp where--- convert= TResp--- -instance ConvertTo Error TResp where - convert (Error e)= TResp $ pack e--instance ToResponse v =>ConvertTo (HttpData v) TResp where- convert= TRespR --- ---instance Typeable (HSP XML) where --- typeOf = \_ -> mkTyConApp (mkTyCon "HSP") [mkTyConApp ( mkTyCon "XML") []] --- --- --- ---instance ConvertTo (HSP XML) TResp where --- convert xml=unsafePerformIO $ do --- (_,html) <- evalHSP Nothing xml --- return . TResp . pack $ renderAsHTML html --- --- ------instance Typeable X.Html where --- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Transitional.Html") [] --- --- --- --- --- ---instance ConvertTo X.Html TResp where --- convert = TResp . pack . X.showHtml ---- -webScheduler :: -- (Typeable c, ToResponse c) =>- Env - -> ProcList - -> IO (TResp, ThreadId) -webScheduler = msgScheduler - -eitherToError (Right x)= x -eitherToError (Left e)= error $ "eitherToError " ++ show e - ---theDir= unsafePerformIO getCurrentDirectory - -wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) -wFMiddleware filter f = \ env -> if filter env then hackWorkflow env else f env - --- | An instance of the abstract "MFlow" scheduler to the Hack interface--- it accept the list of processes being scheduled and return a hack handler ------ Example:------ @main= do------ putStrLn $ options messageFlows--- 'run' 80 $ 'hackMessageFlow' 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]--- @-hackMessageFlow :: ProcList -> (Env -> IO Response) -hackMessageFlow messageFlows = - unsafePerformIO (addMessageFlows messageFlows) `seq` - wFMiddleware (\env -> (pwfname env) `elem` paths) - (\env -> defaultResponse $ "usage: http//server/" ++ show paths ++ "?verb") - where - (paths,_)= unzip messageFlows - -splitPath ""= ("","","") -splitPath str= - let - strr= reverse str - (ext, rest)= span (/= '.') strr - (mod, path)= span(/='/') $ tail rest - in (tail $ reverse path, reverse mod, reverse ext) --- -hackWorkflow :: Env -> IO Response -hackWorkflow req1= do-- - let httpreq1= http req1 -- !> (show req1) - let cookies= getCookies httpreq1 - - (flow , retcookies) <- case lookup "flow" cookies of - Just fl -> return (fl, []) - Nothing -> do - fl <- newFlow - return (fl, [("flow", fl, "/",Nothing)]) -{- - putStateCookie req1 cookies - let retcookies= case getStateCookie req1 of - Nothing -> retcookies1 - Just ck -> ck:retcookies1 --} - - let [(input, str)]= - case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of - (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack . hackInput $ req1 - (GET, _) -> urlDecode . queryString $ req1 - _ -> [([("","")],"")] - - - let req = case retcookies of - [] -> req1{http= input ++ cookies ++ http req1} -- !> "REQ" - _ -> req1{http= ("flow", flow): input ++ cookies ++ http req1} -- !> "REQ" - - wfs <- getMessageFlows - (resp',th) <- webScheduler req wfs --- 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 resp-- -------persistent state in cookies (not tested) - -tvresources :: MVar (Maybe ( M.Map string string)) -tvresources= unsafePerformIO $ newMVar Nothing -statCookieName= "stat" - -putStateCookie req cookies= - case lookup statCookieName cookies of - Nothing -> return () - Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ - \mmap -> case mmap of - Just map -> return $ Just $ M.insert (keyResource req) str map - Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] - -getStateCookie req= do - mr<- readMVar tvresources - case mr of - Nothing -> return Nothing - Just map -> case M.lookup (keyResource req) map of - Nothing -> return Nothing - Just str -> do - swapMVar tvresources Nothing - return $ Just (statCookieName, str , "/") - -{- -persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} - where - writeResource stat= modifyMVar_ tvresources $ \mmap -> - case mmap of - Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map - Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] - readResource stat= do - mstr <- withMVar tvresources $ \mmap -> - case mmap of - Just map -> return $ M.lookup (keyResource stat) map - Nothing -> return Nothing - case mstr of - Nothing -> return Nothing - Just str -> return $ deserialize str - - deleteResource stat= modifyMVar_ tvresources $ \mmap-> - case mmap of - Just map -> return $ Just $ M.delete (keyResource stat) map - Nothing -> return $ Nothing ---}--- | Users------instance Display String TResp where--- column vs= concat ["<tr>" ++ v ++"</tr>" | v <- vs]--- row vs= concat ["<td>" ++ v ++ "</td>" | v <- vs]--- hsep = "$nbsp;"--- vsep = "<br/>"--- input n t v f= "<input type=\""++ t ++"\" name=\""++n++"\" value=\""++v++"\" "++ if f then "checked " else "" ++"/>"--- textarea name text= "<textarea name=\""++ name++"\">"++ text ++"</textarea>"------ option name list msel= "<select name=\""++ name ++"\">"++--- concatMap (\(n,v) -> "<option value=\""++ n ++ selected msel n ++">"++ v ++ "</option>") list ++--- "</select>"--- where--- selected msel n= if Just n == msel then " \"selected\" " else ""------ option1 name list msel= "<select name=\""++ name ++"\">"++--- concatMap (\v -> "<option" ++ selected msel v ++">"++ v ++ "</option>") list ++--- "</select>"--- where--- selected msel n= if Just n == msel then " \"selected\" " else ""------------ formAction action form = "<form action=\""++action++"\" method=\"post\">"++ form ++ input "cancel" "button" "cancel" False++ input "submit" "submit" "submit" False ++ "</form>"--- fromString s= s--- bold x= "<b>" ++ x ++ "</b>"--- fs x= "<h3>" ++ x ++ "</h3>"--- ts x= "<h4>" ++ x ++ "</h4>"--- style st content = "<span style="++ st++"> "++ content ++"</span>"------ table title head rows=--- "<table>"++ --- (if not . null $ title then "<caption> " ++ title ++ " </caption>" else "") ++ --- (if not . null $ head then "<tr>"++concat ["<th>"++ h ++ "</th>"| h <- head] ++ "</tr>" else "")++ --- (concat ["<tr>" ++ concat["<td>"++ v ++ "</td>"| v <- row] ++ "</tr>" | row <- rows]) ++ --- "</table>"----------- textarea name value= "<texyarea name=\""++name++"\" rows=\"20\" cols="65" warp=\"true\">"++value++ "</textarea>"----- option1 name options option=----- "< input type=\"radio\" checked=\""++option++"\" name=\""++name++"\" value="approbal"--------- link (Verb v) str = "<a href="++v++">"++ str ++"</a>"---{---instance Monoid (HSP XML) where- mempty = <span/>- mappend x y= <span> <% x %> <% y %> </span>--instance Display (HSP XML) TResp where- column vs= <table><td><% [<tr> <% v %> </tr> | v <- vs] %></td></table>- row vs= <tr> <% [<td> <% v %> </td> | v <- vs] %> </tr>-- table title caption rows=- <table> - {- <% when (not . null $ title) -} <caption><% title %> </caption> -- %> - {-<% when (not . null $ caption)-} <tr> <%[<th> <%cap %> </th>| cap <- caption] %></tr> -- %> - <%[<tr> <% [<td><% v %></td>| v <- row] %> </tr> | row <- rows] %> - </table>-- hsep = <span> </span>- style st content = <span style=(st)> <% content %> </span>- vsep = <br/>- fromString s = <span><% s %></span>- -- option (Verb v) view1= <a href = (v)><% view1 %> </a>-- input typ name value= <input type= (typ) name=(name) value=(value)/>----}
− MFlow/Hack/Response.hs
@@ -1,94 +0,0 @@-{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances- -XFlexibleInstances -XDeriveDataTypeable #-} -module MFlow.Hack.Response where - -import Hack-import MFlow.Cookies -import Data.ByteString.Lazy.Char8-import MFlow(HttpData(..)) -import Data.Typeable -import Data.Monoid----import Debug.Trace------(!>)= flip trace- -class ToResponse a where - toResponse :: a -> Response ----data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable--instance Monoid TResp where- mempty = TRempty- mappend (TResp x) (TResp y)=- case cast y of- Just y' -> TResp $ mappend x y'- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)-- - -defaultResponse :: String -> IO Response -defaultResponse msg= return . toResponse $ "<p>Page not found or error ocurred:<br/>" ++ msg ++ "<br/><a href=\"/\" >home</a> </p>" ---instance ToResponse TResp where- 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} - -instance ToResponse String where - toResponse x= Response{status=200, headers=[ctype{-,("Content-Length",show $ B.length x) -}], body= pack x} -----instance ToResponse a => ToResponse (HttpData a) where- toResponse (HttpData cookies x)= (toResponse x) {headers= cookieHeaders cookies}---- ---instance ToResponse (HSP XML) where --- toResponse xml=unsafePerformIO $ do --- (_,html) <- evalHSP Nothing xml --- let bs= pack $ renderAsHTML html --- return $ toResponse bs - - - -{--instance IResource Env where - keyResource env=user ++ "#" ++ flowId where - user= case lookup "user" $ http env of - Nothing -> "nokey" - Just user -> user - flowId= case lookup "flow"$ http env of - Nothing -> error ": No FlowID" - Just fl -> fl - serialize= show - deserialize= error "Env deserialize: undefined" - writeResource _ = return () - readResource _ = undefined --} ---instance Read Env where --- readsPrec= error "Env Read: undefined" -{- -instance IResource Response where - keyResource _ = "resp" - serialize= show - deserialize= error "Response deserialize: undefined" - writeResource _ = return () - readResource _ = undefined --} - - -instance Typeable Env where - typeOf = \_-> mkTyConApp (mkTyCon3 "hack" "Hack" "Env") [] - -instance Typeable Response where - typeOf = \_-> mkTyConApp (mkTyCon3 "Hack" "Hack" "Response")[]
− MFlow/Hack/XHtml.hs
@@ -1,35 +0,0 @@------------------------------------------------------------------------------------ Module : MFlow.Hack.XHtml--- Copyright :--- License : BSD3------ Maintainer : agocorona@gmail.com--- Stability : experimental--- Portability :------ |-----------------------------------------------------------------------------------{--Instantiations necessary for "MFlow.Hack" to use "Text.XHtml" as format for generating output--}--{-# OPTIONS -XMultiParamTypeClasses #-}--module MFlow.Hack.XHtml (--) where-import MFlow-import Hack-import MFlow.Hack.Response-import Text.XHtml-import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString)- -instance ToResponse Html where - toResponse x= Response{ status=200, headers=[]- , Hack.body= pack $ showHtml x} ---
− MFlow/Hack/XHtml/All.hs
@@ -1,45 +0,0 @@------------------------------------------------------------------------------------ Module : MFlow.Hack.XHtml.All--- Copyright :--- License : BSD3------ Maintainer : agocorona@gmail.com--- Stability : experimental--- Portability :------ |-----------------------------------------------------------------------------------module MFlow.Hack.XHtml.All (--module MFlow.Hack-,module MFlow.Forms-,module MFlow.Forms.XHtml-,module MFlow.Hack.XHtml-,module Hack--,module Hack.Handler.SimpleServer--,module Text.XHtml.Strict--,module Control.Applicative---) where--import MFlow.Hack-import MFlow.Forms-import MFlow.Forms.XHtml-import MFlow.Hack.XHtml--import Hack(Env)-import Hack.Handler.SimpleServer----import Text.XHtml.Strict hiding (widget)--import Control.Applicative-
+ src/MFlow.hs view
@@ -0,0 +1,358 @@+{- | Non monadic low level support stuff for the MFlow application server.+it implements an scheduler of queued 'Processable' messages that are served according with+the source identification and the verb invoked.+Ths 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 logged and can be recovered.++The message communication is trough polimorphic, monoidal queues.+There is no asumption about message codification, so instantiations+of this scheduler for many different infrastructures is possible.+"MFlow.Hack" is an instantiation for the Hack interface in a Web context.++"MFlow.Wai" is a instantiation for the WAI interface.++In order to manage resources, the serving process may die after a timeout.+as well as the logged state, usually, after a longer timeout .++All these details are hidden in the monad of "MFlow.Forms" that provides+an higuer level interface. Altroug fragments streaming 'sendFragment' 'sendEndFragment'+are only provided at this level.++'stateless' and 'transient' serving processes are 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.++-}+++{-# LANGUAGE DeriveDataTypeable, UndecidableInstances+ ,ExistentialQuantification, MultiParamTypeClasses+ ,FunctionalDependencies+ ,TypeSynonymInstances+ ,FlexibleInstances+ ,FlexibleContexts+ ,RecordWildCards+ ,OverloadedStrings+ #-} +module MFlow (+Params, Req(..), Resp(..), Workflow, HttpData(..),Processable(..), ToHttpData(..), Token(..), getToken, ProcList+,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment, sendEndFragment+,msgScheduler, addMessageFlows,getMessageFlows, transient, stateless,anonymous+,noScript,hlog,addTokenToList,deleteTokenInList, btag, bhtml, bbody,Attribs)++where +import Control.Concurrent.MVar +import Data.IORef +import GHC.Conc(unsafeIOToSTM) +import Data.Typeable +import Data.Maybe(isJust, isNothing, fromMaybe, fromJust)+import Data.Char(isSeparator) +import Data.List(isPrefixOf, elem , span, (\\)) +import Control.Monad(when)+ +import Data.Monoid +import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId) + + +import Unsafe.Coerce+import System.IO.Unsafe+import Data.TCache.DefaultPersistence hiding(Indexable(..)) ++import Data.ByteString.Lazy.Char8 as B(ByteString, pack, unpack,empty,append,cons,fromChunks) + +import qualified Data.Map as M +import System.IO+import System.Time+import Control.Workflow+import MFlow.Cookies++--import Debug.Trace+--(!>)= flip trace+++--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 Monoid HttpData where+ mempty= HttpData [] [] empty+ mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'++-- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname+type ProcList = WorkflowList IO Token ()+++data Req = forall a.( Processable a,Typeable a)=> Req a deriving Typeable++type Params = [(String,String)]++class Processable a where + pwfname :: a -> String+ puser :: a -> String+ pind :: a -> String+ getParams :: a -> Params+-- getServer ::a -> String+-- getPath :: a -> String+-- getPort :: a -> Int++ +instance Processable Req where + pwfname (Req x)= pwfname x+ puser (Req x)= puser x+ pind (Req x)= pind x + getParams (Req x)= getParams x+-- getServer (Req x)= getServer x+-- getPath (Req x)= getPath x+-- getPort (Req x)= getPort x + +data Resp = Fragm HttpData+ | EndFragm HttpData+ | Resp HttpData+ ++anonymous= "anon#"+noScript = "noscript"+ +data Token = Token{twfname,tuser, tind :: String , q :: MVar Req, qr :: MVar Resp} deriving Typeable ++instance Indexable Token where + key (Token w u i _ _ )=+ if u== anonymous then u++ i -- ++ "@" ++ w+ else u -- ++ "@" ++ w++instance Show Token where + show t = "Token " ++ key t++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)] ++ where++ (ui,str')= span(/='@') str1+ i = drop (length anonymous) ui+ (w,str2) = span (not . isSeparator) $ tail str'+ newVar _= unsafePerformIO $ newEmptyMVar+++ readsPrec _ str= error $ "parse error in Token read from: "++ str++instance Serializable Token where+ serialize = pack . show+ deserialize= read . unpack++iorefqmap= unsafePerformIO . newMVar $ M.empty++addTokenToList t@Token{..} =+ modifyMVar_ iorefqmap $ \ map ->+ return $ M.insert ( tind ++ twfname ++ tuser ) t map++deleteTokenInList t@Token{..} =+ modifyMVar_ iorefqmap $ \ map ->+ return $ M.delete (tind ++ twfname ++ tuser) map+ +getToken msg= do+ qmap <- readMVar iorefqmap+ let u= puser msg ; w= pwfname msg ; i=pind 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+ addTokenToList token+ return token++ Just token-> return token+ + +{-+instance (Monad m, Show a) => Traceable (Workflow m a) where + debugf iox str = do + x <- iox + 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 ++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 + +--emptyReceive (Token queue _ _)= emptyQueue queue +receive :: Typeable a => Token -> IO a +receive t= receiveReq t >>= return . fromReq++flushRec t@(Token _ _ _ queue _)= do+ empty <- isEmptyMVar queue+ when (not empty) $ takeMVar queue >> return ()+++receiveReq :: Token -> IO Req+receiveReq (Token _ _ _ queue _)= readMVar queue -- !> "receiveReqSTM"++fromReq :: Typeable a => Req -> a+fromReq (Req x) = x' where+ x'= case cast x of+ Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x') + Just y -> y+++ +receiveReqTimeout :: Int+ -> Integer+ -> Token + -> IO Req+receiveReqTimeout 0 0 t= receiveReq t+receiveReqTimeout time time2 t=+ let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t)++ +delMsgHistory t = do ++ let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t + delWFHistory1 statKey -- `debug` "delWFHistory" + +++-- ! to add a simple monadic computation of type (a -> IO b) to the list+-- of the scheduler +stateless :: (ToHttpData b) => (Params -> IO b) -> (Token -> Workflow IO ()) +stateless f = transient $ \tk ->do+ req <- receiveReq tk+ resp <- f (getParams req)+ sendFlush tk resp ++-- | to add a monadic computation that send and receive messages, but does+-- not store its state in permanent storage. The process once stopped, will restart anew +transient :: (Token -> IO ()) -> (Token -> Workflow IO ()) +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 ())]) + ++addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union ms (M.fromList wfs)) + +getMessageFlows = readMVar _messageFlows + +class ToHttpData a where + toHttpData :: a -> HttpData ++ ++--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))+ case m of + Resp r -> return r -- !> ("*********** RECIBIDO"++ show(unsafePerformIO myThreadId)) + 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\"" + Fragm h -> do+ rest <- unsafeInterleaveIO $ getStream h+ let result= mappend r rest+ return result + EndFragm h -> do+ let result= mappend r h+ return result ++++ ++ +--data Error= Error String deriving (Read, Show, Typeable) ++instance ToHttpData String where+ toHttpData= HttpData [] [] . pack++msgScheduler+ :: (Typeable a,Processable a)+ => a -> IO (HttpData, ThreadId)+msgScheduler x = do + token <- getToken x ++ th <- startMessageFlow (pwfname x) token+ r<- tellToWF token x + return (r,th)+ where+ + 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 AlreadyRunning -> return () -- !> ("already Running " ++ wfname)+ Left Timeout -> return() -- !> "Timeout in msgScheduler"+ Left (WFException e)-> do+ let user= key token+ print e+ 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)++ Right _ -> do+-- let msg= "finished Flow "++ wfname++ " restarting"+-- logError (key token) wfname msg+-- startMessageFlow wfname token wfs++ delMsgHistory token; return () -- !> ("finished " ++ wfname)+ ++ logError u wf e= do+ hSeek hlog SeekFromEnd 0+ TOD t _ <- getClockTime+ hPutStrLn hlog (","++show [u,show t,wf,e]) >> hFlush hlog ++logFileName= "errlog"+hlog= unsafePerformIO $ openFile logFileName ReadWriteMode +++-- basic bytestring XML 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 "Text.XHtml" or "HSP".+btag :: String -> Attribs -> ByteString -> ByteString+btag t rs v= "<" `append` pt `append` attrs rs `append` ">" `append` v `append`"</"`append` pt `append` ">"+ where+ pt= pack t+ attrs []= B.empty+ 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
+ src/MFlow/Cookies.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}++module MFlow.Cookies+(Cookie,ctype,urlDecode,cookieuser,cookieHeaders,getCookies)+where+import Control.Monad(MonadPlus(..), guard, replicateM_, when)+import Data.Char+import Data.Maybe(fromMaybe)+import System.IO.Unsafe+import Control.Exception(handle)+import Data.Typeable+import Data.Maybe(fromJust)+import Unsafe.Coerce+import Data.Monoid++++import Text.Parsec+import Control.Monad.Identity+--import Text.Parsec.Token++ctype= ("Content-Type", "text/html")++type Cookie= (String,String,String,Maybe String)++cookieuser :: String+cookieuser= "cookieuser"++--getCookies :: Params -> Params+getCookies httpreq=+ case lookup "Cookie" $ httpreq of+ Just str -> splitCookies str+ Nothing -> []++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"++ where+ showMaxAge Nothing = "" + showMaxAge (Just e) = "; Max-age=" <> e+++--showCookie :: Cookie -> String+--showCookie (n,v,p,me) =+-- let e= fromMaybe "" me +-- in showString n . showString "=" . showString v . showString "; path=" +-- . showString p . showMaxAge e . showString "\n" $ ""+--+--+--showMaxAge [] = showString "" +--showMaxAge e = showString "; Max-age=" . showString e+++++++splitCookies cookies = f cookies [] + where + f s r | null s = r + f xs0 r = + let+ xs = dropWhile (==' ') xs0 + name = takeWhile (/='=') xs + xs1 = dropWhile (/='=') xs + xs2 = dropWhile (=='=') xs1 + val = takeWhile (/=';') xs2 + xs3 = dropWhile (/=';') xs2 + xs4 = dropWhile (==';') xs3 + xs5 = dropWhile (==' ') xs4 + in f xs5 ((name,val):r)++-----------------------------++---------------------------------------------+ +-- %*************************************************************************** +-- %* * +-- \subsection[CGI-Parser]{Yet another combinator parser library}. chuck of code taken from Erik Meijer +-- %* * +-- %*************************************************************************** + +-- NOTE: This is all a little bit of a sledgehammer here for the simple task +-- at hand... + +-- The parser monad + +-- +--newtype Parser a = Parser (String -> [(a,String)]) +-- +--instance Functor Parser where +-- -- map :: (a -> b) -> (Parser a -> Parser b) +-- fmap f (Parser p) = Parser (\inp -> [(f v, out) | (v, out) <- p inp]) +-- +--instance Monad Parser where +-- -- return :: a -> Parser a +-- return v = Parser (\inp -> [(v,inp)]) +-- +-- -- >>= :: Parser a -> (a -> Parser b) -> Parser b +-- (Parser p) >>= f = Parser (\inp -> concat [papply (f v) out +-- | (v,out) <- p inp]) +-- +--instance MonadPlus Parser where +-- -- zero :: Parser a +-- mzero = Parser (\_ -> []) +-- -- (++) :: Parser a -> Parser a -> Parser a +-- (Parser p) `mplus` (Parser q) = Parser (\inp -> (p inp ++ q inp)) +-- +-- +---- Other primitive parser combinators +-- +-- +--item :: Parser Char +--item = Parser (\inp -> case inp of +-- [] -> [] +-- (x:xs) -> [(x,xs)]) +-- +--force :: Parser a -> Parser a +--force (Parser p) = Parser (\inp -> let x = p inp in +-- (fst (head x), snd (head x)) : tail x) +-- +--first :: Parser a -> Parser a +--first (Parser p) = Parser (\inp -> case p inp of +-- [] -> [] +-- (x:_) -> [x]) +-- +--papply :: Parser a -> String -> [(a,String)] +--papply (Parser p) inp = p inp +-- +-- +---- Derived combinators +-- +-- +--(+++) :: Parser a -> Parser a -> Parser a +--p +++ q = first (p `mplus` q) +-- +--sat :: (Char -> Bool) -> Parser Char +--sat p = do {x <- item; guard (p x); return x} +-- +--many :: Parser a -> Parser [a] +--many p = force (many1 p +++ return []) +-- +--many1 :: Parser a -> Parser [a] +--many1 p = do {x <- p; xs <- many p; return (x:xs)} +-- +--sepby :: Parser a -> Parser b -> Parser [a] +--p `sepby` sep = (p `sepby1` sep) +++ return [] +-- +--sepby1 :: Parser a -> Parser b -> Parser [a] +--p `sepby1` sep = do x <- p +-- xs <- many (do {sep; p}) +-- return(x:xs) +-- +--char :: Char -> Parser Char +--char x = sat (x==) +-- +--alphanum :: Parser Char +--alphanum = sat (\c -> isAlphaNum c || c == '@' || c =='\'' ) -- Added @ as a valid character +-- +--string :: String -> Parser String +--string "" = return "" +--string (x:xs) = do char x +-- string xs +-- return (x:xs) +-- +--hexdigit :: Parser Char +--hexdigit = sat isHexDigit +-- +--+--readEnv :: Parser [(String,String)] +readEnv = (do+ n <- urlEncoded + string "=" + v <- urlEncoded + return (n,v)) `sepBy` (string "&") + +urlEncoded :: Parsec String () String +urlEncoded + = many ( alphaNum `mplus` extra `mplus` safe + `mplus` do{ char '+' ; return ' '} + `mplus` do{ char '%' ; hexadecimal } + ) ++ +--extra :: Parser Char +extra = satisfy (`Prelude.elem` "!*'(),/") +-- +--safe :: Parser Char +safe = satisfy (`Prelude.elem` "$-_.") +---- +--hexadecimal :: Parser HexString +hexadecimal = do d1 <- hexDigit + d2 <- hexDigit + return .chr $ toInt d1* 16 + toInt d2 + where toInt d | isDigit d = ord d - ord '0' + toInt d | isHexDigit d = (ord d - ord 'A') + 10 + toInt d = error ("hex2int: illegal hex digit " ++ [d]) +--type HexString = String + +--hex2int :: HexString -> Int +--hex2int ds = Prelude.foldl (\n d -> n*16+d) 0 (Prelude.map (toInt . toUpper) ds) +-- where toInt d | isDigit d = ord d - ord '0' +-- toInt d | isHexDigit d = (ord d - ord 'A') + 10 +-- toInt d = error ("hex2int: illegal hex digit " ++ [d]) ++--urlDecode :: String -> [([(String, String)],String)]+urlDecode str= case parse readEnv "" str of -- let Parser p= readEnv in p str+ Left err -> error $ "urlDecode: decode error: " ++ show err+ Right r -> r
+ src/MFlow/FileServer.hs view
@@ -0,0 +1,326 @@+{- | An file server for frequently accessed files, such are static web pages and image decorations, icons etc+that are cached (memoized) in the program space, for enhanced performance.+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 System.Directory+import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty)+++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 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"+ servefile path= do+ mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `catch` const (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:+--+-- @+-- addFileServerWF+-- run 80 $ hackMessageFlow messageFlows+-- 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:+--+-- @\<img src=(linkFile imagepath)/\>@++-- | 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")++ ]+-}
+ src/MFlow/Forms.hs view
@@ -0,0 +1,1599 @@+{-# OPTIONS -XDeriveDataTypeable + -XUndecidableInstances + -XExistentialQuantification + -XMultiParamTypeClasses + -XTypeSynonymInstances + -XFlexibleInstances + -XScopedTypeVariables + -XFunctionalDependencies + -XFlexibleContexts + -XRecordWildCards + -XIncoherentInstances + -XTypeFamilies+ -XTypeOperators+ -XOverloadedStrings +#-} + +{- | This module implement stateful processes (flows) that are optionally persistent,+that is they may store and retrieve 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 event driven, 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 runs in the @MFlow view m@ monad, with m the one chosen by the user, usually IO.+It send user interfaces (in the @View view m@ monad) and return statically +typed responses. The user interface definitions are based on a extension of+formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,+ extra combinators, callbaks and modifiers.+The interaction with the user is stateful. In the same computation there may be many+request-response interactions, in the same way that in 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 the response.++However `MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that+remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.+This is transparent. There is no programmer interface for session management.++The programmer set the process timeout and the session timeout with `setTimeouts` +whether 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 in the same widget.++Links defined with `wlink` are treated the same way than forms. They are type safe and return to the same flow of execution.+It is posssible to combine links and forms in the same widget with applicative combinators but also+additional applicative combinators like `<+>` `!*>` , `|*|`.++* 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 <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)++[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)+, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if+the widget content comes from a database and it is shared by all users.++[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.+The callback may initate a flow of interactions with the user or simply 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 himself as a black box++[@Modifiers@] `wmodify` add a modifier of 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") <! [("size","5")]+ \<*> getPassword <! [("size","5")]+ \<+> submitButton "login")+ \<+> fromString " password again" ++> getPassword <! [("size","5")]+ \<* submitButton "register"+@++[@ByteString normalization and hetereogeneous formatting@] for caching widget rendering at the ByteString level, and to permit many formatring styles+in the same page, there are new operators that combine different renderings which are converted to ByteStrings.+For example the header and footer may be created in XML, and the formlets may be formatted using Text.XHtml.++[@AJAX@] see "MFlow.Forms.Ajax"++[@File Server@] see "MFlow.FileServer"++This is a complete example runnable 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 Debug.Trace+> (!>)= flip trace+>+>+> data Ops= Ints | Strings | Actions | Ajax deriving(Typeable,Read, Show)+> main= do+> syncWrite SyncManual+> setFilesPath ""+> addFileServerWF+> forkIO $ run 80 $ waiMessageFlow [("noscript",transient $ runFlow mainf)]+> 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 << "Ints") <|>+> br ++> wlink Strings (bold << "Strings") <|>+> br ++> wlink Actions (bold << "Example of a string widget with an action") <|>+> br ++> wlink Ajax (bold << "Simple AJAX example")+> case r of+> Ints -> clickn 0+> Strings -> clicks "1"+> Actions -> actions 1+> Ajax -> ajaxsample+> mainf+>+> clickn (n :: Int)= do+> setHeader stdheader+> r <- ask $ wlink "menu" (p << "back")+> |+| 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) <! [("id","text1"),("onclick", ajaxc)])+> breturn()+>+> actions n=do+> ask $ wlink () (p << "exit from action")+> <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions )+> breturn ()+>++ +-} + +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, +-- * Getters to be used in instances of `FormLet` and `Widget` in the Applicative style. + +getString,getInt,getInteger +,getMultilineText,getBool,getOption, getPassword,+getRadio, getRadioActive,+submitButton,resetButton,+validate, noWidget, waction, wmodify,+wlink, wform,+-- * Caching widgets+cachedWidget, +-- * Widget combinators +(<+>),wintersperse,(|*>),(|+|), (**>),(<**),wconcat,(<|>),(<*),(<$>),(<*>),++-- * Normalized( convert to ByteString) widget combinators+(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),++-- * Formatting combinators+(<<<),(<++),(++>),(<!),++-- * Normalized ( convert to ByteString) formatting combinators+(.<<.),(.<++.),(.++>.)++-- * ByteString tags+,btag,bhtml,bbody++-- * Normalization+, flatten, normalize, ToByteString(..)+ +-- * Running the flow monad +,runFlow,MFlow.Forms.step, goingBack,breturn+ +-- * Setting parameters +,setHeader+,getHeader +,setTimeouts+ +-- * Cookies +,setCookie++-- * Internal use+,MFlowState, getNewName +) +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(step,exec1,Workflow, waitUntilSTM, moveState, unsafeIOtoWF) +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+ +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 leave a computation with an ask statement+--+-- This way when the user press the back button, the computation will return back to+-- 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.Hack.XHtm.All+-- import Some.Time.Library+-- main= run 80 hackMessageFlow [(noscript, time)]+-- 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 ++ +runFlow :: (FormInput view, Monoid view, Monad m) + => FlowM view m () -> Token -> m () +runFlow f = \ t -> evalStateT (runBackT $ backp >> f) mFlowState0{mfToken=t} >> return ()+ where+ -- to restart the flow in case of going back before the first page of the flow+ backp = breturn()+++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 -> maybeRead 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+ modify $ \s -> s{validated= True}+ 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 changes a login-password-register widget by changing it by the username when logged.+--+-- @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 + +getString :: (FormInput view,Monad m) => + Maybe String -> View view m String +getString = getElem + +getInteger :: (FormInput view, Functor m, MonadIO m) => + Maybe Integer -> View view m Integer +getInteger = getElem + +getInt :: (FormInput view, Functor m, MonadIO m) => + Maybe Int -> View view m Int +getInt = getElem + +getPassword :: (FormInput view, + Monad m) => + View view m String +getPassword = getParam Nothing "password" Nothing ++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++ ++ ++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++-- get a parameter form the las received response+getEnv :: MonadState (MFlowState view) m => String -> m(Maybe String)+getEnv n= gets mfEnv >>= return . lookup n+ +getElem + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe a -> View view m a +getElem 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++++getMultilineText :: (FormInput view, + Monad m) => + Maybe String -> View view m String +getMultilineText mt = View $ do + tolook <- getNewName + + let nvalue= case mt of + Nothing -> "" + Just v -> v+ 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"+ +getBool :: (FormInput view, + Monad m) => + Maybe String -> 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 $ [foption1 tolook [truestr,falsestr] 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 + +getOption :: (FormInput view, + Monad m) => + Maybe String ->[(String, String)] -> View view m String +getOption mv strings = View $ do + tolook <- getNewName+ st <- get+ let env = mfEnv st+ put st{needForm= True} + getParam1 tolook env [foption tolook strings mv] + + ++ +-- | Encloses instances of `Widget` or `FormLet` in formating +-- view is intended to be instantiated to a particular format +(<<<) :: (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 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 + foption :: String -> [(String, String)] -> Maybe String -> view + foption1 :: String -> [String] -> Maybe String -> view + foption1 name list msel= foption name (zip list list) 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 <!+widget <! atrs= View $ do+ FormElm fs mx <- runView widget+ return $ FormElm [addAttributes (head fs) atrs] mx+++------------------------------- + +-- +-- +--instance (MonadIO m, Functor m, FormInput view) +-- => 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,+-- mfGoingBack :: 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 (<http://hackage.haskell.org/package/hsp>)+--+-- @+-- setHeader $ \c ->+-- \<html\>+-- \<head\>+-- \<title\> my title \</title\>+-- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)+-- \</head\>+-- \<body style= \"margin-left:5%;margin-right:5%\"\>+-- \<% c %\>+-- \</body\>+-- \</html\>+-- @+--+-- 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` <meta name= \"Keywords\" content= \"sci-fi\" />) `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") <! [("size","5")]+ <*> getPassword <! [("size","5")]+ <+> submitButton "login")+ <+> fromString " password again" ++> getPassword <! [("size","5")]+ <* submitButton "register"++-- | Example of user\/password form (no validation) to be used with 'userWidget'+userLogin :: (FormInput view, Monoid view, Functor m, Monad m)+ => View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String)+userLogin=+ ((,) <$> fromString "Enter User: " ++> getString Nothing <! [("size","4")]+ <*> fromString " Enter Pass: " ++> getPassword <! [("size","4")]+ <+> 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++++-- | 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@ +--+(<+>) , 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 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 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 +-- in the FlowM monad +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' <- mx `seq` 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 would execute the ask of the menu once. But if the user press the+-- back button he will see again the menu. 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@++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} + + +--data Selection a view= Selection{stitle:: view, sheader :: [view] , sbody :: [([view],a)]} + + +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++ +--data Link a view = Link a view + +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, to return a single result +wconcat :: (Monoid view, MonadIO m, Functor m)=> [View view m a] -> View view m a +wconcat 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 +++(|*>),wintersperse :: (MonadIO m, Functor m,Monoid view)+ => View view m r+ -> [View view m r']+ -> View view m (Maybe r,Maybe r')+wintersperse x xs= View $ do+ FormElm fxs rxs <- runView $ wconcat xs+ FormElm fx rx <- runView $ x++ return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx)+ $ case (rx,rxs) of+ (Nothing, Nothing) -> Nothing+ other -> Just other++(|*>)= wintersperse++infixr 5 |*>, .|*>.++(|+|) w w'= wintersperse 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 to make matching easier . 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)++++(.<<.) :: (ToByteString view) => (ByteString -> ByteString) -> view -> ByteString+(.<<.) w x = w $ toByteString x++++++(.<+>.)+ :: (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++(.|*>.)+ :: (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++(.|+|.)+ :: (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++(.**>.)+ :: (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++(.<**.)+ :: (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++(.<|>.)+ :: (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++(.++>.) 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++ foption name list msel= btag "select" [("name", name)] (mconcat+ $ map (\(n,v) -> btag "option" ([("value", n)] ++ selected msel n) (pack v)) list)++ where+ selected msel n= if Just n == 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+++ flink v str = btag "a" [("href", v)] str+++
+ src/MFlow/Forms/Admin.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS+ -XScopedTypeVariables++ #-}+module MFlow.Forms.Admin(adminLoop,addAdminWF) where+import MFlow.Hack+import MFlow.Forms+import MFlow.Forms.XHtml+import MFlow.Hack.XHtml+import MFlow+import Text.XHtml.Strict hiding (widget)+import Control.Applicative+import Control.Workflow+import Control.Monad.Trans+import Data.TCache+import Data.TCache.IndexQuery+import System.Exit+import System.IO+import System.IO.Unsafe+import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)+import System.IO+import Data.RefSerialize hiding ((<|>))+import Data.Typeable+import Data.Monoid+import Data.Maybe+import Data.Map as M (keys)+import System.Exit+import Control.Exception as E++ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"++-- | A small console interpreter with some commands:+--+-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)+--+-- [@flush@] Flush the cache+--+-- [@end@] Synchronize and exit+--+-- [@abort@] Exit. Do not synchronize+--+-- on exception, for example Control-c, it sync and exit.+-- it used as the last statement of the main procedure.+adminLoop :: IO ()+adminLoop= do+ op <- getLine+ case op of+ "sync" -> ssyncCache+ "flush" -> atomically flushAll >> putStrLn "flushed cache"+ "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess+ "abort" -> exitWith ExitSuccess+ _ -> return()+ adminLoop++ `E.catch` (\(e:: E.SomeException) ->do+ ssyncCache+ error $ "\nException: "++ show e)++-- | 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`.+addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)]+++adminMFlow :: FlowM Html IO ()+adminMFlow= do+ admin <- getAdminName+ u <- getUser (Just admin) $ p << bold << "Please login as Administrator" ++> userLogin+ op <- ask $ p <<< wlink "sync" (bold << "sync")+ <|> p <<< wlink "flush" (bold << "flush")+ <|> p <<< wlink "errors"(bold << "errors")+ <|> p <<< wlink "users" (bold << "users")+ <|> p <<< wlink "end" (bold << "end")+ <|> wlink "abort" (bold << "abort")++ case op of+ "users" -> users+ "sync" -> liftIO $ syncCache >> print "syncronized cache"+ "flush" -> liftIO $ atomically flushAll >> print "flushed cache"++ "errors" -> errors+ "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)+ "abort" -> liftIO $ exitWith(ExitSuccess)+ _ -> return()+ adminMFlow+++errors= do+ size <- liftIO $ hFileSize hlog+ if size == 0+ then ask $ wlink () (bold << "no error log")+ else do+ liftIO $ hSeek hlog AbsoluteSeek 0+ 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]+ showFormList rows 0 10+ breturn()++++++++users= do+ users <- liftIO $ atomically $ return . map fst =<< indexOf userName++ showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<-users] 0 10++showFormList+ :: (Functor m, MonadIO m) =>+ [[View Html m ()]]+ -> Int -> Int -> FlowM Html m b+showFormList ls n l= do+ nav <- ask $ updown n l <|> (list **> updown n l)+ showFormList ls nav l++ where+ list= table <<< wconcat (span1 n l [tr <<< cols e | e <- ls ])++ cols e= wconcat[td <<< c | c <- e]+ span1 n l = take l . drop n+ updown n l= wlink ( n +l) (bold << "up ") <|> wlink ( n -l) (bold << "down ") <++ br++optionsUser us = do+ wfs <- liftIO $ return . M.keys =<< getMessageFlows++ 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")+ else do+ wf <- ask $ wconcat [ wlink wf (p << wf) | (wf,_) <- wfss]+ ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")+
+ src/MFlow/Forms/Ajax.hs view
@@ -0,0 +1,96 @@+{-# 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) \<! [(\"id\",\"text1\"),(\"onclick\",ajaxc)])+-- breturn()@++module MFlow.Forms.Ajax (ajaxCommand,ajaxHead) where+import MFlow+import MFlow.Forms+import Text.XHtml+import Control.Monad.Trans+import Data.ByteString.Lazy.Char8++import Data.Maybe+import Control.Monad.State+import Data.Map (keys)+import qualified Data.CaseInsensitive as CI++-- | Install the server code and return the client code for an AJAX interaction.+--++ajaxCommand :: (MonadIO m, MonadState (MFlowState view) 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+ servname <- getNewName+ liftIO $ addMessageFlows [( servname, serverp)]+-- 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 $ fromJust 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+++
+ src/MFlow/Forms/HSP.hs view
@@ -0,0 +1,61 @@+{-# 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++-}++module MFlow.Forms.HSP+ where+++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)++++instance Monoid (HSP XML) where+ mempty = <span/>+ mappend x y= <span> <% x %> <% y %> </span>+ mconcat xs= <span> <% [<% x %> | x <- xs] %> </span>++instance FormInput (HSP XML) where++ fromString s = <span><% s %></span>+++ finput typ name value checked onclick=+ <input type= (typ)+ name=(name)+ value=(value)+ checked=(checked)+ onclick=(case onclick of Just s -> s ; _ -> "")/>++ ftextarea name text= <textarea name=(name) > <% text %> </textarea>+++ foption name list msel=+ <select name=(name)>+ <% map (\(n,v) ->+ <option value=(n) selected=(selected msel n) >+ <% v %>+ </option> )+ list+ %>+ </select>+ where+ selected msel n= if Just n == msel then "true" else "false"++ flink v str = <a href=(v)> <% str %> </a>++ inred x= <b style= "color:red"> <% x %> </b>++ formAction action form = <form action=(action) method="post" > <% form %> </form>+++ addAttributes tag attrs= tag <<@ map (\(n,v)-> n:=v) attrs
+ src/MFlow/Forms/XHtml.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+--+-- Module : Control.MessageFlow.Forms.XHtml+-- Copyright : Alberto Gónez Corona+-- License : BSD3+--+-- Maintainer : agocorona@gmail.com+-- Stability : experimental+--+-----------------------------------------------------------------------------+{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package+-}++{-# OPTIONS -XMultiParamTypeClasses+ -XFlexibleInstances+ -XUndecidableInstances+ -XTypeSynonymInstances+ -XFlexibleContexts+ -XTypeOperators+ #-}+++module MFlow.Forms.XHtml where+++import MFlow.Forms+import Data.ByteString.Lazy.Char8(pack,unpack)++import Text.XHtml 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++ 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]; _ -> [] )+ ftextarea name text= X.textarea ! [X.name name] << text++ foption name list msel= select ![ X.name name] << (concatHtml+ $ map (\(n,v) -> X.option ! ([value n] ++ selected msel n) << v ) list)++ where+ selected msel n= if Just n == msel then [X.selected] else []++ addAttributes tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)++++ formAction action form = X.form ! [X.action action, method "post"] << form+ fromString = stringToHtml+++ flink v str = toHtml $ hotlink ( v) << str++
+ src/MFlow/Hack.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE UndecidableInstances+ , TypeSynonymInstances+ , MultiParamTypeClasses+ , DeriveDataTypeable+ , FlexibleInstances #-}+ +module MFlow.Hack(+ module MFlow.Cookies+ ,module MFlow+ ,hackMessageFlow)+where+ +import Data.Typeable +import Hack ++import Control.Concurrent.MVar(modifyMVar_, readMVar) +import Control.Monad(when) + + +import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString) +import Control.Concurrent(ThreadId(..)) +import System.IO.Unsafe +import Control.Concurrent.MVar+import Control.Concurrent +import Control.Exception +import qualified Data.Map as M+import Data.Maybe +import Data.TCache+import Data.TCache.DefaultPersistence +import Control.Workflow hiding (Indexable(..)) + +import MFlow +import MFlow.Cookies++import MFlow.Hack.Response+import Data.Monoid+import Data.CaseInsensitive++import Debug.Trace+(!>)= flip trace++flow= "flow"+ +instance Processable Env where + pwfname env= if null sc then noScript else sc + where + sc= tail $ pathInfo env+ puser env = fromMaybe anonymous $ lookup cookieuser $ http env + + pind env= fromMaybe (error ": No FlowID") $ lookup flow $ http env+ getParams= http+-- 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+ deserialize= read . B.unpack + +instance Indexable Flow where + key _= "Flow" + ++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 + +--------------------------------------------- + + + +-- +--instance ConvertTo String TResp where +-- convert = TResp . pack +--+--instance ConvertTo ByteString TResp where +-- convert = TResp+--+-- +--instance ConvertTo Error TResp where +-- convert (Error e)= TResp . pack $ errorResponse e+--+--instance ToResponse v =>ConvertTo (HttpData v) TResp where+-- convert= TRespR ++ +--webScheduler :: Env +-- -> ProcList +-- -> IO (TResp, ThreadId) +--webScheduler = msgScheduler + +--theDir= unsafePerformIO getCurrentDirectory + +wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) +wFMiddleware filter f = \ env -> if filter env then hackWorkflow env else f env -- !> "new message" + +-- | An instance of the abstract "MFlow" scheduler to the Hack interface+-- it accept the list of processes being scheduled and return a hack handler +--+-- Example:+--+-- @main= do+--+-- putStrLn $ options messageFlows+-- 'run' 80 $ 'hackMessageFlow' 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]+-- @+hackMessageFlow :: [(String, (Token -> Workflow IO ()))]+ -> (Env -> IO Response) +hackMessageFlow messageFlows = + unsafePerformIO (addMessageFlows messageFlows) `seq` + hackWorkflow -- wFMiddleware f other +-- where+-- f env = unsafePerformIO $ do+-- paths <- getMessageFlows >>=+-- return (pwfname env `elem` paths)++-- other= (\env -> defaultResponse $ "options: " ++ opts) +-- (paths,_)= unzip messageFlows+-- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths+ + +splitPath ""= ("","","") +splitPath str= + let + strr= reverse str + (ext, rest)= span (/= '.') strr + (mod, path)= span(/='/') $ tail rest + in (tail $ reverse path, reverse mod, reverse ext) +++ +hackWorkflow :: Env -> IO Response +hackWorkflow req1= do + let httpreq1= http req1 + let cookies= {-# SCC "getCookies" #-} getCookies httpreq1 + + (flowval , retcookies) <- case lookup ( flow) cookies of + Just fl -> return (fl, []) + Nothing -> do + fl <- newFlow + return ( fl, [( flow, fl, "/",Nothing)])+ +{- for state persistence in cookies + putStateCookie req1 cookies + let retcookies= case getStateCookie req1 of + Nothing -> retcookies1 + Just ck -> ck:retcookies1 +-} + + let input= + case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of + (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack $ hackInput req1 + (GET, _) -> urlDecode . queryString $ req1 + _ -> [] + + let req = case retcookies of + [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ" + _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ" + + + (resp',th) <- msgScheduler req+ ++ 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 resp++ +------persistent state in cookies (not tested) + +tvresources :: MVar (Maybe ( M.Map string string)) +tvresources= unsafePerformIO $ newMVar Nothing +statCookieName= "stat" + +putStateCookie req cookies= + case lookup statCookieName cookies of + Nothing -> return () + Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ + \mmap -> case mmap of + Just map -> return $ Just $ M.insert (keyResource req) str map + Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] + +getStateCookie req= do + mr<- readMVar tvresources + case mr of + Nothing -> return Nothing + Just map -> case M.lookup (keyResource req) map of + Nothing -> return Nothing + Just str -> do + swapMVar tvresources Nothing + return $ Just (statCookieName, str , "/") + +{- +persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} + where + writeResource stat= modifyMVar_ tvresources $ \mmap -> + case mmap of + Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map + Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] + readResource stat= do + mstr <- withMVar tvresources $ \mmap -> + case mmap of + Just map -> return $ M.lookup (keyResource stat) map + Nothing -> return Nothing + case mstr of + Nothing -> return Nothing + Just str -> return $ deserialize str + + deleteResource stat= modifyMVar_ tvresources $ \mmap-> + case mmap of + Just map -> return $ Just $ M.delete (keyResource stat) map + Nothing -> return $ Nothing ++-}
+ src/MFlow/Hack/Response.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances+ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-} +module MFlow.Hack.Response where + +import Hack+import MFlow.Cookies +import Data.ByteString.Lazy.Char8 as B++import MFlow +import Data.Typeable +import Data.Monoid+import System.IO.Unsafe+import Data.Map as M+import Control.Workflow (WFErrors(..))++--import Debug.Trace+--+--(!>)= flip trace+++ +class ToResponse a where + toResponse :: a -> Response ++++data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable++instance Monoid TResp where+ mempty = TRempty+ mappend (TResp x) (TResp y)=+ case cast y of+ Just y' -> TResp $ mappend x y'+ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) + +defaultResponse :: String -> IO Response +defaultResponse msg= return . toResponse $ "<p>Page not found or error ocurred:<br/>" ++ msg ++ "<br/><a href=\"/\" >home</a> </p>" ++errorResponse msg=+ "<h4>Page not found or error ocurred:</h4><h3>" <> msg <>+ "</h3><br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a>" ++ where + paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows++ opts= "options: " <> B.concat (Prelude.map (\s ->++ "<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)+++instance ToResponse TResp where+ 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} + +instance ToResponse String where + toResponse x= Response{status=200, headers=[ctype{-,("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= errorResponse str} + +instance Typeable Env where + typeOf = \_-> mkTyConApp (mkTyCon "Hack.Env") [] + +instance Typeable Response where + typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
+ src/MFlow/Hack/XHtml.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+--+-- Module : MFlow.Hack.XHtml+-- Copyright :+-- License : BSD3+--+-- Maintainer : agocorona@gmail.com+-- Stability : experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-+Instantiations necessary for "MFlow.Hack" to use "Text.XHtml" as format for generating output+-}++{-# OPTIONS -XMultiParamTypeClasses #-}++module MFlow.Hack.XHtml (++) where+import MFlow+import Hack+import MFlow.Hack.Response+import Text.XHtml+import Data.Typeable+import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString)+ +instance ToResponse Html where + toResponse x= Response{ status=200, headers=[]+ , Hack.body= pack $ showHtml x} ++instance Typeable Html where + typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") [] +--+--instance ConvertTo Html TResp where +-- convert = TResp+
+ src/MFlow/Hack/XHtml/All.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+--+-- Module : MFlow.Hack.XHtml.All+-- Copyright :+-- License : BSD3+--+-- Maintainer : agocorona@gmail.com+-- Stability : experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module MFlow.Hack.XHtml.All (+ module Data.TCache+,module MFlow.Hack+,module MFlow.FileServer+,module MFlow.Forms+,module MFlow.Forms.XHtml+,module MFlow.Forms.Admin+,module MFlow.Forms.Ajax+,module MFlow.Hack.XHtml+,module Hack+,module Hack.Handler.SimpleServer+,module Text.XHtml.Strict+,module Control.Applicative+) where+++import MFlow.Hack+import MFlow.FileServer+import MFlow.Forms+import MFlow.Forms.XHtml+import MFlow.Forms.Admin+import MFlow.Forms.Ajax+import MFlow.Hack.XHtml++import Hack(Env)+import Hack.Handler.SimpleServer+import Data.TCache+++import Text.XHtml.Strict hiding (widget)++import Control.Applicative+++
+ src/MFlow/Wai.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE UndecidableInstances+ , TypeSynonymInstances+ , MultiParamTypeClasses+ , DeriveDataTypeable+ , FlexibleInstances+ , OverloadedStrings #-}+ +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.Char8 as SB +import Control.Concurrent(ThreadId(..)) +import System.IO.Unsafe +import Control.Concurrent.MVar+import Control.Concurrent+import Control.Monad.Trans +import Control.Exception +import qualified Data.Map as M+import Data.Maybe +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+ +instance Processable Request where + pwfname env= if SB.null sc then noScript else SB.unpack sc + where + 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+ +data Flow= Flow !Int deriving (Read, Show, Typeable) ++instance Serializable Flow where+ serialize= B.pack . show+ deserialize= read . B.unpack + +instance Indexable Flow where + key _= "Flow" + ++rflow= getDBRef . key $ Flow 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 + +--------------------------------------------- + + + +-- +--instance ConvertTo String TResp where +-- convert = TResp . pack +--+--instance ConvertTo ByteString TResp where +-- convert = TResp+--+-- +--instance ConvertTo Error 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) +--webScheduler = msgScheduler + +--theDir= unsafePerformIO getCurrentDirectory + +--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 Wai 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 ()))]+ -> (Request -> ResourceT IO Response) +waiMessageFlow messageFlows = + unsafePerformIO (addMessageFlows messageFlows) `seq` + waiWorkflow -- wFMiddleware f other+ +-- where+-- f env = unsafePerformIO $ do+-- paths <- getMessageFlows >>=+-- return (pwfname env `elem` paths)++-- other= (\env -> defaultResponse $ "options: " ++ opts) +-- (paths,_)= unzip messageFlows+-- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths+ + +splitPath ""= ("","","") +splitPath str= + let + strr= reverse str + (ext, rest)= span (/= '.') strr + (mod, path)= span(/='/') $ tail rest + in (tail $ reverse path, reverse mod, reverse ext) +++ +waiWorkflow :: Request -> ResourceT IO Response +waiWorkflow req1= do + let httpreq1= getParams req1 ++ 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])+ +{- for state persistence in cookies + putStateCookie req1 cookies + let retcookies= case getStateCookie req1 of + Nothing -> retcookies1 + 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 []+ + 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" + + + (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++ +------persistent state in cookies (not tested) + +tvresources :: MVar (Maybe ( M.Map string string)) +tvresources= unsafePerformIO $ newMVar Nothing +statCookieName= "stat" + +putStateCookie req cookies= + case lookup statCookieName cookies of + Nothing -> return () + Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ + \mmap -> case mmap of + Just map -> return $ Just $ M.insert (keyResource req) str map + Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] + +getStateCookie req= do + mr<- readMVar tvresources + case mr of + Nothing -> return Nothing + Just map -> case M.lookup (keyResource req) map of + Nothing -> return Nothing + Just str -> do + swapMVar tvresources Nothing + return $ Just (statCookieName, str , "/") + +{- +persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} + where + writeResource stat= modifyMVar_ tvresources $ \mmap -> + case mmap of + Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map + Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] + readResource stat= do + mstr <- withMVar tvresources $ \mmap -> + case mmap of + Just map -> return $ M.lookup (keyResource stat) map + Nothing -> return Nothing + case mstr of + Nothing -> return Nothing + Just str -> return $ deserialize str + + deleteResource stat= modifyMVar_ tvresources $ \mmap-> + case mmap of + Just map -> return $ Just $ M.delete (keyResource stat) map + Nothing -> return $ Nothing ++-}
+ src/MFlow/Wai/Response.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances+ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-} +module MFlow.Wai.Response where + +import Network.Wai+import MFlow.Cookies +import Data.ByteString.Char8 as SB+import Data.ByteString.Lazy.Char8 as B+import MFlow +import Data.Typeable +import Data.Monoid+import System.IO.Unsafe+import Data.Map as M+import Data.CaseInsensitive+import Network.HTTP.Types+import Control.Workflow(WFErrors(..))+--import Debug.Trace+--+--(!>)= flip trace+++ +class ToResponse a where + toResponse :: a -> Response ++++data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable++instance Monoid TResp where+ mempty = TRempty+ mappend (TResp x) (TResp y)=+ case cast y of+ Just y' -> TResp $ mappend x y'+ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) + +defaultResponse :: String -> IO Response +defaultResponse msg= return . toResponse $ "<p>Page not found or error ocurred:<br/>" ++ msg ++ "<br/><a href=\"/\" >home</a> </p>" +++errorResponse msg=+ "<h4>Page not found or error ocurred:</h4><h3>" <> msg <>+ "</h3><br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a>" ++ where + paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows++ opts= "options: " <> B.concat (Prelude.map (\s ->++ "<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)+++ctype1= [mkparam ctype] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")]+mkParams = Prelude.map mkparam+mkparam (x,y)= (mk $ SB.pack x, SB.pack y)+instance ToResponse TResp where+ toResponse (TResp x)= toResponse x + toResponse (TRespR r)= toResponse r+ +instance ToResponse Response where + toResponse = id + +instance ToResponse B.ByteString where + toResponse x= responseLBS status200 ctype1 {-,("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++instance ToResponse HttpData where+ toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams $ hs ++ cookieHeaders cookies) x+ toResponse (Error NotFound str)= responseLBS status404 [] $ errorResponse str + +
+ src/MFlow/Wai/XHtml/All.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+--+-- Module : MFloll.Wai.XHtml.All+-- Copyright :+-- License : BSD3+--+-- Maintainer : agocorona@gmail.com+-- Stability : experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module MFlow.Wai.XHtml.All (+ module Data.TCache+,module MFlow.Wai+,module MFlow.FileServer+,module MFlow.Forms+,module MFlow.Forms.XHtml+,module MFlow.Forms.Admin+,module MFlow.Forms.Ajax+--,module MFlow.Wai.XHtml+,module Network.Wai+,module Network.Wai.Handler.Warp+,module Text.XHtml.Strict+,module Control.Applicative+) where+++import MFlow.Wai+import MFlow.FileServer+import MFlow.Forms+import MFlow.Forms.XHtml+import MFlow.Forms.Admin+import MFlow.Forms.Ajax+--import MFlow.Wai.XHtml++import Network.Wai+import Network.Wai.Handler.Warp+import Data.TCache++import Text.XHtml.Strict hiding (widget)++import Control.Applicative+++++