diff options
Diffstat (limited to 'src/Test.hs')
| -rw-r--r-- | src/Test.hs | 35 |
1 files changed, 28 insertions, 7 deletions
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) |