Return peer address in IO monad

Changelog: API: Replaced `Network.peerAddress` with `getPeerAddress` and added `getPeerAddresses`

4 files changed, 27 insertions, 17 deletions

diff --git a/main/Main.hs b/main/Main.hs
index 6a6c565..04ae057 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -403,7 +403,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
         peerIdentity peer >>= \case
             pid@(PeerIdentityFull _) -> do
                 dropped <- isPeerDropped peer
-                let shown = showPeer pid $ peerAddress peer
+                shown <- showPeer pid <$> getPeerAddress peer
                 let update [] = ([(peer, shown)], (Nothing, "NEW"))
                     update ((p,s):ps)
                         | p == peer && dropped = (ps, (Nothing, "DEL"))
@@ -880,9 +880,10 @@ cmdDetails :: Command
 cmdDetails = do
     getSelectedOrManualContext >>= \case
         SelectedPeer peer -> do
+            paddr <- getPeerAddress peer
             cmdPutStrLn $ unlines
                 [ "Network peer:"
-                , "  " <> show (peerAddress peer)
+                , "  " <> show paddr
                 ]
             peerIdentity peer >>= \case
                 PeerIdentityUnknown _ -> do
diff --git a/main/Test.hs b/main/Test.hs
index 093d3ac..1167bee 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -557,9 +557,12 @@ cmdStartServer = do
         peer <- getNextPeerChange rsServer
 
         let printPeer TestPeer {..} = do
-                params <- peerIdentity tpPeer >>= return . \case
-                    PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
-                    _ -> [ "addr", show (peerAddress tpPeer) ]
+                params <- peerIdentity tpPeer >>= \case
+                    PeerIdentityFull pid -> do
+                        return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
+                    _ -> do
+                        paddr <- getPeerAddress tpPeer
+                        return $ [ "addr", show paddr ]
                 outLine out $ unwords $ [ "peer", show tpIndex ] ++ params
 
             update ( tpIndex, [] ) = do
@@ -611,9 +614,10 @@ cmdPeerList = do
     forM_ peers $ \peer -> do
         Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers
         mbpid <- peerIdentity peer
+        paddr <- getPeerAddress peer
         cmdOut $ unwords $ concat
             [ [ "peer-list-item", show (tpIndex tp) ]
-            , [ "addr", show (peerAddress peer) ]
+            , [ "addr", show paddr ]
             , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
                             _ -> []
             ]
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index ff07964..a83e589 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -246,19 +246,16 @@ instance Service DiscoveryService where
         DiscoverySelf addrs priority -> do
             pid <- asks svcPeerIdentity
             peer <- asks svcPeer
+            paddrs <- getPeerAddresses peer
+
             let insertHelper new old | dpPriority new > dpPriority old = new
                                      | otherwise                       = old
-            matchedAddrs <- flip filterM addrs $ \case
-                DiscoveryICE -> do
-                    return True
-
-                DiscoveryIP ipaddr port
-                  | DatagramAddress saddr <- peerAddress peer
-                  , Just paddr <- inetFromSockAddr saddr
-                  -> do
-                    return $ ( ipaddr, port ) == paddr
 
-                _ -> return False
+            let matchedAddrs = flip filter addrs $ \case
+                    DiscoveryICE -> True
+                    DiscoveryIP ipaddr port ->
+                        DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs
+                    _ -> False
 
             forM_ (idDataF =<< unfoldOwners pid) $ \sdata -> do
                 let dp = DiscoveryPeer
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 76ecd82..63ce7b8 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -8,7 +8,7 @@ module Erebos.Network (
     ServerOptions(..), serverIdentity, defaultServerOptions,
 
     Peer, peerServer, peerStorage,
-    PeerAddress(..), peerAddress,
+    PeerAddress(..), getPeerAddress, getPeerAddresses,
     PeerIdentity(..), peerIdentity,
     WaitingRef, wrDigest,
     Service(..),
@@ -139,6 +139,14 @@ data Peer = Peer
     , peerWaitingRefs :: TMVar [WaitingRef]
     }
 
+-- | Get current main address of the peer (used to send new packets).
+getPeerAddress :: MonadIO m => Peer -> m PeerAddress
+getPeerAddress = liftIO . return . peerAddress
+
+-- | Get all known addresses of given peer.
+getPeerAddresses :: MonadIO m => Peer -> m [ PeerAddress ]
+getPeerAddresses = fmap (: []) . getPeerAddress
+
 peerServer :: Peer -> Server
 peerServer = peerServer_