From 6f0bcff200598d085c89d167aa126d25fc5df3ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Mon, 3 Feb 2020 22:29:31 +0100 Subject: Service: stored or ref-only reply packet Use the ref-only packet to acknowledge successful storage of received direct message. --- src/Attach.hs | 29 +++++++++++++---------------- src/Message.hs | 13 +++++-------- src/Network.hs | 29 +++++++++++++++++++---------- src/Service.hs | 26 ++++++++++++++++++++------ src/Sync.hs | 1 - 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 -- cgit v1.2.3