module WASH.CGI.CGIHistory where
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (when)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import System.IO (Handle)
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)