diff options
| -rw-r--r-- | erebos.cabal | 2 | ||||
| -rw-r--r-- | main/Main.hs | 10 | ||||
| -rw-r--r-- | src/Erebos/Discovery.hs | 51 |
3 files changed, 51 insertions, 12 deletions
diff --git a/erebos.cabal b/erebos.cabal index fa000bd..97a95ec 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -98,6 +98,7 @@ library Erebos.Chatroom Erebos.Contact Erebos.Conversation + Erebos.Discovery Erebos.Identity Erebos.Message Erebos.Network @@ -126,7 +127,6 @@ library if flag(ice) exposed-modules: - Erebos.Discovery Erebos.ICE c-sources: src/Erebos/ICE/pjproject.c diff --git a/main/Main.hs b/main/Main.hs index 73def51..000bbf9 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -40,8 +40,8 @@ import Erebos.Attach import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation -#ifdef ENABLE_ICE_SUPPORT import Erebos.Discovery +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity @@ -102,10 +102,8 @@ availableServices = True "create contacts with network peers" , ServiceOption "dm" (someService @DirectMessage Proxy) True "direct messages" -#ifdef ENABLE_ICE_SUPPORT , ServiceOption "discovery" (someService @DiscoveryService Proxy) True "peer discovery" -#endif ] options :: [OptDescr (Options -> Options)] @@ -492,9 +490,9 @@ commands = , ("contact-reject", cmdContactReject) , ("conversations", cmdConversations) , ("details", cmdDetails) -#ifdef ENABLE_ICE_SUPPORT , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) +#ifdef ENABLE_ICE_SUPPORT , ("ice-create", cmdIceCreate) , ("ice-destroy", cmdIceDestroy) , ("ice-show", cmdIceShow) @@ -838,8 +836,6 @@ cmdDetails = do , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -#ifdef ENABLE_ICE_SUPPORT - cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do server <- asks ciServer @@ -867,6 +863,8 @@ cmdDiscovery = void $ do Right _ -> return () Left err -> eprint err +#ifdef ENABLE_ICE_SUPPORT + cmdIceCreate :: Command cmdIceCreate = do role <- asks ciLine >>= return . \case diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 48df9c3..e6b5f48 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Erebos.Discovery ( DiscoveryService(..), DiscoveryConnection(..) @@ -16,7 +18,9 @@ import qualified Data.Text as T import Network.Socket +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE +#endif import Erebos.Identity import Erebos.Network import Erebos.Service @@ -38,11 +42,18 @@ data DiscoveryConnection = DiscoveryConnection { dconnSource :: Ref , dconnTarget :: Ref , dconnAddress :: Maybe Text +#ifdef ENABLE_ICE_SUPPORT , dconnIceSession :: Maybe IceRemoteInfo +#endif } emptyConnection :: Ref -> Ref -> DiscoveryConnection -emptyConnection source target = DiscoveryConnection source target Nothing Nothing +emptyConnection dconnSource dconnTarget = DiscoveryConnection {..} + where + dconnAddress = Nothing +#ifdef ENABLE_ICE_SUPPORT + dconnIceSession = Nothing +#endif instance Storable DiscoveryService where store' x = storeRec $ do @@ -64,7 +75,9 @@ instance Storable DiscoveryService where storeRawRef "source" $ dconnSource conn storeRawRef "target" $ dconnTarget conn storeMbText "address" $ dconnAddress conn +#ifdef ENABLE_ICE_SUPPORT storeMbRef "ice-session" $ dconnIceSession conn +#endif load' = loadRec $ msum [ DiscoverySelf @@ -86,13 +99,17 @@ instance Storable DiscoveryService where <$> loadRawRef "source" <*> loadRawRef "target" <*> loadMbText "address" +#ifdef ENABLE_ICE_SUPPORT <*> loadMbRef "ice-session" +#endif data DiscoveryPeer = DiscoveryPeer { dpPriority :: Int , dpPeer :: Maybe Peer , dpAddress :: Maybe Text +#ifdef ENABLE_ICE_SUPPORT , dpIceSession :: Maybe IceSession +#endif } instance Service DiscoveryService where @@ -115,8 +132,14 @@ instance Service DiscoveryService where else Nothing _ -> return Nothing forM_ (idDataF =<< unfoldOwners pid) $ \s -> - svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) $ - DiscoveryPeer priority (Just peer) mbaddr Nothing + svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) DiscoveryPeer + { dpPriority = priority + , dpPeer = Just peer + , dpAddress = mbaddr +#ifdef ENABLE_ICE_SUPPORT + , dpIceSession = Nothing +#endif + } replyPacket $ DiscoveryAcknowledged $ fromMaybe (T.pack "ICE") mbaddr DiscoveryAcknowledged addr -> do @@ -142,6 +165,7 @@ instance Service DiscoveryService where server <- asks svcServer if addr == T.pack "ICE" then do +#ifdef ENABLE_ICE_SUPPORT self <- svcSelf peer <- asks svcPeer ice <- liftIO $ iceCreate PjIceSessRoleControlling $ \ice -> do @@ -154,18 +178,28 @@ instance Service DiscoveryService where svcModifyGlobal $ M.insert (refDigest ref) $ DiscoveryPeer 0 Nothing Nothing (Just ice) +#else + return () +#endif else do case words (T.unpack addr) of [ipaddr, port] -> do saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) peer <- liftIO $ serverPeer server (addrAddress saddr) - svcModifyGlobal $ M.insert (refDigest ref) $ - DiscoveryPeer 0 (Just peer) Nothing Nothing + svcModifyGlobal $ M.insert (refDigest ref) DiscoveryPeer + { dpPriority = 0 + , dpPeer = Just peer + , dpAddress = Nothing +#ifdef ENABLE_ICE_SUPPORT + , dpIceSession = Nothing +#endif + } _ -> svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr DiscoveryConnectionRequest conn -> do +#ifdef ENABLE_ICE_SUPPORT self <- svcSelf let rconn = emptyConnection (dconnSource conn) (dconnTarget conn) if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) @@ -193,8 +227,12 @@ instance Service DiscoveryService where | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionRequest conn | otherwise -> svcPrint $ "Discovery: failed to relay connection request" +#else + return () +#endif DiscoveryConnectionResponse conn -> do +#ifdef ENABLE_ICE_SUPPORT self <- svcSelf dpeers <- svcGetGlobal if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) @@ -221,3 +259,6 @@ instance Service DiscoveryService where Just dp | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionResponse conn _ -> svcPrint $ "Discovery: failed to relay connection response" +#else + return () +#endif |