Pairing failure reason

4 files changed, 47 insertions, 21 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index 0e32294..a776cad 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -109,7 +109,7 @@ instance PairingResult AttachIdentity where
         , pairingHookRejected = do
             svcPrint $ "Attachment rejected by peer"
 
-        , pairingHookFailed = do
+        , pairingHookFailed = \_ -> do
             svcPrint $ "Attachement failed"
         }
 
diff --git a/src/Contact.hs b/src/Contact.hs
index 1dc926e..4e2cb17 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -139,7 +139,7 @@ instance PairingResult ContactAccepted where
         , pairingHookRejected = do
             svcPrint $ "Contact rejected by peer"
 
-        , pairingHookFailed = do
+        , pairingHookFailed = \_ -> do
             svcPrint $ "Contact failed"
         }
 
diff --git a/src/Pairing.hs b/src/Pairing.hs
index 6545376..e122ba4 100644
--- a/src/Pairing.hs
+++ b/src/Pairing.hs
@@ -3,6 +3,7 @@ module Pairing (
     PairingState(..),
     PairingAttributes(..),
     PairingResult(..),
+    PairingFailureReason(..),
 
     pairingRequest,
     pairingAccept,
@@ -44,6 +45,10 @@ data PairingState a = NoPairing
                     | PeerRequestConfirm
                     | PairingDone
 
+data PairingFailureReason a = PairingUserRejected
+                            | PairingUnexpectedMessage (PairingState a) (PairingService a)
+                            | PairingFailedOther String
+
 data PairingAttributes a = PairingAttributes
     { pairingHookRequest :: ServiceHandler (PairingService a) ()
     , pairingHookResponse :: String -> ServiceHandler (PairingService a) ()
@@ -55,7 +60,7 @@ data PairingAttributes a = PairingAttributes
     , pairingHookAcceptedRequest :: ServiceHandler (PairingService a) ()
     , pairingHookVerifyFailed :: ServiceHandler (PairingService a) ()
     , pairingHookRejected :: ServiceHandler (PairingService a) ()
-    , pairingHookFailed :: ServiceHandler (PairingService a) ()
+    , pairingHookFailed :: PairingFailureReason a -> ServiceHandler (PairingService a) ()
     }
 
 class (Typeable a, Storable a) => PairingResult a where
@@ -123,10 +128,10 @@ instance PairingResult a => Service (PairingService a) where
             hook $ confirmationNumber $ nonceDigest self peer nonce pnonce
             svcSet $ OurRequestConfirm Nothing
             replyPacket $ PairingRequestNonce nonce
-        (OurRequest _, _) -> reject
+        x@(OurRequest _, _) -> reject $ uncurry PairingUnexpectedMessage x
 
         (OurRequestConfirm _, PairingAccept x) -> do
-            flip catchError (const reject) $ do
+            flip catchError (reject . PairingFailedOther) $ do
                 pairingVerifyResult x >>= \case
                     Just x' -> do
                         join $ asks $ pairingHookConfirmedRequest . svcAttributes
@@ -136,10 +141,10 @@ instance PairingResult a => Service (PairingService a) where
                         svcSet NoPairing
                         replyPacket PairingReject
 
-        (OurRequestConfirm _, _) -> reject
+        x@(OurRequestConfirm _, _) -> reject $ uncurry PairingUnexpectedMessage x
 
         (OurRequestReady, PairingAccept x) -> do
-            flip catchError (const reject) $ do
+            flip catchError (reject . PairingFailedOther) $ do
                 pairingVerifyResult x >>= \case
                     Just x' -> do
                         pairingFinalizeRequest x'
@@ -148,7 +153,7 @@ instance PairingResult a => Service (PairingService a) where
                     Nothing -> do
                         join $ asks $ pairingHookVerifyFailed . svcAttributes
                         throwError ""
-        (OurRequestReady, _) -> reject
+        x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x
 
         (PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do
             peer <- asks $ svcPeerIdentity
@@ -161,12 +166,12 @@ instance PairingResult a => Service (PairingService a) where
                else do join $ asks $ pairingHookRequestNonceFailed . svcAttributes
                        svcSet NoPairing
                        replyPacket PairingReject
-        (PeerRequest _ _, _) -> reject
-        (PeerRequestConfirm, _) -> reject
+        x@(PeerRequest _ _, _) -> reject $ uncurry PairingUnexpectedMessage x
+        x@(PeerRequestConfirm, _) -> reject $ uncurry PairingUnexpectedMessage x
 
-reject :: PairingResult a => ServiceHandler (PairingService a) ()
-reject = do
-    join $ asks $ pairingHookFailed . svcAttributes
+reject :: PairingResult a => PairingFailureReason a -> ServiceHandler (PairingService a) ()
+reject reason = do
+    join $ asks $ flip pairingHookFailed reason . svcAttributes
     svcSet NoPairing
     replyPacket PairingReject
 
@@ -221,4 +226,4 @@ pairingReject _ peer = runPeerService @(PairingService a) peer $ do
     svcGet >>= \case
         NoPairing -> throwError $ "none in progress"
         PairingDone -> throwError $ "already done"
-        _ -> reject
+        _ -> reject PairingUserRejected
diff --git a/src/Test.hs b/src/Test.hs
index 30aa8c4..19d1a64 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -128,7 +128,7 @@ pairingAttributes _ out peers prefix = PairingAttributes
         index <- show <$> getPeerIndex peers
         liftIO $ outLine out $ unwords [prefix ++ "-request", index, confirm]
 
-    , pairingHookRequestNonceFailed = failed
+    , pairingHookRequestNonceFailed = failed "nonce"
 
     , pairingHookConfirmedResponse = return ()
     , pairingHookConfirmedRequest = return ()
@@ -141,13 +141,16 @@ pairingAttributes _ out peers prefix = PairingAttributes
         index <- show <$> getPeerIndex peers
         liftIO $ outLine out $ unwords [prefix ++ "-request-done", index]
 
-    , pairingHookFailed = failed
-    , pairingHookVerifyFailed = failed
-    , pairingHookRejected = failed
+    , pairingHookFailed = \case
+        PairingUserRejected -> failed "user"
+        PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet
+        PairingFailedOther str -> failed $ "other " ++ str
+    , pairingHookVerifyFailed = failed "verify"
+    , pairingHookRejected = failed "rejected"
     }
     where
-        failed :: PairingResult a => ServiceHandler (PairingService a) ()
-        failed = do
+        failed :: PairingResult a => String -> ServiceHandler (PairingService a) ()
+        failed detail = do
             ptype <- svcGet >>= return . \case
                 OurRequest {} -> "response"
                 OurRequestConfirm {} -> "response"
@@ -157,7 +160,25 @@ pairingAttributes _ out peers prefix = PairingAttributes
                 _ -> fail "unexpected pairing state"
 
             index <- show <$> getPeerIndex peers
-            liftIO $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index
+            liftIO $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index ++ " " ++ detail
+
+        strState :: PairingState a -> String
+        strState = \case
+            NoPairing -> "none"
+            OurRequest {} -> "our-request"
+            OurRequestConfirm {} -> "our-request-confirm"
+            OurRequestReady -> "our-request-ready"
+            PeerRequest {} -> "peer-request"
+            PeerRequestConfirm -> "peer-request-confirm"
+            PairingDone -> "done"
+
+        strPacket :: PairingService a -> String
+        strPacket = \case
+            PairingRequest {} -> "request"
+            PairingResponse {} -> "response"
+            PairingRequestNonce {} -> "nonce"
+            PairingAccept {} -> "accept"
+            PairingReject -> "reject"
 
 
 newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a)