summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Attach.hs29
-rw-r--r--src/Message.hs13
-rw-r--r--src/Network.hs29
-rw-r--r--src/Service.hs26
-rw-r--r--src/Sync.hs1
5 files changed, 57 insertions, 41 deletions
diff --git a/src/Attach.hs b/src/Attach.hs
index f3a98b3..10a87f3 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -84,8 +84,8 @@ instance Service AttachService where
svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
nonce <- liftIO $ getRandomBytes 32
svcSet $ PeerRequest nonce confirm
- return $ Just $ AttachResponse nonce
- (NoAttach, _) -> return Nothing
+ replyPacket $ AttachResponse nonce
+ (NoAttach, _) -> return ()
(OurRequest nonce, AttachResponse pnonce) -> do
peer <- asks $ svcPeer
@@ -93,24 +93,23 @@ instance Service AttachService where
validateIdentity . lsIdentity . fromStored =<< svcGetLocal
svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce)
svcSet $ OurRequestConfirm Nothing
- return $ Just $ AttachRequestNonce nonce
+ replyPacket $ AttachRequestNonce nonce
(OurRequest _, _) -> do
svcSet $ AttachFailed
- return $ Just $ AttachDecline
+ replyPacket AttachDecline
(OurRequestConfirm _, AttachIdentity sdata keys) -> do
verifyAttachedIdentity sdata >>= \case
Just owner -> do
svcPrint $ "Attachment confirmed by peer"
svcSet $ OurRequestConfirm $ Just (owner, keys)
- return Nothing
Nothing -> do
svcPrint $ "Failed to verify new identity"
svcSet $ AttachFailed
- return $ Just AttachDecline
+ replyPacket AttachDecline
(OurRequestConfirm _, _) -> do
svcSet $ AttachFailed
- return $ Just $ AttachDecline
+ replyPacket AttachDecline
(OurRequestReady, AttachIdentity sdata keys) -> do
verifyAttachedIdentity sdata >>= \case
@@ -118,14 +117,13 @@ instance Service AttachService where
svcPrint $ "Accepted updated identity"
st <- storedStorage <$> svcGetLocal
finalizeAttach st identity keys
- return Nothing
Nothing -> do
svcPrint $ "Failed to verify new identity"
svcSet $ AttachFailed
- return $ Just AttachDecline
+ replyPacket AttachDecline
(OurRequestReady, _) -> do
svcSet $ AttachFailed
- return $ Just $ AttachDecline
+ replyPacket AttachDecline
(PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do
peer <- asks $ svcPeer
@@ -134,19 +132,18 @@ instance Service AttachService where
if dgst == nonceDigest peer self pnonce BA.empty
then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce)
svcSet PeerRequestConfirm
- return Nothing
else do svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
svcSet AttachFailed
- return $ Just $ AttachDecline
+ replyPacket AttachDecline
(PeerRequest _ _, _) -> do
svcSet $ AttachFailed
- return $ Just $ AttachDecline
+ replyPacket AttachDecline
(PeerRequestConfirm, _) -> do
svcSet $ AttachFailed
- return $ Just $ AttachDecline
+ replyPacket AttachDecline
- (AttachDone, _) -> return Nothing
- (AttachFailed, _) -> return Nothing
+ (AttachDone, _) -> return ()
+ (AttachFailed, _) -> return ()
attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
attachToOwner _ self peer = do
diff --git a/src/Message.hs b/src/Message.hs
index bfb4b66..ee59dad 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -84,14 +84,11 @@ instance Service DirectMessageService where
shared <- makeSharedStateUpdate st [next] (lsShared $ fromStored erb)
wrappedStore st (fromStored erb) { lsShared = [shared] }
svcSetLocal erb'
- if powner `sameIdentity` msgFrom msg
- then do
- svcPrint $ formatMessage tzone msg
- return $ Just $ DirectMessagePacket smsg
- else return Nothing
-
- else do svcPrint "Owner mismatch"
- return Nothing
+ when (powner `sameIdentity` msgFrom msg) $ do
+ svcPrint $ formatMessage tzone msg
+ replyStoredRef packet
+
+ else svcPrint "Owner mismatch"
instance Storable (ServicePacket DirectMessageService) where
store' (DirectMessagePacket smsg) = store' smsg
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
diff --git a/src/Service.hs b/src/Service.hs
index 59b4e8e..d2848b6 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -6,16 +6,19 @@ module Service (
ServiceHandler,
ServiceInput(..),
+ ServiceReply(..),
handleServicePacket,
svcGet, svcSet,
svcGetLocal, svcSetLocal,
svcPrint,
+ replyPacket, replyStored, replyStoredRef,
) where
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
+import Control.Monad.Writer
import Data.Typeable
import Data.UUID (UUID)
@@ -32,7 +35,7 @@ class (Typeable s, Storable (ServicePacket s)) => Service s where
emptyServiceState :: ServiceState s
data ServicePacket s :: *
- serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
+ serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s ()
data SomeService = forall s. Service s => SomeService (Proxy s)
@@ -58,24 +61,26 @@ data ServiceInput = ServiceInput
, svcPrintOp :: String -> IO ()
}
+data ServiceReply s = ServiceReply (Either (ServicePacket s) (Stored (ServicePacket s))) Bool
+
data ServiceHandlerState s = ServiceHandlerState
{ svcValue :: ServiceState s
, svcLocal :: Stored LocalState
}
-newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceHandlerState s) (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceHandlerState s), MonadError String, MonadIO)
+newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a)
+ deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO)
-handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), ServiceState s)
+handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO ([ServiceReply s], ServiceState s)
handleServicePacket st input svc packet = do
herb <- loadLocalStateHead st
let erb = wrappedLoad $ headRef herb
sstate = ServiceHandlerState { svcValue = svc, svcLocal = erb }
ServiceHandler handler = serviceHandler packet
- (runExceptT $ flip runStateT sstate $ flip runReaderT input $ handler) >>= \case
+ (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case
Left err -> do
svcPrintOp input $ "service failed: " ++ err
- return (Nothing, svc)
+ return ([], svc)
Right (rsp, sstate')
| svcLocal sstate' == svcLocal sstate -> return (rsp, svcValue sstate')
| otherwise -> replaceHead (svcLocal sstate') (Right herb) >>= \case
@@ -96,3 +101,12 @@ svcSetLocal x = modify $ \st -> st { svcLocal = x }
svcPrint :: String -> ServiceHandler s ()
svcPrint str = liftIO . ($str) =<< asks svcPrintOp
+
+replyPacket :: Service s => ServicePacket s -> ServiceHandler s ()
+replyPacket x = tell [ServiceReply (Left x) True]
+
+replyStored :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStored x = tell [ServiceReply (Right x) True]
+
+replyStoredRef :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStoredRef x = tell [ServiceReply (Right x) False]
diff --git a/src/Sync.hs b/src/Sync.hs
index e8edf33..37941b8 100644
--- a/src/Sync.hs
+++ b/src/Sync.hs
@@ -30,7 +30,6 @@ instance Service SyncService where
updated = filterAncestors (added : current)
when (current /= updated) $ do
svcSetLocal =<< wrappedStore st (fromStored ls) { lsShared = updated }
- return Nothing
instance Storable (ServicePacket SyncService) where
store' (SyncPacket smsg) = store' smsg
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 01:55:58 +0000