diff options
Diffstat (limited to 'src/Network.hs')
| -rw-r--r-- | src/Network.hs | 39 |
1 files changed, 22 insertions, 17 deletions
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 |