diff options
| -rw-r--r-- | src/Attach.hs | 2 | ||||
| -rw-r--r-- | src/Contact.hs | 2 | ||||
| -rw-r--r-- | src/Pairing.hs | 29 | ||||
| -rw-r--r-- | src/Test.hs | 35 |
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) |