{-# LANGUAGE CPP #-}

module Erebos.Discovery (
    DiscoveryService(..),
    DiscoveryAttributes(..),
    DiscoveryConnection(..)
) where

import Control.Concurrent
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader

import Data.IP qualified as IP
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word

import Network.Socket

#ifdef ENABLE_ICE_SUPPORT
import Erebos.ICE
#endif
import Erebos.Identity
import Erebos.Network
import Erebos.Service
import Erebos.Storage


data DiscoveryService
    = DiscoverySelf [ Text ] (Maybe Int)
    | DiscoveryAcknowledged [ Text ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16)
    | DiscoverySearch Ref
    | DiscoveryResult Ref [ Text ]
    | DiscoveryConnectionRequest DiscoveryConnection
    | DiscoveryConnectionResponse DiscoveryConnection

data DiscoveryAttributes = DiscoveryAttributes
    { DiscoveryAttributes -> Maybe Word16
discoveryStunPort :: Maybe Word16
    , DiscoveryAttributes -> Maybe Text
discoveryStunServer :: Maybe Text
    , DiscoveryAttributes -> Maybe Word16
discoveryTurnPort :: Maybe Word16
    , DiscoveryAttributes -> Maybe Text
discoveryTurnServer :: Maybe Text
    }

defaultDiscoveryAttributes :: DiscoveryAttributes
defaultDiscoveryAttributes :: DiscoveryAttributes
defaultDiscoveryAttributes = DiscoveryAttributes
    { discoveryStunPort :: Maybe Word16
discoveryStunPort = Maybe Word16
forall a. Maybe a
Nothing
    , discoveryStunServer :: Maybe Text
discoveryStunServer = Maybe Text
forall a. Maybe a
Nothing
    , discoveryTurnPort :: Maybe Word16
discoveryTurnPort = Maybe Word16
forall a. Maybe a
Nothing
    , discoveryTurnServer :: Maybe Text
discoveryTurnServer = Maybe Text
forall a. Maybe a
Nothing
    }

data DiscoveryConnection = DiscoveryConnection
    { DiscoveryConnection -> Ref
dconnSource :: Ref
    , DiscoveryConnection -> Ref
dconnTarget :: Ref
    , DiscoveryConnection -> Maybe Text
dconnAddress :: Maybe Text
#ifdef ENABLE_ICE_SUPPORT
    , dconnIceInfo :: Maybe IceRemoteInfo
#else
    , DiscoveryConnection -> Maybe (Stored Object)
dconnIceInfo :: Maybe (Stored Object)
#endif
    }

emptyConnection :: Ref -> Ref -> DiscoveryConnection
emptyConnection :: Ref -> Ref -> DiscoveryConnection
emptyConnection Ref
dconnSource Ref
dconnTarget = DiscoveryConnection {Maybe Text
Maybe (Stored Object)
Ref
forall a. Maybe a
dconnSource :: Ref
dconnTarget :: Ref
dconnAddress :: Maybe Text
dconnIceInfo :: Maybe (Stored Object)
dconnSource :: Ref
dconnTarget :: Ref
dconnAddress :: forall a. Maybe a
dconnIceInfo :: forall a. Maybe a
..}
  where
    dconnAddress :: Maybe a
dconnAddress = Maybe a
forall a. Maybe a
Nothing
    dconnIceInfo :: Maybe a
dconnIceInfo = Maybe a
forall a. Maybe a
Nothing

instance Storable DiscoveryService where
    store' :: DiscoveryService -> Store
store' DiscoveryService
x = (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c)
 -> Store)
-> (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
forall a b. (a -> b) -> a -> b
$ do
        case DiscoveryService
x of
            DiscoverySelf [Text]
addrs Maybe Int
priority -> do
                (Text -> StoreRec c) -> [Text] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Text -> StoreRec c
forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c
storeText String
"self") [Text]
addrs
                (Int -> StoreRec c) -> Maybe Int -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Int -> StoreRec c
forall a (c :: * -> *). Integral a => String -> a -> StoreRec c
storeInt String
"priority") Maybe Int
priority
            DiscoveryAcknowledged [Text]
addrs Maybe Text
stunServer Maybe Word16
stunPort Maybe Text
turnServer Maybe Word16
turnPort -> do
                if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
addrs then String -> StoreRec c
forall (c :: * -> *). String -> StoreRec c
storeEmpty String
"ack"
                              else (Text -> StoreRec c) -> [Text] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Text -> StoreRec c
forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c
storeText String
"ack") [Text]
addrs
                String -> Maybe Text -> StoreRec c
forall a (c :: * -> *).
StorableText a =>
String -> Maybe a -> StoreRec c
storeMbText String
"stun-server" Maybe Text
stunServer
                String -> Maybe Word16 -> StoreRec c
forall a (c :: * -> *).
Integral a =>
String -> Maybe a -> StoreRec c
storeMbInt String
"stun-port" Maybe Word16
stunPort
                String -> Maybe Text -> StoreRec c
forall a (c :: * -> *).
StorableText a =>
String -> Maybe a -> StoreRec c
storeMbText String
"turn-server" Maybe Text
turnServer
                String -> Maybe Word16 -> StoreRec c
