diff options
| -rw-r--r-- | main/Main.hs | 8 | ||||
| -rw-r--r-- | main/Test.hs | 8 | ||||
| -rw-r--r-- | src/Erebos/Discovery.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Network.hs | 14 | ||||
| -rw-r--r-- | src/Erebos/Pairing.hs | 2 |
5 files changed, 18 insertions, 16 deletions
diff --git a/main/Main.hs b/main/Main.hs index 04ae057..68bbc8a 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -325,7 +325,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do Left cstate -> do pname <- case csContext cstate of NoContext -> return "" - SelectedPeer peer -> peerIdentity peer >>= return . \case + SelectedPeer peer -> getPeerIdentity peer >>= return . \case PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown _ -> "<unknown>" @@ -400,7 +400,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do void $ liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange server - peerIdentity peer >>= \case + getPeerIdentity peer >>= \case pid@(PeerIdentityFull _) -> do dropped <- isPeerDropped peer shown <- showPeer pid <$> getPeerAddress peer @@ -527,7 +527,7 @@ getSelectedConversation = gets csContext >>= getConversationFromContext getConversationFromContext :: CommandContext -> CommandM Conversation getConversationFromContext = \case - SelectedPeer peer -> peerIdentity peer >>= \case + SelectedPeer peer -> getPeerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of @@ -885,7 +885,7 @@ cmdDetails = do [ "Network peer:" , " " <> show paddr ] - peerIdentity peer >>= \case + getPeerIdentity peer >>= \case PeerIdentityUnknown _ -> do cmdPutStrLn $ "unknown identity" PeerIdentityRef wref _ -> do diff --git a/main/Test.hs b/main/Test.hs index 1167bee..e697a91 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -557,7 +557,7 @@ cmdStartServer = do peer <- getNextPeerChange rsServer let printPeer TestPeer {..} = do - params <- peerIdentity tpPeer >>= \case + params <- getPeerIdentity tpPeer >>= \case PeerIdentityFull pid -> do return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) _ -> do @@ -613,7 +613,7 @@ cmdPeerList = do tpeers <- liftIO $ readMVar rsPeers forM_ peers $ \peer -> do Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers - mbpid <- peerIdentity peer + mbpid <- getPeerIdentity peer paddr <- getPeerAddress peer cmdOut $ unwords $ concat [ [ "peer-list-item", show (tpIndex tp) ] @@ -830,7 +830,7 @@ cmdContactSetName = do cmdDmSendPeer :: Command cmdDmSendPeer = do [spidx, msg] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx void $ sendDirectMessage to msg cmdDmSendContact :: Command @@ -861,7 +861,7 @@ dmList peer = do cmdDmListPeer :: Command cmdDmListPeer = do [spidx] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx dmList to cmdDmListContact :: Command diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index a83e589..5590e4c 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -570,7 +570,7 @@ discoverySearch :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> R discoverySearch server dgst = do peers <- liftIO $ getCurrentPeerList server match <- forM peers $ \peer -> do - peerIdentity peer >>= \case + getPeerIdentity peer >>= \case PeerIdentityFull pid -> do return $ dgst `elem` identityDigests pid _ -> return False diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 63ce7b8..7f9b060 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -9,7 +9,7 @@ module Erebos.Network ( Peer, peerServer, peerStorage, PeerAddress(..), getPeerAddress, getPeerAddresses, - PeerIdentity(..), peerIdentity, + PeerIdentity(..), getPeerIdentity, WaitingRef, wrDigest, Service(..), @@ -202,12 +202,14 @@ instance Ord PeerAddress where compare (DatagramAddress addr) (DatagramAddress addr') = compare addr addr' -data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) - | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) - | PeerIdentityFull UnifiedIdentity +data PeerIdentity + = PeerIdentityUnknown (TVar [ UnifiedIdentity -> ExceptT ErebosError IO () ]) + | PeerIdentityRef WaitingRef (TVar [ UnifiedIdentity -> ExceptT ErebosError IO () ]) + | PeerIdentityFull UnifiedIdentity -peerIdentity :: MonadIO m => Peer -> m PeerIdentity -peerIdentity = liftIO . atomically . readTVar . peerIdentityVar +-- | Get currently known identity of the given peer +getPeerIdentity :: MonadIO m => Peer -> m PeerIdentity +getPeerIdentity = liftIO . atomically . readTVar . peerIdentityVar data PeerState diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs index e3ebf2b..d1fdc79 100644 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -209,7 +209,7 @@ pairingRequest :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e pairingRequest _ peer = do self <- liftIO $ serverIdentity $ peerServer peer nonce <- liftIO $ getRandomBytes 32 - pid <- peerIdentity peer >>= \case + pid <- getPeerIdentity peer >>= \case PeerIdentityFull pid -> return pid _ -> throwOtherError "incomplete peer identity" sendToPeerWith @(PairingService a) peer $ \case |