diff --git a/Demos/ShoppingCart1.hs b/Demos/ShoppingCart1.hs
new file mode 100644
--- /dev/null
+++ b/Demos/ShoppingCart1.hs
@@ -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
+
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/MFlow.cabal b/MFlow.cabal
new file mode 100644
--- /dev/null
+++ b/MFlow.cabal
@@ -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:
diff --git a/MFlow.hs b/MFlow.hs
new file mode 100644
--- /dev/null
+++ b/MFlow.hs
@@ -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
+
+
+
diff --git a/MFlow/Cookies.hs b/MFlow/Cookies.hs
new file mode 100644
--- /dev/null
+++ b/MFlow/Cookies.hs
@@ -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
+
diff --git a/MFlow/Forms.hs b/MFlow/Forms.hs
new file mode 100644
--- /dev/null
+++ b/MFlow/Forms.hs
@@ -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
diff --git a/MFlow/Forms/XHtml.hs b/MFlow/Forms/XHtml.hs
new file mode 100644
--- /dev/null
+++ b/MFlow/Forms/XHtml.hs
@@ -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
diff --git a/MFlow/Hack.hs b/MFlow/Hack.hs
new file mode 100644
--- /dev/null
+++ b/MFlow/Hack.hs
@@ -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 ["
" ++ v ++"
" | v <- vs]
+-- row vs= concat ["
" ++ v ++ "
" | v <- vs]
+-- hsep = "$nbsp;"
+-- vsep = " "
+-- input n t v f= ""
+-- textarea name text= ""
+--
+-- option name list msel= ""
+-- where
+-- selected msel n= if Just n == msel then " \"selected\" " else ""
+--
+-- option1 name list msel= ""
+-- where
+-- selected msel n= if Just n == msel then " \"selected\" " else ""
+--
+--
+--
+-- formAction action form = ""
+-- fromString s= s
+-- bold x= "" ++ x ++ ""
+-- fs x= "
" ++ x ++ "
"
+-- ts x= "
" ++ x ++ "
"
+-- style st content = " "++ content ++""
+--
+-- table title head rows=
+-- "
"++
+-- (if not . null $ title then "
" ++ title ++ "
" else "") ++
+-- (if not . null $ head then "
"++concat ["
"++ h ++ "
"| h <- head] ++ "
" else "")++
+-- (concat ["
" ++ concat["
"++ v ++ "
"| v <- row] ++ "
" | row <- rows]) ++
+-- "
"
+--
+--
+---- textarea name value= ""++value++ ""
+---- option1 name options option=
+---- "< input type=\"radio\" checked=\""++option++"\" name=\""++name++"\" value="approbal"
+--
+--
+-- link (Verb v) str = ""++ str ++""
+
+
+{-
+
+instance Monoid (HSP XML) where
+ mempty =
+ mappend x y= <% x %> <% y %>
+
+instance Display (HSP XML) TResp where
+ column vs=
<% [
<% v %>
| v <- vs] %>
+ row vs=
<% [
<% v %>
| v <- vs] %>
+
+ table title caption rows=
+
+ {- <% when (not . null $ title) -}
<% title %>
-- %>
+ {-<% when (not . null $ caption)-}
<%[
<%cap %>
| cap <- caption] %>
-- %>
+ <%[
<% [
<% v %>
| v <- row] %>
| row <- rows] %>
+
+
+ hsep =
+ style st content = <% content %>
+ vsep =
+ fromString s = <% s %>
+ -- option (Verb v) view1= <% view1 %>
+
+ input typ name value=
+
+
+-}
diff --git a/MFlow/Hack/Response.hs b/MFlow/Hack/Response.hs
new file mode 100644
--- /dev/null
+++ b/MFlow/Hack/Response.hs
@@ -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 $ "
Page not found or error ocurred: " ++ msg ++ " home