summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2020-02-03 22:29:31 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2020-02-04 22:52:47 +0100
commit6f0bcff200598d085c89d167aa126d25fc5df3ed (patch)
tree0868edc1759b7c90eaba7ab8d4835179b42541ff /src/Network.hs
parent84d7c83bc85ff0862a39d6de3bd227550175ebce (diff)
Service: stored or ref-only reply packet
Use the ref-only packet to acknowledge successful storage of received direct message.
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs29
1 files changed, 19 insertions, 10 deletions
diff --git a/src/Network.hs b/src/Network.hs
index 09cbea1..7e2568e 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -6,7 +6,7 @@ module Network (
WaitingRef, wrDigest,
Service(..),
startServer,
- sendToPeer, sendToPeerWith,
+ sendToPeer, sendToPeerStored, sendToPeerWith,
) where
import Control.Concurrent
@@ -288,7 +288,7 @@ startServer origHead logd bhost services = do
}
(rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref)
identity <- readMVar midentity
- runExceptT (maybe (return ()) (sendToPeer identity peer) rsp) >>= \case
+ runExceptT (sendToPeerList identity peer rsp) >>= \case
Left err -> logd $ "failed to send response to peer: " ++ show err
Right () -> return ()
return $ M.insert svc (SomeServiceState s') svcs
@@ -588,21 +588,30 @@ handleServices chan = gets (peerServiceQueue . phPeer) >>= \case
sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> ServicePacket s -> m ()
-sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } packet = do
+sendToPeer self peer packet = sendToPeerList self peer [ServiceReply (Left packet) True]
+
+sendToPeerStored :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Stored (ServicePacket s) -> m ()
+sendToPeerStored self peer spacket = sendToPeerList self peer [ServiceReply (Right spacket) True]
+
+sendToPeerList :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> [ServiceReply s] -> m ()
+sendToPeerList _ peer@Peer { peerChannel = ChannelEstablished ch } parts = do
let st = peerInStorage peer
- ref <- liftIO $ store st packet
- bytes <- case lazyLoadBytes ref of
+ srefs <- liftIO $ forM parts $ \case ServiceReply (Left x) _ -> store st x
+ ServiceReply (Right sx) _ -> copyRef st (storedRef sx)
+
+ bytes <- forM (zip parts srefs) $
+ \case (ServiceReply _ False, _) -> return BL.empty
+ (ServiceReply _ True, ref) -> case lazyLoadBytes ref of
Right bytes -> return bytes
Left dgst -> throwError $ "incomplete ref " ++ show ref ++ ", missing " ++ BC.unpack (showRefDigest dgst)
- let plain = BL.toStrict $ BL.concat
- [ serializeObject $ transportToObject $ TransportHeader [ServiceType $ serviceID packet, ServiceRef ref]
- , bytes
- ]
+ let plain = BL.toStrict $ BL.concat $
+ (serializeObject $ transportToObject $ TransportHeader (ServiceType (serviceID $ head parts) : map ServiceRef srefs))
+ : bytes
ctext <- channelEncrypt ch plain
let DatagramAddress paddr = peerAddress peer
void $ liftIO $ sendTo (peerSocket peer) ctext paddr
-sendToPeer _ _ _ = throwError $ "no channel to peer"
+sendToPeerList _ _ _ = throwError $ "no channel to peer"
sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe (ServicePacket s), ServiceState s)) -> m ()
sendToPeerWith identity peer fobj = do