From ba50676a1fe66c5f24f251984f2cb49c0e98aead Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Thu, 28 Jul 2022 21:29:37 +0200
Subject: Service: wait with output after head commit

---
 src/Network.hs | 10 ++++++----
 src/Service.hs |  7 ++++++-
 src/Test.hs    | 10 +++++-----
 3 files changed, 17 insertions(+), 10 deletions(-)

(limited to 'src')

diff --git a/src/Network.hs b/src/Network.hs
index 7195129..3cf714d 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -835,10 +835,12 @@ 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
-                                         ServiceReply (Right sx) _ -> return $ storedRef sx
-    prefs <- mapM (copyRef pst) srefs
-    let content = map snd $ filter (\(ServiceReply _ use, _) -> use) (zip parts srefs)
+    srefs <- liftIO $ fmap catMaybes $ forM parts $ \case
+        ServiceReply (Left x) use -> Just . (,use) <$> store st x
+        ServiceReply (Right sx) use -> return $ Just (storedRef sx, use)
+        ServiceFinally act -> act >> return Nothing
+    prefs <- mapM (copyRef pst . fst) srefs
+    let content = map fst $ filter snd srefs
         header = TransportHeader (ServiceType (serviceID $ head parts) : map ServiceRef prefs)
         packet = TransportPacket header content
         ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- prefs ]
diff --git a/src/Service.hs b/src/Service.hs
index 96fa63d..3ef10d6 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -18,6 +18,7 @@ module Service (
     svcPrint,
 
     replyPacket, replyStored, replyStoredRef,
+    afterCommit,
 ) where
 
 import Control.Monad.Except
@@ -101,6 +102,7 @@ data ServiceInput s = ServiceInput
     }
 
 data ServiceReply s = ServiceReply (Either s (Stored s)) Bool
+                    | ServiceFinally (IO ())
 
 data ServiceHandlerState s = ServiceHandlerState
     { svcValue :: ServiceState s
@@ -163,7 +165,7 @@ svcSelf = maybe (throwError "failed to validate own identity") return .
         validateIdentity . lsIdentity . fromStored =<< svcGetLocal
 
 svcPrint :: String -> ServiceHandler s ()
-svcPrint str = liftIO . ($str) =<< asks svcPrintOp
+svcPrint str = afterCommit . ($str) =<< asks svcPrintOp
 
 replyPacket :: Service s => s -> ServiceHandler s ()
 replyPacket x = tell [ServiceReply (Left x) True]
@@ -173,3 +175,6 @@ replyStored x = tell [ServiceReply (Right x) True]
 
 replyStoredRef :: Service s => Stored s -> ServiceHandler s ()
 replyStoredRef x = tell [ServiceReply (Right x) False]
+
+afterCommit :: IO () -> ServiceHandler s ()
+afterCommit x = tell [ServiceFinally x]
diff --git a/src/Test.hs b/src/Test.hs
index 19d1a64..8c26f5e 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -122,11 +122,11 @@ pairingAttributes _ out peers prefix = PairingAttributes
 
     , pairingHookResponse = \confirm -> do
         index <- show <$> getPeerIndex peers
-        liftIO $ outLine out $ unwords [prefix ++ "-response", index, confirm]
+        afterCommit $ outLine out $ unwords [prefix ++ "-response", index, confirm]
 
     , pairingHookRequestNonce = \confirm -> do
         index <- show <$> getPeerIndex peers
-        liftIO $ outLine out $ unwords [prefix ++ "-request", index, confirm]
+        afterCommit $ outLine out $ unwords [prefix ++ "-request", index, confirm]
 
     , pairingHookRequestNonceFailed = failed "nonce"
 
@@ -135,11 +135,11 @@ pairingAttributes _ out peers prefix = PairingAttributes
 
     , pairingHookAcceptedResponse = do
         index <- show <$> getPeerIndex peers
-        liftIO $ outLine out $ unwords [prefix ++ "-response-done", index]
+        afterCommit $ outLine out $ unwords [prefix ++ "-response-done", index]
 
     , pairingHookAcceptedRequest = do
         index <- show <$> getPeerIndex peers
-        liftIO $ outLine out $ unwords [prefix ++ "-request-done", index]
+        afterCommit $ outLine out $ unwords [prefix ++ "-request-done", index]
 
     , pairingHookFailed = \case
         PairingUserRejected -> failed "user"
@@ -160,7 +160,7 @@ pairingAttributes _ out peers prefix = PairingAttributes
                 _ -> fail "unexpected pairing state"
 
             index <- show <$> getPeerIndex peers
-            liftIO $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index ++ " " ++ detail
+            afterCommit $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index ++ " " ++ detail
 
         strState :: PairingState a -> String
         strState = \case
-- 
cgit v1.2.3