Service: stored or ref-only reply packet

Use the ref-only packet to acknowledge successful storage of received
direct message.

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