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