forall a (c :: * -> *).
Integral a =>
String -> Maybe a -> StoreRec c
storeMbInt String
"turn-port" Maybe Word16
turnPort
            DiscoverySearch Ref
ref -> String -> Ref -> StoreRec c
forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
"search" Ref
ref
            DiscoveryResult Ref
ref [Text]
addr -> do
                String -> Ref -> StoreRec c
forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
"result" Ref
ref
                (Text -> StoreRec c) -> [Text] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Text -> StoreRec c
forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c
storeText String
"address") [Text]
addr
            DiscoveryConnectionRequest DiscoveryConnection
conn -> String -> DiscoveryConnection -> StoreRec c
forall {p} {c :: * -> *}.
(StorableText p, StorageCompleteness c) =>
p -> DiscoveryConnection -> StoreRecM c ()
storeConnection String
"request" DiscoveryConnection
conn
            DiscoveryConnectionResponse DiscoveryConnection
conn -> String -> DiscoveryConnection -> StoreRec c
forall {p} {c :: * -> *}.
(StorableText p, StorageCompleteness c) =>
p -> DiscoveryConnection -> StoreRecM c ()
storeConnection String
"response" DiscoveryConnection
conn

        where storeConnection :: p -> DiscoveryConnection -> StoreRecM c ()
storeConnection p
ctype DiscoveryConnection
conn = do
                  String -> p -> StoreRecM c ()
forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c
storeText String
"connection" (p -> StoreRecM c ()) -> p -> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ p
ctype
                  String -> Ref -> StoreRecM c ()
forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
"source" (Ref -> StoreRecM c ()) -> Ref -> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> Ref
dconnSource DiscoveryConnection
conn
                  String -> Ref -> StoreRecM c ()
forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
"target" (Ref -> StoreRecM c ()) -> Ref -> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> Ref
dconnTarget DiscoveryConnection
conn
                  String -> Maybe Text -> StoreRecM c ()
forall a (c :: * -> *).
StorableText a =>
String -> Maybe a -> StoreRec c
storeMbText String
"address" (Maybe Text -> StoreRecM c ()) -> Maybe Text -> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> Maybe Text
dconnAddress DiscoveryConnection
conn
                  String -> Maybe (Stored Object) -> StoreRecM c ()
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> Maybe a -> StoreRec c
storeMbRef String
"ice-info" (Maybe (Stored Object) -> StoreRecM c ())
-> Maybe (Stored Object) -> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> Maybe (Stored Object)
dconnIceInfo DiscoveryConnection
conn

    load' :: Load DiscoveryService
load' = LoadRec DiscoveryService -> Load DiscoveryService
forall a. LoadRec a -> Load a
loadRec (LoadRec DiscoveryService -> Load DiscoveryService)
-> LoadRec DiscoveryService -> Load DiscoveryService
forall a b. (a -> b) -> a -> b
$ [LoadRec DiscoveryService] -> LoadRec DiscoveryService
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
            [ do
                [Text]
addrs <- String -> LoadRec [Text]
forall a. StorableText a => String -> LoadRec [a]
loadTexts String
"self"
                Bool -> LoadRec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
addrs)
                [Text] -> Maybe Int -> DiscoveryService
DiscoverySelf [Text]
addrs
                    (Maybe Int -> DiscoveryService)
-> LoadRec (Maybe Int) -> LoadRec DiscoveryService
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec (Maybe Int)
forall a. Num a => String -> LoadRec (Maybe a)
loadMbInt String
"priority"
            , do
                [Text]
addrs <- String -> LoadRec [Text]
forall a. StorableText a => String -> LoadRec [a]
loadTexts String
"ack"
                Maybe ()
mbEmpty <- String -> LoadRec (Maybe ())
loadMbEmpty String
"ack"
                Bool -> LoadRec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
addrs) Bool -> Bool -> Bool
|| Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
mbEmpty)
                [Text]
-> Maybe Text
-> Maybe Word16
-> Maybe Text
-> Maybe Word16
-> DiscoveryService
DiscoveryAcknowledged
                    ([Text]
 -> Maybe Text
 -> Maybe Word16
 -> Maybe Text
 -> Maybe Word16
 -> DiscoveryService)
-> LoadRec [Text]
-> LoadRec
     (Maybe Text
      -> Maybe Word16 -> Maybe Text -> Maybe Word16 -> DiscoveryService)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> LoadRec [Text]
forall a. a -> LoadRec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
addrs
                    LoadRec
  (Maybe Text
   -> Maybe Word16 -> Maybe Text -> Maybe Word16 -> DiscoveryService)
-> LoadRec (Maybe Text)
-> LoadRec
     (Maybe Word16 -> Maybe Text -> Maybe Word16 -> DiscoveryService)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe Text)
forall a. StorableText a => String -> LoadRec (Maybe a)
loadMbText String
"stun-server"
                    LoadRec
  (Maybe Word16 -> Maybe Text -> Maybe Word16 -> DiscoveryService)
