From cc132e005f974577c2ff782add7df8247c4eb541 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 29 Dec 2020 21:39:19 +0100
Subject: Discovery service
---
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 +-
11 files changed, 296 insertions(+), 15 deletions(-)
create mode 100644 src/Discovery.hs
create mode 100644 src/Network.hs-boot
(limited to 'src')
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