module Holumbus.Distribution.DNode.Base
(
DistributedException(..)
, DNodeConfig(..)
, defaultDNodeConfig
, DNodeId
, mkDNodeId
, DNodeAddress
, mkDNodeAddress
, DHandlerId
, DResourceType
, mkDResourceType
, DResourceId
, DResourceAddress
, mkDResourceAddress
, DResourceDispatcher
, DResourceEntry(..)
, initDNode
, deinitDNode
, addForeignDNode
, delForeignDNode
, checkForeignDNode
, addForeignDNodeHandler
, addForeignDResourceHandler
, delForeignHandler
, genLocalResourceAddress
, addLocalResource
, delLocalResource
, delForeignResource
, safeAccessForeignResource
, unsafeAccessForeignResource
, getByteStringMessage
, putByteStringMessage
, getDNodeData
)
where
import Prelude hiding (catch)
import Control.Exception
import Control.Concurrent
import Data.Typeable
import Data.Binary
import Data.Char
import Data.Maybe
import Data.Unique
import qualified Data.Map as Map
import qualified Data.Set as Set
import Network.Socket (HostName, PortNumber)
import System.IO
import System.IO.Unsafe
import System.Log.Logger
import System.Random
import Holumbus.Distribution.DNode.Network
localLogger :: String
localLogger = "Holumbus.Distribution.DNode.Base"
data DistributedException = DistributedException {
distEx_msg :: String
, distEx_fct :: String
, distEx_mod :: String
} deriving(Typeable, Show)
instance Exception DistributedException
data DId
= DIdName String
| DIdNumber Integer
deriving (Show, Eq, Ord)
instance Binary DId where
put (DIdName s) = putWord8 0 >> put s
put (DIdNumber n) = putWord8 1 >> put n
get
= do
t <- getWord8
case t of
0 -> get >>= \s -> return (DIdName s)
_ -> get >>= \n -> return (DIdNumber n)
genDId :: String -> IO DId
genDId ""
= do
i <- getStdRandom (randomR (1,1000000)):: IO Integer
return $ DIdNumber i
genDId st
= do
return $ DIdName st
data DNodeConfig = DNodeConfig {
dnc_Name :: String
, dnc_MinPort :: Int
, dnc_MaxPort :: Int
, dnc_AccessDelay :: Int
, dnc_PingDelay :: Int
} deriving (Show)
defaultDNodeConfig :: String -> DNodeConfig
defaultDNodeConfig s
= DNodeConfig s 8000 9000 1000000 1000000
newtype DNodeId = DNodeId DId
deriving (Show, Eq, Ord)
instance Binary DNodeId where
put (DNodeId i) = put i
get = get >>= \i -> return (DNodeId i)
genDNodeId :: String -> IO DNodeId
genDNodeId s = genDId s >>= \i -> return (DNodeId i)
mkDNodeId :: String -> DNodeId
mkDNodeId "" = error "the name of DNode is empty"
mkDNodeId s = DNodeId $ DIdName s
data DNodeAddress = DNodeAddress {
dna_Id :: DNodeId
, dna_HostName :: HostName
, dna_ServiceName :: PortNumber
} deriving (Show, Eq, Ord)
instance Binary DNodeAddress where
put (DNodeAddress i hn po) = put i >> put hn >> put (toInteger po)
get = get >>= \i -> get >>= \hn -> get >>= \po -> return (DNodeAddress i hn (fromInteger po))
mkDNodeAddress :: String -> HostName -> Int -> DNodeAddress
mkDNodeAddress s hn po = DNodeAddress i hn (fromIntegral po)
where
i = mkDNodeId s
type DHandlerFunction = DHandlerId -> IO ()
data DNodeEntry = DNodeEntry {
dne_Address :: DNodeAddress
, dne_PingThreadId :: Maybe ThreadId
, dne_HandlerFunctions :: Map.Map DHandlerId DHandlerFunction
, dne_TriggeredHandlers :: Set.Set DHandlerId
, dne_PositiveNodeHandlers :: Set.Set DHandlerId
, dne_NegativeNodeHandlers :: Set.Set DHandlerId
, dne_PositiveResourceHandlers :: Set.Set DHandlerId
, dne_NegativeResourceHandlers :: Set.Set DHandlerId
}
instance Show DNodeEntry where
show _ = "{DNodeEntry}"
data DHandlerId = DHandlerId {
dhi_Id :: Unique
, dhi_DNodeId :: DNodeId
, dhi_DResourceId :: Maybe DResourceId
} deriving (Eq, Ord)
newtype DResourceType = DResourceType String
deriving (Show, Eq, Ord)
instance Binary DResourceType where
put (DResourceType s) = put s
get = get >>= \s -> return (DResourceType s)
mkDResourceType :: String -> DResourceType
mkDResourceType s = DResourceType (map toUpper s)
data DResourceId = DResourceId DId DResourceType
deriving (Show, Eq, Ord)
instance Binary DResourceId where
put (DResourceId i t) = put i >> put t
get = get >>= \i -> get >>= \t -> return (DResourceId i t)
genDResourceId :: DResourceType -> String -> IO DResourceId
genDResourceId t s = genDId s >>= \i -> return (DResourceId i t)
mkDResourceId :: DResourceType -> String -> DResourceId
mkDResourceId _ "" = error "the name of the DResource is empty"
mkDResourceId t s = DResourceId (DIdName s) t
data DResourceAddress = DResourceAddress {
dra_Id :: DResourceId
, dra_NodeId :: DNodeId
} deriving (Show, Eq, Ord)
instance Binary DResourceAddress where
put (DResourceAddress i a) = put i >> put a
get = get >>= \i -> get >>= \a -> return (DResourceAddress i a)
mkDResourceAddress :: DResourceType -> String -> String -> DResourceAddress
mkDResourceAddress t r n = DResourceAddress dri dni
where
dri = mkDResourceId t r
dni = mkDNodeId n
type DResourceDispatcher = DNodeId -> Handle -> IO ()
data DResourceEntry = DResourceEntry {
dre_Dispatcher :: DResourceDispatcher
}
instance Show DResourceEntry where
show _ = "{DResourceEntry}"
data DNodeData = DNodeData {
dnd_Address :: DNodeAddress
, dnd_SocketServer :: SocketServer
, dnd_AccessDelay :: Int
, dnd_PingDelay :: Int
, dnd_NodeMap :: Map.Map DNodeId DNodeEntry
, dnd_OwnResourceMap :: Map.Map DResourceId DResourceEntry
} deriving (Show)
type DNode = MVar DNodeData
myDNode :: DNode
myDNode
= do
unsafePerformIO $ newEmptyMVar
initDNode :: DNodeConfig -> IO DNodeId
initDNode c
= do
let minPort = fromIntegral $ dnc_MinPort c
maxPort = fromIntegral $ dnc_MaxPort c
accessDelay = dnc_AccessDelay c
pingDelay = dnc_PingDelay c
n <- genDNodeId (dnc_Name c)
serverSocket <- startSocketServer (dispatcher) minPort maxPort
case serverSocket of
Nothing ->
do
errorM localLogger "no socket opened"
error "socket could not be opened"
(Just ss) ->
do
let hn = getSocketServerName ss
po = getSocketServerPort ss
dnd = DNodeData {
dnd_Address = DNodeAddress n hn po
, dnd_SocketServer = ss
, dnd_AccessDelay = accessDelay
, dnd_PingDelay = pingDelay
, dnd_NodeMap = Map.empty
, dnd_OwnResourceMap = Map.empty
}
success <- tryPutMVar myDNode dnd
if success
then do return ()
else do
stopSocketServer ss
error "dnode already initialized"
return n
deinitDNode :: IO ()
deinitDNode
= do
mbDnd <- tryTakeMVar myDNode
case mbDnd of
(Just dnd) ->
do
stopSocketServer (dnd_SocketServer dnd)
(Nothing) ->
do
error "dnode already deinitialized"
addNode :: DNodeAddress -> IO ()
addNode dna
= do
let dne = DNodeEntry dna Nothing Map.empty Set.empty Set.empty Set.empty Set.empty Set.empty
dni = dna_Id dna
modifyMVar_ myDNode $ \dnd -> return $ addNodeP dni dne dnd
addNodeP :: DNodeId -> DNodeEntry -> DNodeData -> DNodeData
addNodeP dni dne dnd = dnd { dnd_NodeMap = am }
where
am = Map.insert dni dne (dnd_NodeMap dnd)
deleteNode :: DNodeId -> IO ()
deleteNode i = modifyMVar_ myDNode $ \dnd -> return $ deleteNodeP i dnd
deleteNodeP :: DNodeId -> DNodeData -> DNodeData
deleteNodeP i dnd = dnd { dnd_NodeMap = am }
where
am = Map.delete i (dnd_NodeMap dnd)
lookupNode :: DNodeId -> IO (Maybe DNodeEntry)
lookupNode i = withMVar myDNode $ \dnd -> return $ lookupNodeP i dnd
lookupNodeP :: DNodeId -> DNodeData -> Maybe DNodeEntry
lookupNodeP i dnd = Map.lookup i (dnd_NodeMap dnd)
addResource :: DResourceId -> DResourceEntry -> IO ()
addResource i d = modifyMVar_ myDNode $ \dnd -> return $ addResourceP dnd i d
addResourceP :: DNodeData -> DResourceId -> DResourceEntry -> DNodeData
addResourceP dnd i d = dnd { dnd_OwnResourceMap = rm }
where
rm = Map.insert i d (dnd_OwnResourceMap dnd)
deleteResource :: DResourceId -> IO ()
deleteResource a = modifyMVar_ myDNode $ \dnd -> return $ deleteResourceP dnd a
deleteResourceP :: DNodeData -> DResourceId -> DNodeData
deleteResourceP dnd i = dnd { dnd_OwnResourceMap = rm }
where
rm = Map.delete i (dnd_OwnResourceMap dnd)
lookupResource :: DResourceId -> IO (Maybe DResourceEntry)
lookupResource i = withMVar myDNode $ \dnd -> return $ lookupResourceP dnd i
lookupResourceP :: DNodeData -> DResourceId -> Maybe DResourceEntry
lookupResourceP dnd i = Map.lookup i (dnd_OwnResourceMap dnd)
getDNodeData :: IO (DNodeData)
getDNodeData = readMVar myDNode
lookupDNodeReqestInfo :: DNodeId -> IO (DNodeAddress, Maybe DNodeAddress)
lookupDNodeReqestInfo dni
= withMVar myDNode $ \dnd ->
do
let myDna = dnd_Address dnd
mbDne = lookupNodeP dni dnd
mbOtherDna = if (isJust mbDne) then (Just $ dne_Address $ fromJust mbDne) else Nothing
return (myDna, mbOtherDna)
checkDNodeRequest :: DNodeAddress -> DNodeAddress -> IO Bool
checkDNodeRequest s r
= modifyMVar myDNode $ \dnd ->
do
let isValid = (dna_Id r) == (dna_Id $ dnd_Address dnd)
dni = dna_Id s
dne = DNodeEntry s Nothing Map.empty Set.empty Set.empty Set.empty Set.empty Set.empty
dnd' = if (Map.member dni (dnd_NodeMap dnd))
then dnd
else addNodeP dni dne dnd
return (dnd', isValid)
data DNodeRequestMessage = DNodeRequestMessage {
dnm_Req_Sender :: DNodeAddress
, dnm_Req_Receiver :: DNodeAddress
, dnm_Req_Message :: DNodeRequest
} deriving (Show)
instance Binary DNodeRequestMessage where
put (DNodeRequestMessage s r m) = put s >> put r >> put m
get = get >>= \s -> get >>= \r -> get >>= \m -> return (DNodeRequestMessage s r m)
data DNodeRequest
= DNMReqPing DNodeId [DResourceId]
| DNMReqResourceMsg DResourceAddress
deriving (Show)
instance Binary DNodeRequest where
put (DNMReqPing i rs) = putWord8 3 >> put i >> put rs
put (DNMReqResourceMsg a) = putWord8 4 >> put a
get
= do
t <- getWord8
case t of
3 -> get >>= \i -> get >>= \rs -> return (DNMReqPing i rs)
4 -> get >>= \a -> return (DNMReqResourceMsg a)
_ -> error "DNodeRequestMessage: wrong encoding"
data DNodeResponseMessage
= DNMRspOk
| DNMRspPing [(DResourceId,Bool)]
| DNMRspError String
deriving (Show)
instance Binary DNodeResponseMessage where
put(DNMRspOk) = putWord8 1
put(DNMRspPing rs) = putWord8 2 >> put rs
put(DNMRspError e) = putWord8 3 >> put e
get
= do
t <- getWord8
case t of
1 -> return (DNMRspOk)
2 -> get >>= \rs -> return (DNMRspPing rs)
3 -> get >>= \e -> return (DNMRspError e)
_ -> error "DNodeResponseMessage: wrong encoding"
dispatcher :: Handle -> IO ()
dispatcher hdl
= do
debugM localLogger "dispatcher: reading message from connection"
raw <- getByteStringMessage hdl
debugM localLogger "dispatcher: message received starting dispatching"
let msg = (decode raw)::DNodeRequestMessage
let sender = dnm_Req_Sender msg
let receiver = dnm_Req_Receiver msg
isValid <- checkDNodeRequest sender receiver
if isValid
then do
debugM localLogger $ "dispatcher: Message: " ++ show msg
case (dnm_Req_Message msg) of
(DNMReqPing i rs) -> handlePing i rs hdl
(DNMReqResourceMsg a) -> handleResourceMessage (dna_Id sender) a hdl
else do
warningM localLogger $ "message for other node received... dropping request: " ++ show msg
putByteStringMessage (encode $ DNMRspError "unknown receiver") hdl
requestPing :: DNodeAddress -> DNodeAddress -> DNodeId -> [DResourceId] -> Handle -> IO (Maybe [(DResourceId, Bool)])
requestPing s r i rs hdl
= do
let request = DNodeRequestMessage s r (DNMReqPing i rs)
putByteStringMessage (encode $ request) hdl
raw <- getByteStringMessage hdl
let rsp = (decode raw)::DNodeResponseMessage
case rsp of
(DNMRspOk) -> return (Just [])
(DNMRspPing ls) -> return (Just ls)
(DNMRspError e) -> do
errorM localLogger e
return Nothing
handlePing :: DNodeId -> [DResourceId] -> Handle -> IO ()
handlePing otherDni rs hdl
= do
dnd <- readMVar myDNode
let myDni = dna_Id $ dnd_Address dnd
if (myDni == otherDni)
then do
let orm = dnd_OwnResourceMap dnd
ls = map (\i -> (i, isJust $ Map.lookup i orm)) rs
putByteStringMessage (encode $ DNMRspPing ls) hdl
else do
putByteStringMessage (encode $ DNMRspError "false ping - ids do not match") hdl
requestResourceMessage :: DNodeAddress -> DNodeAddress -> DResourceAddress -> (Handle -> IO a) -> Handle -> IO a
requestResourceMessage s r dra requester hdl
= do
let request = DNodeRequestMessage s r (DNMReqResourceMsg dra)
debugM localLogger "requestResourceMessage: asking node for resource"
putByteStringMessage (encode $ request) hdl
debugM localLogger "requestResourceMessage: getting the response"
raw <- getByteStringMessage hdl
debugM localLogger "requestResourceMessage: parsing the response"
let rsp = (decode raw)::DNodeResponseMessage
case rsp of
(DNMRspOk) -> do requester hdl
(DNMRspError e) -> error e
_ -> error "false response"
handleResourceMessage :: DNodeId -> DResourceAddress -> Handle -> IO ()
handleResourceMessage sender dra hdl
= do
let i = dra_Id dra
mbDrd <- lookupResource i
case mbDrd of
(Just drd) ->
do
putByteStringMessage (encode $ DNMRspOk) hdl
let handler = dre_Dispatcher drd
handler sender hdl
(Nothing) ->
putByteStringMessage (encode $ DNMRspError "resource not found") hdl
addForeignDNode :: DNodeAddress -> IO ()
addForeignDNode dna
= do
addNode dna
delForeignDNode :: DNodeId -> IO ()
delForeignDNode i
= do
mDne <- lookupNode i
case mDne of
(Just _) ->
do
deleteNode i
(Nothing) -> return ()
checkForeignDNode :: DNodeId -> IO (Bool)
checkForeignDNode dni
= do
(myDna, mbOtherDna) <- lookupDNodeReqestInfo dni
case mbOtherDna of
(Just otherDna) ->
do
let hn = dna_HostName otherDna
po = dna_ServiceName otherDna
res <- performSafeSendRequest (requestPing myDna otherDna dni []) Nothing hn po
return $ isJust res
(Nothing) -> return False
addForeignDNodeHandler :: Bool -> DNodeId -> DHandlerFunction -> IO (Maybe DHandlerId)
addForeignDNodeHandler positive dni f
= modifyMVar myDNode $ \dnd ->
do
case (lookupNodeP dni dnd) of
(Just dne) ->
do
let oldTid = dne_PingThreadId dne
tid <- if (isNothing oldTid)
then do
t <- startPingThread dni
return $ Just t
else return oldTid
uid <- newUnique
let dhi = DHandlerId uid dni Nothing
dne' = dne { dne_HandlerFunctions = Map.insert dhi f (dne_HandlerFunctions dne)
, dne_PositiveNodeHandlers = if positive
then Set.insert dhi (dne_PositiveNodeHandlers dne)
else (dne_PositiveNodeHandlers dne)
, dne_NegativeNodeHandlers = if positive
then (dne_NegativeNodeHandlers dne)
else Set.insert dhi (dne_NegativeNodeHandlers dne)
, dne_PingThreadId = tid }
return ((addNodeP dni dne' dnd), Just dhi)
(Nothing) -> return (dnd, Nothing)
addForeignDResourceHandler :: Bool -> DResourceAddress -> DHandlerFunction -> IO (Maybe DHandlerId)
addForeignDResourceHandler positive dra f
= modifyMVar myDNode $ \dnd ->
do
let dni = dra_NodeId dra
dri = dra_Id dra
case (lookupNodeP dni dnd) of
(Just dne) ->
do
let oldTid = dne_PingThreadId dne
tid <- if (isNothing $ oldTid)
then do
t <- startPingThread dni
return $ Just t
else return oldTid
uid <- newUnique
let dhi = DHandlerId uid dni (Just dri)
dne' = dne { dne_HandlerFunctions = Map.insert dhi f (dne_HandlerFunctions dne)
, dne_PositiveResourceHandlers = if positive
then Set.insert dhi (dne_PositiveResourceHandlers dne)
else (dne_PositiveResourceHandlers dne)
, dne_NegativeResourceHandlers = if positive
then (dne_NegativeResourceHandlers dne)
else Set.insert dhi (dne_NegativeResourceHandlers dne)
, dne_PingThreadId = tid }
return ((addNodeP dni dne' dnd), Just dhi)
(Nothing) -> return (dnd, Nothing)
delForeignHandler :: DHandlerId -> IO ()
delForeignHandler dhi
= do
modifyMVar_ myDNode $ \dnd ->
do
let dni = dhi_DNodeId dhi
case (lookupNodeP dni dnd) of
(Just dne) ->
do
let dne' = dne { dne_HandlerFunctions = Map.delete dhi (dne_HandlerFunctions dne)
, dne_TriggeredHandlers = Set.delete dhi (dne_TriggeredHandlers dne)
, dne_PositiveResourceHandlers = Set.delete dhi (dne_PositiveResourceHandlers dne)
, dne_NegativeResourceHandlers = Set.delete dhi (dne_NegativeResourceHandlers dne)
, dne_PositiveNodeHandlers = Set.delete dhi (dne_PositiveNodeHandlers dne)
, dne_NegativeNodeHandlers = Set.delete dhi (dne_NegativeNodeHandlers dne)
}
return $ addNodeP dni dne' dnd
(Nothing) -> return dnd
genLocalResourceAddress :: DResourceType -> String -> IO DResourceAddress
genLocalResourceAddress t s
= do
i <- genDResourceId t s
dnd <- readMVar myDNode
return $ DResourceAddress i (dna_Id $ dnd_Address dnd)
addLocalResource :: DResourceAddress -> DResourceEntry -> IO ()
addLocalResource a d
= do
let i = dra_Id a
addResource i d
delLocalResource :: DResourceAddress -> IO ()
delLocalResource a
= do
let i = dra_Id a
deleteResource i
delForeignResource :: DResourceAddress -> IO ()
delForeignResource dra
= modifyMVar_ myDNode $ \dnd ->
do
let dni = dra_NodeId dra
dri = dra_Id dra
case (lookupNodeP dni dnd) of
(Just dne) ->
do
let handlerIds = Set.fromList $ filter (\dhi -> (dhi_DResourceId dhi) == (Just dri)) $ Map.keys (dne_HandlerFunctions dne)
dne' = dne { dne_HandlerFunctions = Map.filterWithKey (\k _ -> Set.notMember k handlerIds) (dne_HandlerFunctions dne)
, dne_TriggeredHandlers = Set.difference (dne_TriggeredHandlers dne) handlerIds
, dne_PositiveResourceHandlers = Set.difference (dne_PositiveResourceHandlers dne) handlerIds
, dne_NegativeResourceHandlers = Set.difference (dne_NegativeResourceHandlers dne) handlerIds
}
return $ addNodeP dni dne' dnd
(Nothing) -> return dnd
safeAccessForeignResource :: DResourceAddress -> (Handle -> IO a) -> IO a
safeAccessForeignResource dra requester
= do
debugM localLogger $ "accessForeignResource: " ++ show dra
let dni = dra_NodeId dra
(myDna, mbOtherDna) <- lookupDNodeReqestInfo dni
case mbOtherDna of
(Just otherDna) ->
do
debugM localLogger $ "accessForeignResource: node in list found"
let hn = dna_HostName otherDna
po = dna_ServiceName otherDna
mbres <- performMaybeSendRequest (requestResourceMessage myDna otherDna dra requester) hn po
case mbres of
(Just res) -> return res
(Nothing) -> retryAccess
(Nothing) -> retryAccess
where
retryAccess
= do
dnd <- readMVar myDNode
threadDelay $ dnd_AccessDelay dnd
yield
safeAccessForeignResource dra requester
unsafeAccessForeignResource :: DResourceAddress -> (Handle -> IO a) -> IO a
unsafeAccessForeignResource dra requester
= do
debugM localLogger $ "accessForeignResource: " ++ show dra
let dni = dra_NodeId dra
(myDna, mbOtherDna) <- lookupDNodeReqestInfo dni
case mbOtherDna of
(Just otherDna) ->
do
debugM localLogger $ "accessForeignResource: node in list found"
let hn = dna_HostName otherDna
po = dna_ServiceName otherDna
catch (performUnsafeSendRequest (requestResourceMessage myDna otherDna dra requester) hn po)
(\(e ::IOException) ->
do
debugM localLogger $ show e
throwIO $ DistributedException (show e) "unsafeAccessForeignResource" "DNode")
(Nothing) ->
throwIO $ DistributedException "node not registered" "unsafeAccessForeignResource" "DNode"
startPingThread :: DNodeId -> IO ThreadId
startPingThread otherDNodeId
= do
forkIO $ pingLoop
where
pingLoop = do
myDnd <- readMVar myDNode
let myDna = dnd_Address myDnd
mbDne <- lookupNode otherDNodeId
case mbDne of
(Just dne) -> do
myTid <- myThreadId
if ((Just myTid) == (dne_PingThreadId dne))
then do
pingRes <- doPinging myDna dne
(hdls,pingDelay) <- evaluatePingResult pingRes
sequence_ $ map (\(dhi,f) -> forkIO $ f dhi) hdls
threadDelay pingDelay
pingLoop
else do
debugM localLogger $ "the thread ids don't match - leaving thread" ++ show otherDNodeId
return ()
(Nothing) -> do
debugM localLogger $ "resource not found - leaving thread: " ++ show otherDNodeId
return ()
doPinging myDna dne = do
let resources = mapMaybe (dhi_DResourceId) $ Map.keys $ dne_HandlerFunctions dne
otherDna = dne_Address dne
hn = dna_HostName otherDna
po = dna_ServiceName otherDna
performSafeSendRequest (requestPing myDna otherDna otherDNodeId resources) Nothing hn po
evaluatePingResult res =
modifyMVar myDNode $ \dnd -> do
let pingDelay = dnd_PingDelay dnd
(dnd', hdls) <- case (Map.lookup otherDNodeId (dnd_NodeMap dnd)) of
(Just dne) -> do
let tid = if (hasAnyHandlers dne)then (dne_PingThreadId dne) else Nothing
allPosNodeHdls = dne_PositiveNodeHandlers dne
allPosResHdls = dne_PositiveResourceHandlers dne
allNegNodeHdls = dne_NegativeNodeHandlers dne
allNegResHdls = dne_NegativeResourceHandlers dne
trigHdls = dne_TriggeredHandlers dne
hdlFuncs = dne_HandlerFunctions dne
(allTrigHdls, hdls) <- case (res) of
(Just ls) -> do
let untrigPosNodeHdls = Set.difference allPosNodeHdls trigHdls
existingRes = Set.fromList $ map fst $ filter (snd) ls
missingRes = Set.fromList $ map fst $ filter (not . snd) ls
existingPosResHdls = Set.filter (isMatchingResHdl existingRes) allPosResHdls
missingPosResHdls = Set.filter (isMatchingResHdl missingRes) allPosResHdls
existingNegResHdls = Set.filter (isMatchingResHdl existingRes) allNegResHdls
missingNegResHdls = Set.filter (isMatchingResHdl missingRes) allNegResHdls
untrigPosResHdls = Set.difference existingPosResHdls trigHdls
untrigNegResHdls = Set.difference missingNegResHdls trigHdls
untrigHdls = Set.unions [untrigPosNodeHdls, untrigPosResHdls, untrigNegResHdls]
reUntrigHdls = Set.unions [allNegNodeHdls, missingPosResHdls, existingNegResHdls]
allTrigHdls = Set.union untrigHdls $ Set.difference trigHdls reUntrigHdls
hdls = filter (\(dhi,_) -> Set.member dhi untrigHdls) $ Map.toList hdlFuncs
return (allTrigHdls, hdls)
(Nothing) -> do
let untrigNegNodeHdls = Set.difference allNegNodeHdls trigHdls
untrigNegResHdls = Set.difference allNegResHdls trigHdls
untrigHdls = Set.union untrigNegNodeHdls untrigNegResHdls
allTrigHdls = Set.union allNegNodeHdls allNegResHdls
hdls = filter (\(dhi,_) -> Set.member dhi untrigHdls) $ Map.toList hdlFuncs
return (allTrigHdls, hdls)
let dne' = dne { dne_PingThreadId = tid, dne_TriggeredHandlers = allTrigHdls }
dnd' = addNodeP otherDNodeId dne' dnd
return (dnd', hdls)
(Nothing) -> return (dnd, [])
return (dnd', (hdls, pingDelay))
isMatchingResHdl :: Set.Set DResourceId -> DHandlerId -> Bool
isMatchingResHdl resIds dhi = if (isJust mbResId) then isMember else False
where
mbResId = dhi_DResourceId dhi
resId = fromJust mbResId
isMember = Set.member resId resIds
hasAnyHandlers :: DNodeEntry -> Bool
hasAnyHandlers dne = not $ Map.null (dne_HandlerFunctions dne)