-> LoadRec (Maybe Word16)
-> LoadRec (Maybe Text -> Maybe Word16 -> DiscoveryService)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe Word16)
forall a. Num a => String -> LoadRec (Maybe a)
loadMbInt String
"stun-port"
                    LoadRec (Maybe Text -> Maybe Word16 -> DiscoveryService)
-> LoadRec (Maybe Text)
-> LoadRec (Maybe Word16 -> DiscoveryService)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe Text)
forall a. StorableText a => String -> LoadRec (Maybe a)
loadMbText String
"turn-server"
                    LoadRec (Maybe Word16 -> DiscoveryService)
-> LoadRec (Maybe Word16) -> LoadRec DiscoveryService
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe Word16)
forall a. Num a => String -> LoadRec (Maybe a)
loadMbInt String
"turn-port"
            , Ref -> DiscoveryService
DiscoverySearch (Ref -> DiscoveryService)
-> LoadRec Ref -> LoadRec DiscoveryService
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec Ref
loadRawRef String
"search"
            , Ref -> [Text] -> DiscoveryService
DiscoveryResult
                (Ref -> [Text] -> DiscoveryService)
-> LoadRec Ref -> LoadRec ([Text] -> DiscoveryService)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec Ref
loadRawRef String
"result"
                LoadRec ([Text] -> DiscoveryService)
-> LoadRec [Text] -> LoadRec DiscoveryService
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec [Text]
forall a. StorableText a => String -> LoadRec [a]
loadTexts String
"address"
            , String
-> (DiscoveryConnection -> DiscoveryService)
-> LoadRec DiscoveryService
forall {a} {b}.
(StorableText a, Eq a) =>
a -> (DiscoveryConnection -> b) -> LoadRec b
loadConnection String
"request" DiscoveryConnection -> DiscoveryService
DiscoveryConnectionRequest
            , String
-> (DiscoveryConnection -> DiscoveryService)
-> LoadRec DiscoveryService
forall {a} {b}.
(StorableText a, Eq a) =>
a -> (DiscoveryConnection -> b) -> LoadRec b
loadConnection String
"response" DiscoveryConnection -> DiscoveryService
DiscoveryConnectionResponse
            ]
        where loadConnection :: a -> (DiscoveryConnection -> b) -> LoadRec b
loadConnection a
ctype DiscoveryConnection -> b
ctor = do
                  a
ctype' <- String -> LoadRec a
forall a. StorableText a => String -> LoadRec a
loadText String
"connection"
                  Bool -> LoadRec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> LoadRec ()) -> Bool -> LoadRec ()
forall a b. (a -> b) -> a -> b
$ a
ctype a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ctype'
                  b -> LoadRec b
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> LoadRec b)
-> (DiscoveryConnection -> b) -> DiscoveryConnection -> LoadRec b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiscoveryConnection -> b
ctor (DiscoveryConnection -> LoadRec b)
-> LoadRec DiscoveryConnection -> LoadRec b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ref
-> Ref
-> Maybe Text
-> Maybe (Stored Object)
-> DiscoveryConnection
DiscoveryConnection
                      (Ref
 -> Ref
 -> Maybe Text
 -> Maybe (Stored Object)
 -> DiscoveryConnection)
-> LoadRec Ref
-> LoadRec
     (Ref -> Maybe Text -> Maybe (Stored Object) -> DiscoveryConnection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec Ref
loadRawRef String
"source"
                      LoadRec
  (Ref -> Maybe Text -> Maybe (Stored Object) -> DiscoveryConnection)
-> LoadRec Ref
-> LoadRec
     (Maybe Text -> Maybe (Stored Object) -> DiscoveryConnection)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec Ref
loadRawRef String
"target"
                      LoadRec
  (Maybe Text -> Maybe (Stored Object) -> DiscoveryConnection)
-> LoadRec (Maybe Text)
-> LoadRec (Maybe (Stored Object) -> DiscoveryConnection)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe Text)
forall a. StorableText a => String -> LoadRec (Maybe a)
loadMbText String
"address"
                      LoadRec (Maybe (Stored Object) -> DiscoveryConnection)
-> LoadRec (Maybe (Stored Object)) -> LoadRec DiscoveryConnection
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe (Stored Object))
forall a. Storable a => String -> LoadRec (Maybe a)
loadMbRef String
"ice-info"

data DiscoveryPeer = DiscoveryPeer
    { DiscoveryPeer -> Int
dpPriority :: Int
    , DiscoveryPeer -> Maybe Peer
dpPeer :: Maybe Peer
    , DiscoveryPeer -> [Text]
dpAddress :: [ Text ]
#ifdef ENABLE_ICE_SUPPORT
    , dpIceSession :: Maybe IceSession
#endif
    }

instance Service DiscoveryService where
    serviceID :: forall (proxy :: * -> *). proxy DiscoveryService -> ServiceID
serviceID proxy DiscoveryService
_ = String -> ServiceID
mkServiceID String
"dd59c89c-69cc-4703-b75b-4ddcd4b3c23c"

    type ServiceAttributes DiscoveryService = DiscoveryAttributes
    defaultServiceAttributes :: forall (proxy :: * -> *).
