diff options
| -rw-r--r-- | src/Attach.hs | 13 | ||||
| -rw-r--r-- | src/Contact.hs | 10 | ||||
| -rw-r--r-- | src/Main.hs | 10 | ||||
| -rw-r--r-- | src/Pairing.hs | 53 |
4 files changed, 62 insertions, 24 deletions
diff --git a/src/Attach.hs b/src/Attach.hs index c220e14..90c9900 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -1,6 +1,8 @@ module Attach ( AttachService, - attachToOwner, attachAccept, + attachToOwner, + attachAccept, + attachReject, ) where import Control.Monad.Except @@ -103,6 +105,12 @@ instance PairingResult AttachIdentity where , pairingHookVerifyFailed = do svcPrint $ "Failed to verify new identity" + + , pairingHookRejected = do + svcPrint $ "Attachment rejected by peer" + + , pairingHookFailed = do + svcPrint $ "Attachement failed" } attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m () @@ -110,3 +118,6 @@ attachToOwner = pairingRequest @AttachIdentity Proxy attachAccept :: (MonadIO m, MonadError String m) => Peer -> m () attachAccept = pairingAccept @AttachIdentity Proxy + +attachReject :: (MonadIO m, MonadError String m) => Peer -> m () +attachReject = pairingReject @AttachIdentity Proxy diff --git a/src/Contact.hs b/src/Contact.hs index a4b5cf2..73a179f 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -5,6 +5,7 @@ module Contact ( ContactService, contactRequest, contactAccept, + contactReject, ) where import Control.Arrow @@ -127,6 +128,12 @@ instance PairingResult ContactAccepted where svcPrint $ "Contact accepted" , pairingHookVerifyFailed = return () + + , pairingHookRejected = do + svcPrint $ "Contact rejected by peer" + + , pairingHookFailed = do + svcPrint $ "Contact failed" } contactRequest :: (MonadIO m, MonadError String m) => Peer -> m () @@ -135,6 +142,9 @@ contactRequest = pairingRequest @ContactAccepted Proxy contactAccept :: (MonadIO m, MonadError String m) => Peer -> m () contactAccept = pairingAccept @ContactAccepted Proxy +contactReject :: (MonadIO m, MonadError String m) => Peer -> m () +contactReject = pairingReject @ContactAccepted Proxy + finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState) finalizeContact identity slocal = liftIO $ do let st = storedStorage slocal diff --git a/src/Main.hs b/src/Main.hs index 3045f94..2c56a00 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -230,9 +230,11 @@ commands = , ("update-identity", cmdUpdateIdentity) , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) + , ("attach-reject", cmdAttachReject) , ("contacts", cmdContacts) , ("contact-add", cmdContactAdd) , ("contact-accept", cmdContactAccept) + , ("contact-reject", cmdContactReject) , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) , ("ice-create", cmdIceCreate) @@ -300,6 +302,10 @@ cmdAttachAccept :: Command cmdAttachAccept = join $ attachAccept <$> (maybe (throwError "no peer selected") return =<< gets csPeer) +cmdAttachReject :: Command +cmdAttachReject = join $ attachReject + <$> (maybe (throwError "no peer selected") return =<< gets csPeer) + cmdContacts :: Command cmdContacts = do args <- words <$> asks ciLine @@ -318,6 +324,10 @@ cmdContactAccept :: Command cmdContactAccept = join $ contactAccept <$> (maybe (throwError "no peer selected") return =<< gets csPeer) +cmdContactReject :: Command +cmdContactReject = join $ contactReject + <$> (maybe (throwError "no peer selected") return =<< gets csPeer) + cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do server <- asks ciServer 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 |