summaryrefslogtreecommitdiff
path: root/src/Contact.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2021-12-27 22:46:21 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2021-12-29 23:30:46 +0100
commite9760baab9608419565e253cae101b24f87eb8e5 (patch)
tree3a411690d926f30baae81edbea7a436e22843361 /src/Contact.hs
parent2903fd39c39357168a7cbb8b6821a0c99ed1e5a7 (diff)
Pairing: refactor common logic into the base module
Diffstat (limited to 'src/Contact.hs')
-rw-r--r--src/Contact.hs55
1 files changed, 27 insertions, 28 deletions
diff --git a/src/Contact.hs b/src/Contact.hs
index e0f1a74..a4b5cf2 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -86,6 +86,17 @@ instance Storable ContactAccepted where
instance PairingResult ContactAccepted where
pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084"
+ pairingVerifyResult = return . Just
+
+ pairingFinalizeRequest ContactAccepted = do
+ pid <- asks svcPeerIdentity
+ updateLocalState_ $ finalizeContact pid
+
+ pairingFinalizeResponse = do
+ pid <- asks svcPeerIdentity
+ updateLocalState_ $ finalizeContact pid
+ return ContactAccepted
+
defaultPairingAttributes _ = PairingAttributes
{ pairingHookRequest = do
peer <- asks $ svcPeerIdentity
@@ -103,38 +114,26 @@ instance PairingResult ContactAccepted where
peer <- asks $ svcPeerIdentity
svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
- , pairingHookConfirm = \ContactAccepted -> do
+ , pairingHookConfirmedResponse = do
+ svcPrint $ "Contact accepted, waiting for peer confirmation"
+
+ , pairingHookConfirmedRequest = do
svcPrint $ "Contact confirmed by peer"
- return $ Just ContactAccepted
- , pairingHookAccept = \ContactAccepted -> return ()
+ , pairingHookAcceptedResponse = do
+ svcPrint $ "Contact accepted"
+
+ , pairingHookAcceptedRequest = do
+ svcPrint $ "Contact accepted"
+
+ , pairingHookVerifyFailed = return ()
}
-contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m ()
-contactRequest _ = pairingRequest @ContactAccepted Proxy
-
-contactAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
-contactAccept printMsg h peer = do
- sendToPeerWith peer $ \case
- NoPairing -> throwError $ "none in progress"
- OurRequest {} -> throwError $ "waiting for peer"
- OurRequestConfirm Nothing -> do
- liftIO $ printMsg $ "Contact accepted, waiting for peer confirmation"
- return (Nothing, OurRequestReady)
- OurRequestConfirm (Just ContactAccepted) -> do
- PeerIdentityFull pid <- peerIdentity peer
- liftIO $ printMsg $ "Contact accepted"
- flip runReaderT h $ updateLocalState_ $ finalizeContact pid
- return (Nothing, PairingDone)
- OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
- PeerRequest {} -> throwError $ "waiting for peer"
- PeerRequestConfirm -> do
- PeerIdentityFull pid <- peerIdentity peer
- liftIO $ printMsg $ "Contact accepted"
- flip runReaderT h $ updateLocalState_ $ finalizeContact pid
- return (Just $ PairingAccept ContactAccepted, PairingDone)
- PairingDone -> throwError $ "alredy done"
- PairingFailed -> throwError $ "alredy failed"
+contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()
+contactRequest = pairingRequest @ContactAccepted Proxy
+
+contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
+contactAccept = pairingAccept @ContactAccepted Proxy
finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
finalizeContact identity slocal = liftIO $ do