From cc132e005f974577c2ff782add7df8247c4eb541 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 29 Dec 2020 21:39:19 +0100 Subject: Discovery service --- erebos.cabal | 1 + src/Attach.hs | 8 +- src/Contact.hs | 8 +- src/Discovery.hs | 223 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Identity.hs | 1 + src/Main.hs | 42 +++++++++- src/Message.hs | 2 +- src/Network.hs | 4 +- src/Network.hs-boot | 4 + src/Pairing.hs | 4 +- src/Service.hs | 12 ++- src/Storage.hs | 3 +- 12 files changed, 297 insertions(+), 15 deletions(-) create mode 100644 src/Discovery.hs create mode 100644 src/Network.hs-boot diff --git a/erebos.cabal b/erebos.cabal index 9c3f086..1b6cd6b 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -23,6 +23,7 @@ executable erebos Identity, Channel, Contact + Discovery Message, Network, Pairing diff --git a/src/Attach.hs b/src/Attach.hs index 4df7e5f..055c7fe 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -38,19 +38,19 @@ instance PairingResult AttachIdentity where pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f" pairingHookRequest = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated" pairingHookResponse confirm = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm pairingHookRequestNonce confirm = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm pairingHookRequestNonceFailed = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer) pairingHookConfirm (AttachIdentity sdata keys _) = do diff --git a/src/Contact.hs b/src/Contact.hs index fefcd1f..5c4e265 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -87,19 +87,19 @@ instance PairingResult ContactAccepted where pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084" pairingHookRequest = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated" pairingHookResponse confirm = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm pairingHookRequestNonce confirm = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm pairingHookRequestNonceFailed = do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer) pairingHookConfirm ContactAccepted = do 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" diff --git a/src/Identity.hs b/src/Identity.hs index 91bd04c..effa9e0 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -12,6 +12,7 @@ module Identity ( updateIdentity, updateOwners, sameIdentity, + unfoldOwners, finalOwner, displayIdentity, ) where diff --git a/src/Main.hs b/src/Main.hs index 8da74b1..6fc27b7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -20,11 +20,14 @@ import qualified Data.Text.IO as T import Data.Time.LocalTime import Data.Typeable +import Network.Socket + import System.Console.Haskeline import System.Environment import Attach import Contact +import Discovery import ICE import Identity import Message @@ -108,6 +111,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do , SomeService @SyncService Proxy , SomeService @ContactService Proxy , SomeService @DirectMessage Proxy + , SomeService @DiscoveryService Proxy ] peers <- liftIO $ newMVar [] @@ -167,6 +171,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do loop $ Just $ CommandState { csPeer = Nothing , csIceSessions = [] + , csIcePeer = Nothing } @@ -181,6 +186,7 @@ data CommandInput = CommandInput data CommandState = CommandState { csPeer :: Maybe Peer , csIceSessions :: [IceSession] + , csIcePeer :: Maybe Peer } newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) @@ -205,6 +211,8 @@ commands = , ("contacts", cmdContacts) , ("contact-add", cmdContactAdd) , ("contact-accept", cmdContactAccept) + , ("discovery-init", cmdDiscoveryInit) + , ("discovery", cmdDiscovery) , ("ice-create", cmdIceCreate) , ("ice-destroy", cmdIceDestroy) , ("ice-show", cmdIceShow) @@ -274,10 +282,13 @@ cmdAttachAccept = join $ attachAccept cmdContacts :: Command cmdContacts = do + args <- words <$> asks ciLine ehead <- asks ciHead let contacts = contactView $ lookupSharedValue $ lsShared $ headObject ehead + verbose = "-v" `elem` args forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do - liftIO $ putStrLn $ show i ++ ": " ++ T.unpack (displayIdentity $ contactIdentity c) + liftIO $ putStrLn $ show i ++ ": " ++ T.unpack (displayIdentity $ contactIdentity c) ++ + (if verbose then " " ++ (unwords $ map (BC.unpack . showRef . storedRef) $ idDataF $ contactIdentity c) else "") cmdContactAdd :: Command cmdContactAdd = join $ contactRequest @@ -291,6 +302,35 @@ cmdContactAccept = join $ contactAccept <*> asks ciHead <*> (maybe (throwError "no peer selected") return =<< gets csPeer) +cmdDiscoveryInit :: Command +cmdDiscoveryInit = void $ do + self <- asks (headLocalIdentity . ciHead) + server <- asks ciServer + + (hostname, port) <- (words <$> asks ciLine) >>= return . \case + hostname:p:_ -> (hostname, p) + [hostname] -> (hostname, discoveryPort) + [] -> ("discovery.erebosprotocol.net", discoveryPort) + addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) + peer <- liftIO $ serverPeer server (addrAddress addr) + sendToPeer self peer $ DiscoverySelf (T.pack "ICE") 0 + modify $ \s -> s { csIcePeer = Just peer } + +cmdDiscovery :: Command +cmdDiscovery = void $ do + Just peer <- gets csIcePeer + self <- asks (headLocalIdentity . ciHead) + st <- asks (storedStorage . headStoredObject . ciHead) + sref <- asks ciLine + eprint <- asks ciPrint + liftIO $ readRef st (BC.pack sref) >>= \case + Nothing -> error "ref does not exist" + Just ref -> do + res <- runExceptT $ sendToPeer self peer $ DiscoverySearch ref + case res of + Right _ -> return () + Left err -> eprint err + cmdIceCreate :: Command cmdIceCreate = do role <- asks ciLine >>= return . \case diff --git a/src/Message.hs b/src/Message.hs index 2d00de2..04ddef1 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -52,7 +52,7 @@ instance Service DirectMessage where serviceHandler smsg = do let msg = fromStored smsg - powner <- asks $ finalOwner . svcPeer + powner <- asks $ finalOwner . svcPeerIdentity tzone <- liftIO $ getCurrentTimeZone erb <- svcGetLocal let st = storedStorage erb diff --git a/src/Network.hs b/src/Network.hs index e09b343..7bb9fea 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -363,7 +363,9 @@ startServer opt origHead logd' services = do Just (SomeServiceGlobalState (_ :: Proxy gs) gs)) | Just (Refl :: s :~: gs) <- eqT -> do let inp = ServiceInput - { svcPeer = peerId + { svcPeer = peer + , svcPeerIdentity = peerId + , svcServer = server , svcPrintOp = atomically . logd } reloadHead origHead >>= \case diff --git a/src/Network.hs-boot b/src/Network.hs-boot new file mode 100644 index 0000000..1ec6daa --- /dev/null +++ b/src/Network.hs-boot @@ -0,0 +1,4 @@ +module Network where + +data Server +data Peer diff --git a/src/Pairing.hs b/src/Pairing.hs index 9af33c7..460dd55 100644 --- a/src/Pairing.hs +++ b/src/Pairing.hs @@ -90,7 +90,7 @@ instance PairingResult a => Service (PairingService a) where (NoPairing, _) -> return () (OurRequest nonce, PairingResponse pnonce) -> do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity self <- maybe (throwError "failed to validate own identity") return . validateIdentity . lsIdentity . fromStored =<< svcGetLocal pairingHookResponse $ confirmationNumber $ nonceDigest self peer nonce pnonce @@ -118,7 +118,7 @@ instance PairingResult a => Service (PairingService a) where replyPacket PairingDecline (PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do - peer <- asks $ svcPeer + peer <- asks $ svcPeerIdentity self <- maybe (throwError "failed to verify own identity") return . validateIdentity . lsIdentity . fromStored =<< svcGetLocal if dgst == nonceDigest peer self pnonce BA.empty diff --git a/src/Service.hs b/src/Service.hs index 704bc67..eae43ec 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -13,7 +13,10 @@ module Service ( svcGet, svcSet, svcModify, svcGetGlobal, svcSetGlobal, svcModifyGlobal, svcGetLocal, svcSetLocal, + + svcSelf, svcPrint, + replyPacket, replyStored, replyStoredRef, ) where @@ -27,6 +30,7 @@ import Data.UUID (UUID) import qualified Data.UUID as U import Identity +import {-# SOURCE #-} Network import State import Storage @@ -76,7 +80,9 @@ mkServiceID :: String -> ServiceID mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString data ServiceInput = ServiceInput - { svcPeer :: UnifiedIdentity + { svcPeer :: Peer + , svcPeerIdentity :: UnifiedIdentity + , svcServer :: Server , svcPrintOp :: String -> IO () } @@ -129,6 +135,10 @@ svcGetLocal = gets svcLocal svcSetLocal :: Stored LocalState -> ServiceHandler s () svcSetLocal x = modify $ \st -> st { svcLocal = x } +svcSelf :: ServiceHandler s UnifiedIdentity +svcSelf = maybe (throwError "failed to validate own identity") return . + validateIdentity . lsIdentity . fromStored =<< svcGetLocal + svcPrint :: String -> ServiceHandler s () svcPrint str = liftIO . ($str) =<< asks svcPrintOp diff --git a/src/Storage.hs b/src/Storage.hs index f73c420..8bf8802 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -54,6 +54,7 @@ import Codec.Compression.Zlib import qualified Codec.MIME.Type as MIME import qualified Codec.MIME.Parse as MIME +import Control.Applicative import Control.Arrow import Control.Concurrent import Control.DeepSeq @@ -520,7 +521,7 @@ evalStore _ StoreZero = return ZeroObject type StoreRec c = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) () newtype Load a = Load (ReaderT (Ref, Object) (Either String) a) - deriving (Functor, Applicative, Monad, MonadReader (Ref, Object), MonadError String) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadReader (Ref, Object), MonadError String) type LoadRec a = ReaderT (Ref, [(ByteString, RecItem)]) (Either String) a -- cgit v1.2.3