module WASH.CGI.CGIHistory where
import System.IO.Unsafe (unsafePerformIO)
import IO
import Maybe
import Monad
import Control.Concurrent
import Control.Concurrent.MVar
import qualified Data.Map as Map
import WASH.Utility.SHA1
import WASH.CGI.RawCGITypes
import WASH.CGI.CGIMonad
import WASH.CGI.LogEntry
historyTimeout :: Int
historyTimeout = 100000000
type StateID = (String, String)
history :: MVar (Map.Map StateID TableEntry)
history = unsafePerformIO $ newMVar Map.empty
data TableEntry =
TableEntry
{ myID :: StateID
, parentID :: Maybe StateID
, nextparm :: PARAMETER
, timeout :: Int
, threads :: MVar [MVar (CGIParameters, Handle)]
}
createEntry :: StateID -> Maybe StateID -> PARAMETER -> Maybe Int -> IO ()
createEntry myID parentID nextparm mTimeout = do
threadsvar <- newMVar []
let protoEntry = TableEntry { myID = myID
, parentID = parentID
, nextparm = nextparm
, timeout = fromMaybe historyTimeout mTimeout
, threads = threadsvar
}
modifyMVar_ history (return . Map.insertWith (\ new old -> old) myID protoEntry)
readParameters :: StateID -> IO (CGIParameters, Handle)
readParameters stateID = do
(myVar, myTimeout) <- modifyMVar history update
myID <- myThreadId
killerID <- forkIO (killmeOnTimeout myID myVar myTimeout)
ch <- takeMVar myVar
killThread killerID
return ch
where
update t = do
let Just entry = Map.lookup stateID t
myVar <- newEmptyMVar
modifyMVar_ (threads entry) (\ ms -> return (myVar : ms))
return (t, (myVar, timeout entry))
remove v t = do
let Just entry = Map.lookup stateID t
modifyMVar (threads entry) (\ ms -> return (filter (/= v) ms, v `elem` ms))
killmeOnTimeout tid var timeout = do
threadDelay timeout
wasPresent <- withMVar history (remove var)
when wasPresent (killThread tid)
notify :: StateID -> CGIParameters -> Handle -> IO Bool
notify stateID parms hout = do
b <- withMVar history update
return b
where
update t =
case Map.lookup stateID t of
Just entry ->
do maybeVar <- modifyMVar (threads entry) (return . uncons)
case maybeVar of
Just myVar -> do
putMVar myVar (parms, hout)
return True
Nothing ->
return False
Nothing ->
return False
uncons (x : xs) = (xs, Just x)
uncons [] = ([], Nothing)