Pairing: reject and restart

4 files changed, 62 insertions, 24 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index c220e14..90c9900 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -1,6 +1,8 @@
 module Attach (
     AttachService,
-    attachToOwner, attachAccept,
+    attachToOwner,
+    attachAccept,
+    attachReject,
 ) where
 
 import Control.Monad.Except
@@ -103,6 +105,12 @@ instance PairingResult AttachIdentity where
 
         , pairingHookVerifyFailed = do
             svcPrint $ "Failed to verify new identity"
+
+        , pairingHookRejected = do
+            svcPrint $ "Attachment rejected by peer"
+
+        , pairingHookFailed = do
+            svcPrint $ "Attachement failed"
         }
 
 attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()
@@ -110,3 +118,6 @@ attachToOwner = pairingRequest @AttachIdentity Proxy
 
 attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
 attachAccept = pairingAccept @AttachIdentity Proxy
+
+attachReject :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachReject = pairingReject @AttachIdentity Proxy
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
diff --git a/src/Main.hs b/src/Main.hs
index 3045f94..2c56a00 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -230,9 +230,11 @@ commands =
     , ("update-identity", cmdUpdateIdentity)
     , ("attach", cmdAttach)
     , ("attach-accept", cmdAttachAccept)
+    , ("attach-reject", cmdAttachReject)
     , ("contacts", cmdContacts)
     , ("contact-add", cmdContactAdd)
     , ("contact-accept", cmdContactAccept)
+    , ("contact-reject", cmdContactReject)
     , ("discovery-init", cmdDiscoveryInit)
     , ("discovery", cmdDiscovery)
     , ("ice-create", cmdIceCreate)
@@ -300,6 +302,10 @@ cmdAttachAccept :: Command
 cmdAttachAccept = join $ attachAccept
     <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
 
+cmdAttachReject :: Command
+cmdAttachReject = join $ attachReject
+    <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
 cmdContacts :: Command
 cmdContacts = do
     args <- words <$> asks ciLine
@@ -318,6 +324,10 @@ cmdContactAccept :: Command
 cmdContactAccept = join $ contactAccept
     <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
 
+cmdContactReject :: Command
+cmdContactReject = join $ contactReject
+    <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
 cmdDiscoveryInit :: Command
 cmdDiscoveryInit = void $ do
     server <- asks ciServer
diff --git a/src/Pairing.hs b/src/Pairing.hs
index a30615a..2c3f2ff 100644
--- a/src/Pairing.hs
+++ b/src/Pairing.hs
@@ -6,6 +6,7 @@ module Pairing (
 
     pairingRequest,
     pairingAccept,
+    pairingReject,
 ) where
 
 import Control.Monad.Except
@@ -41,7 +42,6 @@ data PairingState a = NoPairing
                     | PeerRequest Bytes RefDigest
                     | PeerRequestConfirm
                     | PairingDone
-                    | PairingFailed
 
 data PairingAttributes a = PairingAttributes
     { pairingHookRequest :: ServiceHandler (PairingService a) ()
@@ -53,6 +53,8 @@ data PairingAttributes a = PairingAttributes
     , pairingHookAcceptedResponse :: ServiceHandler (PairingService a) ()
     , pairingHookAcceptedRequest :: ServiceHandler (PairingService a) ()
     , pairingHookVerifyFailed :: ServiceHandler (PairingService a) ()
+    , pairingHookRejected :: ServiceHandler (PairingService a) ()
+    , pairingHookFailed :: ServiceHandler (PairingService a) ()
     }
 
 class (Typeable a, Storable a) => PairingResult a where
@@ -107,6 +109,11 @@ instance PairingResult a => Service (PairingService a) where
             replyPacket $ PairingResponse nonce
         (NoPairing, _) -> return ()
 
+        (PairingDone, _) -> return ()
+        (_, PairingDecline) -> do
+            join $ asks $ pairingHookRejected . svcAttributes
+            svcSet NoPairing
+
         (OurRequest nonce, PairingResponse pnonce) -> do
             peer <- asks $ svcPeerIdentity
             self <- maybe (throwError "failed to validate own identity") return .
@@ -115,26 +122,23 @@ instance PairingResult a => Service (PairingService a) where
             hook $ confirmationNumber $ nonceDigest self peer nonce pnonce
             svcSet $ OurRequestConfirm Nothing
             replyPacket $ PairingRequestNonce nonce
-        (OurRequest _, _) -> do
-            svcSet $ PairingFailed
-            replyPacket PairingDecline
+        (OurRequest _, _) -> reject
 
         (OurRequestConfirm _, PairingAccept x) -> do
-            flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do
+            flip catchError (const reject) $ do
                 pairingVerifyResult x >>= \case
                     Just x' -> do
                         join $ asks $ pairingHookConfirmedRequest . svcAttributes
                         svcSet $ OurRequestConfirm (Just x')
                     Nothing -> do
                         join $ asks $ pairingHookVerifyFailed . svcAttributes
-                        throwError ""
+                        svcSet NoPairing
+                        replyPacket PairingDecline
 
-        (OurRequestConfirm _, _) -> do
-            svcSet $ PairingFailed
-            replyPacket PairingDecline
+        (OurRequestConfirm _, _) -> reject
 
         (OurRequestReady, PairingAccept x) -> do
-            flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do
+            flip catchError (const reject) $ do
                 pairingVerifyResult x >>= \case
                     Just x' -> do
                         pairingFinalizeRequest x'
@@ -143,9 +147,7 @@ instance PairingResult a => Service (PairingService a) where
                     Nothing -> do
                         join $ asks $ pairingHookVerifyFailed . svcAttributes
                         throwError ""
-        (OurRequestReady, _) -> do
-            svcSet $ PairingFailed
-            replyPacket PairingDecline
+        (OurRequestReady, _) -> reject
 
         (PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do
             peer <- asks $ svcPeerIdentity
@@ -156,17 +158,16 @@ instance PairingResult a => Service (PairingService a) where
                        hook $ confirmationNumber $ nonceDigest peer self pnonce nonce
                        svcSet PeerRequestConfirm
                else do join $ asks $ pairingHookRequestNonceFailed . svcAttributes
-                       svcSet PairingFailed
+                       svcSet NoPairing
                        replyPacket PairingDecline
-        (PeerRequest _ _, _) -> do
-            svcSet $ PairingFailed
-            replyPacket PairingDecline
-        (PeerRequestConfirm, _) -> do
-            svcSet $ PairingFailed
-            replyPacket PairingDecline
+        (PeerRequest _ _, _) -> reject
+        (PeerRequestConfirm, _) -> reject
 
-        (PairingDone, _) -> return ()
-        (PairingFailed, _) -> return ()
+reject :: PairingResult a => ServiceHandler (PairingService a) ()
+reject = do
+    join $ asks $ pairingHookFailed . svcAttributes
+    svcSet NoPairing
+    replyPacket PairingDecline
 
 
 nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
@@ -213,4 +214,10 @@ pairingAccept _ peer = runPeerService @(PairingService a) peer $ do
             replyPacket . PairingAccept =<< pairingFinalizeResponse
             svcSet PairingDone
         PairingDone -> throwError $ "already done"
-        PairingFailed -> throwError $ "already failed"
+
+pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
+pairingReject _ peer = runPeerService @(PairingService a) peer $ do
+    svcGet >>= \case
+        NoPairing -> throwError $ "none in progress"
+        PairingDone -> throwError $ "already done"
+        _ -> reject