Discovery service

12 files changed, 297 insertions, 15 deletions

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