From c1fff94d244d6754a0976d0385d4333249fc5ca6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 16 Dec 2021 21:30:06 +0100 Subject: Remove unnecessary self identity parameters --- src/Attach.hs | 5 ++--- src/Contact.hs | 5 ++--- src/Discovery.hs | 11 +++++------ src/Main.hs | 8 ++------ src/Message.hs | 2 +- src/Network.hs | 39 ++++++++++++++++++++++----------------- src/Pairing.hs | 7 ++++--- 7 files changed, 38 insertions(+), 39 deletions(-) (limited to 'src') diff --git a/src/Attach.hs b/src/Attach.hs index 055c7fe..adb9d2f 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -71,14 +71,13 @@ instance PairingResult AttachIdentity where svcPrint $ "Failed to verify new identity" throwError "Failed to verify new identity" -attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m () +attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m () attachToOwner _ = pairingRequest @AttachIdentity Proxy attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m () attachAccept printMsg h peer = do let st = refStorage $ headRef h - self = headLocalIdentity h - sendToPeerWith self peer $ \case + sendToPeerWith peer $ \case NoPairing -> throwError $ "none in progress" OurRequest {} -> throwError $ "waiting for peer" OurRequestConfirm Nothing -> do diff --git a/src/Contact.hs b/src/Contact.hs index 5c4e265..01bd49d 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -108,13 +108,12 @@ instance PairingResult ContactAccepted where pairingHookAccept ContactAccepted = return () -contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m () +contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m () contactRequest _ = pairingRequest @ContactAccepted Proxy contactAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m () contactAccept printMsg h peer = do - let self = headLocalIdentity h - sendToPeerWith self peer $ \case + sendToPeerWith peer $ \case NoPairing -> throwError $ "none in progress" OurRequest {} -> throwError $ "waiting for peer" OurRequestConfirm Nothing -> do diff --git a/src/Discovery.hs b/src/Discovery.hs index aedfda4..f419eab 100644 --- a/src/Discovery.hs +++ b/src/Discovery.hs @@ -121,11 +121,10 @@ instance Service DiscoveryService where 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 + res <- runExceptT $ sendToPeer peer $ DiscoverySelf addr 0 case res of Right _ -> return () Left err -> putStrLn $ "Discovery: failed to send keep-alive: " ++ err @@ -146,7 +145,7 @@ instance Service DiscoveryService where peer <- asks svcPeer ice <- liftIO $ iceCreate PjIceSessRoleControlling $ \ice -> do rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer self peer $ + res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceSession = Just rinfo } case res of Right _ -> return () @@ -175,7 +174,7 @@ instance Service DiscoveryService where peer <- asks svcPeer liftIO $ void $ iceCreate PjIceSessRoleControlled $ \ice -> do rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer self peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } + res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } case res of Right _ -> do case dconnIceSession conn of @@ -191,7 +190,7 @@ instance Service DiscoveryService where Just dp | Just addr <- dpAddress dp -> do replyPacket $ DiscoveryConnectionResponse rconn { dconnAddress = Just addr } | Just dpeer <- dpPeer dp -> do - sendToPeer self dpeer $ DiscoveryConnectionRequest conn + sendToPeer dpeer $ DiscoveryConnectionRequest conn | otherwise -> svcPrint $ "Discovery: failed to relay connection request" DiscoveryConnectionResponse conn -> do @@ -219,5 +218,5 @@ instance Service DiscoveryService where -- response to relayed request case M.lookup (refDigest $ dconnSource conn) dpeers of Just dp | Just dpeer <- dpPeer dp -> do - sendToPeer self dpeer $ DiscoveryConnectionResponse conn + sendToPeer dpeer $ DiscoveryConnectionResponse conn _ -> svcPrint $ "Discovery: failed to relay connection response" diff --git a/src/Main.hs b/src/Main.hs index 8d6f8de..fcdb2c5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -296,7 +296,6 @@ cmdUpdateIdentity = void $ do cmdAttach :: Command cmdAttach = join $ attachToOwner <$> asks ciPrint - <*> asks (headLocalIdentity . ciHead) <*> (maybe (throwError "no peer selected") return =<< gets csPeer) cmdAttachAccept :: Command @@ -318,7 +317,6 @@ cmdContacts = do cmdContactAdd :: Command cmdContactAdd = join $ contactRequest <$> asks ciPrint - <*> asks (headLocalIdentity . ciHead) <*> (maybe (throwError "no peer selected") return =<< gets csPeer) cmdContactAccept :: Command @@ -329,7 +327,6 @@ cmdContactAccept = join $ contactAccept cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do - self <- asks (headLocalIdentity . ciHead) server <- asks ciServer (hostname, port) <- (words <$> asks ciLine) >>= return . \case @@ -338,20 +335,19 @@ cmdDiscoveryInit = void $ do [] -> ("discovery.erebosprotocol.net", show 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 + sendToPeer 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 + res <- runExceptT $ sendToPeer peer $ DiscoverySearch ref case res of Right _ -> return () Left err -> eprint err diff --git a/src/Message.hs b/src/Message.hs index 04ddef1..192ab9d 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -141,7 +141,7 @@ sendDirectMessage h peer text = do } return ([next], smsg) - sendToPeerStored self peer smsg + sendToPeerStored peer smsg return smsg diff --git a/src/Network.hs b/src/Network.hs index 26f1db3..5f7d823 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -2,9 +2,9 @@ module Network ( Server, startServer, getNextPeerChange, - ServerOptions(..), defaultServerOptions, + ServerOptions(..), serverIdentity, defaultServerOptions, - Peer, + Peer, peerServer, PeerAddress(..), peerAddress, PeerIdentity(..), peerIdentity, PeerChannel(..), @@ -61,7 +61,7 @@ announceIntervalSeconds = 60 data Server = Server { serverStorage :: Storage - , serverIdentity :: MVar UnifiedIdentity + , serverIdentity_ :: MVar UnifiedIdentity , serverSocket :: MVar Socket , serverChanPacket :: Chan (PeerAddress, BC.ByteString) , serverOutQueue :: TQueue (Peer, Bool, TransportPacket) @@ -72,6 +72,9 @@ data Server = Server , serverErrorLog :: TQueue String } +serverIdentity :: Server -> IO UnifiedIdentity +serverIdentity = readMVar . serverIdentity_ + getNextPeerChange :: Server -> IO Peer getNextPeerChange = atomically . readTChan . serverChanPeer @@ -89,7 +92,7 @@ defaultServerOptions = ServerOptions data Peer = Peer { peerAddress :: PeerAddress - , peerServer :: Server + , peerServer_ :: Server , peerIdentityVar :: TVar PeerIdentity , peerChannel :: TVar PeerChannel , peerStorage :: Storage @@ -99,6 +102,9 @@ data Peer = Peer , peerWaitingRefs :: TMVar [WaitingRef] } +peerServer :: Peer -> Server +peerServer = peerServer_ + instance Eq Peer where (==) = (==) `on` peerIdentityVar @@ -230,7 +236,7 @@ startServer opt origHead logd' services = do let server = Server { serverStorage = storage - , serverIdentity = midentity + , serverIdentity_ = midentity , serverSocket = ssocket , serverChanPacket = chanPacket , serverOutQueue = outQueue @@ -378,8 +384,7 @@ startServer opt origHead logd' services = do Just h -> do (rsp, (s', gs')) <- handleServicePacket h inp s gs (wrappedLoad ref :: Stored s) when (not (null rsp)) $ do - identity <- readMVar midentity - sendToPeerList identity peer rsp + sendToPeerList peer rsp atomically $ do putTMVar (peerServiceState peer) $ M.insert svc (SomeServiceState proxy s') svcs putTMVar svcStates $ M.insert svc (SomeServiceGlobalState proxy gs') global @@ -752,7 +757,7 @@ serverPeer' server paddr = do peer <- mkPeer server paddr return (M.insert paddr peer pvalue, (peer, True)) when hello $ do - identity <- readMVar (serverIdentity server) + identity <- serverIdentity server atomically $ writeTQueue (serverOutQueue server) $ (peer, False,) $ TransportPacket (TransportHeader [ AnnounceSelf $ partialRef (peerInStorage peer) $ storedRef $ idData identity ]) @@ -760,14 +765,14 @@ serverPeer' server paddr = do return peer -sendToPeer :: (Service s, MonadIO m) => UnifiedIdentity -> Peer -> s -> m () -sendToPeer self peer packet = sendToPeerList self peer [ServiceReply (Left packet) True] +sendToPeer :: (Service s, MonadIO m) => Peer -> s -> m () +sendToPeer peer packet = sendToPeerList peer [ServiceReply (Left packet) True] -sendToPeerStored :: (Service s, MonadIO m) => UnifiedIdentity -> Peer -> Stored s -> m () -sendToPeerStored self peer spacket = sendToPeerList self peer [ServiceReply (Right spacket) True] +sendToPeerStored :: (Service s, MonadIO m) => Peer -> Stored s -> m () +sendToPeerStored peer spacket = sendToPeerList peer [ServiceReply (Right spacket) True] -sendToPeerList :: (Service s, MonadIO m) => UnifiedIdentity -> Peer -> [ServiceReply s] -> m () -sendToPeerList _ peer parts = do +sendToPeerList :: (Service s, MonadIO m) => Peer -> [ServiceReply s] -> m () +sendToPeerList peer parts = do let st = peerStorage peer pst = peerInStorage peer srefs <- liftIO $ forM parts $ \case ServiceReply (Left x) _ -> store st x @@ -784,8 +789,8 @@ sendToPeerS peer packet = writeTQueue (serverOutQueue $ peerServer peer) (peer, sendToPeerPlain :: Peer -> TransportPacket -> STM () sendToPeerPlain peer packet = writeTQueue (serverOutQueue $ peerServer peer) (peer, False, packet) -sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m () -sendToPeerWith identity peer fobj = do +sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m () +sendToPeerWith peer fobj = do let sproxy = Proxy @s sid = serviceID sproxy res <- liftIO $ do @@ -797,7 +802,7 @@ sendToPeerWith identity peer fobj = do return res case res of - Right (Just obj) -> sendToPeer identity peer obj + Right (Just obj) -> sendToPeer peer obj Right Nothing -> return () Left err -> throwError err diff --git a/src/Pairing.hs b/src/Pairing.hs index ce176a6..6407afa 100644 --- a/src/Pairing.hs +++ b/src/Pairing.hs @@ -152,12 +152,13 @@ confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: in replicate (len - length str) '0' ++ str where len = 6 -pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> UnifiedIdentity -> Peer -> m () -pairingRequest _ self peer = do +pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingRequest _ peer = do + self <- liftIO $ serverIdentity $ peerServer peer nonce <- liftIO $ getRandomBytes 32 pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid _ -> throwError "incomplete peer identity" - sendToPeerWith @(PairingService a) self peer $ \case + sendToPeerWith @(PairingService a) peer $ \case NoPairing -> return (Just $ PairingRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce) _ -> throwError "alredy in progress" -- cgit v1.2.3