module Network.AdHoc.Routing (
RoutingStrategy(..),
Addressed(..)
) where
import Network.AdHoc.UserID
import Data.List as List
import Data.Map as Map
import Data.Word
import Network.Socket
import Network.AdHoc.Message
import Network.AdHoc.Encryption
class RoutingStrategy rs where
routeSingle :: UserID -> rs -> Maybe SockAddr
routeSingle uid strat = let mp = fst (routeMulti [uid] strat) in case Map.keys mp of
k:_ -> Just k
_ -> Nothing
routeMulti :: [UserID] -> rs -> (Map SockAddr [UserID],[UserID])
routeMulti users strat = foldl (\(mp,nor) user -> case routeSingle user strat of
Nothing -> (mp,user:nor)
Just addr -> (Map.alter ((Just).maybe [user] (user:)) addr mp,nor)) (Map.empty, []) users
class Addressed a where
route :: RoutingStrategy r =>
r
-> a
-> (Map SockAddr a, Maybe a)
instance Addressed (Routed (RSAEncrypted String) sign) where
route strategy rt = routingSingleMap (routedUserID rt) rt strategy
instance Addressed (Routed TargetContent sign) where
route s rt@(Routed _ _ _ cont _) = case cont of
Nack srt -> routingSingleMap (routedUserID srt) rt s
GetCertificate for -> routingSingleMap for rt s
Certificate recv _ _ -> routingMultiMap recv (\nrecv -> rt
{routedContent = cont {certificateReceivers = nrecv}}) s
Message recv _ _ _ _ _ -> routingMultiMap recv (\nrecv -> rt
{routedContent = cont {messageReceivers = nrecv}}) s
GetKey recv _ _ -> routingSingleMap recv rt s
Key recv _ _ _ _ -> routingSingleMap recv rt s
routingSingleMap :: RoutingStrategy rs => UserID -> Routed t sign -> rs -> (Map SockAddr (Routed t sign),Maybe (Routed t sign))
routingSingleMap user obj = (maybe (Map.empty,Just obj) (\raddr -> (Map.singleton raddr obj,Nothing))).(routeSingle user)
routingMultiMap :: RoutingStrategy rs => [UserID] -> ([UserID] -> Routed t sign) -> rs -> (Map SockAddr (Routed t sign),Maybe (Routed t sign))
routingMultiMap users f s = let
(succ,nor) = routeMulti users s
in (Map.map f succ,case nor of
[] -> Nothing
_ -> Just (f nor))
instance Ord SockAddr where
compare (SockAddrUnix a) (SockAddrUnix b) = compare a b
compare (SockAddrUnix _) (SockAddrInet _ _) = LT
compare (SockAddrInet _ _) (SockAddrUnix _) = GT
compare (SockAddrInet p1 h1) (SockAddrInet p2 h2) = case compare h1 h2 of
EQ -> compare p1 p2
x -> x