diff --git a/Demos/ShoppingCart.Wai.hs b/Demos/ShoppingCart.Wai.hs new file mode 100644 --- /dev/null +++ b/Demos/ShoppingCart.Wai.hs @@ -0,0 +1,54 @@ +{-# OPTIONS -XDeriveDataTypeable -XScopedTypeVariables #-} +module Test where + +{- +A stateless flow example. Convert it into persistent by uncommenting {- step -} and see the differences. + +after 10 seconds without user interaction, the process is killed (set by setTimeout) +:l demos\shoppingCart.Wai.hs +-} + +import MFlow.Wai +import MFlow.Forms +import Text.XHtml +import MFlow.Forms.XHtml +import Control.Concurrent +import Network.Wai.Handler.Warp +import MFlow.Forms.Admin +import qualified Data.Vector as V + + + +main= do +-- syncWrite SyncManual + putStrLn $ options messageFlows + forkIO $ run 80 $ waiMessageFlow messageFlows + adminLoop + + +options msgs= "in the browser navigate to\n\n" ++ + concat [ "http://localhost/"++ i ++ "\n" | (i,_) <- msgs] + +messageFlows= [("noscript", runFlow shopCart ) + ,("stateless", stateless st)] + +st _ = return "hi" + +--shopCart1 :: V.Vector Int -> FlowM (Workflow IO) b +shopCart = do + setTimeouts 10 0 + shopCart1 (V.fromList [0,0,0:: Int]) + where + shopCart1 cart= do + i <- {-step . -} ask + $ table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] + <<< caption << "choose an item" + ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] + ++> (tbody + <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) + <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) + <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2))) + ) + let newCart= cart V.// [(i, cart V.! i + 1 )] + shopCart1 newCart + diff --git a/Demos/ShoppingCart.hs b/Demos/ShoppingCart.hs new file mode 100644 --- /dev/null +++ b/Demos/ShoppingCart.hs @@ -0,0 +1,48 @@ +{-# OPTIONS -XDeriveDataTypeable -XScopedTypeVariables #-} +module Test where + +{- +A stateless flow example. Convert it into persistent by uncommenting {- step -} and see the differences. + +after 10 seconds without user interaction, the process is killed (set by setTimeout) + +-} + +import MFlow.Hack.XHtml.All +import Control.Concurrent + +import qualified Data.Vector as V + + + +main= do +-- syncWrite SyncManual + putStrLn $ options messageFlows + forkIO $ run 80 $ hackMessageFlow messageFlows + adminLoop + + +options msgs= "in the browser navigate to\n\n" ++ + concat [ "http://localhost/"++ i ++ "\n" | (i,_) <- msgs] + +messageFlows= [("noscript", runFlow shopCart )] + + +--shopCart1 :: V.Vector Int -> FlowM (Workflow IO) b +shopCart = do + setTimeouts 10 0 + shopCart1 (V.fromList [0,0,0:: Int]) + where + shopCart1 cart= do + i <- {-step . -} ask + $ table ! [border 1,thestyle "width:20%;margin-left:auto;margin-right:auto"] + <<< caption << "choose an item" + ++> thead << tr << concatHtml[ th << bold << "item", th << bold << "times chosen"] + ++> (tbody + <<< (tr <<< td <<< wlink 0 (bold <<"iphone") <++ td << ( bold << show ( cart V.! 0)) + <|> tr <<< td <<< wlink 1 (bold <<"ipad") <++ td << ( bold << show ( cart V.! 1)) + <|> tr <<< td <<< wlink 2 (bold <<"ipod") <++ td << ( bold << show ( cart V.! 2))) + ) + let newCart= cart V.// [(i, cart V.! i + 1 )] + shopCart1 newCart + diff --git a/Demos/ShoppingCart1.hs b/Demos/ShoppingCart1.hs deleted file mode 100644 --- a/Demos/ShoppingCart1.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# OPTIONS -XDeriveDataTypeable - -XMultiParamTypeClasses -XRecordWildCards - - #-} -module Main where -import MFlow.Hack.XHtml.All - -import Data.Typeable -import Control.Monad.Trans -import qualified Data.Vector as V - - - - - -main= do - userRegister "pepe" "pepe" - putStrLn $ options messageFlows - run 80 $ hackMessageFlow messageFlows - where - messageFlows= [("main", runFlow mainProds) - ,("hello", stateless hello)] - - options msgs= "in the browser choose\n\n" ++ - concat [ "http://server/"++ i ++ "\n" | (i,_) <- msgs] - - - --- an stateless procedure, as an example -hello :: Env -> IO String -hello env = return "hello, this is a stateless response" - - -data Prod= Prod{pname :: String, pprice :: Int} deriving (Typeable,Read,Show) - --- formLets can have Html formatting -instance FormLet Prod IO Html where - digest mp= table <<< ( - Prod <$> tr <<< (td << "enter the name" <++ td <<< getString (pname <$> mp)) - <*> tr <<< (td << "enter the price" <++ td <<< getInt ( pprice <$> mp))) - - --- Here an example of predefined widget (`Selection`) that return an Int, combined in the same --- page with the fromLet for the introduction of a new product. --- The result of the interaction with the user is either one or the other result - -shopProds :: V.Vector Int -> [Prod] - -> View Html IO (Either Int Prod) -shopProds cart products= - br - <++ -- add Html to the first widget - p << "-----Shopping List-----" - <++ - widget(Selection{ - stitle = bold << "choose an item", - sheader= [ bold << "item" , bold << "price", bold << "times chosen"], - sbody= [([toHtml pname, toHtml $ show pprice, toHtml $ show $ cart V.! i],i ) - | (Prod{..},i ) <- zip products [1..]]}) - - <+> -- operator to mix two wdigets - - br - <++ -- add Html to the second widget - p << "---Add a new product---" - <++ - table <<< -- <<< encloses a widget in HTML tags - (tr <<< td ! [valign "top"] - <<< widget (Form (Nothing :: Maybe Prod) ) - - ++> -- append Html after the widget - - tr << td ! [align "center"] - << hotlink "hello" - (bold << "Hello World")) - --- the header - -appheader user forms= thehtml - << body << dlist << (concatHtml - [dterm <<("Hi "++ user) - ,dterm << "This example contains two forms enclosed within user defined HTML formatting" - ,dterm << "The first one is defined as a Widget, the second is a formlet formatted within a table" - ,dterm << "both are defined using an extension of the FormLets concept" - ,dterm << "the form results are statically typed" - ,dterm << "The state is implicitly logged. No explicit handling of state" - ,dterm << "The program logic is written as a procedure. Not in request-response form. But request response is possible" - ,dterm << "lifespan of the serving process and the execution state defined by the programmer" - ,dterm << "user state is automatically recovered after cold re-start" - ,dterm << "transient, non persistent states possible." - ]) - +++ forms - --- Here the procedure. It ask for either entering a new product --- or to "buy" one of the entered products. --- There is a timeout of ten minutes before the process is stopped --- There is a timeout of one day for the whole session so after this, the --- user will see the list or prudicts erased. --- In a real application the product list should be stored out of the session --- using TCache's writeDBRef for example --- The state is user specific. - -mainProds :: FlowM Html (Workflow IO) () -mainProds = do - setTimeouts (10*60) (24*60*60) - setHeader $ \w -> bold << "Please enter user/password (pepe/pepe)" +++ br +++ w - us <- getUser - - setHeader $ appheader us - mainProds1 [] $ V.fromList [0] - where - mainProds1 prods cart= do - mr <- step . ask $ shopProds cart prods - case mr of - Right prod -> mainProds1 (prod:prods) (V.snoc cart 0) - Left i -> do - let newCart= cart V.// [(i, cart V.! i + 1 )] - mainProds1 prods newCart - - diff --git a/Demos/demos.hs b/Demos/demos.hs new file mode 100644 --- /dev/null +++ b/Demos/demos.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} +module Main where +import MFlow.Wai.XHtml.All +import Data.TCache +import Control.Monad.Trans +import Data.Typeable +import Control.Concurrent +import Control.Exception as E +import qualified Data.ByteString.Char8 as SB + +import Debug.Trace +(!>)= flip trace + + +data Ops= Ints | Strings | Actions | Ajax deriving(Typeable,Read, Show) +main= do + syncWrite SyncManual + setFilesPath "" + addFileServerWF + forkIO $ run 80 $ waiMessageFlow [("noscript",transient $ runFlow mainf)] + adminLoop + + + +stdheader c= p << "you can press the back button to go to the menu"+++ c +mainf= do + setHeader stdheader + r <- ask $ wlink Ints (bold << "Ints") <|> + br ++> wlink Strings (bold << "Strings") <|> + br ++> wlink Actions (bold << "Example of a string widget with an action") <|> + br ++> wlink Ajax (bold << "Simple AJAX example") + case r of + Ints -> clickn 0 + Strings -> clicks "1" + Actions -> actions 1 + Ajax -> ajaxsample + mainf + +clickn (n :: Int)= do + setHeader stdheader + r <- ask $ wlink "menu" (p << "back") + |+| getInt (Just n) <* submitButton "submit" + case r of + (Just _,_) -> breturn () + (_, Just n') -> clickn $ n'+1 + + +clicks s= do + setHeader stdheader + s' <- ask $ (getString (Just s) + <* submitButton "submit") + `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) + clicks $ s'++ "1" + + +ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html + +ajaxsample= do + setHeader ajaxheader + ajaxc <- ajaxCommand "document.getElementById('text1').value" + (\n -> return $ "document.getElementById('text1').value='"++show(read n +1)++"'") + ask $ (getInt (Just 0) = 1.6 build-type: Simple license: BSD3 license-file: LICENSE -copyright: maintainer: agocorona@gmail.com -build-depends: Workflow >=0.6.0.0 && < 0.6.1, transformers -any, mtl -any, - extensible-exceptions -any, xhtml -any, base > 4.4 && < 4.6, - hack -any, hack-handler-simpleserver -any, bytestring -any, - containers -any - , RefSerialize >= 0.2.8.1 && < 0.2.9 - , TCache >= 0.9.0.2 && < 0.9.1 - , stm >2, - old-time -any, - vector -any stability: experimental -homepage: -package-url: -bug-reports: - -description: Simple application server with stateful request-response flows, persistent - and transparent session handling. server process management, combinators for the definition of widgets - and formlets that can be mixed freely with HTML formatting and produce statically - typed web applications. Adopt and extend the best formlet/applicative Haskell traditions - Console and window oriented apps are possible. - . - MFlow (MessageFlow) was created initially as the user interface for the Workflow package - Currently is an alpha version. It has only basic authentication but I plan to inprove it for serious applications. - . - It includes Application Server features such is resource an process management - and automatic recovery - . - Resource management: The user can define process and session timeout. The - process is automatically rerun after timeout if a new request arrive with transparent - recovery of state, at the point of the interrupted dialog even after server crash. - . - The backend operation relies on the Workflow package ("http:\/\/hackage.haskell.org\/package\/Workflow/index"), - this gives transparent sessión persistence and recovery, all of this - is supported by - TCache ("http:\/\/hackage.haskell.org\/package\/TCache/index"), that gives backend-independent transactions and can be used - directly by the programmer. Persistence in files for session and data out of the box enables - very fast prototyping. - . - All the plumbing is hidden to the programmer, There are no methods for - session management, database query, recovery and so on. All of this is - transparent So the surface exposed to the programmer is minimal. - . - Includes generalized formlets that permits the mix of active widgets - in the same page while remaining statically typed and, thus the programs - can verify correctness at compilation time. - . - Includes combinators for seamless inclusion of these widgets within - user defined HTML formatting. Bindings for Text.XHtml. The widget generation may be easy - for user with familiarity with formlets/digestive functors and Text.XHtml formatting. - . - Currently it has bindings for the Hack interface - . - Streaming facilities. - . - To do: - . - Bindings for HSP - . - Clustering - . - Other bindigs for Hack alternatives - +synopsis: Web application serverfor processes with type safe, composable user interfaces. +description: It is a Web framework with some unique features thanks to the power of the Haskell language. + MFlow run stateful server processes. Because flows are stateful, not event driven, the code is more + understandable, because all the flow of request and responses is coded by the programmer in a single function. + Allthoug single request-response flows and callbacks are possible. + . + Technically it is a Web application server for stateful processes (flows) that are optionally persistent. + These processes interact with the user trough interfaces made of widgets that return back statically typed responses to + the calling process. All is coded in pure haskell (with optional XML from Haskell Server Pages). + It adopt and extend the formlet/applicative approach. It has bindings for HSP and Text.XHtml + . + It includes Application Server features such is process and session timeouts + and automatic recovery of flow execution state. + . + This release add transparent back button management, cached widgets, callbacks, modifiers, heterogeneous formatting AJAX, + and WAI integration. + . + It is designed for coding an entire application in a single file to be run with runghc in order + to speed up the prototyping process. + . + See "MFlow.Forms" for details + . + Altroug still it is experimental, it is used in at least one future commercial project. So I have te commitment to + continue its development. There are many examples in the documentation and in the package. + . + To do: + . + -Clustering + . category: Web, Application Server author: Alberto Gómez Corona -tested-with: -data-files: data-dir: "" -extra-source-files: Demos/ShoppingCart1.hs -extra-tmp-files: -exposed-modules: - - MFlow.Forms - MFlow.Hack - MFlow.Forms.XHtml - MFlow.Hack.XHtml - MFlow.Hack.XHtml.All +extra-source-files: Demos/ShoppingCart.hs, Demos/ShoppingCart.Wai.hs, Demos/demos.hs -other-modules: MFlow - MFlow.Cookies - MFlow.Hack.Response +library + build-depends: Workflow -any, transformers -any, mtl -any, + extensible-exceptions -any, xhtml -any, base >4.0 && <4.6, + hack -any, hack-handler-simpleserver -any, bytestring -any, + containers -any, RefSerialize -any, TCache -any, stm >2, + old-time -any, vector -any, hsp -any, directory -any, + utf8-string -any, wai -any, case-insensitive -any, http-types -any, conduit -any + ,text -any, parsec -any,warp -any + exposed-modules: MFlow.Forms -exposed: True -buildable: True -build-tools: -cpp-options: -cc-options: -ld-options: -pkgconfig-depends: -frameworks: -c-sources: -default-language: -other-languages: -default-extensions: -other-extensions: -extensions: -extra-libraries: -extra-lib-dirs: -includes: -install-includes: -include-dirs: -hs-source-dirs: . + MFlow.Forms.Admin MFlow MFlow.FileServer + MFlow.Forms.Ajax MFlow.Cookies + MFlow.Hack.Response, MFlow.Hack MFlow.Hack.XHtml MFlow.Hack.XHtml.All + MFlow.Wai.Response, MFlow.Wai, MFlow.Wai.XHtml.All + MFlow.Forms.XHtml + MFlow.Forms.HSP + exposed: True + buildable: True + hs-source-dirs: src . + other-modules: -ghc-prof-options: -ghc-shared-options: -ghc-options: -hugs-options: -nhc98-options: -jhc-options: +source-repository head + type: git + location: http://github.com/agocorona/MFlow diff --git a/MFlow.hs b/MFlow.hs deleted file mode 100644 --- a/MFlow.hs +++ /dev/null @@ -1,352 +0,0 @@ -{- | Non monadic low level support stuff for the MFlow application server. -it implements an scheduler of queued 'Processable' messages that are served according with -the source identification and the verb invoked. -Ths scheduler executed the appropriate workflow (using the workflow package) -the workflow may send additional messages to the source, identified by a 'Token' -. The computation state is logged and can be recovered. - -The message communication is trough polimorphic, monoidal queues. -There is no asumption about message codification, so instantiations -of this scheduler for many different infrastructures is possible. -"MFlow.Hack" is an instantiation for the Hack interface in a Web context. - -In order to manage resources, the serving process may die after a timeout. -as well as the logged state, usually, after a longer timeout . - -All these details are hidden in the monad of "MFlow.Forms" that provides -an higuer level interface. Altroug fragments streaming 'sendFragment' 'sendEndFragment' -are only provided at this level. - -'stateless' and 'transient' serving processes are possible. `stateless` are request-response - with no intermediate messaging dialog. `transient` processes have no persistent - state, so they restart anew after a timeout or a crash. - --} - - -{-# LANGUAGE DeriveDataTypeable, UndecidableInstances - ,ExistentialQuantification, MultiParamTypeClasses - ,FunctionalDependencies - ,TypeSynonymInstances - ,FlexibleInstances - ,FlexibleContexts #-} -module MFlow ( -Params, getParam1, Req(..), Resp(..), Workflow, HttpData(..),Processable(..), ConvertTo(..), Token(..), getToken, Error(..), ProcList -,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment, sendEndFragment -,msgScheduler, addMessageFlows,getMessageFlows, transient, stateless -) - -where -import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import GHC.Conc(unsafeIOToSTM) -import Data.Typeable -import Data.Maybe(isJust, isNothing, fromMaybe, fromJust) -import Data.List(isPrefixOf, elem , span, (\\)) -import Control.Monad(when) - -import Data.Monoid -import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId) -import Control.Concurrent.MVar - -import Unsafe.Coerce -import System.IO.Unsafe -import Data.TCache.DefaultPersistence - -import Data.ByteString.Lazy.Char8(pack, unpack) - -import qualified Data.Map as M - -import Control.Workflow - -import MFlow.Cookies - -import Debug.Trace - -(!>)= flip trace - -data HttpData a= HttpData [Cookie] a deriving Typeable - --- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname -type ProcList = WorkflowList IO Token () - - -data Req = forall a.( Processable a,Typeable a)=> Req a deriving Typeable - -type Params = [(String,String)] - -class Processable a where - pwfname :: a -> String - puser :: a -> String - pind :: a -> String - getParams :: a -> Params --- getServer ::a -> String --- getPath :: a -> String --- getPort :: a -> Int - - -instance Processable Req where - pwfname (Req x)= pwfname x - puser (Req x)= puser x - pind (Req x)= pind x - getParams (Req x)= getParams x --- getServer (Req x)= getServer x --- getPath (Req x)= getPath x --- getPort (Req x)= getPort x - -data Resp = forall a c.( Typeable a,Typeable c, Monoid c, ConvertTo a c)=> Fragm a - | forall a c.( Typeable a,Typeable c, Monoid c, ConvertTo a c)=> EndFragm a - | forall a c.( Typeable a,Typeable c, ConvertTo a c) => Resp a - - - ---instance Typeable a => Typeable (Workflow IO a) where --- typeOf = \_ -> mkTyConApp (mkTyCon "Control.Workflow.Workflow IO") [Data.Typeable.typeOf (undefined ::a)] - - -data Token = Token{twfname,tuser, tind :: String , q :: TChan Req, qr :: TChan Resp} deriving Typeable - -{-idToken (Token _ _ n)= n -instance IResource Token where - keyResource (Token w u i _ _ )= u ++ "#" ++ w ++ "#" ++ i - serialize t = "Token " ++ keyResource t - deserialize ('T':'o':'k':'e':'n':' ':str) = Token w u i undef undef - where - (w,r) = span (/= '#') str - (u,_:i)= span (/= '#') $ tail r - - undef= error "deserialize for Token undefined" --} -instance Indexable Token where - key (Token w u i _ _ )= u ++ "#" ++ w ++ "#" ++ i - -instance Show Token where - show t = "Token " ++ key t - -instance Read Token where - readsPrec _ ('T':'o':'k':'e':'n':' ':str1) = [(Token w u i (newChan 0) (newChan 0), tail str2)] - where - (str,str2)= span(/=' ') str - (w,r) = span (/= '#') str - (u,_:i)= span (/= '#') $ tail r - newChan _= unsafePerformIO newTChanIO - -- undef= error "deserialize for Token undefined" - readsPrec _ str= error $ "parse error in Token read from: "++ str - -instance Serializable Token where - serialize= pack . show - deserialize= read . unpack - -iorefqmap= unsafePerformIO . newMVar $ M.empty - -getToken msg= do - qmap <- readMVar iorefqmap - let u= puser msg ; w= pwfname msg ; i=pind msg - let mqs = M.lookup ( i ++ w ++ u) qmap - (q,qr) <- case mqs of - Nothing -> do - q <- atomically $ newTChan -- `debug` (i++w++u) - qr <- atomically $ newTChan - let qs= (q,qr) - modifyMVar_ iorefqmap $ \ map -> return $ M.insert ( i ++ w ++ u) qs map - return qs - - Just qs -> return qs - - return (Token w u i q qr ) --`debug1` "returning getToken" -{- -instance (Monad m, Show a) => Traceable (Workflow m a) where - debugf iox str = do - x <- iox - return $ debug x (str++" => Workflow "++ show x) --} --- | send a complete response -send :: (Typeable a, Typeable b, ConvertTo a b) => Token -> a -> IO() -send (Token _ _ _ queue qresp) msg= atomically $ do - writeTChan qresp $ Resp msg - -sendFlush t msg= flushRec t >> send t msg - --- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' -sendFragment :: ( Typeable a, Typeable b, Monoid b, ConvertTo a b) => Token -> a -> IO() -sendFragment (Token _ _ _ _ qresp) msg= atomically $ writeTChan qresp $ Fragm msg - -sendEndFragment :: ( Typeable a, Typeable b, Monoid b, ConvertTo a b) => Token -> a -> IO() -sendEndFragment (Token _ _ _ _ qresp ) msg= atomically $ writeTChan qresp $ EndFragm msg - ---emptyReceive (Token queue _ _)= emptyQueue queue -receive :: (Processable a, Typeable a) => Token -> IO a -receive t= receiveReq t >>= return . fromReq - -flushRec t@(Token _ _ _ queue _)= do - empty <- atomically $ isEmptyTChan queue - if empty then return() else atomically(readTChan queue) >> flushRec t - -receiveReq :: Token -> IO Req -receiveReq (Token _ _ _ queue _)= atomically $ readTChan queue - -fromReq :: (Processable a, Typeable a) => Req -> a -fromReq (Req x) = x' where - x'= case cast x of - Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x') - Just y -> y - -receiveReqTimeout :: Int - -> Integer - -> Token - -> IO Req -receiveReqTimeout 0 0 t= receiveReq t -receiveReqTimeout time time2 t@(Token _ _ _ queue qresp)=do - let id= twfname t ++ "#" ++key t - flag <- transientTimeout time - r <- atomically $ (readTChan queue >>= return . Just ) - `orElse` (waitUntilSTM flag >> return Nothing) - case r of - Just r@(Req v) -> return r - Nothing -> do - clearRunningFlag id !> "killed" - forkIO $ sessionTimeout (fromIntegral time2- time) id - throw Timeout - where - sessionTimeout t id= do - - --this thread becomes now dedicated to keep the second timeout before deleting the state - flag <- transientTimeout t - - - - r <- atomically $ (waitWFActive id >> return True) - `orElse` - (waitUntilSTM flag >> return False ) -- or timeout - - case r of - False -> delWF1 id !> "state deleted" - True -> return () -- thread has been reactivated - - - - -transientTimeout 0= atomically $ newTVar False -transientTimeout t= do - flag <- atomically $ newTVar False - forkIO $ threadDelay (t * 1000000) >> atomically (writeTVar flag True) >> myThreadId >>= killThread - return flag - - -delMsgHistory t = do - let qnme=key t - let statKey= twfname t ++ "#" ++ qnme -- !> "wf" --let qnme= keyWF wfname t - delWFHistory1 statKey -- `debug` "delWFHistory" - where - u= undefined - - --- ! to add a simple monadic computation of type (a -> IO b) to the list --- of the scheduler -stateless :: ( Typeable a, Processable a, Typeable b - , ConvertTo b c, Typeable c) - => (a -> IO b) -> (Token -> Workflow IO ()) -stateless f = transient $ \tk -> receive tk >>= f >>= send tk - --- | to add a monadic computation that send and receive messages, but does --- not store its state in permanent storage. -transient :: (Token -> IO ()) -> (Token -> Workflow IO ()) -transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) ) - - -_messageFlows :: MVar ProcList -_messageFlows= unsafePerformIO $ newMVar [] -- [(String,Token -> Workflow IO ())]) - - -addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ ms ++ wfs) - -getMessageFlows = readMVar _messageFlows - -class ConvertTo a b | a -> b where - convert :: a -> b - - - ---tellToWF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c -tellToWF (Token _ _ _ queue qresp ) msg = do - atomically $ writeTChan queue $ Req msg -- `debug` ("tell wf="++wf) - m <- atomically $ readTChan qresp - case m of - Resp r -> return . cast1 $ convert r - Fragm r -> do - result <- getStream $ convert r - return $ cast1 result - - - where - - - cast1 :: (Typeable a, Typeable b) => a -> b - cast1 x= y where - y= case cast x of - Nothing -> error $ "cast error: " ++ show (typeOf x) ++ " to " ++ show (typeOf y) - Just y -> y - getStream :: (Typeable a, Monoid a) => a -> IO a - getStream r = do - mr <- atomically $ readTChan qresp - case mr of - Resp _ -> error "\"send\" used instead of \"sendFragment\" or \"sendEndFragment\"" - Fragm h -> do - rest <- unsafeInterleaveIO $ getStream ( convert h) - let result= mappend r (cast1 rest) - return (cast1 result ) - EndFragm h -> do - let result= mappend r $ cast1 (convert h) - return (cast1 result) - - - - - - -data Error= Error String deriving (Read, Show, Typeable) - -instance Indexable Error where - key _= error "Idexablew instance for Error" - -msgScheduler - :: (Processable a, Typeable a, ConvertTo Error c, Typeable c) - => a -> ProcList -> IO (c, ThreadId) -msgScheduler x wfs = do - token <- getToken x - - th <- startMessageFlow (pwfname x) token wfs - r<- tellToWF token x - return (r,th) - where - - startMessageFlow wfname token wfs= - forkIO $ do - r <- startWF wfname token wfs -- `debug`( "init wf " ++ wfname) - case r of - Left NotFound -> error ( "procedure not found: "++ wfname) - Left AlreadyRunning -> return () -- `debug` ("already Running " ++ wfname) - Left Timeout -> return () -- `debug` "Timeout in webScheduler" - Left (Exception e)-> send token $ Error (show e) -- `debug` ("WF error: "++ show e) - Right _ -> do delMsgHistory token; return () -- `debug` ("finished " ++ wfname) - - - - - -getParam1 :: ( Typeable a, Read a) => String -> Params -> Maybe a -getParam1 str req= r - where - r= case lookup str req of - Just x -> maybeRead x - Nothing -> Nothing - - maybeRead str= - if typeOf r == (typeOf $ Just "") - then Just $ unsafeCoerce str - else case readsPrec 0 str of - [(x,"")] -> Just x - _ -> Nothing - - - diff --git a/MFlow/Cookies.hs b/MFlow/Cookies.hs deleted file mode 100644 --- a/MFlow/Cookies.hs +++ /dev/null @@ -1,189 +0,0 @@ -module MFlow.Cookies -(Cookie,ctype,getCookies,cookieHeaders,urlDecode) -where -import Control.Monad(MonadPlus(..), guard, replicateM_, when) -import Data.Char -import Data.Maybe(fromMaybe) -import System.IO.Unsafe -import Control.Exception(handle) -import Data.Typeable -import Data.Maybe(fromJust) -import Unsafe.Coerce - -type Cookie= (String,String,String,Maybe String) - -getCookies httpreq= - case lookup "Cookie" $ httpreq of - Just str -> splitCookies str - Nothing -> [] - -cookieHeaders cs = map (\c-> ("Set-Cookie", showCookie c)) cs - -showCookie :: Cookie -> String -showCookie (n,v,p,me) = - let e= fromMaybe "" me - in showString n . showString "=" . showString v . showString "; path=" - . showString p . showExpires e . showString "\n" $ "" - - -showExpires [] = showString "" -showExpires e = showString "; expires=" . showString e - - - - -ctype= ("Content-Type", "text/html") - - - -splitCookies cookies = f cookies [] - where - f [] r = r - f xs0 r = - let - xs = dropWhile (==' ') xs0 - name = takeWhile (/='=') xs - xs1 = dropWhile (/='=') xs - xs2 = dropWhile (=='=') xs1 - val = takeWhile (/=';') xs2 - xs3 = dropWhile (/=';') xs2 - xs4 = dropWhile (==';') xs3 - xs5 = dropWhile (==' ') xs4 - in f xs5 ((name,val):r) - ------------------------------ - ---------------------------------------------- - --- %*************************************************************************** --- %* * --- \subsection[CGI-Parser]{Yet another combinator parser library}. chuck of code taken from Erik Meijer --- %* * --- %*************************************************************************** - --- NOTE: This is all a little bit of a sledgehammer here for the simple task --- at hand... - --- The parser monad - - -newtype Parser a = Parser (String -> [(a,String)]) - -instance Functor Parser where - -- map :: (a -> b) -> (Parser a -> Parser b) - fmap f (Parser p) = Parser (\inp -> [(f v, out) | (v, out) <- p inp]) - -instance Monad Parser where - -- return :: a -> Parser a - return v = Parser (\inp -> [(v,inp)]) - - -- >>= :: Parser a -> (a -> Parser b) -> Parser b - (Parser p) >>= f = Parser (\inp -> concat [papply (f v) out - | (v,out) <- p inp]) - -instance MonadPlus Parser where - -- zero :: Parser a - mzero = Parser (\_ -> []) - -- (++) :: Parser a -> Parser a -> Parser a - (Parser p) `mplus` (Parser q) = Parser (\inp -> (p inp ++ q inp)) - - --- Other primitive parser combinators - - -item :: Parser Char -item = Parser (\inp -> case inp of - [] -> [] - (x:xs) -> [(x,xs)]) - -force :: Parser a -> Parser a -force (Parser p) = Parser (\inp -> let x = p inp in - (fst (head x), snd (head x)) : tail x) - -first :: Parser a -> Parser a -first (Parser p) = Parser (\inp -> case p inp of - [] -> [] - (x:_) -> [x]) - -papply :: Parser a -> String -> [(a,String)] -papply (Parser p) inp = p inp - - --- Derived combinators - - -(+++) :: Parser a -> Parser a -> Parser a -p +++ q = first (p `mplus` q) - -sat :: (Char -> Bool) -> Parser Char -sat p = do {x <- item; guard (p x); return x} - -many :: Parser a -> Parser [a] -many p = force (many1 p +++ return []) - -many1 :: Parser a -> Parser [a] -many1 p = do {x <- p; xs <- many p; return (x:xs)} - -sepby :: Parser a -> Parser b -> Parser [a] -p `sepby` sep = (p `sepby1` sep) +++ return [] - -sepby1 :: Parser a -> Parser b -> Parser [a] -p `sepby1` sep = do x <- p - xs <- many (do {sep; p}) - return(x:xs) - -char :: Char -> Parser Char -char x = sat (x==) - -alphanum :: Parser Char -alphanum = sat (\c -> isAlphaNum c || c == '@' || c =='\'' ) -- Added @ as a valid character - -string :: String -> Parser String -string "" = return "" -string (x:xs) = do char x - string xs - return (x:xs) - -hexdigit :: Parser Char -hexdigit = sat isHexDigit - - ---readEnv :: Parser [(String,String)] -readEnv = (do - n <- urlEncoded - string "=" - v <- urlEncoded - return (n,v)) `sepby` (string "&") - -urlEncoded :: Parser String -urlEncoded - = many ( alphanum `mplus` extra `mplus` safe - `mplus` do{ char '+' ; return ' '} - `mplus` do{ char '%' - ; d <- hexadecimal - ; return $ chr (hex2int d) - } - ) - -extra :: Parser Char -extra = sat (`elem` "!*'(),") - -safe :: Parser Char -safe = sat (`elem` "$-_.") - -hexadecimal :: Parser HexString -hexadecimal = do d1 <- hexdigit - d2 <- hexdigit - return [d1,d2] - -type HexString = String - -hex2int :: HexString -> Int -hex2int ds = foldl (\n d -> n*16+d) 0 (map (toInt . toUpper) ds) - where toInt d | isDigit d = ord d - ord '0' - toInt d | isHexDigit d = (ord d - ord 'A') + 10 - toInt d = error ("hex2int: illegal hex digit " ++ [d]) - -urlDecode :: String -> [([(String, String)],String)] -urlDecode str= let Parser p= readEnv in p str - diff --git a/MFlow/Forms.hs b/MFlow/Forms.hs deleted file mode 100644 --- a/MFlow/Forms.hs +++ /dev/null @@ -1,776 +0,0 @@ - -{-# OPTIONS -XDeriveDataTypeable - -XUndecidableInstances - -XExistentialQuantification - -XMultiParamTypeClasses - -XTypeSynonymInstances - -XFlexibleInstances - -XScopedTypeVariables - -XFunctionalDependencies - -XFlexibleContexts - -XRecordWildCards - -XIncoherentInstances - -#-} - -{- | This module defines an integrated way to interact with the user. `ask` is -a single method of user interaction. it send user interfaces and return statically -typed responses. The user interface definitions are based on the formLets interface - -But additionally, unlike formLets in its current form, it permits the - definition of widgets. A widget is data that, when renderized -and interact with the user, return data, just like a formlet, but it hasn -to be an HTML form. it can contain JavaScript, or additional Html decoration or -it can use Ajax istead of form post for the interaction. -There is an example of widget defined (`Selection`) - -widgets (and formlets) can be combined in a sigle Html page. -Here is a ready-to-run example that combines a Widget (Selection) and -a HTML decorated formLet in the same page. - -@ -import "MFlow.Hack.XHtml.All" - -import Data.Typeable -import Control.Monad.Trans -import qualified Data.Vector as V - -main= do - - putStrLn $ options messageFlows - 'run' 80 $ 'hackMessageFlow' messageFlows - where - messageFlows= [(\"main\", runFlow mainProds ) - ,(\"hello\", stateless hello)] - options msgs= \"in the browser choose\\n\\n\" ++ - concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] - - -\--an stateless procedure, as an example -hello :: 'Env' -> IO String -hello env = return \"hello, this is a stateless response\" - - -data Prod= Prod{pname :: String, pprice :: Int} deriving (Typeable,Read,Show) - -\-- formLets can have Html formatting. Additional operators \<\++ \<+\> \<\<\< ++\> to XHtml formatting - -instance 'FormLet' Prod IO Html where - 'digest' mp= table \<\<\< ( - Prod \<\$\> tr \<\<\< (td \<\< \"enter the name\" \<++ td \<\<\< getString (pname \<\$\> mp)) - \<\*\> tr \<\<\< (td \<\< \"enter the price\" \<++ td \<\<\< getInt ( pprice \<\$\> mp))) - - -\-- Here an example of predefined widget (`Selection`) that return an Int, combined in the same -\-- page with the fromLet for the introduction of a product. -\-- The result of the user interaction is Either one or the other value - -shopProds :: V.Vector Int -\> [Prod] - -\> 'View' Html IO (Either Int Prod) -shopProds cart products= - - p \<\< \"\--\--\--\--\--\--\--\--Shopping List\--\--\--\--\--\--\--\" - \<++ - widget(Selection{ - stitle = bold \<\< \"choose an item\", - sheader= [ bold \<\< \"item\" , bold \<\< \"price\", bold \<\< \"times chosen\"], - sbody= [([toHtml pname, toHtml \$ show pprice, toHtml \$ show \$ cart V.! i],i ) - | (Prod{..},i ) \<- zip products [1..]]}) - - \<+\> - p \<\< \"\--\--\--\--\--\--\--Add a new product \--\--\--\--\--\--\---\" - \<++ - table \<\<\< (tr \<\<\< td ! [valign \"top\"] - \<\<\< widget (Form (Nothing :: Maybe Prod) ) - ++\> - tr \<\< td ! [align \"center\"] - \<\< hotlink \"hello\" - (bold \<\< \"Hello World\")) - -\-- the header - -appheader user forms= thehtml - \<\< body \<\< dlist \<\< (concatHtml - [dterm \<\<(\"Hi \"++ user) - ,dterm \<\< \"This example contains two forms enclosed within user defined HTML formatting\" - ,dterm \<\< \"The first one is defined as a Widget, the second is a formlet formatted within a table\" - ,dterm \<\< \"both are defined using an extension of the FormLets concept\" - ,dterm \<\< \"the form results are statically typed\" - ,dterm \<\< \"The state is implicitly logged. No explicit handling of state\" - ,dterm \<\< \"The program logic is written as a procedure. Not in request-response form. But request response is possible\" - ,dterm \<\< \"lifespan of the serving process and the execution state defined by the programmer\" - ,dterm \<\< \"user state is automatically recovered after cold re-start\" - ,dterm \<\< \"transient, non persistent states possible.\" - ]) - +++ forms - -\-- Here the procedure. It ask for either entering a new product -\-- or to \"buy\" one of the entered products. -\-- There is a timeout of ten minutes before the process is stopped -\-- THERE IS A timeout of one day for the whole state so after this, the -\-- user will see the list erased. -\-- The state is user specific. - -\--mainProds :: FlowM Html (Workflow IO) () -mainProds = do - setTimeouts (10\*60) (24\*60\*60) - setHeader \$ \w -\> bold \<\< \"Please enter user/password (pepe/pepe)\" +++ br +++ w - - - setHeader \$ appheader "user" - mainProds1 [] \$ V.fromList [0] - where - mainProds1 prods cart= do - mr \<- step . ask \$ shopProds cart prods - case mr of - Right prod -\> mainProds1 (prod:prods) (V.snoc cart 0) - Left i -\> do - let newCart= cart V.// [(i, cart V.! i + 1 )] - mainProds1 prods newCart -@ - --} - -module MFlow.Forms( -{- basic definitions -} -Widget(..),FormLet(..), Launchable(..) -,View, FormInput(..), FormT(..),FormElm(..) -{- widget instances -} -,Form(..),Selection(..) - -{- users -} -,userRegister, userAuthenticate, User(userName) -,getUser, --- * user interaction -ask, --- * getters to be used in instances of `FormLet` and `Widget` in the Applicative style. - -getString,getInt,getInteger -,getMultilineText,getBool,getOption, getPassword,validate --- * formatting and combining widgets - -,mix,wrap,addToForm --- * running the flow monad -,FlowM,runFlow,MFlow.Forms.step --- * setting parameters -,setHeader -,setTimeouts --- * Cookies -,setCookie -) -where -import Data.TCache ---import Data.Persistent.Queue -import MFlow -import MFlow.Cookies -import Data.RefSerialize (Serialize) -import Control.Workflow as WF -import Data.Typeable -import Data.Monoid -import Control.Monad.State -import Control.Monad.Trans.Maybe -import Control.Applicative -import Control.Exception -import Control.Workflow(exec1,Workflow, waitUntilSTM, step, unsafeIOtoWF) - - -import Debug.Trace --- -(!>)= flip trace - - -type UserName= String - -data User= User - { userName :: UserName - , upassword :: String - } deriving (Read, Show, Typeable) - -eUser= User (error1 "username") (error1 "password") - - -error1 s= error $ s ++ " undefined" - -userPrefix= "User#" -instance Indexable User where - key User{userName= user}= userPrefix++user - - - - - -maybeError err iox = runMaybeT iox >>= \x -> - case x of - Nothing -> error err - Just x -> return x - --- | register an user/password combination -userRegister :: String -> String -> IO() -userRegister user password = withResources [] $ const [ User user password] - - ---newDBRef1 :: (IResource a, Typeable a) => a -> STM (DBRef a) ---newDBRef1 x = do --- let ref= getDBRef $ keyResource x --- mr <- readDBRef ref --- case mr of --- Nothing -> writeDBRef ref x >> return ref --- Just r -> return ref - - --- let u= User user password --- let ref= getDBRef $ key u --- atomically $ do --- mr <- readDBRef ref --- case mr of --- Nothing -> writeDBRef ref u -- !> (show mr) --- Just u -> return () --- return ref - --- | authentication against `userRegister`ed users. --- to be used with `validate` -userAuthenticate :: MonadIO m => User -> m (Maybe String) -userAuthenticate user@User{..} = liftIO $ atomically - $ withSTMResources [user] - $ \ mu -> case mu of - [Nothing] -> resources{toReturn= err } - [Just (User _ p )] -> resources{toReturn= - case upassword==p of - True -> Nothing - False -> err - - } - - where - err= Just "Username or password invalid" - - -type FlowM view = StateT (MFlowState view) - -runFlow :: (FormInput view, Monoid view, Monad m) - => FlowM view m () -> Token -> m () -runFlow f = \t -> evalStateT f mFlowState0{mfToken=t} - -step - :: (Serialize a, - MonadIO m, - Typeable a) => - FlowM view m a - -> FlowM view (Workflow m) a - -step f=do - s <- get - lift . WF.step $ evalStateT f s - - - - - - -cookieuser= "cookieuser" - - -instance (MonadIO m, Functor m, FormInput view) => FormLet User m view where - digest muser = - (User <$> getString (fmap userName muser) - <*> getPassword) - `validate` userAuthenticate - - -newtype Lang= Lang String - -data MFlowState view= MFlowState{ - mfSequence :: Int, - mfUser :: String, - mfLang :: Lang, - mfEnv :: Params, --- mfServer :: String, --- mfPath :: String, --- mfPort :: Int, - - mfToken :: Token, - mfkillTime :: Int, - mfStateTime :: Integer, - mfCookies :: [Cookie], - mfHeader :: view -> view} - - - -stdHeader v= v - -anonymous= "anonymous" ---rAnonUser= getDBRef . key $ eUser{userName=anonymous} :: DBRef User - -mFlowState0 :: (FormInput view, Monoid view) => MFlowState view -mFlowState0= MFlowState 0 anonymous (Lang "en") [] undefined 0 0 [] stdHeader - -setHeader :: Monad m => (view -> view) -> FlowM view m () -setHeader header= do - fs <- get - put fs{mfHeader= header} - --- | set an HTTP cookie -setCookie :: Monad m - => String -- ^ name - -> String -- ^ value - -> String -- ^ path - -> Maybe String -- ^ expires - -> FlowM view m () -setCookie n v p me= do - st <- get - put st{mfCookies= (n,v,p,me):mfCookies st } - -setTimeouts :: (Monad m)=> Int -> Integer -> FlowM view m () -setTimeouts kt st= do - fs <- get - put fs{ mfkillTime= kt, mfStateTime= st} - --- | Very basic user authentication. The user is stored in a cookie. --- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed --- user-password combination. It return a reference to the user. - -getUser :: ( FormInput view, Monoid view, Typeable view - , ConvertTo (HttpData view) display, Typeable display - , MonadIO m, Functor m) - => FlowM view m String -getUser = do - - rus <- gets mfUser - case rus == anonymous of - False -> return rus - True -> do - env <- do - env <- gets mfEnv - if null env then receiveWithTimeouts>> gets mfEnv - else return env - ref <- case lookup cookieuser env of - Nothing -> do - us <- ask (Form (Nothing :: Maybe User)) - ref <- liftIO . atomically $ newDBRef us - setCookie cookieuser (userName us) "/" Nothing - get >>= \s -> liftIO $ print (mfCookies s) - return $ userName us - Just usname -> return usname --- modify $ \s -> s{mfUser= ref}F - return ref - --- | Launchable widgets create user requests. For example whatever piece containing --- a Form tag, a link with an embeeded Ajax invocation etc. --- --- A FormLet for an input field can not be an instance of Launchable, for example --- to invoke it with ask, make the widget an instance of Launchable -class Widget a b m view => Launchable a b m view - - -instance (MonadIO m, Functor m) - => Widget(View view m a) a m view where - widget = id - -instance (MonadIO m, Functor m) - => Launchable (View view m a) a m view - - --- | join two widgets in the same pages --- the resulting widget, when `ask`ed with it, returns a either one or the other -mix :: ( FormInput view , Monad m) - => View view m a' - -> View view m b' - -> View view m (Either a' b') -mix digest1 digest2= FormT $ \env -> do - FormElm f1 mx' <- (runFormT $ digest1) env - FormElm f2 my' <- (runFormT $ digest2) env - return $ FormElm (f1++f2) - $ case (mx',my') of - (Nothing, Nothing) -> Nothing - (Just x,Nothing) -> Just $ Left x - (Nothing,Just x) -> Just $ Right x - (Just _,Just _) -> error "malformed getters in widget combination" - --- | it is the way to interact with the user. --- It takes a combination of `launchable` objects and return the user result --- in the FlowM monad -ask - :: ( Launchable a b m view - , FormInput view, Monoid view - , Typeable view, ConvertTo (HttpData view) display - , Typeable display ) - => a -> FlowM view m b -ask mx = do - st <- get - let t= mfToken st - FormElm forms mx' <- generateForm mx - case mx' of - Just x -> return x - _ -> do - let header= mfHeader st - liftIO . sendFlush t $ HttpData (mfCookies st) (header $ mconcat forms) - put st{mfCookies=[]} - receiveWithTimeouts - ask mx - - - - -receiveWithTimeouts :: MonadIO m => FlowM view m () -receiveWithTimeouts= do - st <- get - let t= mfToken st - t1= mfkillTime st - t2= mfStateTime st - req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t) - put st{mfEnv= req} - - -data Selection a view= Selection{stitle:: view, sheader :: [view] , sbody :: [([view],a)]} - -instance (MonadIO m, Functor m, FormInput view, Typeable a, Show a, Read a, Eq a) - => Launchable (Selection a view) a m view - -instance (MonadIO m, Functor m - ,FormInput view, Read a , Show a, Eq a, Typeable a) - => Widget (Selection a view) a m view where - widget Selection {..} =FormT(\env -> do - t <- fmap mfToken get - let mn = getParam1 "select" env - - toSend = fformAction (twfname t) . ftable stitle sheader $ - map(\(vs,x) -> vs ++ [finput "select" "radio" (show x) - ( Just x== mn) (Just "this.form.submit()")] ) sbody - return $ FormElm [toSend] mn) - --- ---data Link view = Link view (FlowM view (Workflow IO) ()) --- ---instance ( FormInput view, Monoid view) --- => Launchable (Link view ) () IO view --- ---instance (FormInput view, Monoid view) --- => Widget (Link view ) () IO view where --- widget (Link v f) = FormT $ \ env -> do --- n <- getnewname --- --- let render= FormElm [flink (Verb n ) v] --- case getParam1 n env :: Maybe String of --- Nothing -> return () --- Just _ -> do --- token <- liftIO $ getToken (n,env) --- liftIO $ forkIO $ exec verb (runFlow f) token --- return() --- return $ render Nothing --- ---instance Processable (String, Params) where --- pwfname (pwfname, env)= pwfname --- puser (_,env) = case lookup "cookieuser" env of --- Nothing -> "nouser" --- Just user -> user --- pind (_,env)= case lookup "flow" env of --- Nothing -> error ": No FlowID" --- Just fl -> fl --- getParams (_,env)= env --- --- - ---data LocalLink view = LocalLink view (FlowM view IO ()) --- --- --- ---instance (MonadIO m, Functor m,FormInput view, Monoid view) --- => Launchable (LocalLink view ) String m view --- ---instance (MonadIO m,Functor m,FormInput view, Monoid view) --- => Widget (LocalLink view ) String m view where --- widget (LocalLink v f) = FormT $ \ env -> do --- t <- fmap mfToken get --- let verb= twfname t --- widget $ Link verb v (transient f) - - - -newtype Form a= Form a - -instance (FormInput view, Monoid view, Widget a b m view) - => Launchable (Form a) b m view - -instance (FormInput view, Monoid view, Widget a b m view) - => Widget (Form a) b m view - where - widget (Form x) = FormT $ \env -> do - FormElm form mr <- (runFormT $ widget x ) env - t <- fmap mfToken get - let form1= fformAction (twfname t) . mconcat - $ form - ++ [finput "reset" "reset" "Reset" False Nothing - ,finput "submit" "submit" "Submit" False Nothing] - - return $ FormElm [form1] mr - - - -data FormElm view a = FormElm [view] (Maybe a) - - -newtype FormT view m a = FormT { runFormT :: Params -> m (FormElm view a) } - -instance Functor (FormElm view ) where - fmap f (FormElm form x)= FormElm form (fmap f x) - -instance Functor m => Functor (FormT view m) where - fmap f = FormT .(\env -> fmap (fmap f) . (runFormT env) ) - -instance (Functor m, Monad m) => Applicative (FormT view m) where - pure a = FormT $ \env -> return (FormElm [] $ Just a) - FormT f <*> FormT g= FormT $ \env -> - f env >>= \(FormElm form1 k) -> - g env >>= \(FormElm form2 x) -> - return (FormElm (form1 ++ form2) (k <*> x)) - -instance (Monad m, Functor m) => Monad (FormT view m) where - x >>= f = join $ fmap f x - return= pure - -type View view m a= FormT view (FlowM view m) a - --- a FormLet instance -class (Functor m, MonadIO m) => FormLet a m view where - digest :: Maybe a - -- -> Validate m a - -> View view m a - - -class (Functor m, MonadIO m) => Widget a b m view | a -> view where - widget :: a - -- -> Validate m b - -> View view m b - - - -instance FormLet a m view => Widget (Maybe a) a m view where - widget = digest - - --- | Validates a form or widget result against a validating procedure --- --- getOdd= getInt Nothing `validate` (\x-> return $ if mod x 2==0 then Nothing else Just "only odd number please") - -validate - :: (FormInput view, - Functor m, MonadIO m) - => View view m a - -> (a -> m (Maybe String)) - -> View view m a -validate formt val= FormT $ \env -> do - FormElm form mx <- (runFormT formt) env - case mx of - Just x -> do - me <- lift $ val x - case me of - Just str ->do - --FormElm form mx' <- generateForm [] (Just x) noValidate - return $ FormElm ( inred (fromString str) : form) Nothing - Nothing -> return $ FormElm [] mx - _ -> return $ FormElm form mx - -generateForm - :: (Widget a b m view, FormInput view ) => - a -> FlowM view m (FormElm view b) -generateForm mx = do - st <- get - (runFormT $ widget mx ) $ mfEnv st --- lift $ evalStateT --- ((runFormT $ digest mx val) $ mfEnv st) --- st - - - -instance (FormInput view, FormLet a m view , FormLet b m view ) - => FormLet (a,b) m view where - digest mxy = do - let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y) - (,) <$> digest x <*> digest y - -instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view ) - => FormLet (a,b,c) m view where - digest mxy = do - let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z) - (,,) <$> digest x <*> digest y <*> digest z - - - --- --- ---instance (MonadIO m, Functor m, FormInput view) => FormLet Verb m view where --- digest _ = FormT $ \env -> return $ case getParam1 "verb" env of --- Nothing -> error "digst: verb not found" --- Just x -> FormElm [] . Just $ Verb x --- - - - - - - -getString :: (FormInput view,Monad m) => - Maybe String -> View view m String -getString = getElem - -getInteger :: (FormInput view, Functor m, MonadIO m) => - Maybe Integer -> View view m Integer -getInteger = getElem - -getInt :: (FormInput view, Functor m, MonadIO m) => - Maybe Int -> View view m Int -getInt = getElem - -getPassword :: (FormInput view, - Monad m) => - View view m String -getPassword = getParam Nothing "password" (Just "enter password") - - -getElem - :: (FormInput view, - Monad m, - Typeable a, - Show a, - Read a) => - Maybe a -> View view m a -getElem ms = getParam Nothing "text" ms - - -getParam - :: (FormInput view, - Monad m, - Typeable a, - Show a, - Read a) => - Maybe String -> String -> Maybe a -> View view m a -getParam look type1 mvalue = FormT $ \env -> do - tolook <- case look of - Nothing -> getnewname - Just n -> return n - let nvalue= case mvalue of - Nothing -> "" - Just v -> show v - form= [finput tolook type1 nvalue False Nothing] - case getParam1 tolook env of - Nothing -> return $ FormElm form Nothing - justx -> return $ FormElm form justx --- do --- me <- lift $ val justx --- case me of --- Nothing -> return $ FormElm [] justx --- Just str -> return $ FormElm [bold $ fromString str,input tolook type1 nvalue False] Nothing - -getnewname :: Monad m => FlowM view m String -getnewname= do - st <- get - let n= mfSequence st - put $ st{mfSequence= n+1} - return $ "Parm"++show n - -getMultilineText :: (FormInput view, - Monad m) => - Maybe [Char] -> View view m String -getMultilineText mt = FormT $ \env -> do - tolook <- getnewname - - let nvalue= case mt of - Nothing -> "" - Just v -> show v - case (getParam1 tolook env, mt) of - (Nothing, Nothing) -> return $ FormElm [ftextarea tolook nvalue] Nothing - (Nothing, Just v) -> return $ FormElm [] $ Just v - (justx,_) -> return $ FormElm [] justx - -instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where - digest mv = getBool b "True" "False" - where - b= case mv of - Nothing -> Nothing - Just bool -> Just $ show bool - -getBool :: (FormInput view, - Monad m) => - Maybe String -> String -> String -> View view m Bool -getBool mv truestr falsestr= FormT $ \env -> do - tolook <- getnewname - case (getParam1 tolook env, mv) of - (Nothing, Nothing) -> return $ FormElm [foption1 tolook [truestr,falsestr] mv] Nothing - (Nothing,Just x) -> return . FormElm [] . Just $ fromstr x - (Just x,_) -> return . FormElm [] . Just $ fromstr x - where - fromstr x= if x== truestr then True else False - -getOption :: (FormInput view, - Monad m) => - Maybe String ->[(String,String)] -> View view m String -getOption mv strings = FormT $ \env -> do - tolook <- getnewname - case (getParam1 tolook env, mv) of - (Nothing, Nothing) -> return $ FormElm [foption tolook strings mv] Nothing - (Nothing,Just x) -> return . FormElm [] $ Just x - (justx,_) -> return $ FormElm [] justx - - --- | encloses instances of `Widget` or `FormLet` in formating --- view is intended to be instantiated to a particular format --- see "MFlow.Forms.XHtml" for usage examples -wrap :: (Monad m, FormInput view, Monoid view) - => (view ->view) - -> View view m a - -> View view m a -wrap v form= FormT $ \env -> do - FormElm f mx <- runFormT form env - return $ FormElm [v $ mconcat f] mx - --- | append formatting to `Widget` or `FormLet` instances --- view is intended to be instantiated to a particular format --- see "MFlow.Forms.XHtml" for usage examples -addToForm :: (Monad m, FormInput view, Monoid view) - => View view m a - -> view - -> View view m a -addToForm form v= FormT $ \env -> do - FormElm f mx <- runFormT form env - return $ FormElm (f++[v]) mx - - - -type Name= String -type Type= String -type Value= String -type Checked= Bool -type OnClick= Maybe String - - --- | Minimal interface for defining the abstract basic form combinators --- defined in this module. see "MFlow.Forms.XHtml" for the instance for "Text.XHtml" --- format -class FormInput view where --- column :: [view] -> view --- column columns= table (fromString "") [] [columns] --- row :: [view] -> view - - inred :: view -> view --- fs :: view -> view --- ts :: view -> view - - ftable:: view -> [view] -> [[view]] -> view --- hsep :: view --- vsep :: view --- style :: String -> view -> view - - fromString :: String -> view - flink :: String -> view -> view - - flink1:: String -> view - flink1 verb = flink verb (fromString verb) - - - finput :: Name -> Type -> Value -> Checked -> OnClick -> view - ftextarea :: String -> String -> view - foption :: String -> [(String,String)] -> Maybe String -> view - foption1 :: String -> [String] -> Maybe String -> view - foption1 name list msel= foption name (zip list list) msel - - fformAction :: String -> view -> view diff --git a/MFlow/Forms/XHtml.hs b/MFlow/Forms/XHtml.hs deleted file mode 100644 --- a/MFlow/Forms/XHtml.hs +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Control.MessageFlow.Forms.XHtml --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ -{- Instantiation of "MFlow.Forms" for the xhtml package "Text.XHtml" module -it includes additional XHtml style operators for embedding widgets within XHtml formatting - --} - -{-# OPTIONS -XMultiParamTypeClasses - -XFlexibleInstances - -XUndecidableInstances - -XTypeSynonymInstances - -XFlexibleContexts - #-} - - -module MFlow.Forms.XHtml((<++), (<+>), (++>), (<<<)) - where - - -import MFlow.Forms -import Text.XHtml as X -import Control.Monad.Trans -import Data.Typeable - - --- | encloses a widget in Html formatting --- --- @table <<< ( --- tr <<< (td << widget widget1) --- tr <<< (td << widget widget2))@ - -(<<<) :: Monad m => (Html -> Html) -> View Html m a -> View Html m a -tag <<< d= wrap tag d -infixr 7 <<< - -infixr 3 <++ --- | prepend Html formatting to a widget --- --- @bold << "hi there" --- <++ --- widget widget1@ - -(<++) :: Monad m => Html -> View Html m a -> View Html m a -html <++ digest = (html +++) <<< digest - -infix 3 ++> --- | append Html to a widget --- --- @widget widget1 --- ++> --- H1 << "hi there"@ -(++>) :: Monad m => View Html m a -> Html -> View Html m a -digest ++> html = addToForm digest html - - --- | join two widgets in the same pages --- the resulting widget, when `ask`ed with it, returns a either one or the other --- --- @r <- ask widget widget1 <+> widget widget2@ --- -infixr 2 <+> -(<+>) :: Monad m - => View Html m a' - -> View Html m b' - -> View Html m (Either a' b') -(<+>) = mix - - - - -instance Typeable X.Html where - typeOf = \_ -> mkTyConApp (mkTyCon3 "XHtml" "Text.XHtml.Strict" "Html") [] - -instance FormInput Html where --- column vs= concatHtml [tr v | v <- vs] --- row vs= concatHtml [td v | v <- vs] --- hsep = spaceHtml --- vsep = br - inred = X.bold ![X.thestyle "color:red"] - finput n t v f c= X.input ! ([thetype t ,name n, value v]++ if f then [checked] else [] - ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] ) - ftextarea name text= X.textarea ! [X.name name] << text - - foption name list msel= select ![ X.name name] << (concatHtml - $ map (\(n,v) -> X.option ! ([value n] ++ selected msel n) << v ) list) - - where - selected msel n= if Just n == msel then [X.selected] else [] - - - - - fformAction action form = X.form ! [X.action action, method "post"] << form - fromString = stringToHtml --- bold = X.bold --- fs = h3 --- ts = h4 --- style st content = thespan ![thestyle st] << content - - ftable title head rows= - X.table << ( - (if not . isNoHtml $ title then caption << title else noHtml ) +++ - (if not . null $ head then tr << (concatHtml [th h | h <- head]) else noHtml) +++ - (concatHtml[tr << concatHtml[td v| v <- row] | row <- rows])) - - flink v str = p << hotlink v << str diff --git a/MFlow/Hack.hs b/MFlow/Hack.hs deleted file mode 100644 --- a/MFlow/Hack.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE UndecidableInstances - , TypeSynonymInstances - , MultiParamTypeClasses - , DeriveDataTypeable - , FlexibleInstances #-} - -module MFlow.Hack( - module MFlow.Cookies - ,module MFlow - ,hackMessageFlow) -where - -import Data.Typeable -import Hack - -import Control.Concurrent.MVar(modifyMVar_, readMVar) -import Control.Monad(when) - - -import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString) -import Control.Concurrent(ThreadId(..)) -import System.IO.Unsafe -import Control.Concurrent.MVar -import Control.Exception -import qualified Data.Map as M - -import Data.TCache - -import Control.Workflow - -import MFlow -import MFlow.Cookies -import MFlow.Hack.Response -import Data.Monoid - ---(!>)= flip trace - -assocList ->> k = getParam1 assocList k - -instance Processable Env where - pwfname env= if null sc then "noscript" else sc - where - sc= tail $ pathInfo env -- takeWhile (/= '?') $ queryString env - puser env = case lookup "cookieuser" $ http env of - Nothing -> "nouser" - Just user -> user - pind env= case lookup "flow" $ http env of - Nothing -> error ": No FlowID" - Just fl -> fl - getParams env= http env --- getServer env= serverName env --- getPath env= pathInfo env --- getPort env= serverPort env - -data Flow= Flow !Int deriving (Read, Show, Typeable) - - -instance Indexable Flow where - key _= "Flow" - - - - -newFlow= do - fl <- atomically $ do - withSTMResources [Flow undefined] $ - \m -> - let - (add, ret)= case m of - [Just (Flow n)] -> ([Flow $ n+1],n) - [Nothing] -> ([Flow 1],0) - in resources{toAdd=add, toReturn= ret} - - return $ show fl - ---------------------------------------------- - - - - -instance ConvertTo String TResp where - convert = TResp . pack - -instance ConvertTo ByteString TResp where - convert = TResp - ---instance ConvertTo Response TResp where --- convert= TResp --- -instance ConvertTo Error TResp where - convert (Error e)= TResp $ pack e - -instance ToResponse v =>ConvertTo (HttpData v) TResp where - convert= TRespR --- ---instance Typeable (HSP XML) where --- typeOf = \_ -> mkTyConApp (mkTyCon "HSP") [mkTyConApp ( mkTyCon "XML") []] --- --- --- ---instance ConvertTo (HSP XML) TResp where --- convert xml=unsafePerformIO $ do --- (_,html) <- evalHSP Nothing xml --- return . TResp . pack $ renderAsHTML html --- --- --- ---instance Typeable X.Html where --- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Transitional.Html") [] --- --- --- --- --- ---instance ConvertTo X.Html TResp where --- convert = TResp . pack . X.showHtml --- - -webScheduler :: -- (Typeable c, ToResponse c) => - Env - -> ProcList - -> IO (TResp, ThreadId) -webScheduler = msgScheduler - -eitherToError (Right x)= x -eitherToError (Left e)= error $ "eitherToError " ++ show e - ---theDir= unsafePerformIO getCurrentDirectory - -wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) -wFMiddleware filter f = \ env -> if filter env then hackWorkflow env else f env - --- | An instance of the abstract "MFlow" scheduler to the Hack interface --- it accept the list of processes being scheduled and return a hack handler --- --- Example: --- --- @main= do --- --- putStrLn $ options messageFlows --- 'run' 80 $ 'hackMessageFlow' messageFlows --- where --- messageFlows= [(\"main\", 'runFlow' flowname ) --- ,(\"hello\", 'stateless' statelesproc) --- ,(\"trans\", 'transient' $ runflow transientflow] --- options msgs= \"in the browser choose\\n\\n\" ++ --- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] --- @ -hackMessageFlow :: ProcList -> (Env -> IO Response) -hackMessageFlow messageFlows = - unsafePerformIO (addMessageFlows messageFlows) `seq` - wFMiddleware (\env -> (pwfname env) `elem` paths) - (\env -> defaultResponse $ "usage: http//server/" ++ show paths ++ "?verb") - where - (paths,_)= unzip messageFlows - -splitPath ""= ("","","") -splitPath str= - let - strr= reverse str - (ext, rest)= span (/= '.') strr - (mod, path)= span(/='/') $ tail rest - in (tail $ reverse path, reverse mod, reverse ext) - - - -hackWorkflow :: Env -> IO Response -hackWorkflow req1= do - - - let httpreq1= http req1 -- !> (show req1) - let cookies= getCookies httpreq1 - - (flow , retcookies) <- case lookup "flow" cookies of - Just fl -> return (fl, []) - Nothing -> do - fl <- newFlow - return (fl, [("flow", fl, "/",Nothing)]) -{- - putStateCookie req1 cookies - let retcookies= case getStateCookie req1 of - Nothing -> retcookies1 - Just ck -> ck:retcookies1 --} - - let [(input, str)]= - case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of - (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack . hackInput $ req1 - (GET, _) -> urlDecode . queryString $ req1 - _ -> [([("","")],"")] - - - let req = case retcookies of - [] -> req1{http= input ++ cookies ++ http req1} -- !> "REQ" - _ -> req1{http= ("flow", flow): input ++ cookies ++ http req1} -- !> "REQ" - - wfs <- getMessageFlows - (resp',th) <- webScheduler req wfs - - - let resp''= toResponse resp' - let headers1= case retcookies of [] -> headers resp''; _ -> ctype : cookieHeaders retcookies - let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} - - - return resp - - -------persistent state in cookies (not tested) - -tvresources :: MVar (Maybe ( M.Map string string)) -tvresources= unsafePerformIO $ newMVar Nothing -statCookieName= "stat" - -putStateCookie req cookies= - case lookup statCookieName cookies of - Nothing -> return () - Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ - \mmap -> case mmap of - Just map -> return $ Just $ M.insert (keyResource req) str map - Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] - -getStateCookie req= do - mr<- readMVar tvresources - case mr of - Nothing -> return Nothing - Just map -> case M.lookup (keyResource req) map of - Nothing -> return Nothing - Just str -> do - swapMVar tvresources Nothing - return $ Just (statCookieName, str , "/") - -{- -persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} - where - writeResource stat= modifyMVar_ tvresources $ \mmap -> - case mmap of - Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map - Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] - readResource stat= do - mstr <- withMVar tvresources $ \mmap -> - case mmap of - Just map -> return $ M.lookup (keyResource stat) map - Nothing -> return Nothing - case mstr of - Nothing -> return Nothing - Just str -> return $ deserialize str - - deleteResource stat= modifyMVar_ tvresources $ \mmap-> - case mmap of - Just map -> return $ Just $ M.delete (keyResource stat) map - Nothing -> return $ Nothing - --} --- | Users --- ---instance Display String TResp where --- column vs= concat ["" ++ 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 = "
"++ form ++ input "cancel" "button" "cancel" False++ input "submit" "submit" "submit" False ++ "
" --- 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 "" else "") ++ --- (if not . null $ head then ""++concat [""| h <- head] ++ "" else "")++ --- (concat ["" ++ concat[""| v <- row] ++ "" | row <- rows]) ++ --- "
" ++ title ++ "
"++ h ++ "
"++ v ++ "
" --- --- ----- 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) -} -- %> - {-<% when (not . null $ caption)-} <%[| cap <- caption] %> -- %> - <%[ <% [| v <- row] %> | row <- rows] %> -
<% title %>
<%cap %>
<% v %>
- - 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 deleted file mode 100644 --- a/MFlow/Hack/Response.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances - -XFlexibleInstances -XDeriveDataTypeable #-} -module MFlow.Hack.Response where - -import Hack -import MFlow.Cookies -import Data.ByteString.Lazy.Char8 -import MFlow(HttpData(..)) -import Data.Typeable -import Data.Monoid - ---import Debug.Trace --- ---(!>)= flip trace - -class ToResponse a where - toResponse :: a -> Response - - - -data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable - -instance Monoid TResp where - mempty = TRempty - mappend (TResp x) (TResp y)= - case cast y of - Just y' -> TResp $ mappend x y' - Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) - - - -defaultResponse :: String -> IO Response -defaultResponse msg= return . toResponse $ "

Page not found or error ocurred:
" ++ msg ++ "
home

" - - -instance ToResponse TResp where - toResponse (TResp x)= toResponse x - toResponse (TRespR r)= toResponse r - -instance ToResponse Response where - toResponse = id - -instance ToResponse ByteString where - toResponse x= Response{status=200, headers=[ctype {-,("Content-Length",show $ B.length x) -}], body= x} - -instance ToResponse String where - toResponse x= Response{status=200, headers=[ctype{-,("Content-Length",show $ B.length x) -}], body= pack x} - - - - -instance ToResponse a => ToResponse (HttpData a) where - toResponse (HttpData cookies x)= (toResponse x) {headers= cookieHeaders cookies} - --- ---instance ToResponse (HSP XML) where --- toResponse xml=unsafePerformIO $ do --- (_,html) <- evalHSP Nothing xml --- let bs= pack $ renderAsHTML html --- return $ toResponse bs - - - -{- -instance IResource Env where - keyResource env=user ++ "#" ++ flowId where - user= case lookup "user" $ http env of - Nothing -> "nokey" - Just user -> user - flowId= case lookup "flow"$ http env of - Nothing -> error ": No FlowID" - Just fl -> fl - serialize= show - deserialize= error "Env deserialize: undefined" - writeResource _ = return () - readResource _ = undefined --} ---instance Read Env where --- readsPrec= error "Env Read: undefined" -{- -instance IResource Response where - keyResource _ = "resp" - serialize= show - deserialize= error "Response deserialize: undefined" - writeResource _ = return () - readResource _ = undefined --} - - -instance Typeable Env where - typeOf = \_-> mkTyConApp (mkTyCon3 "hack" "Hack" "Env") [] - -instance Typeable Response where - typeOf = \_-> mkTyConApp (mkTyCon3 "Hack" "Hack" "Response")[] diff --git a/MFlow/Hack/XHtml.hs b/MFlow/Hack/XHtml.hs deleted file mode 100644 --- a/MFlow/Hack/XHtml.hs +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : MFlow.Hack.XHtml --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{- -Instantiations necessary for "MFlow.Hack" to use "Text.XHtml" as format for generating output --} - -{-# OPTIONS -XMultiParamTypeClasses #-} - -module MFlow.Hack.XHtml ( - -) where -import MFlow -import Hack -import MFlow.Hack.Response -import Text.XHtml -import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString) - -instance ToResponse Html where - toResponse x= Response{ status=200, headers=[] - , Hack.body= pack $ showHtml x} - - - diff --git a/MFlow/Hack/XHtml/All.hs b/MFlow/Hack/XHtml/All.hs deleted file mode 100644 --- a/MFlow/Hack/XHtml/All.hs +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : MFlow.Hack.XHtml.All --- Copyright : --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module MFlow.Hack.XHtml.All ( - -module MFlow.Hack -,module MFlow.Forms -,module MFlow.Forms.XHtml -,module MFlow.Hack.XHtml -,module Hack - -,module Hack.Handler.SimpleServer - -,module Text.XHtml.Strict - -,module Control.Applicative - - -) where - -import MFlow.Hack -import MFlow.Forms -import MFlow.Forms.XHtml -import MFlow.Hack.XHtml - -import Hack(Env) -import Hack.Handler.SimpleServer - - - -import Text.XHtml.Strict hiding (widget) - -import Control.Applicative - diff --git a/src/MFlow.hs b/src/MFlow.hs new file mode 100644 --- /dev/null +++ b/src/MFlow.hs @@ -0,0 +1,358 @@ +{- | Non monadic low level support stuff for the MFlow application server. +it implements an scheduler of queued 'Processable' messages that are served according with +the source identification and the verb invoked. +Ths scheduler executed the appropriate workflow (using the workflow package) +the workflow may send additional messages to the source, identified by a 'Token' +. The computation state is logged and can be recovered. + +The message communication is trough polimorphic, monoidal queues. +There is no asumption about message codification, so instantiations +of this scheduler for many different infrastructures is possible. +"MFlow.Hack" is an instantiation for the Hack interface in a Web context. + +"MFlow.Wai" is a instantiation for the WAI interface. + +In order to manage resources, the serving process may die after a timeout. +as well as the logged state, usually, after a longer timeout . + +All these details are hidden in the monad of "MFlow.Forms" that provides +an higuer level interface. Altroug fragments streaming 'sendFragment' 'sendEndFragment' +are only provided at this level. + +'stateless' and 'transient' serving processes are possible. `stateless` are request-response + with no intermediate messaging dialog. `transient` processes have no persistent + state, so they restart anew after a timeout or a crash. + +-} + + +{-# LANGUAGE DeriveDataTypeable, UndecidableInstances + ,ExistentialQuantification, MultiParamTypeClasses + ,FunctionalDependencies + ,TypeSynonymInstances + ,FlexibleInstances + ,FlexibleContexts + ,RecordWildCards + ,OverloadedStrings + #-} +module MFlow ( +Params, Req(..), Resp(..), Workflow, HttpData(..),Processable(..), ToHttpData(..), Token(..), getToken, ProcList +,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment, sendEndFragment +,msgScheduler, addMessageFlows,getMessageFlows, transient, stateless,anonymous +,noScript,hlog,addTokenToList,deleteTokenInList, btag, bhtml, bbody,Attribs) + +where +import Control.Concurrent.MVar +import Data.IORef +import GHC.Conc(unsafeIOToSTM) +import Data.Typeable +import Data.Maybe(isJust, isNothing, fromMaybe, fromJust) +import Data.Char(isSeparator) +import Data.List(isPrefixOf, elem , span, (\\)) +import Control.Monad(when) + +import Data.Monoid +import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId) + + +import Unsafe.Coerce +import System.IO.Unsafe +import Data.TCache.DefaultPersistence hiding(Indexable(..)) + +import Data.ByteString.Lazy.Char8 as B(ByteString, pack, unpack,empty,append,cons,fromChunks) + +import qualified Data.Map as M +import System.IO +import System.Time +import Control.Workflow +import MFlow.Cookies + +--import Debug.Trace +--(!>)= flip trace + + +--type Header= (String,String) +data HttpData = HttpData Params [Cookie] ByteString | Error WFErrors ByteString deriving (Typeable, Show) + +instance ToHttpData HttpData where + toHttpData= id + +instance ToHttpData ByteString where + toHttpData bs= HttpData [] [] bs + +instance Monoid HttpData where + mempty= HttpData [] [] empty + mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s' + +-- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname +type ProcList = WorkflowList IO Token () + + +data Req = forall a.( Processable a,Typeable a)=> Req a deriving Typeable + +type Params = [(String,String)] + +class Processable a where + pwfname :: a -> String + puser :: a -> String + pind :: a -> String + getParams :: a -> Params +-- getServer ::a -> String +-- getPath :: a -> String +-- getPort :: a -> Int + + +instance Processable Req where + pwfname (Req x)= pwfname x + puser (Req x)= puser x + pind (Req x)= pind x + getParams (Req x)= getParams x +-- getServer (Req x)= getServer x +-- getPath (Req x)= getPath x +-- getPort (Req x)= getPort x + +data Resp = Fragm HttpData + | EndFragm HttpData + | Resp HttpData + + +anonymous= "anon#" +noScript = "noscript" + +data Token = Token{twfname,tuser, tind :: String , q :: MVar Req, qr :: MVar Resp} deriving Typeable + +instance Indexable Token where + key (Token w u i _ _ )= + if u== anonymous then u++ i -- ++ "@" ++ w + else u -- ++ "@" ++ w + +instance Show Token where + show t = "Token " ++ key t + +instance Read Token where + readsPrec _ ('T':'o':'k':'e': 'n':' ':str1) + | anonymous `isPrefixOf` str1= [(Token w anonymous i (newVar 0) (newVar 0), tail str2)] + | otherwise = [(Token w ui "0" (newVar 0) (newVar 0), tail str2)] + + where + + (ui,str')= span(/='@') str1 + i = drop (length anonymous) ui + (w,str2) = span (not . isSeparator) $ tail str' + newVar _= unsafePerformIO $ newEmptyMVar + + + readsPrec _ str= error $ "parse error in Token read from: "++ str + +instance Serializable Token where + serialize = pack . show + deserialize= read . unpack + +iorefqmap= unsafePerformIO . newMVar $ M.empty + +addTokenToList t@Token{..} = + modifyMVar_ iorefqmap $ \ map -> + return $ M.insert ( tind ++ twfname ++ tuser ) t map + +deleteTokenInList t@Token{..} = + modifyMVar_ iorefqmap $ \ map -> + return $ M.delete (tind ++ twfname ++ tuser) map + +getToken msg= do + qmap <- readMVar iorefqmap + let u= puser msg ; w= pwfname msg ; i=pind msg + let mqs = M.lookup ( i ++ w ++ u) qmap + case mqs of + Nothing -> do + q <- newEmptyMVar -- `debug` (i++w++u) + qr <- newEmptyMVar + let token= Token w u i q qr + addTokenToList token + return token + + Just token-> return token + + +{- +instance (Monad m, Show a) => Traceable (Workflow m a) where + debugf iox str = do + x <- iox + return $ debug x (str++" => Workflow "++ show x) +-} +-- | send a complete response +send :: ToHttpData a => Token -> a -> IO() +send (Token _ _ _ queue qresp) msg= do + putMVar qresp . Resp $ toHttpData msg + +sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush " + +-- | send a response fragment. Useful for streaming. the last packet must sent trough 'send' +sendFragment :: ToHttpData a => Token -> a -> IO() +sendFragment (Token _ _ _ _ qresp) msg= putMVar qresp . Fragm $ toHttpData msg + +sendEndFragment :: ToHttpData a => Token -> a -> IO() +sendEndFragment (Token _ _ _ _ qresp ) msg= putMVar qresp . EndFragm $ toHttpData msg + +--emptyReceive (Token queue _ _)= emptyQueue queue +receive :: Typeable a => Token -> IO a +receive t= receiveReq t >>= return . fromReq + +flushRec t@(Token _ _ _ queue _)= do + empty <- isEmptyMVar queue + when (not empty) $ takeMVar queue >> return () + + +receiveReq :: Token -> IO Req +receiveReq (Token _ _ _ queue _)= readMVar queue -- !> "receiveReqSTM" + +fromReq :: Typeable a => Req -> a +fromReq (Req x) = x' where + x'= case cast x of + Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x') + Just y -> y + + + +receiveReqTimeout :: Int + -> Integer + -> Token + -> IO Req +receiveReqTimeout 0 0 t= receiveReq t +receiveReqTimeout time time2 t= + let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t) + + +delMsgHistory t = do + + let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t + delWFHistory1 statKey -- `debug` "delWFHistory" + + + +-- ! to add a simple monadic computation of type (a -> IO b) to the list +-- of the scheduler +stateless :: (ToHttpData b) => (Params -> IO b) -> (Token -> Workflow IO ()) +stateless f = transient $ \tk ->do + req <- receiveReq tk + resp <- f (getParams req) + sendFlush tk resp + +-- | to add a monadic computation that send and receive messages, but does +-- not store its state in permanent storage. The process once stopped, will restart anew +transient :: (Token -> IO ()) -> (Token -> Workflow IO ()) +transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) ) + + +_messageFlows :: MVar (M.Map String (Token-> Workflow IO ())) +_messageFlows= unsafePerformIO $ newMVar M.empty -- [(String,Token -> Workflow IO ())]) + + +addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union ms (M.fromList wfs)) + +getMessageFlows = readMVar _messageFlows + +class ToHttpData a where + toHttpData :: a -> HttpData + + + +--tellToWF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c +tellToWF (Token _ _ _ queue qresp ) msg = do + putMVar queue $ Req msg + m <- takeMVar qresp -- !> ("********antes de recibir" ++ show(unsafePerformIO myThreadId)) + case m of + Resp r -> return r -- !> ("*********** RECIBIDO"++ show(unsafePerformIO myThreadId)) + Fragm r -> do + result <- getStream r + return result + + + where + + getStream r = do + mr <- takeMVar qresp + case mr of + Resp _ -> error "\"send\" used instead of \"sendFragment\" or \"sendEndFragment\"" + Fragm h -> do + rest <- unsafeInterleaveIO $ getStream h + let result= mappend r rest + return result + EndFragm h -> do + let result= mappend r h + return result + + + + + + +--data Error= Error String deriving (Read, Show, Typeable) + +instance ToHttpData String where + toHttpData= HttpData [] [] . pack + +msgScheduler + :: (Typeable a,Processable a) + => a -> IO (HttpData, ThreadId) +msgScheduler x = do + token <- getToken x + + th <- startMessageFlow (pwfname x) token + r<- tellToWF token x + return (r,th) + where + + startMessageFlow wfname token = + forkIO $ do + wfs <- getMessageFlows + r <- startWF wfname token wfs -- !>( "init wf " ++ wfname) + case r of + Left NotFound -> sendFlush token (Error NotFound $ "Not found: " <> pack wfname) + Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname) + Left Timeout -> return() -- !> "Timeout in msgScheduler" + Left (WFException e)-> do + let user= key token + print e + logError user wfname e + moveState wfname token token{tuser= "error/"++tuser token} + + case user of + "admin" -> sendFlush token (show e) -- !> ("WF error: "++ show e) + _ -> sendFlush token ("An Error has ocurred." :: ByteString) + + Right _ -> do +-- let msg= "finished Flow "++ wfname++ " restarting" +-- logError (key token) wfname msg +-- startMessageFlow wfname token wfs + + delMsgHistory token; return () -- !> ("finished " ++ wfname) + + + logError u wf e= do + hSeek hlog SeekFromEnd 0 + TOD t _ <- getClockTime + hPutStrLn hlog (","++show [u,show t,wf,e]) >> hFlush hlog + +logFileName= "errlog" +hlog= unsafePerformIO $ openFile logFileName ReadWriteMode + + +-- basic bytestring XML tags +type Attribs= [(String,String)] +-- | writes a XML tag in a ByteString. It is the most basic form of formatting. For +-- more sophisticated formatting , use "Text.XHtml" or "HSP". +btag :: String -> Attribs -> ByteString -> ByteString +btag t rs v= "<" `append` pt `append` attrs rs `append` ">" `append` v `append`"" + where + pt= pack t + attrs []= B.empty + attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs +-- | +-- > bhtml ats v= btag "html" ats v +bhtml :: Attribs -> ByteString -> ByteString +bhtml ats v= btag "html" ats v + +-- | +-- > bbody ats v= btag "body" ats v +bbody :: Attribs -> ByteString -> ByteString +bbody ats v= btag "body" ats v diff --git a/src/MFlow/Cookies.hs b/src/MFlow/Cookies.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Cookies.hs @@ -0,0 +1,212 @@ +{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-} + +module MFlow.Cookies +(Cookie,ctype,urlDecode,cookieuser,cookieHeaders,getCookies) +where +import Control.Monad(MonadPlus(..), guard, replicateM_, when) +import Data.Char +import Data.Maybe(fromMaybe) +import System.IO.Unsafe +import Control.Exception(handle) +import Data.Typeable +import Data.Maybe(fromJust) +import Unsafe.Coerce +import Data.Monoid + + + +import Text.Parsec +import Control.Monad.Identity +--import Text.Parsec.Token + +ctype= ("Content-Type", "text/html") + +type Cookie= (String,String,String,Maybe String) + +cookieuser :: String +cookieuser= "cookieuser" + +--getCookies :: Params -> Params +getCookies httpreq= + case lookup "Cookie" $ httpreq of + Just str -> splitCookies str + Nothing -> [] + +cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs + +showCookie :: Cookie -> String +showCookie (n,v,p,me) = n <> "=" <> v <> "; path=" + <> p <> showMaxAge me <> "\n" + + where + showMaxAge Nothing = "" + showMaxAge (Just e) = "; Max-age=" <> e + + +--showCookie :: Cookie -> String +--showCookie (n,v,p,me) = +-- let e= fromMaybe "" me +-- in showString n . showString "=" . showString v . showString "; path=" +-- . showString p . showMaxAge e . showString "\n" $ "" +-- +-- +--showMaxAge [] = showString "" +--showMaxAge e = showString "; Max-age=" . showString e + + + + + + +splitCookies cookies = f cookies [] + where + f s r | null s = r + f xs0 r = + let + xs = dropWhile (==' ') xs0 + name = takeWhile (/='=') xs + xs1 = dropWhile (/='=') xs + xs2 = dropWhile (=='=') xs1 + val = takeWhile (/=';') xs2 + xs3 = dropWhile (/=';') xs2 + xs4 = dropWhile (==';') xs3 + xs5 = dropWhile (==' ') xs4 + in f xs5 ((name,val):r) + +----------------------------- + +--------------------------------------------- + +-- %*************************************************************************** +-- %* * +-- \subsection[CGI-Parser]{Yet another combinator parser library}. chuck of code taken from Erik Meijer +-- %* * +-- %*************************************************************************** + +-- NOTE: This is all a little bit of a sledgehammer here for the simple task +-- at hand... + +-- The parser monad + +-- +--newtype Parser a = Parser (String -> [(a,String)]) +-- +--instance Functor Parser where +-- -- map :: (a -> b) -> (Parser a -> Parser b) +-- fmap f (Parser p) = Parser (\inp -> [(f v, out) | (v, out) <- p inp]) +-- +--instance Monad Parser where +-- -- return :: a -> Parser a +-- return v = Parser (\inp -> [(v,inp)]) +-- +-- -- >>= :: Parser a -> (a -> Parser b) -> Parser b +-- (Parser p) >>= f = Parser (\inp -> concat [papply (f v) out +-- | (v,out) <- p inp]) +-- +--instance MonadPlus Parser where +-- -- zero :: Parser a +-- mzero = Parser (\_ -> []) +-- -- (++) :: Parser a -> Parser a -> Parser a +-- (Parser p) `mplus` (Parser q) = Parser (\inp -> (p inp ++ q inp)) +-- +-- +---- Other primitive parser combinators +-- +-- +--item :: Parser Char +--item = Parser (\inp -> case inp of +-- [] -> [] +-- (x:xs) -> [(x,xs)]) +-- +--force :: Parser a -> Parser a +--force (Parser p) = Parser (\inp -> let x = p inp in +-- (fst (head x), snd (head x)) : tail x) +-- +--first :: Parser a -> Parser a +--first (Parser p) = Parser (\inp -> case p inp of +-- [] -> [] +-- (x:_) -> [x]) +-- +--papply :: Parser a -> String -> [(a,String)] +--papply (Parser p) inp = p inp +-- +-- +---- Derived combinators +-- +-- +--(+++) :: Parser a -> Parser a -> Parser a +--p +++ q = first (p `mplus` q) +-- +--sat :: (Char -> Bool) -> Parser Char +--sat p = do {x <- item; guard (p x); return x} +-- +--many :: Parser a -> Parser [a] +--many p = force (many1 p +++ return []) +-- +--many1 :: Parser a -> Parser [a] +--many1 p = do {x <- p; xs <- many p; return (x:xs)} +-- +--sepby :: Parser a -> Parser b -> Parser [a] +--p `sepby` sep = (p `sepby1` sep) +++ return [] +-- +--sepby1 :: Parser a -> Parser b -> Parser [a] +--p `sepby1` sep = do x <- p +-- xs <- many (do {sep; p}) +-- return(x:xs) +-- +--char :: Char -> Parser Char +--char x = sat (x==) +-- +--alphanum :: Parser Char +--alphanum = sat (\c -> isAlphaNum c || c == '@' || c =='\'' ) -- Added @ as a valid character +-- +--string :: String -> Parser String +--string "" = return "" +--string (x:xs) = do char x +-- string xs +-- return (x:xs) +-- +--hexdigit :: Parser Char +--hexdigit = sat isHexDigit +-- +-- +--readEnv :: Parser [(String,String)] +readEnv = (do + n <- urlEncoded + string "=" + v <- urlEncoded + return (n,v)) `sepBy` (string "&") + +urlEncoded :: Parsec String () String +urlEncoded + = many ( alphaNum `mplus` extra `mplus` safe + `mplus` do{ char '+' ; return ' '} + `mplus` do{ char '%' ; hexadecimal } + ) + + +--extra :: Parser Char +extra = satisfy (`Prelude.elem` "!*'(),/") +-- +--safe :: Parser Char +safe = satisfy (`Prelude.elem` "$-_.") +---- +--hexadecimal :: Parser HexString +hexadecimal = do d1 <- hexDigit + d2 <- hexDigit + return .chr $ toInt d1* 16 + toInt d2 + where toInt d | isDigit d = ord d - ord '0' + toInt d | isHexDigit d = (ord d - ord 'A') + 10 + toInt d = error ("hex2int: illegal hex digit " ++ [d]) +--type HexString = String + +--hex2int :: HexString -> Int +--hex2int ds = Prelude.foldl (\n d -> n*16+d) 0 (Prelude.map (toInt . toUpper) ds) +-- where toInt d | isDigit d = ord d - ord '0' +-- toInt d | isHexDigit d = (ord d - ord 'A') + 10 +-- toInt d = error ("hex2int: illegal hex digit " ++ [d]) + +--urlDecode :: String -> [([(String, String)],String)] +urlDecode str= case parse readEnv "" str of -- let Parser p= readEnv in p str + Left err -> error $ "urlDecode: decode error: " ++ show err + Right r -> r diff --git a/src/MFlow/FileServer.hs b/src/MFlow/FileServer.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/FileServer.hs @@ -0,0 +1,326 @@ +{- | An file server for frequently accessed files, such are static web pages and image decorations, icons etc +that are cached (memoized) in the program space, for enhanced performance. +It uses 'Data.TCache.Memoization'. +The caching-uncaching follows the `setPersist` criteria. +-} +----------------------------------------------------------------------------- +-- +-- Module : FileServer +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- +-- +----------------------------------------------------------------------------- +{-# OPTIONS -XScopedTypeVariables #-} +module MFlow.FileServer (addFileServerWF, linkFile,setFilesPath + +) where + +import MFlow +import Control.Monad.State +import Data.TCache.Memoization + +import System.Directory +import Data.ByteString.Lazy.Char8 as B(readFile,concat,append,pack,empty) + + +import Data.Char +import Data.List +import System.IO.Unsafe +import Data.IORef +import Data.Monoid + +--import Debug.Trace +--(!>)= flip trace + +rfilesPath= unsafePerformIO $ newIORef "files/" + +-- | Set the path of the files in the web server. the links to files are relative to it +setFilesPath :: String -> IO () +setFilesPath path= writeIORef rfilesPath path + +pathPrm= "path" +fileServe ::(Token -> Workflow IO ()) +fileServe = stateless $ \env -> do + case lookup pathPrm env of + Nothing -> error " no file specified" + Just path' ->do + when(let hpath= head path' in hpath == '/' || hpath =='\\') $ error noperm + when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm + filesPath <- readIORef rfilesPath + let path= filesPath ++ path' + isDirectory <- doesDirectoryExist path -- !> path + case isDirectory of + True -> directory1 $ path ++ "/" + False -> do + isFile <- doesFileExist path + case isFile of + True -> servefile path + False -> return . pack $ "path not found" + + where + dropBack ".."= ".." + + dropBack path + + | "../" `isPrefixOf` revpath =reverse . maybetail $ dropWhile (/= '/') $ drop 3 revpath + | otherwise= path + where + revpath= reverse path +-- maybetail ""= "." + maybetail xs= tail xs + noperm= "no permissions" + servefile path= do + mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `catch` const (return Nothing) + case mr of + Nothing -> return . pack $ "no permissions" + Just r -> return r +-- let ext = reverse . takeWhile (/='.') $ reverse path +-- mmime= lookup (map toLower ext) mimeTable +-- mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream" +-- mimet= [("Content-Type",mime)] +-- in return r -- $ HttpData mimet [] r + +-- | Is the flow to be added to the list in order to stream any file from the filesystem +-- for example, images +-- +-- This app includes the fileServe flow: +-- +-- @ +-- addFileServerWF +-- run 80 $ hackMessageFlow messageFlows +-- adminLoop +-- where +-- messageFlows= [("noscript" , transient $ runFlow showStories) +-- ,("admin" , transient $ runFlow admin) +-- ,("mail" , transient $ runFlow mail)]@ +-- +-- | Add the fileServer to the list of server flows +addFileServerWF= addMessageFlows [("file", fileServe)] + + + +-- | Creates the url of file path. To be used in ordinary links to files. +-- in Text.XHtml, a image would be embeded as +-- +-- @image ![src linkFile imagepath]@ +-- +-- in HSP: +-- +-- @\@ + +-- | Given the relative path of a file, it return the content of the @href@ element in a html link +linkFile :: String -> String +linkFile path= "file?path=" <> path + +directory :: Token -> Workflow IO () +directory = stateless $ \_ -> do + path <- readIORef rfilesPath + directory1 path + +directory1 path = do + fs <- getDirectoryContents path + return $ B.concat [btag "a" [("href",linkFile ( path ++ file))] (B.pack file) `append` btag "br" [] B.empty | file <- fs] + +{- +mimeTable=[ + ("html", "text/html"), + ("htm", "text/html"), + ("txt", "text/plain"), + ("jpeg", "image/jpeg"), + ("pdf", "application/pdf"), + ("js", "application/x-javascript"), + ("gif", "image/gif"), + ("bmp", "image/bmp"), + ("ico", "image/x-icon"), + ("doc", "application/msword"), + ("jpg", "image/jpeg"), + ("eps", "application/postscript"), + ("zip", "application/zip"), + ("exe", "application/octet-stream"), + ("tif", "image/tiff"), + ("tiff", "image/tiff"), + ("mov", "video/quicktime"), + ("movie", "video/x-sgi-movie"), + ("mp2", "video/mpeg"), + ("mp3", "audio/mpeg"), + ("mpa", "video/mpeg"), + ("mpe", "video/mpeg"), + ("mpeg", "video/mpeg"), + ("mpg", "video/mpeg"), + ("mpp", "application/vnd.ms-project"), + ("323", "text/h323"), + ("*", "application/octet-stream"), + ("acx", "application/internet-property-stream"), + ("ai", "application/postscript"), + ("aif", "audio/x-aiff"), + ("aifc", "audio/x-aiff"), + ("aiff", "audio/x-aiff"), + ("asf", "video/x-ms-asf"), + ("asr", "video/x-ms-asf"), + ("asx", "video/x-ms-asf"), + ("au", "audio/basic"), + ("avi", "video/x-msvideo"), + ("axs", "application/olescript"), + ("bas", "text/plain"), + ("bcpio", "application/x-bcpio"), + ("bin", "application/octet-stream"), + ("c", "text/plain"), + ("cat", "application/vnd.ms-pkiseccat"), + ("cdf", "application/x-cdf"), + ("cdf", "application/x-netcdf"), + ("cer", "application/x-x509-ca-cert"), + ("class", "application/octet-stream"), + ("clp", "application/x-msclip"), + ("cmx", "image/x-cmx"), + ("cod", "image/cis-cod"), + ("cpio", "application/x-cpio"), + ("crd", "application/x-mscardfile"), + ("crl", "application/pkix-crl"), + ("crt", "application/x-x509-ca-cert"), + ("csh", "application/x-csh"), + ("css", "text/css"), + ("dcr", "application/x-director"), + ("der", "application/x-x509-ca-cert"), + ("dir", "application/x-director"), + ("dll", "application/x-msdownload"), + ("dms", "application/octet-stream"), + ("dot", "application/msword"), + ("dvi", "application/x-dvi"), + ("dxr", "application/x-director"), + ("eps", "application/postscript"), + ("etx", "text/x-setext"), + ("evy", "application/envoy"), + ("fif", "application/fractals"), + ("flr", "x-world/x-vrml"), + ("gtar", "application/x-gtar"), + ("gz", "application/x-gzip"), + ("h", "text/plain"), + ("hdf", "application/x-hdf"), + ("hlp", "application/winhlp"), + ("hqx", "application/mac-binhex40"), + ("hta", "application/hta"), + ("htc", "text/x-component"), + ("htt", "text/webviewhtml"), + ("ief", "image/ief"), + ("iii", "application/x-iphone"), + ("ins", "application/x-internet-signup"), + ("isp", "application/x-internet-signup"), + ("jfif", "image/pipeg"), + ("jpe", "image/jpeg"), + ("latex", "application/x-latex"), + ("lha", "application/octet-stream"), + ("lsf", "video/x-la-asf"), + ("lsx", "video/x-la-asf"), + ("lzh", "application/octet-stream"), + ("m13", "application/x-msmediaview"), + ("m14", "application/x-msmediaview"), + ("m3u", "audio/x-mpegurl"), + ("man", "application/x-troff-man"), + ("mdb", "application/x-msaccess"), + ("me", "application/x-troff-me"), + ("mht", "message/rfc822"), + ("mhtml", "message/rfc822"), + ("mid", "audio/mid"), + ("mny", "application/x-msmoney"), + ("mpv2", "video/mpeg"), + ("ms", "application/x-troff-ms"), + ("msg", "application/vnd.ms-outlook"), + ("mvb", "application/x-msmediaview"), + ("nc", "application/x-netcdf"), + ("nws", "message/rfc822"), + ("oda", "application/oda"), + ("p10", "application/pkcs10"), + ("p12", "application/x-pkcs12"), + ("p7b", "application/x-pkcs7-certificates"), + ("p7c", "application/x-pkcs7-mime"), + ("p7m", "application/x-pkcs7-mime"), + ("p7r", "application/x-pkcs7-certreqresp"), + ("p7s", "application/x-pkcs7-signature"), + ("pbm", "image/x-portable-bitmap"), + ("pfx", "application/x-pkcs12"), + ("pgm", "image/x-portable-graymap"), + ("pko", "application/ynd.ms-pkipko"), + ("pma", "application/x-perfmon"), + ("pmc", "application/x-perfmon"), + ("pml", "application/x-perfmon"), + ("pmr", "application/x-perfmon"), + ("pmw", "application/x-perfmon"), + ("pnm", "image/x-portable-anymap"), + ("pot", "application/vnd.ms-powerpoint"), + ("ppm", "image/x-portable-pixmap"), + ("pps", "application/vnd.ms-powerpoint"), + ("ppt", "application/vnd.ms-powerpoint"), + ("prf", "application/pics-rules"), + ("ps", "application/postscript"), + ("pub", "application/x-mspublisher"), + ("qt", "video/quicktime"), + ("ra", "audio/x-pn-realaudio"), + ("ram", "audio/x-pn-realaudio"), + ("ras", "image/x-cmu-raster"), + ("rgb", "image/x-rgb"), + ("rmi", "audio/mid"), + ("roff", "application/x-troff"), + ("rtf", "application/rtf"), + ("rtx", "text/richtext"), + ("scd", "application/x-msschedule"), + ("sct", "text/scriptlet"), + ("setpay", "application/set-payment-initiation"), + ("setreg", "application/set-registration-initiation"), + ("sh", "application/x-sh"), + ("shar", "application/x-shar"), + ("sit", "application/x-stuffit"), + ("snd", "audio/basic"), + ("spc", "application/x-pkcs7-certificates"), + ("spl", "application/futuresplash"), + ("src", "application/x-wais-source"), + ("sst", "application/vnd.ms-pkicertstore"), + ("stl", "application/vnd.ms-pkistl"), + ("stm", "text/html"), + ("sv4cpio", "application/x-sv4cpio"), + ("sv4crc", "application/x-sv4crc"), + ("svg", "image/svg+xml"), + ("swf", "application/x-shockwave-flash"), + ("t", "application/x-troff"), + ("tar", "application/x-tar"), + ("tcl", "application/x-tcl"), + ("tex", "application/x-tex"), + ("texi", "application/x-texinfo"), + ("texinfo", "application/x-texinfo"), + ("tgz", "application/x-compressed"), + ("tr", "application/x-troff"), + ("trm", "application/x-msterminal"), + ("tsv", "text/tab-separated-values"), + ("uls", "text/iuls"), + ("ustar", "application/x-ustar"), + ("vcf", "text/x-vcard"), + ("vrml", "x-world/x-vrml"), + ("wav", "audio/x-wav"), + ("wcm", "application/vnd.ms-works"), + ("wdb", "application/vnd.ms-works"), + ("wks", "application/vnd.ms-works"), + ("wmf", "application/x-msmetafile"), + ("wps", "application/vnd.ms-works"), + ("wri", "application/x-mswrite"), + ("wrl", "x-world/x-vrml"), + ("wrz", "x-world/x-vrml"), + ("xaf", "x-world/x-vrml"), + ("xbm", "image/x-xbitmap"), + ("xla", "application/vnd.ms-excel"), + ("xlc", "application/vnd.ms-excel"), + ("xlm", "application/vnd.ms-excel"), + ("xls", "application/vnd.ms-excel"), + ("xlt", "application/vnd.ms-excel"), + ("xlw", "application/vnd.ms-excel"), + ("xof", "x-world/x-vrml"), + ("xpm", "image/x-xpixmap"), + ("xwd", "image/x-xwindowdump"), + ("z", "application/x-compress") + + ] +-} diff --git a/src/MFlow/Forms.hs b/src/MFlow/Forms.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms.hs @@ -0,0 +1,1599 @@ +{-# OPTIONS -XDeriveDataTypeable + -XUndecidableInstances + -XExistentialQuantification + -XMultiParamTypeClasses + -XTypeSynonymInstances + -XFlexibleInstances + -XScopedTypeVariables + -XFunctionalDependencies + -XFlexibleContexts + -XRecordWildCards + -XIncoherentInstances + -XTypeFamilies + -XTypeOperators + -XOverloadedStrings +#-} + +{- | This module implement stateful processes (flows) that are optionally persistent, +that is they may store and retrieve his execution state. They are executed by the MFlow app server. +defined in the "MFlow" module. + +These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to +the calling process. Because flows are stateful, not event driven, the code is more understandable, because +all the flow of request and responses is coded by the programmer in a single function. Allthoug +single request-response flows and callbacks are possible. + +This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an +instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" . +To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here. + +`ask` is the only method for user interaction it runs in the @MFlow view m@ monad, with m the one chosen by the user, usually IO. +It send user interfaces (in the @View view m@ monad) and return statically +typed responses. The user interface definitions are based on a extension of +formLets () with the addition of caching, links, formatting, attributes, + extra combinators, callbaks and modifiers. +The interaction with the user is stateful. In the same computation there may be many +request-response interactions, in the same way that in a console applications. + +* APPLICATION SERVER + +Therefore, session and state management is simple and transparent: it is in the haskell +structures in the scope of the computation. `transient` (normal) procedures have no persistent session state +and `stateless` procedures accept a single request and return the response. + +However `MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that +remember the execution state even after system shutdowns by using the package workflow () internally. +This is transparent. There is no programmer interface for session management. + +The programmer set the process timeout and the session timeout with `setTimeouts` +whether the procedure has been stopped due to the process timeout or due to a system shutdowm, +the procedure restart in the last state when a request for this procedure arrives +(if the procedure uses the `step` monad transformer) + +* WIDGETS + +The correctness of the web responses is assured by the use of formLets. +But unlike formLets in its current form, it permits the definition of widgets. +/A widget is a combination of formLets and links within its own formatting template/, all in +the same definition in the same source file, in plain declarative Haskell style. + +The formatting is abstract. It has to implement the 'FormInput' class. +There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP") +and ByteString. So widgets +can use any formatting that is instance of FormInput. +It is possible to use more than one in the same widget. + +Links defined with `wlink` are treated the same way than forms. They are type safe and return to the same flow of execution. +It is posssible to combine links and forms in the same widget with applicative combinators but also +additional applicative combinators like `<+>` `!*>` , `|*|`. + +* NEW IN THIS RELEASE: + +[@Back Button@] This is probably the first implementation of an stateful Web framework that works well with the back button thanks +to monad magic. (See ) + +[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) +, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if +the widget content comes from a database and it is shared by all users. + +[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated. +The callback may initate a flow of interactions with the user or simply execute an internal computation. +Callbacks are necessary for the creation of abstract container +widgets that may not know the behaviour of its content. The widget manages himself as a black box + +[@Modifiers@] `wmodify` add a modifier of the visualization and result returned by the widget. For example it may hide a +login form and substitute it by the username if already logged. + +Example: + +@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@ + + +[@attributes for formLet elements@] it is not only possible to add Html formatting, but also to add atributes to a formlet element. +This example has three formLet elements with the attribute "size" added, and a string prepended to the second password box. + +@ +userFormLine= + (User \<$> getString (Just "enter user") getPassword submitButton "login") + \<+> fromString " password again" ++> getPassword {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} +> module Main where +> import MFlow.Wai.XHtml.All +> import Data.TCache +> import Control.Monad.Trans +> import Data.Typeable +> import Control.Concurrent +> import Control.Exception as E +> import qualified Data.ByteString.Char8 as SB +> +> import Debug.Trace +> (!>)= flip trace +> +> +> data Ops= Ints | Strings | Actions | Ajax deriving(Typeable,Read, Show) +> main= do +> syncWrite SyncManual +> setFilesPath "" +> addFileServerWF +> forkIO $ run 80 $ waiMessageFlow [("noscript",transient $ runFlow mainf)] +> adminLoop +> +> +> +> stdheader c= p << "you can press the back button to go to the menu"+++ c +> mainf= do +> setHeader stdheader +> r <- ask $ wlink Ints (bold << "Ints") <|> +> br ++> wlink Strings (bold << "Strings") <|> +> br ++> wlink Actions (bold << "Example of a string widget with an action") <|> +> br ++> wlink Ajax (bold << "Simple AJAX example") +> case r of +> Ints -> clickn 0 +> Strings -> clicks "1" +> Actions -> actions 1 +> Ajax -> ajaxsample +> mainf +> +> clickn (n :: Int)= do +> setHeader stdheader +> r <- ask $ wlink "menu" (p << "back") +> |+| getInt (Just n) <* submitButton "submit" +> case r of +> (Just _,_) -> breturn () +> (_, Just n') -> clickn $ n'+1 +> +> +> clicks s= do +> setHeader stdheader +> s' <- ask $ (getString (Just s) +> <* submitButton "submit") +> `validate` (\s -> return $ if length s > 5 then Just "length must be < 5" else Nothing ) +> clicks $ s'++ "1" +> +> +> ajaxheader html= thehtml << ajaxHead << p << "click the box" +++ html +> +> ajaxsample= do +> setHeader ajaxheader +> ajaxc <- ajaxCommand "document.getElementById('text1').value" +> (\n -> return $ "document.getElementById('text1').value='"++show(read n +1)++"'") +> ask $ (getInt (Just 0) breturn() +> +> actions n=do +> ask $ wlink () (p << "exit from action") +> <**((getInt (Just (n+1)) <** submitButton "submit" ) `waction` actions ) +> breturn () +> + + +-} + +module MFlow.Forms( + +-- * Basic definitions +FormLet(..), +FlowM,View, FormInput(..) + +-- * Users +,userRegister, userValidate, isLogged, User(userName), setAdminUser, getAdminName +,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin, userWidget, +-- * User interaction +ask, clearEnv, +-- * Getters to be used in instances of `FormLet` and `Widget` in the Applicative style. + +getString,getInt,getInteger +,getMultilineText,getBool,getOption, getPassword, +getRadio, getRadioActive, +submitButton,resetButton, +validate, noWidget, waction, wmodify, +wlink, wform, +-- * Caching widgets +cachedWidget, +-- * Widget combinators +(<+>),wintersperse,(|*>),(|+|), (**>),(<**),wconcat,(<|>),(<*),(<$>),(<*>), + +-- * Normalized( convert to ByteString) widget combinators +(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.), + +-- * Formatting combinators +(<<<),(<++),(++>),(.) + +-- * ByteString tags +,btag,bhtml,bbody + +-- * Normalization +, flatten, normalize, ToByteString(..) + +-- * Running the flow monad +,runFlow,MFlow.Forms.step, goingBack,breturn + +-- * Setting parameters +,setHeader +,getHeader +,setTimeouts + +-- * Cookies +,setCookie + +-- * Internal use +,MFlowState, getNewName +) +where +import Data.TCache +import Data.TCache.DefaultPersistence +import Data.TCache.Memoization +import MFlow +import MFlow.Cookies +import Data.RefSerialize hiding((<|>)) +import Data.ByteString.Lazy.Char8 as B(ByteString,cons,pack,unpack,append,empty,fromChunks) + +import qualified Data.CaseInsensitive as CI +import Data.Typeable +import Data.Monoid +import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe +import Data.Maybe +import Control.Applicative +import Control.Exception + +import Control.Workflow as WF(step,exec1,Workflow, waitUntilSTM, moveState, unsafeIOtoWF) +import Control.Monad.Identity +import Unsafe.Coerce +import Data.List(intersperse) +import Data.IORef + +import System.IO.Unsafe +import Data.Char(isNumber) +import Network.HTTP.Types.Header + +--import Debug.Trace +--import System.IO (hFlush,stdout) +--(!>)= flip trace + + +instance Serialize a => Serializable a where + serialize= runW . showp + deserialize= runR readp + +data User= User + { userName :: String + , upassword :: String + } deriving (Read, Show, Typeable) + +eUser= User (error1 "username") (error1 "password") + +error1 s= error $ s ++ " undefined" + +userPrefix= "User#" +instance Indexable User where + key User{userName= user}= keyUserName user + +keyUserName n= userPrefix++n + +-- | Register an user/password +userRegister :: MonadIO m => String -> String -> m (DBRef User) +userRegister user password = liftIO . atomically $ newDBRef $ User user password + + + +-- | Authentication against `userRegister`ed users. +-- to be used with `validate` +userValidate :: MonadIO m => (UserStr,PasswdStr) -> m (Maybe String) +userValidate (u,p) = + let user= eUser{userName=u} + in liftIO $ atomically + $ withSTMResources [user] + $ \ mu -> case mu of + [Nothing] -> resources{toReturn= err } + [Just (User _ pass )] -> resources{toReturn= + case pass==p of + True -> Nothing + False -> err + } + + where + err= Just "Username or password invalid" + +data Config = Config UserStr deriving (Read, Show, Typeable) + +keyConfig= "MFlow.Config" +instance Indexable Config where key _= keyConfig +rconf= getDBRef keyConfig + +setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m () +setAdminUser user password= liftIO $ atomically $ do + newDBRef $ User user password + writeDBRef rconf $ Config user + +getAdminName :: MonadIO m => m UserStr +getAdminName= liftIO $ atomically ( readDBRef rconf `onNothing` error "admin user not set" ) >>= \(Config u) -> return u + + +--test= runBackT $ do +-- liftRepeat $ print "hola" +-- n2 <- lift $ getLine +-- lift $ print "n3" +-- +-- n3 <- lift $ getLine +-- if n3 == "back" +-- then fail "" +-- else lift $ print $ n2++n3 + + +data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable) + + +instance (Serialize a) => Serialize (FailBack a ) where + showp (BackPoint x)= insertString (pack iCanFailBack) >> showp x + showp (NoBack x)= insertString (pack noFailBack) >> showp x + showp GoBack = insertString (pack repeatPlease) + + readp = choice [icanFailBackp,repeatPleasep,noFailBackp] + where + noFailBackp = {-# SCC "deserialNoBack" #-} symbol noFailBack >> readp >>= return . NoBack + icanFailBackp = {-# SCC "deserialBackPoint" #-} symbol iCanFailBack >> readp >>= return . BackPoint + repeatPleasep = {-# SCC "deserialbackPlease" #-} symbol repeatPlease >> return GoBack + +iCanFailBack= "B" +repeatPlease= "G" +noFailBack= "N" + +newtype BackT m a = BackT { runBackT :: m (FailBack a ) } + +--instance Monad m => Monad (BackT m) where +-- fail _ = BackT $ return GoBack +-- return x = BackT . return $ NoBack x +-- x >>= f = BackT $ loop +-- where +-- loop = do +-- res<- do +-- v <- runBackT x -- !> "loop" +-- case v of +-- NoBack y -> runBackT (f y) >>= return . Right -- !> "runback" +-- BackPoint y -> do +-- z <- runBackT (f y) -- !> "BACK" +-- case z of +-- GoBack -> return $ Left () -- !> "GoBack" +-- other -> return $ Right other +-- GoBack -> return $ Right GoBack +-- case res of +-- Left _ -> loop +-- Right r -> return r + +instance Monad m => Monad (BackT m) where + fail _ = BackT . return $ GoBack + return x = BackT . return $ NoBack x + x >>= f = BackT $ loop + where + loop = do + v <- runBackT x -- !> "loop" + case v of + NoBack y -> runBackT (f y) -- !> "runback" + BackPoint y -> do + z <- runBackT (f y) -- !> "BACK" + case z of + GoBack -> loop -- !> "GoBack" + other -> return other + GoBack -> return $ GoBack + +--instance Monad m => Monad (BackT m) where +-- fail _ = BackT $ return GoBack +-- return x = BackT . return $ NoBack x +-- x >>= f = BackT $ do +-- v <- runBackT x +-- case v of +-- NoBack y -> runBackT (f y) +-- BackPoint y -> loop +-- where +-- loop= do +-- z <- runBackT (f y) +-- case z of +-- GoBack -> loop +-- other -> return other +-- GoBack -> return GoBack + + +{-# NOINLINE breturn #-} + +-- | Use this instead of return to leave a computation with an ask statement +-- +-- This way when the user press the back button, the computation will return back to +-- according with the user navigation. +breturn x= BackT . return $ BackPoint x -- !> "breturn" + + +instance (MonadIO m) => MonadIO (BackT m) where + liftIO f= BackT $ liftIO f >>= \ x -> return $ NoBack x + +instance (Monad m,Functor m) => Functor (BackT m) where + fmap f g= BackT $ do + mr <- runBackT g + case mr of + BackPoint x -> return . BackPoint $ f x + NoBack x -> return . NoBack $ f x + GoBack -> return $ GoBack + +{-# NOINLINE liftBackT #-} +liftBackT f = BackT $ f >>= \x -> return $ NoBack x +instance MonadTrans BackT where + lift f = BackT $ f >>= \x -> return $ NoBack x + + +instance MonadState s m => MonadState s (BackT m) where + get= lift get -- !> "get" + put= lift . put + +type WState view m = StateT (MFlowState view) m +type FlowM view m= BackT (WState view m) + +data FormElm view a = FormElm [view] (Maybe a) deriving Typeable + +newtype View v m a = View { runView :: WState v m (FormElm v a) } + + +instance (FormInput v, Monoid v,Serialize a) + => Serialize (a,MFlowState v) where + showp (x,s)= case mfDebug s of + False -> showp x + True -> showp(x, mfEnv s) + readp= choice[nodebug, debug] + where + nodebug= readp >>= \x -> return (x, mFlowState0) + debug= do + (x,env) <- readp + return (x,mFlowState0{mfEnv= env}) + + +instance Functor (FormElm view ) where + fmap f (FormElm form x)= FormElm form (fmap f x) + +instance (Monad m,Functor m) => Functor (View view m) where + fmap f x= View $ fmap (fmap f) $ runView x + + +instance (Functor m, Monad m) => Applicative (View view m) where + pure a = View $ return (FormElm [] $ Just a) + View f <*> View g= View $ + f >>= \(FormElm form1 k) -> + g >>= \(FormElm form2 x) -> + return $ FormElm (form1 ++ form2) (k <*> x) + +instance (Functor m, Monad m) => Alternative (View view m) where + empty= View $ return $ FormElm [] Nothing + View f <|> View g= View $ + f >>= \(FormElm form1 k) -> + g >>= \(FormElm form2 x) -> + return $ FormElm (form1 ++ form2) (k <|> x) + + +instance (Monad m, Functor m) => Monad (View view m) where + --View view m a-> (a -> View view m b) -> View view m b + View x >>= f = View $ do + FormElm form1 mk <- x + case mk of + Just k -> do + FormElm form2 mk <- runView $ f k + return $ FormElm (form1++ form2) mk + Nothing -> return $ FormElm form1 Nothing + + return= View . return . FormElm [] . Just + + +instance MonadTrans (View view) where + lift f = View $ lift f >>= \x -> return $ FormElm [] $ Just x + +instance (Functor m, Monad m)=> MonadState (MFlowState view) (View view m) where + get = View $ get >>= \x -> return $ FormElm [] $ Just x + put st = View $ put st >>= \x -> return $ FormElm [] $ Just x + + +instance (MonadIO m, Functor m) => MonadIO (View view m) where + liftIO= lift . liftIO + +--instance Executable (View v m) where +-- execute = runView + + +--instance (Monad m, Executable m, Monoid view, FormInput view) +-- => Executable (StateT (MFlowState view) m) where +-- execute f= execute $ evalStateT f mFlowState0 + +-- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance +-- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose +-- such is caching. This is defined in "Data.TCache.Memoization". The user can create his +-- own instance for his monad. +-- +-- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety) +--, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases. +-- +-- @ +-- import Mflow.Hack.XHtm.All +-- import Some.Time.Library +-- main= run 80 hackMessageFlow [(noscript, time)] +-- time=do ask $ cachedWidget \"time\" 5 +-- $ wlink () bold << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\" +-- time +-- @ +-- +-- this pseudocode would update the time every 5 seconds. The execution of the IO computation +-- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions. + +cachedWidget ::(Show a,MonadIO m,Typeable view, Monoid view + , FormInput view, Typeable a, Functor m, Executable m ) + => String -- ^ The key of the cached object for the retrieval + -> Int -- ^ Timeout of the caching. Zero means sessionwide + -> View view Identity a -- ^ The cached widget, in the Identity monad + -> View view m a -- ^ The cached result +cachedWidget key t mf = View $ StateT $ \s -> do + let(FormElm form _, seq)= execute $ cachedByKey key 0 $ proc mf s{mfCached=True} + let(FormElm _ mx2, s2) = execute $ runStateT (runView mf) s{mfSequence= seq,mfCached=True} -- !> ("mfSequence s1="++ show(mfSequence s1)) !> ("mfSequence s="++ show(mfSequence s)) !> ("mfSequence s'="++ show(mfSequence s')) + let s''= s{validated = validated s2} + return (FormElm form mx2, s'') + where + proc mf s= runStateT (runView mf) s>>= \(r,_) -> return (r,mfSequence s) + + +-- | A FormLet instance +class (Functor m, MonadIO m) => FormLet a m view where + digest :: Maybe a + -> View view m a + +--wrender +-- :: Widget a1 a m v => a1 -> StateT (MFlowState v) m ([v], Maybe a) +-- +--wrender x =do +-- (FormElm frm x) <- runView (widget x) +-- return (frm, x) + +-- | Minimal definition: either (wrender and wget) or widget +--class (Functor m, MonadIO m) => Widget a b m view | a -> b view where +-- wrender :: a -> WState view m [view] +-- wrender x =do +-- (FormElm frm (_ :: Maybe b)) <- runView (widget x) +-- return frm +-- wget :: a -> WState view m (Maybe b) +-- wget x= runView (widget x) >>= \(FormElm _ mx) -> return mx + +-- widget :: a -> View view m b +-- widget x = View $ do +-- form <- wrender x +-- got <- wget x +-- return $ FormElm form got + + +--instance FormLet a m view => Widget (Maybe a) a m view where +-- widget = digest + + +runFlow :: (FormInput view, Monoid view, Monad m) + => FlowM view m () -> Token -> m () +runFlow f = \ t -> evalStateT (runBackT $ backp >> f) mFlowState0{mfToken=t} >> return () + where + -- to restart the flow in case of going back before the first page of the flow + backp = breturn() + + +step + :: (Serialize a, + Typeable view, + FormInput view, + Monoid view, + MonadIO m, + Typeable a) => + FlowM view m a + -> FlowM view (Workflow m) a + +step f= do + s <- get + BackT $ do + (r,s') <- lift . WF.step $ runStateT (runBackT f) s + -- when recovery of a workflow, the MFlow state is not considered + when( mfSequence s' >0) $ put s' + return r + + + +--stepDebug +-- :: (Serialize a, +-- Typeable view, +-- FormInput view, +-- Monoid view, +-- MonadIO m, +-- Typeable a) => +-- FlowM view m a +-- -> FlowM view (Workflow m) a +--stepDebug f= BackT $ do +-- s <- get +-- (r, s') <- lift $ do +-- (r',stat)<- do +-- rec <- isInRecover +-- case rec of +-- True ->do (r', s'') <- getStep 0 +-- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)}) +-- False -> return (undefined,s) +-- (r'', s''') <- WF.stepDebug $ runStateT (runBackT f) stat >>= \(r,s)-> return (r, s) +-- return $ (r'' `asTypeOf` r', s''' ) +-- put s' +-- return r + + + +getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v) + => String -> Params -> [v] -> m (FormElm v a) +getParam1 par req form= r + where + r= case lookup par req of + Just x -> maybeRead x + Nothing -> return $ FormElm form Nothing + getType :: m (FormElm v a) -> a + getType= undefined + x= getType r + maybeRead str= do + + if typeOf x == (typeOf ( undefined :: String)) + then return . FormElm form . Just $ unsafeCoerce str + else case readsPrec 0 $ str of + [(x,"")] -> return . FormElm form $ Just x + _ -> do + modify $ \s -> s{validated= True} + let err= inred . fromString $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) + return $ FormElm (err:form) Nothing + +-- | Validates a form or widget result against a validating procedure +-- +-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@ +validate + :: (FormInput view, Monad m) => + View view m a + -> (a -> WState view m (Maybe String)) + -> View view m a +validate formt val= View $ do + FormElm form mx <- (runView formt) + case mx of + Just x -> do + me <- val x + modify (\s -> s{validated= True}) + case me of + Just str -> + --FormElm form mx' <- generateForm [] (Just x) noValidate + return $ FormElm ( inred (fromString str) : form) Nothing + Nothing -> return $ FormElm [] mx + _ -> return $ FormElm form mx + +-- | Actions are callbacks that are executed when a widget is validated. +-- It is useful when the widget is inside widget containers that know nothing about his content +-- it returns a result that can be significative or, else, be ignored with '<**' and '**>'. +-- An action may or may not initiate his own dialog with the user via `ask` +waction + :: (FormInput view, Monad m) => + View view m a + -> (a -> FlowM view m b) + -> View view m b +waction formt act= View $ do + FormElm form mx <- (runView formt) + case mx of + Just x -> do + modify (\s -> s{validated= True}) + clearEnv + br <- runBackT $ act x + case br of + GoBack -> do + modify (\s -> s{validated= False}) + return $ FormElm form Nothing + NoBack r -> return . FormElm form $ Just r + BackPoint r -> return . FormElm form $ Just r -- bad. no backpoints + + _ -> return $ FormElm form Nothing + +-- | A modifier get the result and the rendering of a widget and change them +-- This modifier changes a login-password-register widget by changing it by the username when logged. +-- +-- @userFormOrName= `userWidget` Nothing `userFormLine` \`wmodify\` f +-- where +-- f _ justu\@(Just u) = return ([`fromString` u], justu) -- user validated, display and return user +-- f felem Nothing = do +-- us <- `getCurrentUser` +-- if us == `anonymous` +-- then return (felem, Nothing) -- user not logged, present the form +-- else return([`fromString` us], Just us) -- already logged, display and return user@ +wmodify :: (Monad m, FormInput v) + => View v m a + -> ([v] -> Maybe a -> WState v m ([v], Maybe b)) + -> View v m b +wmodify formt act = View $ do + FormElm f mx <- runView formt + (f',mx') <- act f mx + return $ FormElm f' mx' + + + +instance (FormInput view, FormLet a m view , FormLet b m view ) + => FormLet (a,b) m view where + digest mxy = do + let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y) + (,) <$> digest x <*> digest y + +instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view ) + => FormLet (a,b,c) m view where + digest mxy = do + let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z) + (,,) <$> digest x <*> digest y <*> digest z + +getString :: (FormInput view,Monad m) => + Maybe String -> View view m String +getString = getElem + +getInteger :: (FormInput view, Functor m, MonadIO m) => + Maybe Integer -> View view m Integer +getInteger = getElem + +getInt :: (FormInput view, Functor m, MonadIO m) => + Maybe Int -> View view m Int +getInt = getElem + +getPassword :: (FormInput view, + Monad m) => + View view m String +getPassword = getParam Nothing "password" Nothing + +getRadioActive :: (FormInput view, Functor m, MonadIO m) => + String -> String -> View view m String +getRadioActive n v= View $ do + st <- get + put st{needForm= True} + let env = mfEnv st + FormElm form mn <- getParam1 n env [] + return $ FormElm [finput n "radio" v + ( isJust mn && v== fromJust mn) (Just "this.form.submit()")] + mn + + + + + +getRadio :: (FormInput view, Functor m, MonadIO m) => + String -> String -> View view m String +getRadio n v= View $ do + st <- get + put st{needForm= True} + let env = mfEnv st + FormElm f mn <- getParam1 n env [] + return $ FormElm + (f++[finput n "radio" v + ( isJust mn && v== fromJust mn) Nothing]) + mn + +-- get a parameter form the las received response +getEnv :: MonadState (MFlowState view) m => String -> m(Maybe String) +getEnv n= gets mfEnv >>= return . lookup n + +getElem + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe a -> View view m a +getElem ms = getParam Nothing "text" ms + + +getParam + :: (FormInput view, + Monad m, + Typeable a, + Show a, + Read a) => + Maybe String -> String -> Maybe a -> View view m a +getParam look type1 mvalue = View $ do + tolook <- case look of + Nothing -> getNewName + Just n -> return n + let nvalue= case mvalue of + Nothing -> "" + Just v -> + let typev= typeOf v + in if typev==typeOf (undefined :: String) then unsafeCoerce v + else if typev==typeOf (undefined :: String) then unsafeCoerce v + else if typev==typeOf (undefined :: ByteString) then unsafeCoerce v + else show v + form= [finput tolook type1 nvalue False Nothing] + st <- get + let env = mfEnv st + put st{needForm= True} + getParam1 tolook env form + + +getNewName :: MonadState (MFlowState view) m => m String +getNewName= do + st <- get + let n= mfSequence st + put $ st{mfSequence= n+1} + let pref= if mfCached st then 'c' else 'p' + return $ pref : (show n) + +getCurrentName :: MonadState (MFlowState view) m => m String +getCurrentName= do + st <- get + let parm = mfSequence st + return $ if mfCached st then "c" else "p"++show parm + + + +getMultilineText :: (FormInput view, + Monad m) => + Maybe String -> View view m String +getMultilineText mt = View $ do + tolook <- getNewName + + let nvalue= case mt of + Nothing -> "" + Just v -> v + env <- gets mfEnv + let form= [ftextarea tolook nvalue] + getParam1 tolook env form + +instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where + digest mv = getBool b "True" "False" + where + b= case mv of + Nothing -> Nothing + Just bool -> Just $ case bool of + True -> "True" + False -> "False" + +getBool :: (FormInput view, + Monad m) => + Maybe String -> String -> String -> View view m Bool +getBool mv truestr falsestr= View $ do + tolook <- getNewName + st <- get + let env = mfEnv st + put st{needForm= True} + r <- getParam1 tolook env $ [foption1 tolook [truestr,falsestr] mv] + return $ fmap fromstr r +-- case mx of +-- Nothing -> return $ FormElm f Nothing +-- Just x -> return . FormElm f $ fromstr x + where + fromstr x= if x== truestr then True else False + +getOption :: (FormInput view, + Monad m) => + Maybe String ->[(String, String)] -> View view m String +getOption mv strings = View $ do + tolook <- getNewName + st <- get + let env = mfEnv st + put st{needForm= True} + getParam1 tolook env [foption tolook strings mv] + + + + +-- | Encloses instances of `Widget` or `FormLet` in formating +-- view is intended to be instantiated to a particular format +(<<<) :: (Monad m, Monoid view) + => (view ->view) + -> View view m a + -> View view m a +(<<<) v form= View $ do + FormElm f mx <- runView form + return $ FormElm [v $ mconcat f] mx + + +infixr 5 <<< + + + +-- | Useful for the creation of pages using two or more views. +-- For example 'HSP' and 'Html'. +-- Because both have ConvertTo instances to ByteString, then it is possible +-- to mix them via 'normalize': +-- +-- > normalize widget <+> normalize widget' +-- +-- is equivalent to +-- +-- > widget .<+>. widget' + +normalize ::(Monad m, ToByteString v) => View v m a -> View ByteString m a +normalize f= View $ StateT $ \s ->do + (FormElm fs mx, s') <- runStateT (runView f) $ unsafeCoerce s + -- the only diference between the states of the two views is mfHeader + -- which don't affect to runState + return $ (FormElm (map toByteString fs ) mx,unsafeCoerce s') + +class ToByteString a where + toByteString :: a -> ByteString + +instance ToByteString a => ToHttpData a where + toHttpData = toHttpData . toByteString + +instance ToByteString ByteString where + toByteString= id + + + +-- | Append formatting code to a widget +-- +-- @ getString "hi" <++ H1 << "hi there"@ +(<++) :: (Monad m) + => View v m a + -> v + -> View v m a +(<++) form v= View $ do + FormElm f mx <- runView form + return $ FormElm ( f ++ [ v]) mx + +infixr 6 <++ , .<++. + + +infixr 6 ++> , .++>. +-- | Prepend formatting code to a widget +-- +-- @bold << "enter name" ++> getString Nothing @ + +(++>) :: (Monad m, Monoid view) + => view -> View view m a -> View view m a +html ++> digest = (html `mappend`) <<< digest + + + + +type Name= String +type Type= String +type Value= String +type Checked= Bool +type OnClick= Maybe String + + +-- | Minimal interface for defining the basic form combinators in a concrete rendering. +-- defined in this module. see "MFlow.Forms.XHtml" for the instance for @Text.XHtml@ and MFlow.Forms.HSP for an instance +-- form Haskell Server Pages. +class FormInput view where + inred :: view -> view + fromString :: String -> view + flink :: String -> view -> view + flink1:: String -> view + flink1 verb = flink verb (fromString verb) + finput :: Name -> Type -> Value -> Checked -> OnClick -> view + ftextarea :: String -> String -> view + foption :: String -> [(String, String)] -> Maybe String -> view + foption1 :: String -> [String] -> Maybe String -> view + foption1 name list msel= foption name (zip list list) msel + formAction :: String -> view -> view + addAttributes :: view -> Attribs -> view + +-- | add attributes to the form element +-- if the view has more than one element, it is applied to the first +infix 8 FormLet User m view where +-- digest muser= +-- (User <$> getString ( userName <$> muser) +-- <*> getPassword) +-- `validate` userValidate + + +newtype Lang= Lang String + +data MFlowState view= MFlowState{ + mfSequence :: Int, + mfCached :: Bool, + prevSeq :: [Int], + onInit :: Bool, +-- mfGoingBack :: Bool, + validated :: Bool, +-- mfUser :: String, + mfLang :: Lang, + mfEnv :: Params, + needForm :: Bool, + hasForm :: Bool, +-- mfServer :: String, +-- mfPath :: String, +-- mfPort :: Int, + + mfToken :: Token, + mfkillTime :: Int, + mfSessionTime :: Integer, + mfCookies :: [Cookie], + mfHeader :: view -> view, + mfDebug :: Bool + } + + deriving Typeable + + + +stdHeader v = v + + + +mFlowState0 :: (FormInput view, Monoid view) => MFlowState view +mFlowState0= MFlowState 0 False [] True False (Lang "en") [] False False (error "token of mFlowState0 used") 0 0 [] stdHeader False + +-- | Set the header-footer that will enclose the widgets. It must be provided in the +-- same formatting than them, altrough with normalization to byteStrings can be used any formatting +-- +-- This header uses XML trough Haskell Server Pages () +-- +-- @ +-- setHeader $ \c -> +-- \ +-- \ +-- \ my title \ +-- \) +-- \ +-- \ +-- \<% c %\> +-- \ +-- \ +-- @ +-- +-- This header uses "Text.XHtml" +-- +-- @ +-- setHeader $ \c -> +-- `thehtml` +-- << (`header` +-- << (`thetitle` << title +++ +-- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++ +-- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c +-- @ +-- +-- This header uses both. It uses byteString tags +-- +-- @ +-- setHeader $ \c -> +-- `bhtml` [] $ +-- `btag` "head" [] $ +-- (`toByteString` (thetitle << title) `append` +-- `toByteString` ) `append` +-- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c +-- @ + +setHeader :: Monad m => (view -> view) -> FlowM view m () +setHeader header= do + fs <- get + put fs{mfHeader= header} + +-- | return the current header +getHeader :: Monad m => FlowM view m (view -> view) +getHeader= gets mfHeader + +-- | Set an HTTP cookie +setCookie :: MonadState (MFlowState view) m + => String -- ^ name + -> String -- ^ value + -> String -- ^ path + -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie + -> m () +setCookie n v p me= do + modify $ \st -> st{mfCookies= (n,v,p,fmap show me):mfCookies st } + +-- | Set 1) the timeout of the flow execution since the last user interaction. +-- Once passed, the flow executes from the begining. 2). In persistent flows +-- it set the session state timeout for the flow, that is persistent. If the +-- flow is not persistent, it has no effect. +-- +-- `transient` flows restart anew. +-- persistent flows (that use `step`) restart at the las saved execution point, unless +-- the session time has expired for the user. +setTimeouts :: Monad m => Int -> Integer -> FlowM view m () +setTimeouts kt st= do + fs <- get + put fs{ mfkillTime= kt, mfSessionTime= st} + + +getWFName :: MonadState (MFlowState view) m => m String +getWFName = do + fs <- get + return . twfname $ mfToken fs + +getCurrentUser :: MonadState (MFlowState view) m=> m String +getCurrentUser = return . tuser =<< gets mfToken + +type UserStr= String +type PasswdStr= String +-- | Is an example of login\/register validation form needed by 'userWidget'. In this case +-- the form field appears in a single line. it shows, in sequence, entries for the username, +-- password, a button for loging, a entry to repeat password necesary for registering +-- and a button for registering. +-- The user can build its own user login\/validation forms by modifying this example +-- +-- @ userFormLine= +-- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\") +-- \<\+\> fromString \" password again\" \+\> getPassword \<\* submitButton \"register\" +-- @ +userFormLine :: (FormInput view, Monoid view, Functor m, Monad m) + => View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) +userFormLine= + ((,) <$> getString (Just "enter user") getPassword submitButton "login") + <+> fromString " password again" ++> getPassword View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) +userLogin= + ((,) <$> fromString "Enter User: " ++> getString Nothing fromString " Enter Pass: " ++> getPassword submitButton "login") + <+> noWidget + <* noWidget + + + +-- | empty widget that return Nothing. May be used as \"empty boxes\" inside larger widgets +noWidget :: (FormInput view, + Monad m) => + View view m a +noWidget= View . return $ FormElm [] Nothing + + + +-- | Wether the user is logged or is anonymous +isLogged :: MonadState (MFlowState v) m => m Bool +isLogged= do + rus <- return . tuser =<< gets mfToken + return . not $ rus == anonymous + +-- | It creates a widget for user login\/registering. If a user name is specified +-- in the first parameter, it is forced to login\/password as this specific user. +-- Otherwise, if the user is already logged, the widget does not appear +-- If the user press the register button, the user/password is registered and the +-- user +userWidget :: ( MonadIO m, Functor m + , FormInput view, Monoid view ) + => Maybe String + -> View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) + -> View view m String +userWidget muser formuser= wform formuser `validate` val muser `waction` login + where + val _ (Nothing,_) = return $ Just "Plese fill in the user/passwd to login, or user/passwd/passwd to register" + val mu (Just (Just us , Just _), Nothing)= + if isNothing mu || isJust mu && fromJust mu == fst us + then userValidate us + else return $ Just "wrong user for the operation" + val mu (Just (Just us , Just _), Just p)= + if isNothing mu || isJust mu && fromJust mu == fst us + then if length p > 0 && snd us== p + then return Nothing + else return $ Just "The passwords do not match" + else return $ Just "wrong user for the operation" + + val _ _ = return $ Just "Please fill in the fields for login or register" + + login (Just (Just (u,p) , Just _), Nothing)= do + + let uname= u + st <- get + let t = mfToken st + t'= t{tuser= uname} + moveState (twfname t) t t' + put st{mfToken= t'} + liftIO $ deleteTokenInList t + liftIO $ addTokenToList t' + setCookie cookieuser uname "/" Nothing -- !> "setcookie" + return uname + + login (Just (Just us@(u,p) , Just _), Just _)= do + userRegister u p + login (Just (Just us , Just p), Nothing) + + +-- | If not logged, perform login. otherwise return the user +-- +-- @getUserSimple= getUser Nothing userFormLine@ +getUserSimple :: ( FormInput view, Monoid view, Typeable view + , ToHttpData view + , MonadIO m, Functor m) + => FlowM view m String +getUserSimple= getUser Nothing userFormLine + +-- | Very basic user authentication. The user is stored in a cookie. +-- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed +-- user-password combination. +-- The user-password combination is only asked if the user has not logged already +-- otherwise, the stored username is returned. +-- +-- @getUser mu form= ask $ userWidget mu form@ +getUser :: ( FormInput view, Monoid view, Typeable view + , ToHttpData view + , MonadIO m, Functor m) + => Maybe String + -> View view m (Maybe(Maybe (UserStr,PasswdStr), Maybe String), Maybe String) + -> FlowM view m String +getUser mu form= ask $ userWidget mu form + + +--instance (MonadIO m, Functor m, m1 ~ m, b ~ a) +-- => Widget(View view m1 b) a m view where +-- widget = id + +-- | Join two widgets in the same page +-- the resulting widget, when `ask`ed with it, returns a either one or the other +-- +-- @r <- ask widget widget1 <+> widget widget2@ +-- +(<+>) , mix :: Monad m + => View view m a + -> View view m b + -> View view m (Maybe a, Maybe b) +mix digest1 digest2= View $ do + FormElm f1 mx' <- runView digest1 + FormElm f2 my' <- runView digest2 + return $ FormElm (f1++f2) + $ case (mx',my') of + (Nothing, Nothing) -> Nothing + other -> Just other + +infixr 2 <+>, .<+>. + +(<+>) = mix + + +infixr 3 <**, **>, .**>., .<**. +-- | The first elem result (even if it is not validated) is discarded, and the secod is returned +-- . This contrast with the applicative operator '*>' which fails the whole validation if +-- the validation of the first elem fails. +-- . The first element is displayed however, as in the case of '*>' +(**>) :: (Functor m, Monad m) + => View view m a -> View view m b -> View view m b +(**>) form1 form2 = valid form1 *> form2 + + +-- | The second elem result (even if it is not validated) is discarded, and the first is returned +-- . This contrast with the applicative operator '<*' which fails the whole validation if +-- the validation of the first elem fails. +-- . The first element is displayed however, as in the case of '<*' +(<**) + :: (Functor m, Monad m) => + View view m a -> View view m b -> View view m a +(<**) form1 form2 = form1 <* valid form2 + + +valid form= View $ do + FormElm form mx <- runView form + return $ FormElm form $ Just undefined + + + +-- | It is the way to interact with the user. +-- It takes a widget and return the user result +-- If the environment has the result, ask don't ask to the user. +-- To force asking in any case, put an `clearEnv` statement before +-- in the FlowM monad +ask + :: ( + ToHttpData view, + FormInput view, + Monoid view, + MonadIO m, + Typeable view) => + View view m b -> FlowM view m b +ask x = do + st1 <- get + let st= st1{hasForm= False, needForm= False,validated= False} + put st + FormElm forms mx <- lift $ runView x -- !> "runWidget" + st' <- mx `seq` get + case mx of + Just x -> do + put st'{prevSeq= mfSequence st: prevSeq st',onInit= True ,mfEnv=[]} + breturn x -- !> "just x" + + _ -> + if not (validated st') && not (onInit st') && hasParams (mfSequence st') ( mfEnv st') -- !> (show $ validated st') !> (show $ onInit st') + then do + put st'{mfSequence= head1 $ prevSeq st' + ,prevSeq= tail1 $ prevSeq st' } + fail "" -- !> "repeatPlease" + else do + let header= mfHeader st' + t= mfToken st' + cont = case (needForm st', hasForm st') of + (True, False) -> header $ formAction (twfname t) $ mconcat forms + _ -> header $ mconcat forms + + let HttpData ctype c s= toHttpData cont + liftIO . sendFlush t $ HttpData ctype (mfCookies st' ++ c) s + put st{mfCookies=[], onInit= False, mfToken= t } -- !> ("after "++show ( mfSequence st')) + receiveWithTimeouts + ask x + where + head1 []=0 + head1 xs= head xs + tail1 []=[] + tail1 xs= tail xs + + hasParams seq= not . null . filter (\(p,_) -> + + let tailp = tail p in + (head p== 'p' || head p == 'c') + && and (map isNumber tailp) + && read tailp <= seq) + +-- | True if the flow is going back (as a result of the back button pressed in the web browser). +-- Usually this chech is nos necessary unless conditional code make it necessary +-- +-- @menu= do +-- mop <- getGoStraighTo +-- case mop of +-- Just goop -> goop +-- Nothing -> do +-- r \<- `ask` option1 \<|> option2 +-- case r of +-- op1 -> setGoStraighTo (Just goop1) >> goop1 +-- op2 -> setGoStraighTo (Just goop2) >> goop2@ +-- +-- This pseudocode would execute the ask of the menu once. But if the user press the +-- back button he will see again the menu. To let him choose other option, the code +-- has to be change to +-- +-- @menu= do +-- mop <- getGoStraighTo +-- back <- `goingBack` +-- case (mop,back) of +-- (Just goop,False) -> goop +-- _ -> do +-- r \<- `ask` option1 \<|> option2 +-- case r of +-- op1 -> setGoStraighTo (Just goop1) >> goop1 +-- op2 -> setGoStraighTo (Just goop2) >> goop2@ + +goingBack :: MonadState (MFlowState view) m => m Bool +goingBack = do + st <- get + return $ not (validated st) && not (onInit st) + +-- | Clears the environment +clearEnv :: MonadState (MFlowState view) m => m () +clearEnv= do + st <- get + put st{ mfEnv= []} + +receiveWithTimeouts :: MonadIO m => FlowM view m () +receiveWithTimeouts= do + st <- get + let t= mfToken st + t1= mfkillTime st + t2= mfSessionTime st + req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t) + put st{mfEnv= req} + + +--data Selection a view= Selection{stitle:: view, sheader :: [view] , sbody :: [([view],a)]} + + +wform :: (Monad m, FormInput view, Monoid view) + => View view m b -> View view m b + +wform x = View $ do + FormElm form mr <- (runView $ x ) + st <- get + let t = mfToken st + put st{hasForm= True} + let form1= formAction ( twfname t) $ mconcat form + + return $ FormElm [form1] mr + +resetButton :: (FormInput view, Monad m) => String -> View view m () +resetButton label= View $ return $ FormElm [finput "reset" "reset" label False Nothing] $ Just () + +submitButton :: (FormInput view, Monad m) => String -> View view m String +submitButton label= getParam Nothing "submit" $ Just label + + +--insertView view= View $ return $ FormElm [view] $ Just () +-- +--infix 3 +> +--view +> widget= (insertView view) *> widget +-- +--infix 3 <+ +--widget <+ view = widget <* insertView view + + +--data Link a view = Link a view + +wlink :: (Typeable a, Read a, Show a, MonadIO m, Functor m, FormInput view) + => a -> view -> View view m a +wlink x v= View $ do + verb <- getWFName + name <- getNewName + env <- gets mfEnv + let + showx= if typeOf x== typeOf (undefined :: String) then unsafeCoerce x else show x + toSend = flink (verb ++ "?" ++ name ++ "=" ++ showx) v + getParam1 name env [toSend] + + + + +--instance (Widget a b m view, Monoid view) => Widget [a] b m view where +-- widget xs = View $ do +-- forms <- mapM(\x -> (runView $ widget x )) xs +-- let vs = concatMap (\(FormElm v _) -> v) forms +-- res = filter isJust $ map (\(FormElm _ r) -> r) forms +-- res1= if null res then Nothing else head res +-- return $ FormElm [mconcat vs] res1 + +-- | Concat a list of widgets of the same type, to return a single result +wconcat :: (Monoid view, MonadIO m, Functor m)=> [View view m a] -> View view m a +wconcat xs= View $ do + forms <- mapM(\x -> (runView x )) xs + let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms + res = filter isJust $ map (\(FormElm _ r) -> r) forms + res1= if null res then Nothing else head res + return $ FormElm vs res1 + + +(|*>),wintersperse :: (MonadIO m, Functor m,Monoid view) + => View view m r + -> [View view m r'] + -> View view m (Maybe r,Maybe r') +wintersperse x xs= View $ do + FormElm fxs rxs <- runView $ wconcat xs + FormElm fx rx <- runView $ x + + return $ FormElm (fx ++ intersperse (mconcat fx) fxs ++ fx) + $ case (rx,rxs) of + (Nothing, Nothing) -> Nothing + other -> Just other + +(|*>)= wintersperse + +infixr 5 |*>, .|*>. + +(|+|) w w'= wintersperse w [w'] + +infixr 1 |+|, .|+|. + + +-- | Flatten a binary tree of tuples of Maybe results produced by the <+> operator +-- into a single tuple with the same elements in the same order. +-- This is useful to make matching easier . For example: +-- +-- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@ +-- +-- @res@ has type: +-- +-- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@ +-- +-- but @flatten res@ has type: +-- +-- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@ + +flatten :: Flatten (Maybe tree) list => tree -> list +flatten res= doflat $ Just res + +class Flatten tree list where + doflat :: tree -> list + + +type Tuple2 a b= Maybe (Maybe a, Maybe b) +type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c) +type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d) +type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e) +type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f) + +instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where + doflat (Just(ma,mb))= (ma,mb) + doflat Nothing= (Nothing,Nothing) + +instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where + doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc) + doflat Nothing= (Nothing,Nothing,Nothing) + +instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where + doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc) + doflat Nothing= (Nothing,Nothing,Nothing,Nothing) + +instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where + doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc) + doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing) + +instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where + doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc) + doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing) + + + +(.<<.) :: (ToByteString view) => (ByteString -> ByteString) -> view -> ByteString +(.<<.) w x = w $ toByteString x + + + + + +(.<+>.) + :: (Monad m, ToByteString v, ToByteString v1) => + View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b) +(.<+>.) x y = normalize x <+> normalize y + +(.|*>.) + :: (Functor m, MonadIO m, ToByteString v, ToByteString v1) => + View v m r + -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r') +(.|*>.) x y = normalize x |*> map normalize y + +(.|+|.) + :: (Functor m, MonadIO m, ToByteString v, ToByteString v1) => + View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r') +(.|+|.) x y = normalize x |+| normalize y + +(.**>.) + :: (Monad m, Functor m, ToByteString v, ToByteString v1) => + View v m a -> View v1 m b -> View ByteString m b +(.**>.) x y = normalize x **> normalize y + +(.<**.) + :: (Monad m, Functor m, ToByteString v, ToByteString v1) => + View v m a -> View v1 m b -> View ByteString m a +(.<**.) x y = normalize x <** normalize y + +(.<|>.) + :: (Monad m, Functor m, ToByteString v, ToByteString v1) => + View v m a -> View v1 m a -> View ByteString m a +(.<|>.) x y= normalize x <|> normalize y + + +(.<++.) x v= normalize x <++ toByteString v + +(.++>.) v x= toByteString v ++> normalize x + + +instance FormInput ByteString where + + inred = btag "b" [("style", "color:red")] + finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else [] + ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) "" + ftextarea name text= btag "textarea" [("name", name)] $ pack text + + foption name list msel= btag "select" [("name", name)] (mconcat + $ map (\(n,v) -> btag "option" ([("value", n)] ++ selected msel n) (pack v)) list) + + where + selected msel n= if Just n == msel then [("selected","true")] else [] + + addAttributes tag attrs = error "addAttributes not implemented for ByteString" + + + formAction action form = btag "form" [("action", action),("method", "post")] form + fromString = pack + + + flink v str = btag "a" [("href", v)] str + + + diff --git a/src/MFlow/Forms/Admin.hs b/src/MFlow/Forms/Admin.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/Admin.hs @@ -0,0 +1,137 @@ +{-# OPTIONS + -XScopedTypeVariables + + #-} +module MFlow.Forms.Admin(adminLoop,addAdminWF) where +import MFlow.Hack +import MFlow.Forms +import MFlow.Forms.XHtml +import MFlow.Hack.XHtml +import MFlow +import Text.XHtml.Strict hiding (widget) +import Control.Applicative +import Control.Workflow +import Control.Monad.Trans +import Data.TCache +import Data.TCache.IndexQuery +import System.Exit +import System.IO +import System.IO.Unsafe +import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack) +import System.IO +import Data.RefSerialize hiding ((<|>)) +import Data.Typeable +import Data.Monoid +import Data.Maybe +import Data.Map as M (keys) +import System.Exit +import Control.Exception as E + +ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done" + +-- | A small console interpreter with some commands: +-- +-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`) +-- +-- [@flush@] Flush the cache +-- +-- [@end@] Synchronize and exit +-- +-- [@abort@] Exit. Do not synchronize +-- +-- on exception, for example Control-c, it sync and exit. +-- it used as the last statement of the main procedure. +adminLoop :: IO () +adminLoop= do + op <- getLine + case op of + "sync" -> ssyncCache + "flush" -> atomically flushAll >> putStrLn "flushed cache" + "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess + "abort" -> exitWith ExitSuccess + _ -> return() + adminLoop + + `E.catch` (\(e:: E.SomeException) ->do + ssyncCache + error $ "\nException: "++ show e) + +-- | Install the admin flow in the list of flows handled by `HackMessageFlow` +-- this gives access to an administrator page. It is necessary to +-- create an admin user with `setAdminUser`. +addAdminWF= addMessageFlows[("adminserv",transient $ runFlow adminMFlow)] + + +adminMFlow :: FlowM Html IO () +adminMFlow= do + admin <- getAdminName + u <- getUser (Just admin) $ p << bold << "Please login as Administrator" ++> userLogin + op <- ask $ p <<< wlink "sync" (bold << "sync") + <|> p <<< wlink "flush" (bold << "flush") + <|> p <<< wlink "errors"(bold << "errors") + <|> p <<< wlink "users" (bold << "users") + <|> p <<< wlink "end" (bold << "end") + <|> wlink "abort" (bold << "abort") + + case op of + "users" -> users + "sync" -> liftIO $ syncCache >> print "syncronized cache" + "flush" -> liftIO $ atomically flushAll >> print "flushed cache" + + "errors" -> errors + "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess) + "abort" -> liftIO $ exitWith(ExitSuccess) + _ -> return() + adminMFlow + + +errors= do + size <- liftIO $ hFileSize hlog + if size == 0 + then ask $ wlink () (bold << "no error log") + else do + liftIO $ hSeek hlog AbsoluteSeek 0 + log <- liftIO $ hGetNonBlocking hlog (fromIntegral size) + + let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]" + let rows= [wlink (head e) (bold << head e) `waction` optionsUser : map (\x ->noWidget <++ fromString x) (Prelude.tail e) | e <- ls] + showFormList rows 0 10 + breturn() + + + + + + + +users= do + users <- liftIO $ atomically $ return . map fst =<< indexOf userName + + showFormList [[wlink u (bold << u) `waction` optionsUser ] | u<-users] 0 10 + +showFormList + :: (Functor m, MonadIO m) => + [[View Html m ()]] + -> Int -> Int -> FlowM Html m b +showFormList ls n l= do + nav <- ask $ updown n l <|> (list **> updown n l) + showFormList ls nav l + + where + list= table <<< wconcat (span1 n l [tr <<< cols e | e <- ls ]) + + cols e= wconcat[td <<< c | c <- e] + span1 n l = take l . drop n + updown n l= wlink ( n +l) (bold << "up ") <|> wlink ( n -l) (bold << "down ") <++ br + +optionsUser us = do + wfs <- liftIO $ return . M.keys =<< getMessageFlows + + stats <- liftIO $ mapM (\wf -> getWFHistory wf Token{twfname= wf,tuser=us}) wfs + let wfss= filter (isJust . snd) $ zip wfs stats + if null wfss + then ask $ bold << " not logs for this user" ++> wlink () (bold << "Press here") + else do + wf <- ask $ wconcat [ wlink wf (p << wf) | (wf,_) <- wfss] + ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu") + diff --git a/src/MFlow/Forms/Ajax.hs b/src/MFlow/Forms/Ajax.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/Ajax.hs @@ -0,0 +1,96 @@ +{-# OPTIONS -XFlexibleContexts #-} + +-- | A very simple (but effective) support for AJAX. +-- The value of a javaScript variable is sent to the server. +-- The server must return a valid sequence of javaScript statements +-- that are evaluated in the client. +-- +-- This example increase the value, from 0 on, in a text box trough AJAX: +-- +-- @ +-- import Text.XHtml +-- import MFlow.Forms +-- import MFlow.Forms.Ajax +-- ajaxsample= do +-- ajaxheader html= thehtml << `ajaxHead` << html +-- setHeader ajaxheader +-- ajaxc \<- `ajaxCommand` \"document.getElementById(\'text1\').value\" +-- (\n -> return $ \"document.getElementById(\'text1\').value='\"++show(read n +1)++\"'\") +-- ask $ (getInt (Just 0) \ String -- ^ The javScript variable whose value will be sent to the server + -> (String -> IO String) -- ^ The server procedure to be executed with the + -- variable value as parameter. It must return a string with valid + -- javaScript code to be executed in the client + -> m (String) -- ^ return the javascript of the event handler, to be inserted in + -- the HTML to be sent to the client +ajaxCommand jsparam serverProc = do + servname <- getNewName + liftIO $ addMessageFlows [( servname, serverp)] +-- liftIO $ getMessageFlows >>= return . keys >>= print + return $ "doServer("++"'" ++ servname++"',"++jsparam++")" + where + serverp = stateless $ \env -> do + let c = lookup "ajax" env -- `justify` (error "not found ajax command") -- :: String + serverProc $ fromJust c + justify = flip . fromMaybe + + +-- | @ajaxHead@ must be used instead of `header` when using ajax(see example). +-- +-- Although it produces code form "Text.XHtml" rendering (package xhtml), +-- it can be converted to byteString, so that any rendering can be used trough normalization +-- . see `setHeader` +ajaxHead :: Html -> Html +ajaxHead html= + (header << (script ![thetype "text/javascript"] << ( + "function loadXMLObj()\n" ++ + "{\n" ++ + "var xmlhttp;\n" ++ + "if (window.XMLHttpRequest)\n" ++ + " {\n// code for IE7+, Firefox, Chrome, Opera, Safari\n" ++ + " xmlhttp=new XMLHttpRequest();\n" ++ + " }\n" ++ + "else\n" ++ + " {\n// code for IE6, IE5\n\n" ++ + " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');\n" ++ + " }\n" ++ + "return xmlhttp\n" ++ + "}\n" ++ + + " xmlhttp= loadXMLObj()\n" ++ + " noparam= ''\n"++ + "\n"++ + "function doServer (servproc,param){\n" ++ + " xmlhttp.open('GET',servproc+'?ajax='+param,true);\n" ++ + " xmlhttp.send();}\n" ++ + "\n"++ + "xmlhttp.onreadystatechange=function()\n" ++ + " {\n" ++ + " if (xmlhttp.readyState + xmlhttp.status==204)\n" ++ + " { \n" ++ + " eval(xmlhttp.responseText);\n" ++ + " }\n" ++ + " }\n" ++ + "\n" ))) + +++ body << html + + + diff --git a/src/MFlow/Forms/HSP.hs b/src/MFlow/Forms/HSP.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/HSP.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -F -pgmFtrhsx -XUndecidableInstances -XOverlappingInstances -XTypeSynonymInstances -XFlexibleInstances #-} + +{- | Instantiation of "MFlow.Forms" for the hsp package +it includes additional features for embedding widgets within HTML formatting + +-} + +module MFlow.Forms.HSP + where + + +import MFlow.Forms +import Control.Monad.Trans +import Data.Typeable +import HSP +import Data.Monoid +import Control.Monad(when) +import Data.ByteString.Lazy.Char8(unpack) + + + +instance Monoid (HSP XML) where + mempty = + mappend x y= <% x %> <% y %> + mconcat xs= <% [<% x %> | x <- xs] %> + +instance FormInput (HSP XML) where + + fromString s = <% s %> + + + finput typ name value checked onclick= + s ; _ -> "")/> + + ftextarea name text= + + + foption name list msel= + + where + selected msel n= if Just n == msel then "true" else "false" + + flink v str = <% str %> + + inred x= <% x %> + + formAction action form =
<% form %>
+ + + addAttributes tag attrs= tag <<@ map (\(n,v)-> n:=v) attrs diff --git a/src/MFlow/Forms/XHtml.hs b/src/MFlow/Forms/XHtml.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Forms/XHtml.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.MessageFlow.Forms.XHtml +-- Copyright : Alberto Gónez Corona +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- +----------------------------------------------------------------------------- +{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package +-} + +{-# OPTIONS -XMultiParamTypeClasses + -XFlexibleInstances + -XUndecidableInstances + -XTypeSynonymInstances + -XFlexibleContexts + -XTypeOperators + #-} + + +module MFlow.Forms.XHtml where + + +import MFlow.Forms +import Data.ByteString.Lazy.Char8(pack,unpack) + +import Text.XHtml as X +import Control.Monad.Trans +import Data.Typeable + + +instance Monad m => ADDATTRS (View Html m a) where + widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx) + + +-- View $ do +-- FormElm fs mx <- runView widget +-- return $ FormElm [head fs ! atrs] mx + +instance ToByteString Html where + toByteString = pack. showHtml + +instance FormInput Html where + + inred = X.bold ![X.thestyle "color:red"] + finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else [] + ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] ) + ftextarea name text= X.textarea ! [X.name name] << text + + foption name list msel= select ![ X.name name] << (concatHtml + $ map (\(n,v) -> X.option ! ([value n] ++ selected msel n) << v ) list) + + where + selected msel n= if Just n == msel then [X.selected] else [] + + addAttributes tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs) + + + + formAction action form = X.form ! [X.action action, method "post"] << form + fromString = stringToHtml + + + flink v str = toHtml $ hotlink ( v) << str + + diff --git a/src/MFlow/Hack.hs b/src/MFlow/Hack.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Hack.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE UndecidableInstances + , TypeSynonymInstances + , MultiParamTypeClasses + , DeriveDataTypeable + , FlexibleInstances #-} + +module MFlow.Hack( + module MFlow.Cookies + ,module MFlow + ,hackMessageFlow) +where + +import Data.Typeable +import Hack + +import Control.Concurrent.MVar(modifyMVar_, readMVar) +import Control.Monad(when) + + +import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString) +import Control.Concurrent(ThreadId(..)) +import System.IO.Unsafe +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Exception +import qualified Data.Map as M +import Data.Maybe +import Data.TCache +import Data.TCache.DefaultPersistence +import Control.Workflow hiding (Indexable(..)) + +import MFlow +import MFlow.Cookies + +import MFlow.Hack.Response +import Data.Monoid +import Data.CaseInsensitive + +import Debug.Trace +(!>)= flip trace + +flow= "flow" + +instance Processable Env where + pwfname env= if null sc then noScript else sc + where + sc= tail $ pathInfo env + puser env = fromMaybe anonymous $ lookup cookieuser $ http env + + pind env= fromMaybe (error ": No FlowID") $ lookup flow $ http env + getParams= http +-- getServer env= serverName env +-- getPath env= pathInfo env +-- getPort env= serverPort env + + +data Flow= Flow !Int deriving (Read, Show, Typeable) + +instance Serializable Flow where + serialize= B.pack . show + deserialize= read . B.unpack + +instance Indexable Flow where + key _= "Flow" + + +rflow= getDBRef . key $ Flow undefined + +newFlow= do + fl <- atomically $ do + m <- readDBRef rflow + case m of + Just (Flow n) -> do + writeDBRef rflow . Flow $ n+1 + return n + + Nothing -> do + writeDBRef rflow $ Flow 1 + return 0 + + + return $ show fl + +--------------------------------------------- + + + +-- +--instance ConvertTo String TResp where +-- convert = TResp . pack +-- +--instance ConvertTo ByteString TResp where +-- convert = TResp +-- +-- +--instance ConvertTo Error TResp where +-- convert (Error e)= TResp . pack $ errorResponse e +-- +--instance ToResponse v =>ConvertTo (HttpData v) TResp where +-- convert= TRespR + + +--webScheduler :: Env +-- -> ProcList +-- -> IO (TResp, ThreadId) +--webScheduler = msgScheduler + +--theDir= unsafePerformIO getCurrentDirectory + +wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) +wFMiddleware filter f = \ env -> if filter env then hackWorkflow env else f env -- !> "new message" + +-- | An instance of the abstract "MFlow" scheduler to the Hack interface +-- it accept the list of processes being scheduled and return a hack handler +-- +-- Example: +-- +-- @main= do +-- +-- putStrLn $ options messageFlows +-- 'run' 80 $ 'hackMessageFlow' messageFlows +-- where +-- messageFlows= [(\"main\", 'runFlow' flowname ) +-- ,(\"hello\", 'stateless' statelesproc) +-- ,(\"trans\", 'transient' $ runflow transientflow] +-- options msgs= \"in the browser choose\\n\\n\" ++ +-- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] +-- @ +hackMessageFlow :: [(String, (Token -> Workflow IO ()))] + -> (Env -> IO Response) +hackMessageFlow messageFlows = + unsafePerformIO (addMessageFlows messageFlows) `seq` + hackWorkflow -- wFMiddleware f other +-- where +-- f env = unsafePerformIO $ do +-- paths <- getMessageFlows >>= +-- return (pwfname env `elem` paths) + +-- other= (\env -> defaultResponse $ "options: " ++ opts) +-- (paths,_)= unzip messageFlows +-- opts= concatMap (\s -> ""++s ++", ") paths + + +splitPath ""= ("","","") +splitPath str= + let + strr= reverse str + (ext, rest)= span (/= '.') strr + (mod, path)= span(/='/') $ tail rest + in (tail $ reverse path, reverse mod, reverse ext) + + + +hackWorkflow :: Env -> IO Response +hackWorkflow req1= do + let httpreq1= http req1 + let cookies= {-# SCC "getCookies" #-} getCookies httpreq1 + + (flowval , retcookies) <- case lookup ( flow) cookies of + Just fl -> return (fl, []) + Nothing -> do + fl <- newFlow + return ( fl, [( flow, fl, "/",Nothing)]) + +{- for state persistence in cookies + putStateCookie req1 cookies + let retcookies= case getStateCookie req1 of + Nothing -> retcookies1 + Just ck -> ck:retcookies1 +-} + + let input= + case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of + (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack $ hackInput req1 + (GET, _) -> urlDecode . queryString $ req1 + _ -> [] + + let req = case retcookies of + [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ" + _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ" + + + (resp',th) <- msgScheduler req + + + let resp''= toResponse resp' + let headers1= case retcookies of [] -> headers resp''; _ -> ctype : (cookieHeaders retcookies) + let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} + + return resp + + +------persistent state in cookies (not tested) + +tvresources :: MVar (Maybe ( M.Map string string)) +tvresources= unsafePerformIO $ newMVar Nothing +statCookieName= "stat" + +putStateCookie req cookies= + case lookup statCookieName cookies of + Nothing -> return () + Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ + \mmap -> case mmap of + Just map -> return $ Just $ M.insert (keyResource req) str map + Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] + +getStateCookie req= do + mr<- readMVar tvresources + case mr of + Nothing -> return Nothing + Just map -> case M.lookup (keyResource req) map of + Nothing -> return Nothing + Just str -> do + swapMVar tvresources Nothing + return $ Just (statCookieName, str , "/") + +{- +persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} + where + writeResource stat= modifyMVar_ tvresources $ \mmap -> + case mmap of + Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map + Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] + readResource stat= do + mstr <- withMVar tvresources $ \mmap -> + case mmap of + Just map -> return $ M.lookup (keyResource stat) map + Nothing -> return Nothing + case mstr of + Nothing -> return Nothing + Just str -> return $ deserialize str + + deleteResource stat= modifyMVar_ tvresources $ \mmap-> + case mmap of + Just map -> return $ Just $ M.delete (keyResource stat) map + Nothing -> return $ Nothing + +-} diff --git a/src/MFlow/Hack/Response.hs b/src/MFlow/Hack/Response.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Hack/Response.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances + -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-} +module MFlow.Hack.Response where + +import Hack +import MFlow.Cookies +import Data.ByteString.Lazy.Char8 as B + +import MFlow +import Data.Typeable +import Data.Monoid +import System.IO.Unsafe +import Data.Map as M +import Control.Workflow (WFErrors(..)) + +--import Debug.Trace +-- +--(!>)= flip trace + + + +class ToResponse a where + toResponse :: a -> Response + + + +data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable + +instance Monoid TResp where + mempty = TRempty + mappend (TResp x) (TResp y)= + case cast y of + Just y' -> TResp $ mappend x y' + Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) + +defaultResponse :: String -> IO Response +defaultResponse msg= return . toResponse $ "

Page not found or error ocurred:
" ++ msg ++ "
home

" + +errorResponse msg= + "

Page not found or error ocurred:

" <> msg <> + "


" <> opts <> "
press here to go home" + + where + paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows + + opts= "options: " <> B.concat (Prelude.map (\s -> + + " s <>"\">"<> s <>", ") paths) + + +instance ToResponse TResp where + toResponse (TResp x)= toResponse x + toResponse (TRespR r)= toResponse r + +instance ToResponse Response where + toResponse = id + +instance ToResponse ByteString where + toResponse x= Response{status=200, headers=[ctype {-,("Content-Length",show $ B.length x) -}], body= x} + +instance ToResponse String where + toResponse x= Response{status=200, headers=[ctype{-,("Content-Length",show $ B.length x) -}], body= B.pack x} + +instance ToResponse HttpData where + toResponse (HttpData hs cookies x)= (toResponse x) {headers= hs++ cookieHeaders cookies} + toResponse (Error NotFound str)= Response{status=404, headers=[], body= errorResponse str} + +instance Typeable Env where + typeOf = \_-> mkTyConApp (mkTyCon "Hack.Env") [] + +instance Typeable Response where + typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[] diff --git a/src/MFlow/Hack/XHtml.hs b/src/MFlow/Hack/XHtml.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Hack/XHtml.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- +-- Module : MFlow.Hack.XHtml +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +{- +Instantiations necessary for "MFlow.Hack" to use "Text.XHtml" as format for generating output +-} + +{-# OPTIONS -XMultiParamTypeClasses #-} + +module MFlow.Hack.XHtml ( + +) where +import MFlow +import Hack +import MFlow.Hack.Response +import Text.XHtml +import Data.Typeable +import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString) + +instance ToResponse Html where + toResponse x= Response{ status=200, headers=[] + , Hack.body= pack $ showHtml x} + +instance Typeable Html where + typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") [] +-- +--instance ConvertTo Html TResp where +-- convert = TResp + diff --git a/src/MFlow/Hack/XHtml/All.hs b/src/MFlow/Hack/XHtml/All.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Hack/XHtml/All.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- +-- Module : MFlow.Hack.XHtml.All +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module MFlow.Hack.XHtml.All ( + module Data.TCache +,module MFlow.Hack +,module MFlow.FileServer +,module MFlow.Forms +,module MFlow.Forms.XHtml +,module MFlow.Forms.Admin +,module MFlow.Forms.Ajax +,module MFlow.Hack.XHtml +,module Hack +,module Hack.Handler.SimpleServer +,module Text.XHtml.Strict +,module Control.Applicative +) where + + +import MFlow.Hack +import MFlow.FileServer +import MFlow.Forms +import MFlow.Forms.XHtml +import MFlow.Forms.Admin +import MFlow.Forms.Ajax +import MFlow.Hack.XHtml + +import Hack(Env) +import Hack.Handler.SimpleServer +import Data.TCache + + +import Text.XHtml.Strict hiding (widget) + +import Control.Applicative + + + diff --git a/src/MFlow/Wai.hs b/src/MFlow/Wai.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Wai.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE UndecidableInstances + , TypeSynonymInstances + , MultiParamTypeClasses + , DeriveDataTypeable + , FlexibleInstances + , OverloadedStrings #-} + +module MFlow.Wai( + module MFlow.Cookies + ,module MFlow + ,waiMessageFlow) +where + +import Data.Typeable +import Network.Wai + +import Control.Concurrent.MVar(modifyMVar_, readMVar) +import Control.Monad(when) + + +import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail) +import Data.ByteString.Lazy(fromChunks) +import qualified Data.ByteString.Char8 as SB +import Control.Concurrent(ThreadId(..)) +import System.IO.Unsafe +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad.Trans +import Control.Exception +import qualified Data.Map as M +import Data.Maybe +import Data.TCache +import Data.TCache.DefaultPersistence +import Control.Workflow hiding (Indexable(..)) + +import MFlow +import MFlow.Cookies +import Data.Monoid +import MFlow.Wai.Response +import Network.Wai +import Network.HTTP.Types hiding (urlDecode) +import Data.Conduit +import Data.Conduit.Lazy +import qualified Data.Conduit.List as CList +import Data.CaseInsensitive + +--import Debug.Trace +--(!>)= flip trace + +flow= "flow" +--ciflow= mk flow + +instance Processable Request where + pwfname env= if SB.null sc then noScript else SB.unpack sc + where + sc= SB.tail $ rawPathInfo env + + puser env = fromMaybe anonymous $ fmap SB.unpack $ lookup ( mk $SB.pack cookieuser) $ requestHeaders env + + pind env= fromMaybe (error ": No FlowID") $ fmap SB.unpack $ lookup (mk $ SB.pack flow) $ requestHeaders env + getParams= mkParams1 . requestHeaders + where + mkParams1 = Prelude.map mkParam1 + mkParam1 ( x,y)= (SB.unpack $ original x, SB.unpack y) + +-- getServer env= serverName env +-- getPath env= pathInfo env +-- getPort env= serverPort env + +data Flow= Flow !Int deriving (Read, Show, Typeable) + +instance Serializable Flow where + serialize= B.pack . show + deserialize= read . B.unpack + +instance Indexable Flow where + key _= "Flow" + + +rflow= getDBRef . key $ Flow undefined + +newFlow= liftIO $ do + fl <- atomically $ do + m <- readDBRef rflow + case m of + Just (Flow n) -> do + writeDBRef rflow . Flow $ n+1 + return n + + Nothing -> do + writeDBRef rflow $ Flow 1 + return 0 + return $ show fl + +--------------------------------------------- + + + +-- +--instance ConvertTo String TResp where +-- convert = TResp . pack +-- +--instance ConvertTo ByteString TResp where +-- convert = TResp +-- +-- +--instance ConvertTo Error TResp where +-- convert (Error e)= TResp . pack $ errorResponse e +-- +--instance ToResponse v =>ConvertTo (HttpData v) TResp where +-- convert= TRespR + + +--webScheduler :: Request +-- -> ProcList +-- -> IO (TResp, ThreadId) +--webScheduler = msgScheduler + +--theDir= unsafePerformIO getCurrentDirectory + +--wFMiddleware :: (Request -> Bool) -> (Request-> IO Response) -> (Request -> IO Response) +--wFMiddleware filter f = \ env -> if filter env then waiWorkflow env else f env -- !> "new message" + +-- | An instance of the abstract "MFlow" scheduler to the Wai interface +-- it accept the list of processes being scheduled and return a wai handler +-- +-- Example: +-- +-- @main= do +-- +-- putStrLn $ options messageFlows +-- 'run' 80 $ 'waiMessageFlow' messageFlows +-- where +-- messageFlows= [(\"main\", 'runFlow' flowname ) +-- ,(\"hello\", 'stateless' statelesproc) +-- ,(\"trans\", 'transient' $ runflow transientflow] +-- options msgs= \"in the browser choose\\n\\n\" ++ +-- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] +-- @ +waiMessageFlow :: [(String, (Token -> Workflow IO ()))] + -> (Request -> ResourceT IO Response) +waiMessageFlow messageFlows = + unsafePerformIO (addMessageFlows messageFlows) `seq` + waiWorkflow -- wFMiddleware f other + +-- where +-- f env = unsafePerformIO $ do +-- paths <- getMessageFlows >>= +-- return (pwfname env `elem` paths) + +-- other= (\env -> defaultResponse $ "options: " ++ opts) +-- (paths,_)= unzip messageFlows +-- opts= concatMap (\s -> ""++s ++", ") paths + + +splitPath ""= ("","","") +splitPath str= + let + strr= reverse str + (ext, rest)= span (/= '.') strr + (mod, path)= span(/='/') $ tail rest + in (tail $ reverse path, reverse mod, reverse ext) + + + +waiWorkflow :: Request -> ResourceT IO Response +waiWorkflow req1= do + let httpreq1= getParams req1 + + let cookies=getCookies httpreq1 + + + (flowval , retcookies) <- case lookup flow cookies of + Just fl -> return (fl, []) + Nothing -> do + fl <- newFlow + return (fl, [(flow, fl, "/",Nothing)::Cookie]) + +{- for state persistence in cookies + putStateCookie req1 cookies + let retcookies= case getStateCookie req1 of + Nothing -> retcookies1 + Just ck -> ck:retcookies1 +-} + + input <- + case parseMethod $ requestMethod req1 of + Right POST -> if lookup ("Content-Type") httpreq1 == Just "application/x-www-form-urlencoded" + then do + inp <- liftIO $ runResourceT (requestBody req1 $$ CList.consume) + return . urlDecode $ concatMap SB.unpack inp + else return [] + + Right GET -> let tail1 s | s==SB.empty =s + tail1 xs= SB.tail xs + in return . urlDecode $ SB.unpack . tail1 $ rawQueryString req1 -- !> (SB.unpack $ rawQueryString req1) + x -> return [] + let req = case retcookies of + [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ" + + + (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req) + + let resp= case (resp',retcookies) of + (_,[]) -> resp' + (error@(Error _ _),_) -> error + (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str + +-- let resp''= toResponse resp' +-- let headers1= case retcookies of [] -> headers resp''; _ -> ctype : cookieHeaders retcookies +-- let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} + + return $ toResponse resp + + +------persistent state in cookies (not tested) + +tvresources :: MVar (Maybe ( M.Map string string)) +tvresources= unsafePerformIO $ newMVar Nothing +statCookieName= "stat" + +putStateCookie req cookies= + case lookup statCookieName cookies of + Nothing -> return () + Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ + \mmap -> case mmap of + Just map -> return $ Just $ M.insert (keyResource req) str map + Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] + +getStateCookie req= do + mr<- readMVar tvresources + case mr of + Nothing -> return Nothing + Just map -> case M.lookup (keyResource req) map of + Nothing -> return Nothing + Just str -> do + swapMVar tvresources Nothing + return $ Just (statCookieName, str , "/") + +{- +persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} + where + writeResource stat= modifyMVar_ tvresources $ \mmap -> + case mmap of + Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map + Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] + readResource stat= do + mstr <- withMVar tvresources $ \mmap -> + case mmap of + Just map -> return $ M.lookup (keyResource stat) map + Nothing -> return Nothing + case mstr of + Nothing -> return Nothing + Just str -> return $ deserialize str + + deleteResource stat= modifyMVar_ tvresources $ \mmap-> + case mmap of + Just map -> return $ Just $ M.delete (keyResource stat) map + Nothing -> return $ Nothing + +-} diff --git a/src/MFlow/Wai/Response.hs b/src/MFlow/Wai/Response.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Wai/Response.hs @@ -0,0 +1,75 @@ +{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances + -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-} +module MFlow.Wai.Response where + +import Network.Wai +import MFlow.Cookies +import Data.ByteString.Char8 as SB +import Data.ByteString.Lazy.Char8 as B +import MFlow +import Data.Typeable +import Data.Monoid +import System.IO.Unsafe +import Data.Map as M +import Data.CaseInsensitive +import Network.HTTP.Types +import Control.Workflow(WFErrors(..)) +--import Debug.Trace +-- +--(!>)= flip trace + + + +class ToResponse a where + toResponse :: a -> Response + + + +data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable + +instance Monoid TResp where + mempty = TRempty + mappend (TResp x) (TResp y)= + case cast y of + Just y' -> TResp $ mappend x y' + Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x) + +defaultResponse :: String -> IO Response +defaultResponse msg= return . toResponse $ "

Page not found or error ocurred:
" ++ msg ++ "
home

" + + +errorResponse msg= + "

Page not found or error ocurred:

" <> msg <> + "


" <> opts <> "
press here to go home" + + where + paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows + + opts= "options: " <> B.concat (Prelude.map (\s -> + + " s <>"\">"<> s <>", ") paths) + + +ctype1= [mkparam ctype] -- [(mk $ SB.pack "Content-Type", SB.pack "text/html")] +mkParams = Prelude.map mkparam +mkparam (x,y)= (mk $ SB.pack x, SB.pack y) +instance ToResponse TResp where + toResponse (TResp x)= toResponse x + toResponse (TRespR r)= toResponse r + +instance ToResponse Response where + toResponse = id + +instance ToResponse B.ByteString where + toResponse x= responseLBS status200 ctype1 {-,("Content-Length",show $ B.length x) -} x + + + +instance ToResponse String where + toResponse x= responseLBS status200 ctype1{-,("Content-Length",show $ B.length x) -} $ B.pack x + +instance ToResponse HttpData where + toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams $ hs ++ cookieHeaders cookies) x + toResponse (Error NotFound str)= responseLBS status404 [] $ errorResponse str + + diff --git a/src/MFlow/Wai/XHtml/All.hs b/src/MFlow/Wai/XHtml/All.hs new file mode 100644 --- /dev/null +++ b/src/MFlow/Wai/XHtml/All.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- +-- Module : MFloll.Wai.XHtml.All +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module MFlow.Wai.XHtml.All ( + module Data.TCache +,module MFlow.Wai +,module MFlow.FileServer +,module MFlow.Forms +,module MFlow.Forms.XHtml +,module MFlow.Forms.Admin +,module MFlow.Forms.Ajax +--,module MFlow.Wai.XHtml +,module Network.Wai +,module Network.Wai.Handler.Warp +,module Text.XHtml.Strict +,module Control.Applicative +) where + + +import MFlow.Wai +import MFlow.FileServer +import MFlow.Forms +import MFlow.Forms.XHtml +import MFlow.Forms.Admin +import MFlow.Forms.Ajax +--import MFlow.Wai.XHtml + +import Network.Wai +import Network.Wai.Handler.Warp +import Data.TCache + +import Text.XHtml.Strict hiding (widget) + +import Control.Applicative + + + + +