module MFlow (
Flow, Params, HttpData(..),Processable(..)
, Token(..), ProcList
,flushRec, flushResponse, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment
, sendEndFragment, sendToMF
,setNoScript,addMessageFlows,getMessageFlows,delMessageFlow, transient, stateless,anonymous
,noScript,hlog, setNotFoundResponse,getNotFoundResponse,
btag, bhtml, bbody,Attribs, addAttrs
, userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod
,Config(..), config
,setFilesPath
,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
,UserStr,PasswdStr, User(..),eUser
)
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, (\\),intersperse)
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
import Data.TCache.DefaultPersistence hiding(Indexable(..))
import Data.TCache.Memoization
import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
import Data.ByteString.Lazy.Internal (ByteString(Chunk))
import qualified Data.ByteString.Char8 as SB
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
import Data.RefSerialize hiding (empty)
import qualified Data.Text as T
import System.Posix.Internals
import Debug.Trace
(!>) = flip trace
data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable
instance Indexable Token where
key (Token w u i _ _ _ _ )= i
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 = B.pack . show
deserialize= read . B.unpack
setPersist = \_ -> Just filePersist
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; ppath=pwfPath 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 ppath penv q qr
addTokenToList token
return token
Just token -> return token{tpath= ppath, tenv= penv}
type Flow= (Token -> Workflow IO ())
data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
instance Monoid HttpData where
mempty= HttpData [] [] B.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
pwfname s= Prelude.head $ pwfPath s
pwfPath :: a -> [String]
puser :: a -> String
pind :: a -> String
getParams :: a -> Params
instance Processable Token where
pwfname = twfname
pwfPath = tpath
puser = tuser
pind = tind
getParams = tenv
instance Processable Req where
pwfname (Req x)= pwfname x
pwfPath (Req x)= pwfPath x
puser (Req x)= puser x
pind (Req x)= pind x
getParams (Req x)= getParams x
data Resp = Fragm HttpData
| EndFragm HttpData
| Resp HttpData
anonymous= "anon#"
noScriptRef= unsafePerformIO $ newIORef "noscript"
noScript= unsafePerformIO $ readIORef noScriptRef
setNoScript scr= writeIORef noScriptRef scr
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
flushResponse t@(Token _ _ _ _ _ _ qresp)= do
empty <- isEmptyMVar qresp
when (not empty) $ takeMVar qresp >> return ()
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 (WorkflowList IO Token ())
_messageFlows= unsafePerformIO $ newMVar emptyFList
where
emptyFList= M.empty :: WorkflowList IO Token ()
addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union (M.fromList $ map flt wfs)ms)
where flt ("",f)= (noScript,f)
flt e= e
getMessageFlows = readMVar _messageFlows
delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
sendToMF Token{..} msg= putMVar tsendq $ Req msg
recFromMF Token{..} = do
m <- takeMVar trecq
case m of
Resp r -> return r
Fragm r -> do
result <- getStream r
return result
where
getStream r = do
mr <- takeMVar trecq
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
let wfname = takeWhile (/='/') $ pwfname x
sendToMF token x
th <- startMessageFlow wfname token
r <- recFromMF token
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 (pwfname x))
`CE.catch` \(e:: CE.SomeException) -> do
showError wfname token (show e)
deleteTokenInList token
Left AlreadyRunning -> return ()
Left Timeout -> do
hFlush stdout
deleteTokenInList token
Left (WFException e)-> do
showError wfname token e
moveState wfname token token{tind= "error/"++tuser token}
deleteTokenInList token
Right _ -> delMsgHistory token >> return ()
showError wfname token@Token{..} e= do
t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime
let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv
logError msg
fresp <- getNotFoundResponse
let admin= getAdminName
sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
errorMessage t e u path env=
"\n---------------------ERROR-------------------------\
\\nTIME=" ++ t ++"\n\n" ++
e++
"\n\nUSER= " ++ u ++
"\n\nPATH= " ++ path ++
"\n\nREQUEST:\n\n" ++
show env
line= unsafePerformIO $ newMVar ()
logError err= do
takeMVar line
putStrLn err
hSeek hlog SeekFromEnd 0
hPutStrLn hlog err
hFlush hlog
putMVar line ()
logFileName= "errlog"
hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
data Auth = Auth{
uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
setAuthMethod auth= writeIORef _authMethod auth
getAuthMethod = readIORef _authMethod
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
instance Serializable User where
serialize= B.pack . show
deserialize= read . B.unpack
setPersist = \_ -> Just filePersist
tCacheRegister :: String -> String -> IO (Maybe String)
tCacheRegister user password = atomically $ do
withSTMResources [newuser] doit
where
newuser= User user password
doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
tCacheValidate u p =
let user= eUser{userName=u}
in 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"
userRegister u p= liftIO $ do
Auth reg _ <- getAuthMethod :: IO Auth
reg u p
data Config = Config{cadmin :: UserStr
,cjqueryScript :: String
,cjqueryCSS :: String
,cjqueryUI :: String
,cnicEditUrl :: String
}
deriving (Read, Show, Typeable)
defConfig= Config "admin" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
"//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
"//code.jquery.com/ui/1.10.3/jquery-ui.js"
"//js.nicedit.com/nicEdit-latest.js"
config= unsafePerformIO $! atomically $! readConfig
readConfig= readDBRef rconf `onNothing` return defConfig
keyConfig= "mflow.config"
instance Indexable Config where key _= keyConfig
rconf= getDBRef keyConfig
instance Serializable Config where
serialize= B.pack . show
deserialize= read . B.unpack
setPersist = \_ -> Just filePersist
type UserStr= String
type PasswdStr= String
setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
setAdminUser user password= liftIO $ do
userRegister user password
atomically $ do
conf <- readConfig
writeDBRef rconf $ conf{cadmin= user}
getAdminName= cadmin config
defNotFoundResponse isAdmin msg= fresp $
case isAdmin of
True -> B.pack msg
_ -> "The administrator has been notified"
where
fresp msg=
"<html><h4>Error 404: Page not found or error ocurred</h4> <p style=\"font-family:courier\">" <> msg <>"</p>" <>
"<br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>"
paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
opts= "options: " <> B.concat (Prelude.map (\s ->
"<a href=\"/"<> s <>"\">"<> s <>"</a>, ") $ filter (\s -> B.head s /= '_') paths)
notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
setNotFoundResponse ::
(Bool
-> String
-> ByteString)
-> IO ()
setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
getNotFoundResponse= liftIO $ readIORef notFoundResponse
type Attribs= [(String,String)]
btag :: String -> Attribs -> ByteString -> ByteString
btag t rs v= "<" <> pt <> attrs rs <> ">" <> v <> "</" <> pt <> ">"
where
pt= B.pack t
attrs []= B.empty
attrs rs= B.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 (B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest
addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
setFilesPath :: MonadIO m => String -> m ()
setFilesPath path= liftIO $ writeIORef rfilesPath path
rfilesPath= unsafePerformIO $ newIORef "files/"
serveFile path'= do
when(let hpath= Prelude.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 -> error "not found"
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)
data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
instance Indexable NFlow where
key _= "Flow"
instance Serializable NFlow where
serialize= B.pack . show
deserialize= read . B.unpack
setPersist = \_ -> Just filePersist
rflow= getDBRef . key $ NFlow undefined
newFlow= do
TOD t _ <- getClockTime
atomically $ do
NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
writeDBRef rflow . NFlow $ n+1
return . SB.pack . show $ t + n
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")
]