summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network.hs10
-rw-r--r--src/Service.hs7
-rw-r--r--src/Test.hs10
3 files changed, 17 insertions, 10 deletions
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