Pairing: reject and restart

1 files changed, 10 insertions, 0 deletions

diff --git a/src/Contact.hs b/src/Contact.hs
index a4b5cf2..73a179f 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -5,6 +5,7 @@ module Contact (
     ContactService,
     contactRequest,
     contactAccept,
+    contactReject,
 ) where
 
 import Control.Arrow
@@ -127,6 +128,12 @@ instance PairingResult ContactAccepted where
             svcPrint $ "Contact accepted"
 
         , pairingHookVerifyFailed = return ()
+
+        , pairingHookRejected = do
+            svcPrint $ "Contact rejected by peer"
+
+        , pairingHookFailed = do
+            svcPrint $ "Contact failed"
         }
 
 contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()
@@ -135,6 +142,9 @@ contactRequest = pairingRequest @ContactAccepted Proxy
 contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
 contactAccept = pairingAccept @ContactAccepted Proxy
 
+contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
+contactReject = pairingReject @ContactAccepted Proxy
+
 finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
 finalizeContact identity slocal = liftIO $ do
     let st = storedStorage slocal