summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs2
-rw-r--r--src/Contact.hs2
-rw-r--r--src/Pairing.hs29
-rw-r--r--src/Test.hs35
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)