proxy DiscoveryService -> ServiceAttributes DiscoveryService
defaultServiceAttributes proxy DiscoveryService
_ = ServiceAttributes DiscoveryService
DiscoveryAttributes
defaultDiscoveryAttributes

#ifdef ENABLE_ICE_SUPPORT
    type ServiceState DiscoveryService = Maybe IceConfig
    emptyServiceState _ = Nothing
#endif

    type ServiceGlobalState DiscoveryService = Map RefDigest DiscoveryPeer
    emptyServiceGlobalState :: forall (proxy :: * -> *).
proxy DiscoveryService -> ServiceGlobalState DiscoveryService
emptyServiceGlobalState proxy DiscoveryService
_ = Map RefDigest DiscoveryPeer
ServiceGlobalState DiscoveryService
forall k a. Map k a
M.empty

    serviceHandler :: Stored DiscoveryService -> ServiceHandler DiscoveryService ()
serviceHandler Stored DiscoveryService
msg = case Stored DiscoveryService -> DiscoveryService
forall a. Stored a -> a
fromStored Stored DiscoveryService
msg of
        DiscoverySelf [Text]
addrs Maybe Int
priority -> do
            UnifiedIdentity
pid <- (ServiceInput DiscoveryService -> UnifiedIdentity)
-> ServiceHandler DiscoveryService UnifiedIdentity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> UnifiedIdentity
forall s. ServiceInput s -> UnifiedIdentity
svcPeerIdentity
            Peer
peer <- (ServiceInput DiscoveryService -> Peer)
-> ServiceHandler DiscoveryService Peer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> Peer
forall s. ServiceInput s -> Peer
svcPeer
            let insertHelper :: DiscoveryPeer -> DiscoveryPeer -> DiscoveryPeer
insertHelper DiscoveryPeer
new DiscoveryPeer
old | DiscoveryPeer -> Int
dpPriority DiscoveryPeer
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> DiscoveryPeer -> Int
dpPriority DiscoveryPeer
old = DiscoveryPeer
new
                                     | Bool
otherwise                       = DiscoveryPeer
old
            [Text]
matchedAddrs <- ([Maybe Text] -> [Text])
-> ServiceHandler DiscoveryService [Maybe Text]
-> ServiceHandler DiscoveryService [Text]
forall a b.
(a -> b)
-> ServiceHandler DiscoveryService a
-> ServiceHandler DiscoveryService b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes (ServiceHandler DiscoveryService [Maybe Text]
 -> ServiceHandler DiscoveryService [Text])
-> ServiceHandler DiscoveryService [Maybe Text]
-> ServiceHandler DiscoveryService [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
-> (Text -> ServiceHandler DiscoveryService (Maybe Text))
-> ServiceHandler DiscoveryService [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
addrs ((Text -> ServiceHandler DiscoveryService (Maybe Text))
 -> ServiceHandler DiscoveryService [Maybe Text])
-> (Text -> ServiceHandler DiscoveryService (Maybe Text))
-> ServiceHandler DiscoveryService [Maybe Text]
forall a b. (a -> b) -> a -> b
$ \Text
addr -> if
                | Text
addr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
"ICE" -> do
                    Maybe Text -> ServiceHandler DiscoveryService (Maybe Text)
forall a. a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ServiceHandler DiscoveryService (Maybe Text))
-> Maybe Text -> ServiceHandler DiscoveryService (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
addr

                | [ String
ipaddr, String
port ] <- String -> [String]
words (Text -> String
T.unpack Text
addr)
                , DatagramAddress SockAddr
paddr <- Peer -> PeerAddress
peerAddress Peer
peer -> do
                    AddrInfo
saddr <- IO AddrInfo -> ServiceHandler DiscoveryService AddrInfo
forall a. IO a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AddrInfo -> ServiceHandler DiscoveryService AddrInfo)
-> IO AddrInfo -> ServiceHandler DiscoveryService AddrInfo
forall a b. (a -> b) -> a -> b
$ [AddrInfo] -> AddrInfo
forall a. HasCallStack => [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo -> Maybe AddrInfo) -> AddrInfo -> Maybe AddrInfo
forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrSocketType = Datagram }) (String -> Maybe String
forall a. a -> Maybe a
Just String
ipaddr) (String -> Maybe String
forall a. a -> Maybe a
Just String
port)
                    Maybe Text -> ServiceHandler DiscoveryService (Maybe Text)
