module MFlow (
Flow, Params, HttpData(..),Processable(..)
, Token(..), ProcList
,flushRec, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment
, sendEndFragment
,addMessageFlows,getMessageFlows, transient, stateless,anonymous
,noScript,hlog, setNotFoundResponse,getNotFoundResponse,
btag, bhtml, bbody,Attribs, addAttrs
,setFilesPath
,addTokenToList,deleteTokenInList, msgScheduler,serveFile)
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,isSuffixOf,isInfixOf, elem , span, (\\))
import Control.Monad(when)
import Data.Monoid
import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
import Data.Char(toLower)
import Unsafe.Coerce
import System.IO.Unsafe
import Data.TCache.DefaultPersistence hiding(Indexable(..))
import Data.TCache.Memoization
import Data.ByteString.Lazy.Char8 as B (readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
import Data.ByteString.Lazy.Internal (ByteString(Chunk))
import qualified Data.Map as M
import System.IO
import System.Time
import Control.Workflow
import MFlow.Cookies
import Control.Monad.Trans
import qualified Control.Exception as CE
type Flow= (Token -> Workflow IO ())
data HttpData = HttpData Params [Cookie] ByteString | Error WFErrors ByteString deriving (Typeable, Show)
instance Monoid HttpData where
mempty= HttpData [] [] empty
mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'
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
instance Processable Token where
pwfname = twfname
puser = tuser
pind = tind
getParams = tenv
instance Processable Req where
pwfname (Req x)= pwfname x
puser (Req x)= puser x
pind (Req x)= pind x
getParams (Req x)= getParams x
data Resp = Fragm HttpData
| EndFragm HttpData
| Resp HttpData
data Token = Token{twfname,tuser, tind :: String , tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable
instance Indexable Token where
key (Token w u i _ _ _ )=
if u== anonymous then u++ i
else u
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; penv= getParams msg
let mqs = M.lookup ( i ++ w ++ u) qmap
case mqs of
Nothing -> do
q <- newEmptyMVar
qr <- newEmptyMVar
let token= Token w u i penv q qr
addTokenToList token
return token
Just token-> return token
anonymous= "anon#"
noScript = "noscript"
send :: Token -> HttpData -> IO()
send t@(Token _ _ _ _ _ qresp) msg= do
( putMVar qresp . Resp $ msg )
sendFlush t msg= flushRec t >> send t msg
sendFragment :: Token -> HttpData -> IO()
sendFragment (Token _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg
sendEndFragment :: Token -> HttpData -> IO()
sendEndFragment (Token _ _ _ _ _ qresp ) msg= putMVar qresp $ EndFragm msg
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 t@(Token _ _ _ _ queue _)= readMVar queue
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
delWFHistory1 statKey
stateless :: (Params -> IO HttpData) -> Flow
stateless f = transient proc
where
proc t@(Token _ _ _ _ queue qresp) = loop t queue qresp
loop t queue qresp=do
req <- takeMVar queue
resp <- f (getParams req)
(putMVar qresp $ Resp resp )
loop t queue qresp
transient :: (Token -> IO ()) -> Flow
transient f= unsafeIOtoWF . f
_messageFlows :: MVar (M.Map String Flow)
_messageFlows= unsafePerformIO $ newMVar M.empty
addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union ms (M.fromList $ map flt wfs))
where flt ("",f)= (noScript,f)
flt e= e
getMessageFlows = readMVar _messageFlows
thread t= show(unsafePerformIO myThreadId) ++ " "++ show (twfname t)
tellToWF t@(Token _ _ _ _ queue qresp ) msg = do
putMVar queue (Req msg)
m <- takeMVar qresp
case m of
Resp r -> return r
Fragm r -> do
result <- getStream r
return result
where
getStream r = do
mr <- takeMVar qresp
case mr of
Fragm h -> do
rest <- unsafeInterleaveIO $ getStream h
let result= mappend r rest
return result
EndFragm h -> do
let result= mappend r h
return result
Resp h -> do
let result= mappend r h
return result
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
case r of
Left NotFound -> do
sendFlush token =<< serveFile wfname
deleteTokenInList token
Left AlreadyRunning -> return ()
Left Timeout -> return()
Left (WFException e)-> do
let user= key token
print e
logError user wfname e
moveState wfname token token{tuser= "error/"++tuser token}
sendFlush token $ HttpData [("Content-Type", "text/plain")] [] $
case user of
"admin" -> pack $ show e
_ -> "An Error has ocurred."
Right _ -> do
delMsgHistory token; return ()
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
defNotFoundResponse msg=
"<html><h4>Error 404: Page not found or error ocurred:</h4><h3>" <> msg <>
"</h3><br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>"
where
paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
opts= "options: " <> B.concat (Prelude.map (\s ->
"<a href=\""<> s <>"\">"<> s <>"</a>, ") paths)
notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
getNotFoundResponse= unsafePerformIO $ readIORef notFoundResponse
type Attribs= [(String,String)]
btag :: String -> Attribs -> ByteString -> ByteString
btag t rs v= "<" `append` pt `append` attrs rs `append` ">" `append` v `append`"</"`append` pt `append` ">"
where
pt= pack t
attrs []= B.empty
attrs rs= pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
bhtml :: Attribs -> ByteString -> ByteString
bhtml ats v= btag "html" ats v
bbody :: Attribs -> ByteString -> ByteString
bbody ats v= btag "body" ats v
addAttrs :: ByteString -> Attribs -> ByteString
addAttrs (Chunk "<" (Chunk tag rest)) rs=
Chunk "<"(Chunk tag (pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest
addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
setFilesPath :: String -> IO ()
setFilesPath path= writeIORef rfilesPath path
rfilesPath= unsafePerformIO $ newIORef "files/"
serveFile 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'
mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing)
case mr of
Nothing -> return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
Just r ->
let ext = reverse . takeWhile (/='.') $ reverse path
mmime= lookup (map toLower ext) mimeTable
mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream"
in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
where
noperm= "no permissions"
ioerr x= \(e :: CE.IOException) -> x
setMime x= ("Content-Type",x)
mimeTable=[
("html", "text/html"),
("htm", "text/html"),
("txt", "text/plain"),
("hs", "text/plain"),
("lhs", "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"),
("png", "image/png"),
("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")
]