MFlow (empty) → 0.0.0
raw patch · 12 files changed
+2184/−0 lines, 12 filesdep +RefSerializedep +TCachedep +Workflowsetup-changed
Dependencies added: RefSerialize, TCache, Workflow, base, bytestring, containers, extensible-exceptions, hack, hack-handler-simpleserver, mtl, old-time, stm, transformers, vector, xhtml
Files
- Demos/ShoppingCart1.hs +118/−0
- LICENSE +27/−0
- MFlow.cabal +121/−0
- MFlow.hs +352/−0
- MFlow/Cookies.hs +189/−0
- MFlow/Forms.hs +754/−0
- MFlow/Forms/XHtml.hs +117/−0
- MFlow/Hack.hs +327/−0
- MFlow/Hack/Response.hs +94/−0
- MFlow/Hack/XHtml.hs +35/−0
- MFlow/Hack/XHtml/All.hs +45/−0
- Setup.lhs +5/−0
+ Demos/ShoppingCart1.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS -XDeriveDataTypeable+ -XMultiParamTypeClasses -XRecordWildCards++ #-}+module Test where+import MFlow.Hack.XHtml.All++import Data.Typeable+import Control.Monad.Trans+import qualified Data.Vector as V++import Data.TCache+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 product.+-- The result is a 2-tuple of Maybes++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 "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++
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Alberto Gómez Corona 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ MFlow.cabal view
@@ -0,0 +1,121 @@+name: MFlow+synopsis: (Web) application server. Stateful server processes. Simple, statically correct widget combinators.+++version: 0.0.0+cabal-version: -any+build-type: Simple+license: BSD3+license-file: LICENSE+copyright:+maintainer: agocorona@gmail.com+build-depends: Workflow ==0.5.8.2, transformers -any, mtl -any,+ extensible-exceptions -any, xhtml -any, base > 4.3 && < 4.4,+ hack -any, hack-handler-simpleserver -any, bytestring -any,+ containers -any, RefSerialize == 0.2.8, TCache == 0.9.0.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.+ .+ Examples included+ .+ 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 is 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++++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++other-modules: MFlow+ MFlow.Cookies+ MFlow.Hack.Response+++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: .++ghc-prof-options:+ghc-shared-options:+ghc-options: -O2+hugs-options:+nhc98-options:+jhc-options:
+ MFlow.hs view
@@ -0,0 +1,352 @@+{- | 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.Text++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 view
@@ -0,0 +1,189 @@+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 view
@@ -0,0 +1,754 @@++{-# OPTIONS -XDeriveDataTypeable+ -XUndecidableInstances+ -XExistentialQuantification+ -XMultiParamTypeClasses+ -XTypeSynonymInstances+ -XFlexibleInstances+ -XScopedTypeVariables+ -XFunctionalDependencies+ -XFlexibleContexts+ -XRecordWildCards++#-}++{- | 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.Text+import MFlow+import MFlow.Cookies+import Data.RefSerialize (Serialize)+import Control.Workflow.Text 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.Text(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(DBRef User)+userRegister user password = atomically .+ newDBRef $ User user password++-- | 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= just }+ [Just (User _ p )] -> resources{toReturn=+ case upassword==p of+ True -> Nothing+ False -> just++ }++ where+ just= 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 view
@@ -0,0 +1,117 @@+-----------------------------------------------------------------------------+--+-- 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 (mkTyCon "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 view
@@ -0,0 +1,327 @@+{-# 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.Text + +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 view
@@ -0,0 +1,94 @@+{-# 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 (mkTyCon "Hack.Env") [] + +instance Typeable Response where + typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
+ MFlow/Hack/XHtml.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+--+-- 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 view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+--+-- 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+
+ Setup.lhs view
@@ -0,0 +1,5 @@+#! /usr/bin/runghc + +> import Distribution.Simple +> +> main = defaultMain