forall a. a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ServiceHandler DiscoveryService (Maybe Text))
-> Maybe Text -> ServiceHandler DiscoveryService (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if SockAddr
paddr SockAddr -> SockAddr -> Bool
forall a. Eq a => a -> a -> Bool
== AddrInfo -> SockAddr
addrAddress AddrInfo
saddr
                                then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
addr
                                else Maybe Text
forall a. Maybe a
Nothing

                | Bool
otherwise -> Maybe Text -> ServiceHandler DiscoveryService (Maybe Text)
forall a. a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing

            [Stored (Signed IdentityData)]
-> (Stored (Signed IdentityData)
    -> ServiceHandler DiscoveryService ())
-> ServiceHandler DiscoveryService ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Identity [] -> [Stored (Signed IdentityData)]
forall (m :: * -> *).
Identity m -> m (Stored (Signed IdentityData))
idDataF (Identity [] -> [Stored (Signed IdentityData)])
-> [Identity []] -> [Stored (Signed IdentityData)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UnifiedIdentity -> [Identity []]
forall (m :: * -> *). Foldable m => Identity m -> [Identity []]
unfoldOwners UnifiedIdentity
pid) ((Stored (Signed IdentityData)
  -> ServiceHandler DiscoveryService ())
 -> ServiceHandler DiscoveryService ())
-> (Stored (Signed IdentityData)
    -> ServiceHandler DiscoveryService ())
-> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ \Stored (Signed IdentityData)
s ->
                (ServiceGlobalState DiscoveryService
 -> ServiceGlobalState DiscoveryService)
-> ServiceHandler DiscoveryService ()
forall s.
(ServiceGlobalState s -> ServiceGlobalState s)
-> ServiceHandler s ()
svcModifyGlobal ((ServiceGlobalState DiscoveryService
  -> ServiceGlobalState DiscoveryService)
 -> ServiceHandler DiscoveryService ())
-> (ServiceGlobalState DiscoveryService
    -> ServiceGlobalState DiscoveryService)
-> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryPeer -> DiscoveryPeer -> DiscoveryPeer)
-> RefDigest
-> DiscoveryPeer
-> Map RefDigest DiscoveryPeer
-> Map RefDigest DiscoveryPeer
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith DiscoveryPeer -> DiscoveryPeer -> DiscoveryPeer
insertHelper (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest) -> Ref -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef Stored (Signed IdentityData)
s) DiscoveryPeer
                    { dpPriority :: Int
dpPriority = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
priority
                    , dpPeer :: Maybe Peer
dpPeer = Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
peer
                    , dpAddress :: [Text]
dpAddress = [Text]
addrs
#ifdef ENABLE_ICE_SUPPORT
                    , dpIceSession = Nothing
#endif
                    }
            DiscoveryAttributes
attrs <- (ServiceInput DiscoveryService -> DiscoveryAttributes)
-> ServiceHandler DiscoveryService DiscoveryAttributes
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> ServiceAttributes DiscoveryService
ServiceInput DiscoveryService -> DiscoveryAttributes
forall s. ServiceInput s -> ServiceAttributes s
svcAttributes
            DiscoveryService -> ServiceHandler DiscoveryService ()
forall s. Service s => s -> ServiceHandler s ()
replyPacket (DiscoveryService -> ServiceHandler DiscoveryService ())
-> DiscoveryService -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ [Text]
-> Maybe Text
-> Maybe Word16
-> Maybe Text
-> Maybe Word16
-> DiscoveryService
DiscoveryAcknowledged [Text]
matchedAddrs
                (DiscoveryAttributes -> Maybe Text
discoveryStunServer DiscoveryAttributes
attrs)
                (DiscoveryAttributes -> Maybe Word16
discoveryStunPort DiscoveryAttributes
attrs)
                (DiscoveryAttributes -> Maybe Text
discoveryTurnServer DiscoveryAttributes
attrs)
                (DiscoveryAttributes -> Maybe Word16
discoveryTurnPort DiscoveryAttributes
attrs)

        DiscoveryAcknowledged [Text]
_ Maybe Text
stunServer Maybe Word16
stunPort Maybe Text
turnServer Maybe Word16
turnPort -> do
#ifdef ENABLE_ICE_SUPPORT
            paddr <- asks (peerAddress . svcPeer) >>= return . \case
                (DatagramAddress saddr) -> case IP.fromSockAddr saddr of
                    Just (IP.IPv6 ipv6, _)
                        | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6
                        -> Just $ T.pack $ show (IP.toIPv4w ipv4)
                    Just (addr, _)
                        -> Just $ T.pack $ show addr
                    _ -> Nothing
                _ -> Nothing

            let toIceServer Nothing Nothing = Nothing
                toIceServer Nothing (Just port) = ( , port) <$> paddr
                toIceServer (Just server) Nothing = Just ( server, 0 )
                toIceServer (Just server) (Just port) = Just ( server, port )

            cfg <- liftIO $ iceCreateConfig
                (toIceServer stunServer stunPort)
                (toIceServer turnServer turnPort)
            svcSet cfg
#endif
            () -> ServiceHandler DiscoveryService ()
forall a. a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        DiscoverySearch Ref
ref -> do
            Maybe DiscoveryPeer
