Remove unnecessary self identity parameters

7 files changed, 38 insertions, 39 deletions

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"