diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Network.hs | 10 | ||||
| -rw-r--r-- | src/Service.hs | 7 | ||||
| -rw-r--r-- | src/Test.hs | 10 |
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 |