dpeer <- RefDigest -> Map RefDigest DiscoveryPeer -> Maybe DiscoveryPeer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref
ref) (Map RefDigest DiscoveryPeer -> Maybe DiscoveryPeer)
-> ServiceHandler DiscoveryService (Map RefDigest DiscoveryPeer)
-> ServiceHandler DiscoveryService (Maybe DiscoveryPeer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServiceHandler DiscoveryService (Map RefDigest DiscoveryPeer)
ServiceHandler
  DiscoveryService (ServiceGlobalState DiscoveryService)
forall s. ServiceHandler s (ServiceGlobalState s)
svcGetGlobal
            DiscoveryService -> ServiceHandler DiscoveryService ()
forall s. Service s => s -> ServiceHandler s ()
replyPacket (DiscoveryService -> ServiceHandler DiscoveryService ())
-> DiscoveryService -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ Ref -> [Text] -> DiscoveryService
DiscoveryResult Ref
ref ([Text] -> DiscoveryService) -> [Text] -> DiscoveryService
forall a b. (a -> b) -> a -> b
$ [Text]
-> (DiscoveryPeer -> [Text]) -> Maybe DiscoveryPeer -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] DiscoveryPeer -> [Text]
dpAddress Maybe DiscoveryPeer
dpeer

        DiscoveryResult Ref
ref [] -> do
            String -> ServiceHandler DiscoveryService ()
forall s. String -> ServiceHandler s ()
svcPrint (String -> ServiceHandler DiscoveryService ())
-> String -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ String
"Discovery: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RefDigest -> String
forall a. Show a => a -> String
show (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref
ref) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"

        DiscoveryResult Ref
ref [Text]
addrs -> do
            -- TODO: check if we really requested that
            Server
server <- (ServiceInput DiscoveryService -> Server)
-> ServiceHandler DiscoveryService Server
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> Server
forall s. ServiceInput s -> Server
svcServer
            UnifiedIdentity
self <- ServiceHandler DiscoveryService UnifiedIdentity
forall s. ServiceHandler s UnifiedIdentity
svcSelf
            ()
mbIceConfig <- ServiceHandler DiscoveryService ()
ServiceHandler DiscoveryService (ServiceState DiscoveryService)
forall s. ServiceHandler s (ServiceState s)
svcGet
            Peer
discoveryPeer <- (ServiceInput DiscoveryService -> Peer)
-> ServiceHandler DiscoveryService Peer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> Peer
forall s. ServiceInput s -> Peer
svcPeer
            let runAsService :: ServiceHandler DiscoveryService () -> IO ()
runAsService = forall s (m :: * -> *).
(Service s, MonadIO m) =>
Peer -> ServiceHandler s () -> m ()
runPeerService @DiscoveryService Peer
discoveryPeer

            IO () -> ServiceHandler DiscoveryService ()
forall a. IO a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServiceHandler DiscoveryService ())
-> IO () -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
addrs ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
addr -> if
                | Text
addr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
"ICE"
#ifdef ENABLE_ICE_SUPPORT
                , Just config <- mbIceConfig
                -> do
                    ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do
                        rinfo <- iceRemoteInfo ice
                        res <- runExceptT $ sendToPeer discoveryPeer $
                            DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceInfo = Just rinfo }
                        case res of
                            Right _ -> return ()
                            Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err

                    runAsService $ do
                        svcModifyGlobal $ M.insert (refDigest ref) DiscoveryPeer
                            { dpPriority = 0
                            , dpPeer = Nothing
                            , dpAddress = []
                            , dpIceSession = Just ice
                            }
#else
                -> do
                    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

                | [ String
ipaddr, String
port ] <- String -> [String]
words (Text -> String
T.unpack Text
addr) -> do
                    AddrInfo
saddr <- [AddrInfo] -> AddrInfo
forall a. HasCallStack => [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo -> Maybe AddrInfo) -> AddrInfo -> Maybe AddrInfo
forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrSocketType = Datagram }) (String -> Maybe String
forall a. a -> Maybe a
Just String
ipaddr) (String -> Maybe String
forall a. a -> Maybe a
Just String
port)
                    Peer
peer <- Server -> SockAddr -> IO Peer
serverPeer Server
server (AddrInfo -> SockAddr
addrAddress AddrInfo
saddr)
                    ServiceHandler DiscoveryService () -> IO ()
runAsService (ServiceHandler DiscoveryService () -> IO ())
-> ServiceHandler DiscoveryService () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        (ServiceGlobalState DiscoveryService
 -> ServiceGlobalState DiscoveryService)
-> ServiceHandler DiscoveryService ()
forall s.
(ServiceGlobalState s -> ServiceGlobalState s)
-> ServiceHandler s ()
svcModifyGlobal ((ServiceGlobalState DiscoveryService
  -> ServiceGlobalState DiscoveryService)
 -> ServiceHandler DiscoveryService ())
-> (ServiceGlobalState DiscoveryService
    -> ServiceGlobalState DiscoveryService)
-> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ RefDigest
-> DiscoveryPeer
-> Map RefDigest DiscoveryPeer
-> Map RefDigest DiscoveryPeer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref
ref) DiscoveryPeer
                            { dpPriority :: Int
dpPriority = Int
0
                            , dpPeer :: Maybe Peer
dpPeer = Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
peer
                            , dpAddress :: [Text]
dpAddress = []
#ifdef ENABLE_ICE_SUPPORT
                            , dpIceSession = Nothing
#endif
                        }

                | Bool
otherwise -> do
                    ServiceHandler DiscoveryService () -> IO ()
