{-# LANGUAGE UndecidableInstances , TypeSynonymInstances , MultiParamTypeClasses , DeriveDataTypeable , FlexibleInstances #-} module MFlow.Hack( module MFlow.Cookies ,module MFlow ,hackMessageFlow) where import Data.Typeable import Hack import Control.Concurrent.MVar(modifyMVar_, readMVar) import Control.Monad(when) import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString) import Control.Concurrent(ThreadId(..)) import System.IO.Unsafe import Control.Concurrent.MVar import Control.Exception import qualified Data.Map as M import Data.TCache import Control.Workflow import MFlow import MFlow.Cookies import MFlow.Hack.Response import Data.Monoid --(!>)= flip trace assocList ->> k = getParam1 assocList k instance Processable Env where pwfname env= if null sc then "noscript" else sc where sc= tail $ pathInfo env -- takeWhile (/= '?') $ queryString env puser env = case lookup "cookieuser" $ http env of Nothing -> "nouser" Just user -> user pind env= case lookup "flow" $ http env of Nothing -> error ": No FlowID" Just fl -> fl getParams env= http env -- getServer env= serverName env -- getPath env= pathInfo env -- getPort env= serverPort env data Flow= Flow !Int deriving (Read, Show, Typeable) instance Indexable Flow where key _= "Flow" newFlow= do fl <- atomically $ do withSTMResources [Flow undefined] $ \m -> let (add, ret)= case m of [Just (Flow n)] -> ([Flow $ n+1],n) [Nothing] -> ([Flow 1],0) in resources{toAdd=add, toReturn= ret} return $ show fl --------------------------------------------- instance ConvertTo String TResp where convert = TResp . pack instance ConvertTo ByteString TResp where convert = TResp --instance ConvertTo Response TResp where -- convert= TResp -- instance ConvertTo Error TResp where convert (Error e)= TResp $ pack e instance ToResponse v =>ConvertTo (HttpData v) TResp where convert= TRespR -- --instance Typeable (HSP XML) where -- typeOf = \_ -> mkTyConApp (mkTyCon "HSP") [mkTyConApp ( mkTyCon "XML") []] -- -- -- --instance ConvertTo (HSP XML) TResp where -- convert xml=unsafePerformIO $ do -- (_,html) <- evalHSP Nothing xml -- return . TResp . pack $ renderAsHTML html -- -- -- --instance Typeable X.Html where -- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Transitional.Html") [] -- -- -- -- -- --instance ConvertTo X.Html TResp where -- convert = TResp . pack . X.showHtml -- webScheduler :: -- (Typeable c, ToResponse c) => Env -> ProcList -> IO (TResp, ThreadId) webScheduler = msgScheduler eitherToError (Right x)= x eitherToError (Left e)= error $ "eitherToError " ++ show e --theDir= unsafePerformIO getCurrentDirectory wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response) wFMiddleware filter f = \ env -> if filter env then hackWorkflow env else f env -- | An instance of the abstract "MFlow" scheduler to the Hack interface -- it accept the list of processes being scheduled and return a hack handler -- -- Example: -- -- @main= do -- -- putStrLn $ options messageFlows -- 'run' 80 $ 'hackMessageFlow' messageFlows -- where -- messageFlows= [(\"main\", 'runFlow' flowname ) -- ,(\"hello\", 'stateless' statelesproc) -- ,(\"trans\", 'transient' $ runflow transientflow] -- options msgs= \"in the browser choose\\n\\n\" ++ -- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs] -- @ hackMessageFlow :: ProcList -> (Env -> IO Response) hackMessageFlow messageFlows = unsafePerformIO (addMessageFlows messageFlows) `seq` wFMiddleware (\env -> (pwfname env) `elem` paths) (\env -> defaultResponse $ "usage: http//server/" ++ show paths ++ "?verb") where (paths,_)= unzip messageFlows splitPath ""= ("","","") splitPath str= let strr= reverse str (ext, rest)= span (/= '.') strr (mod, path)= span(/='/') $ tail rest in (tail $ reverse path, reverse mod, reverse ext) hackWorkflow :: Env -> IO Response hackWorkflow req1= do let httpreq1= http req1 -- !> (show req1) let cookies= getCookies httpreq1 (flow , retcookies) <- case lookup "flow" cookies of Just fl -> return (fl, []) Nothing -> do fl <- newFlow return (fl, [("flow", fl, "/",Nothing)]) {- putStateCookie req1 cookies let retcookies= case getStateCookie req1 of Nothing -> retcookies1 Just ck -> ck:retcookies1 -} let [(input, str)]= case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack . hackInput $ req1 (GET, _) -> urlDecode . queryString $ req1 _ -> [([("","")],"")] let req = case retcookies of [] -> req1{http= input ++ cookies ++ http req1} -- !> "REQ" _ -> req1{http= ("flow", flow): input ++ cookies ++ http req1} -- !> "REQ" wfs <- getMessageFlows (resp',th) <- webScheduler req wfs let resp''= toResponse resp' let headers1= case retcookies of [] -> headers resp''; _ -> ctype : cookieHeaders retcookies let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}} return resp ------persistent state in cookies (not tested) tvresources :: MVar (Maybe ( M.Map string string)) tvresources= unsafePerformIO $ newMVar Nothing statCookieName= "stat" putStateCookie req cookies= case lookup statCookieName cookies of Nothing -> return () Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $ \mmap -> case mmap of Just map -> return $ Just $ M.insert (keyResource req) str map Nothing -> return $ Just $ M.fromList [((keyResource req), str) ] getStateCookie req= do mr<- readMVar tvresources case mr of Nothing -> return Nothing Just map -> case M.lookup (keyResource req) map of Nothing -> return Nothing Just str -> do swapMVar tvresources Nothing return $ Just (statCookieName, str , "/") {- persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource} where writeResource stat= modifyMVar_ tvresources $ \mmap -> case mmap of Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ] readResource stat= do mstr <- withMVar tvresources $ \mmap -> case mmap of Just map -> return $ M.lookup (keyResource stat) map Nothing -> return Nothing case mstr of Nothing -> return Nothing Just str -> return $ deserialize str deleteResource stat= modifyMVar_ tvresources $ \mmap-> case mmap of Just map -> return $ Just $ M.delete (keyResource stat) map Nothing -> return $ Nothing -} -- | Users -- --instance Display String TResp where -- column vs= concat ["<tr>" ++ v ++"</tr>" | v <- vs] -- row vs= concat ["<td>" ++ v ++ "</td>" | v <- vs] -- hsep = "$nbsp;" -- vsep = "<br/>" -- input n t v f= "<input type=\""++ t ++"\" name=\""++n++"\" value=\""++v++"\" "++ if f then "checked " else "" ++"/>" -- textarea name text= "<textarea name=\""++ name++"\">"++ text ++"</textarea>" -- -- option name list msel= "<select name=\""++ name ++"\">"++ -- concatMap (\(n,v) -> "<option value=\""++ n ++ selected msel n ++">"++ v ++ "</option>") list ++ -- "</select>" -- where -- selected msel n= if Just n == msel then " \"selected\" " else "" -- -- option1 name list msel= "<select name=\""++ name ++"\">"++ -- concatMap (\v -> "<option" ++ selected msel v ++">"++ v ++ "</option>") list ++ -- "</select>" -- where -- selected msel n= if Just n == msel then " \"selected\" " else "" -- -- -- -- formAction action form = "<form action=\""++action++"\" method=\"post\">"++ form ++ input "cancel" "button" "cancel" False++ input "submit" "submit" "submit" False ++ "</form>" -- fromString s= s -- bold x= "<b>" ++ x ++ "</b>" -- fs x= "<h3>" ++ x ++ "</h3>" -- ts x= "<h4>" ++ x ++ "</h4>" -- style st content = "<span style="++ st++"> "++ content ++"</span>" -- -- table title head rows= -- "<table>"++ -- (if not . null $ title then "<caption> " ++ title ++ " </caption>" else "") ++ -- (if not . null $ head then "<tr>"++concat ["<th>"++ h ++ "</th>"| h <- head] ++ "</tr>" else "")++ -- (concat ["<tr>" ++ concat["<td>"++ v ++ "</td>"| v <- row] ++ "</tr>" | row <- rows]) ++ -- "</table>" -- -- ---- textarea name value= "<texyarea name=\""++name++"\" rows=\"20\" cols="65" warp=\"true\">"++value++ "</textarea>" ---- option1 name options option= ---- "< input type=\"radio\" checked=\""++option++"\" name=\""++name++"\" value="approbal" -- -- -- link (Verb v) str = "<a href="++v++">"++ str ++"</a>" {- instance Monoid (HSP XML) where mempty = <span/> mappend x y= <span> <% x %> <% y %> </span> instance Display (HSP XML) TResp where column vs= <table><td><% [<tr> <% v %> </tr> | v <- vs] %></td></table> row vs= <tr> <% [<td> <% v %> </td> | v <- vs] %> </tr> table title caption rows= <table> {- <% when (not . null $ title) -} <caption><% title %> </caption> -- %> {-<% when (not . null $ caption)-} <tr> <%[<th> <%cap %> </th>| cap <- caption] %></tr> -- %> <%[<tr> <% [<td><% v %></td>| v <- row] %> </tr> | row <- rows] %> </table> hsep = <span> </span> style st content = <span style=(st)> <% content %> </span> vsep = <br/> fromString s = <span><% s %></span> -- option (Verb v) view1= <a href = (v)><% view1 %> </a> input typ name value= <input type= (typ) name=(name) value=(value)/> -}