diff options
Diffstat (limited to 'src/Discovery.hs')
| -rw-r--r-- | src/Discovery.hs | 223 |
1 files changed, 223 insertions, 0 deletions
diff --git a/src/Discovery.hs b/src/Discovery.hs new file mode 100644 index 0000000..aedfda4 --- /dev/null +++ b/src/Discovery.hs @@ -0,0 +1,223 @@ +module Discovery ( + DiscoveryService(..), + DiscoveryConnection(..) +) where + +import Control.Concurrent +import Control.Monad.Except +import Control.Monad.Reader + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T + +import Network.Socket + +import ICE +import Identity +import Network +import Service +import Storage + + +keepaliveSeconds :: Int +keepaliveSeconds = 20 + + +data DiscoveryService = DiscoverySelf Text Int + | DiscoveryAcknowledged Text + | DiscoverySearch Ref + | DiscoveryResult Ref (Maybe Text) + | DiscoveryConnectionRequest DiscoveryConnection + | DiscoveryConnectionResponse DiscoveryConnection + +data DiscoveryConnection = DiscoveryConnection + { dconnSource :: Ref + , dconnTarget :: Ref + , dconnAddress :: Maybe Text + , dconnIceSession :: Maybe IceRemoteInfo + } + +emptyConnection :: Ref -> Ref -> DiscoveryConnection +emptyConnection source target = DiscoveryConnection source target Nothing Nothing + +instance Storable DiscoveryService where + store' x = storeRec $ do + case x of + DiscoverySelf addr priority -> do + storeText "self" addr + storeInt "priority" priority + DiscoveryAcknowledged addr -> do + storeText "ack" addr + DiscoverySearch ref -> storeRawRef "search" ref + DiscoveryResult ref addr -> do + storeRawRef "result" ref + storeMbText "address" addr + DiscoveryConnectionRequest conn -> storeConnection "request" conn + DiscoveryConnectionResponse conn -> storeConnection "response" conn + + where storeConnection ctype conn = do + storeText "connection" $ ctype + storeRawRef "source" $ dconnSource conn + storeRawRef "target" $ dconnTarget conn + storeMbText "address" $ dconnAddress conn + storeMbRef "ice-session" $ dconnIceSession conn + + load' = loadRec $ msum + [ DiscoverySelf + <$> loadText "self" + <*> loadInt "priority" + , DiscoveryAcknowledged + <$> loadText "ack" + , DiscoverySearch <$> loadRawRef "search" + , DiscoveryResult + <$> loadRawRef "result" + <*> loadMbText "address" + , loadConnection "request" DiscoveryConnectionRequest + , loadConnection "response" DiscoveryConnectionResponse + ] + where loadConnection ctype ctor = do + ctype' <- loadText "connection" + guard $ ctype == ctype' + return . ctor =<< DiscoveryConnection + <$> loadRawRef "source" + <*> loadRawRef "target" + <*> loadMbText "address" + <*> loadMbRef "ice-session" + +data DiscoveryPeer = DiscoveryPeer + { dpPriority :: Int + , dpPeer :: Maybe Peer + , dpAddress :: Maybe Text + , dpIceSession :: Maybe IceSession + } + +instance Service DiscoveryService where + serviceID _ = mkServiceID "dd59c89c-69cc-4703-b75b-4ddcd4b3c23b" + + type ServiceGlobalState DiscoveryService = Map RefDigest DiscoveryPeer + emptyServiceGlobalState _ = M.empty + + serviceHandler msg = case fromStored msg of + DiscoverySelf addr priority -> do + pid <- asks svcPeerIdentity + peer <- asks svcPeer + let insertHelper new old | dpPriority new > dpPriority old = new + | otherwise = old + mbaddr <- case words (T.unpack addr) of + [ipaddr, port] | DatagramAddress _ paddr <- peerAddress peer -> do + saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) + return $ if paddr == addrAddress saddr + then Just addr + else Nothing + _ -> return Nothing + forM_ (idDataF =<< unfoldOwners pid) $ \s -> + svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) $ + DiscoveryPeer priority (Just peer) mbaddr Nothing + replyPacket $ DiscoveryAcknowledged $ fromMaybe (T.pack "ICE") mbaddr + + DiscoveryAcknowledged addr -> do + when (addr == T.pack "ICE") $ do + -- keep-alive packet from behind NAT + self <- svcSelf + peer <- asks svcPeer + liftIO $ void $ forkIO $ do + threadDelay (keepaliveSeconds * 1000 * 1000) + res <- runExceptT $ sendToPeer self peer $ DiscoverySelf addr 0 + case res of + Right _ -> return () + Left err -> putStrLn $ "Discovery: failed to send keep-alive: " ++ err + + DiscoverySearch ref -> do + addr <- M.lookup (refDigest ref) <$> svcGetGlobal + replyPacket $ DiscoveryResult ref $ fromMaybe (T.pack "ICE") . dpAddress <$> addr + + DiscoveryResult ref Nothing -> do + svcPrint $ "Discovery: " ++ show (refDigest ref) ++ " not found" + + DiscoveryResult ref (Just addr) -> do + -- TODO: check if we really requested that + server <- asks svcServer + if addr == T.pack "ICE" + then do + self <- svcSelf + peer <- asks svcPeer + ice <- liftIO $ iceCreate PjIceSessRoleControlling $ \ice -> do + rinfo <- iceRemoteInfo ice + res <- runExceptT $ sendToPeer self peer $ + DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceSession = Just rinfo } + case res of + Right _ -> return () + Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err + + svcModifyGlobal $ M.insert (refDigest ref) $ + DiscoveryPeer 0 Nothing Nothing (Just ice) + 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 + + _ -> svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr + + DiscoveryConnectionRequest conn -> do + self <- svcSelf + let rconn = emptyConnection (dconnSource conn) (dconnTarget conn) + if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) + then do + -- request for us, create ICE sesssion + server <- asks svcServer + peer <- asks svcPeer + liftIO $ void $ iceCreate PjIceSessRoleControlled $ \ice -> do + rinfo <- iceRemoteInfo ice + res <- runExceptT $ sendToPeer self peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } + case res of + Right _ -> do + case dconnIceSession conn of + Just prinfo -> iceConnect ice prinfo $ void $ serverPeerIce server ice + Nothing -> putStrLn $ "Discovery: connection request without ICE remote info" + Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + + else do + -- request to some of our peers, relay + mbdp <- M.lookup (refDigest $ dconnTarget conn) <$> svcGetGlobal + case mbdp of + Nothing -> replyPacket $ DiscoveryConnectionResponse rconn + Just dp | Just addr <- dpAddress dp -> do + replyPacket $ DiscoveryConnectionResponse rconn { dconnAddress = Just addr } + | Just dpeer <- dpPeer dp -> do + sendToPeer self dpeer $ DiscoveryConnectionRequest conn + | otherwise -> svcPrint $ "Discovery: failed to relay connection request" + + DiscoveryConnectionResponse conn -> do + self <- svcSelf + dpeers <- svcGetGlobal + if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) + then do + -- response to our request, try to connect to the peer + server <- asks svcServer + if | Just addr <- dconnAddress conn + , [ipaddr, port] <- words (T.unpack addr) -> do + saddr <- liftIO $ head <$> + getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) + peer <- liftIO $ serverPeer server (addrAddress saddr) + svcModifyGlobal $ M.insert (refDigest $ dconnTarget conn) $ + DiscoveryPeer 0 (Just peer) Nothing Nothing + + | Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers + , Just ice <- dpIceSession dp + , Just rinfo <- dconnIceSession conn -> do + liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice + + | otherwise -> svcPrint $ "Discovery: connection request failed" + else do + -- response to relayed request + case M.lookup (refDigest $ dconnSource conn) dpeers of + Just dp | Just dpeer <- dpPeer dp -> do + sendToPeer self dpeer $ DiscoveryConnectionResponse conn + _ -> svcPrint $ "Discovery: failed to relay connection response" |