runAsService (ServiceHandler DiscoveryService () -> IO ())
-> ServiceHandler DiscoveryService () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        String -> ServiceHandler DiscoveryService ()
forall s. String -> ServiceHandler s ()
svcPrint (String -> ServiceHandler DiscoveryService ())
-> String -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ String
"Discovery: invalid address in result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
addr

        DiscoveryConnectionRequest DiscoveryConnection
conn -> do
            UnifiedIdentity
self <- ServiceHandler DiscoveryService UnifiedIdentity
forall s. ServiceHandler s UnifiedIdentity
svcSelf
            let rconn :: DiscoveryConnection
rconn = Ref -> Ref -> DiscoveryConnection
emptyConnection (DiscoveryConnection -> Ref
dconnSource DiscoveryConnection
conn) (DiscoveryConnection -> Ref
dconnTarget DiscoveryConnection
conn)
            if Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (DiscoveryConnection -> Ref
dconnTarget DiscoveryConnection
conn) RefDigest -> [RefDigest] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Stored (Signed IdentityData) -> RefDigest)
-> [Stored (Signed IdentityData)] -> [RefDigest]
forall a b. (a -> b) -> [a] -> [b]
map (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest)
-> (Stored (Signed IdentityData) -> Ref)
-> Stored (Signed IdentityData)
-> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef) ([Stored (Signed IdentityData)] -> [RefDigest])
-> [Stored (Signed IdentityData)] -> [RefDigest]
forall a b. (a -> b) -> a -> b
$ Identity [] -> [Stored (Signed IdentityData)]
forall (m :: * -> *).
Identity m -> m (Stored (Signed IdentityData))
idDataF (Identity [] -> [Stored (Signed IdentityData)])
-> [Identity []] -> [Stored (Signed IdentityData)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UnifiedIdentity -> [Identity []]
forall (m :: * -> *). Foldable m => Identity m -> [Identity []]
unfoldOwners UnifiedIdentity
self)
               then do
#ifdef ENABLE_ICE_SUPPORT
                    -- request for us, create ICE sesssion
                    server <- asks svcServer
                    peer <- asks svcPeer
                    svcGet >>= \case
                        Just config -> do
                            liftIO $ void $ iceCreateSession config PjIceSessRoleControlled $ \ice -> do
                                rinfo <- iceRemoteInfo ice
                                res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceInfo = Just rinfo }
                                case res of
                                    Right _ -> do
                                        case dconnIceInfo 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
                        Nothing -> do
                            svcPrint $ "Discovery: ICE request from peer without ICE configuration"
#else
                    () -> ServiceHandler DiscoveryService ()
forall a. a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

               else do
                    -- request to some of our peers, relay
                    Maybe DiscoveryPeer
mbdp <- RefDigest -> Map RefDigest DiscoveryPeer -> Maybe DiscoveryPeer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest) -> Ref -> RefDigest
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> Ref
dconnTarget DiscoveryConnection
conn) (Map RefDigest DiscoveryPeer -> Maybe DiscoveryPeer)
-> ServiceHandler DiscoveryService (Map RefDigest DiscoveryPeer)
-> ServiceHandler DiscoveryService (Maybe DiscoveryPeer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServiceHandler DiscoveryService (Map RefDigest DiscoveryPeer)
ServiceHandler
  DiscoveryService (ServiceGlobalState DiscoveryService)
forall s. ServiceHandler s (ServiceGlobalState s)
svcGetGlobal
                    case Maybe DiscoveryPeer
mbdp of
                        Maybe DiscoveryPeer
Nothing -> DiscoveryService -> ServiceHandler DiscoveryService ()
forall s. Service s => s -> ServiceHandler s ()
replyPacket (DiscoveryService -> ServiceHandler DiscoveryService ())
-> DiscoveryService -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> DiscoveryService
DiscoveryConnectionResponse DiscoveryConnection
rconn
                        Just DiscoveryPeer
dp
                            | Just Peer
dpeer <- DiscoveryPeer -> Maybe Peer
dpPeer DiscoveryPeer
dp -> do
                                Peer -> DiscoveryService -> ServiceHandler DiscoveryService ()
forall s (m :: * -> *). (Service s, MonadIO m) => Peer -> s -> m ()
sendToPeer Peer
dpeer (DiscoveryService -> ServiceHandler DiscoveryService ())
-> DiscoveryService -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> DiscoveryService
DiscoveryConnectionRequest DiscoveryConnection
conn
                            | Bool
otherwise -> String -> ServiceHandler DiscoveryService ()
forall s. String -> ServiceHandler s ()
svcPrint (String -> ServiceHandler DiscoveryService ())
-> String -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ String
"Discovery: failed to relay connection request"

        DiscoveryConnectionResponse DiscoveryConnection
conn -> do
            UnifiedIdentity
self <- ServiceHandler DiscoveryService UnifiedIdentity
forall s. ServiceHandler s UnifiedIdentity
svcSelf
            Map RefDigest DiscoveryPeer
dpeers <- ServiceHandler DiscoveryService (Map RefDigest DiscoveryPeer)
ServiceHandler
  DiscoveryService (ServiceGlobalState DiscoveryService)
forall s. ServiceHandler s (ServiceGlobalState s)
svcGetGlobal
            if Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (DiscoveryConnection -> Ref
dconnSource DiscoveryConnection
conn) RefDigest -> [RefDigest] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Stored (Signed IdentityData) -> RefDigest)
-> [Stored (Signed IdentityData)] -> [RefDigest]
forall a b. (a -> b) -> [a] -> [b]
map (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest)
-> (Stored (Signed IdentityData) -> Ref)
-> Stored (Signed IdentityData)
-> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef) ([Stored (Signed IdentityData)] -> [RefDigest])
-> [Stored (Signed IdentityData)] -> [RefDigest]
forall a b. (a -> b) -> a -> b
$ Identity [] -> [Stored (Signed IdentityData)]
forall (m :: * -> *).
Identity m -> m (Stored (Signed IdentityData))
idDataF (Identity [] -> [Stored (Signed IdentityData)])
-> [Identity []] -> [Stored (Signed IdentityData)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UnifiedIdentity -> [Identity []]
forall (m :: * -> *). Foldable m => Identity m -> [Identity []]
unfoldOwners UnifiedIdentity
self)
               then do
                    -- response to our request, try to connect to the peer
#ifdef ENABLE_ICE_SUPPORT
                    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

                        | Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers
                        , Just ice <- dpIceSession dp
                        , Just rinfo <- dconnIceInfo conn -> do
                            liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice

                        | otherwise -> svcPrint $ "Discovery: connection request failed"
#else
                    () -> ServiceHandler DiscoveryService ()
forall a. a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
               else do
                    -- response to relayed request
                    case RefDigest -> Map RefDigest DiscoveryPeer -> Maybe DiscoveryPeer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest) -> Ref -> RefDigest
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> Ref
dconnSource DiscoveryConnection
conn) Map RefDigest DiscoveryPeer
dpeers of
                        Just DiscoveryPeer
dp | Just Peer
dpeer <- DiscoveryPeer -> Maybe Peer
dpPeer DiscoveryPeer
dp -> do
                            Peer -> DiscoveryService -> ServiceHandler DiscoveryService ()
forall s (m :: * -> *). (Service s, MonadIO m) => Peer -> s -> m ()
sendToPeer Peer
dpeer (DiscoveryService -> ServiceHandler DiscoveryService ())
-> DiscoveryService -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ DiscoveryConnection -> DiscoveryService
DiscoveryConnectionResponse DiscoveryConnection
conn
                        Maybe DiscoveryPeer
_ -> String -> ServiceHandler DiscoveryService ()
forall s. String -> ServiceHandler s ()
svcPrint (String -> ServiceHandler DiscoveryService ())
-> String -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ String
"Discovery: failed to relay connection response"

    serviceNewPeer :: ServiceHandler DiscoveryService ()
serviceNewPeer = do
        Server
server <- (ServiceInput DiscoveryService -> Server)
-> ServiceHandler DiscoveryService Server
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> Server
forall s. ServiceInput s -> Server
svcServer
        Peer
peer <- (ServiceInput DiscoveryService -> Peer)
-> ServiceHandler DiscoveryService Peer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServiceInput DiscoveryService -> Peer
forall s. ServiceInput s -> Peer
svcPeer

        let addrToText :: SockAddr -> Maybe Text
addrToText SockAddr
saddr = do
                ( IP
addr, PortNumber
port ) <- SockAddr -> Maybe (IP, PortNumber)
IP.fromSockAddr SockAddr
saddr
                Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IP -> String
forall a. Show a => a -> String
show IP
addr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port
        [Text]
addrs <- [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text])
-> ServiceHandler DiscoveryService [[Text]]
-> ServiceHandler DiscoveryService [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ServiceHandler DiscoveryService [Text]]
-> ServiceHandler DiscoveryService [[Text]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
            [ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> ([SockAddr] -> [Maybe Text]) -> [SockAddr] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SockAddr -> Maybe Text) -> [SockAddr] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map SockAddr -> Maybe Text
addrToText ([SockAddr] -> [Text])
-> ServiceHandler DiscoveryService [SockAddr]
-> ServiceHandler DiscoveryService [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [SockAddr] -> ServiceHandler DiscoveryService [SockAddr]
forall a. IO a -> ServiceHandler DiscoveryService a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> IO [SockAddr]
getServerAddresses Server
server)
#ifdef ENABLE_ICE_SUPPORT
            , return [ T.pack "ICE" ]
#endif
            ]

        Bool
-> ServiceHandler DiscoveryService ()
-> ServiceHandler DiscoveryService ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
addrs) (ServiceHandler DiscoveryService ()
 -> ServiceHandler DiscoveryService ())
-> ServiceHandler DiscoveryService ()
-> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ do
            Peer -> DiscoveryService -> ServiceHandler DiscoveryService ()
forall s (m :: * -> *). (Service s, MonadIO m) => Peer -> s -> m ()
sendToPeer Peer
peer (DiscoveryService -> ServiceHandler DiscoveryService ())
-> DiscoveryService -> ServiceHandler DiscoveryService ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe Int -> DiscoveryService
DiscoverySelf [Text]
addrs Maybe Int
forall a. Maybe a
Nothing