From 29773f1485076a5f6257c209274769c03220d22d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 26 Jul 2022 21:22:21 +0200 Subject: Explicit identities in pairing request Actual device identities can change at any point during the pairing process, so it is necessary to fix the ones used for nonce confirmation and just initially verify that they belong to the respective sides. --- src/Pairing.hs | 57 ++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 34 insertions(+), 23 deletions(-) (limited to 'src/Pairing.hs') diff --git a/src/Pairing.hs b/src/Pairing.hs index e122ba4..3af3435 100644 --- a/src/Pairing.hs +++ b/src/Pairing.hs @@ -27,21 +27,22 @@ import Data.Word import Identity import Network +import PubKey import Service import State import Storage -data PairingService a = PairingRequest RefDigest +data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest | PairingResponse Bytes | PairingRequestNonce Bytes | PairingAccept a | PairingReject data PairingState a = NoPairing - | OurRequest Bytes + | OurRequest UnifiedIdentity UnifiedIdentity Bytes | OurRequestConfirm (Maybe (PairingVerifiedResult a)) | OurRequestReady - | PeerRequest Bytes RefDigest + | PeerRequest UnifiedIdentity UnifiedIdentity Bytes RefDigest | PeerRequestConfirm | PairingDone @@ -75,7 +76,10 @@ class (Typeable a, Storable a) => PairingResult a where instance Storable a => Storable (PairingService a) where - store' (PairingRequest x) = storeRec $ storeBinary "request" x + store' (PairingRequest idReq idRsp x) = storeRec $ do + storeRef "id-req" idReq + storeRef "id-rsp" idRsp + storeBinary "request" x store' (PairingResponse x) = storeRec $ storeBinary "response" x store' (PairingRequestNonce x) = storeRec $ storeBinary "reqnonce" x store' (PairingAccept x) = store' x @@ -84,11 +88,13 @@ instance Storable a => Storable (PairingService a) where load' = do res <- loadRec $ do (req :: Maybe Bytes) <- loadMbBinary "request" + idReq <- loadMbRef "id-req" + idRsp <- loadMbRef "id-rsp" rsp <- loadMbBinary "response" rnonce <- loadMbBinary "reqnonce" (rej :: Maybe T.Text) <- loadMbText "reject" return $ catMaybes - [ PairingRequest <$> (refDigestFromByteString =<< req) + [ PairingRequest <$> idReq <*> idRsp <*> (refDigestFromByteString =<< req) , PairingResponse <$> rsp , PairingRequestNonce <$> rnonce , const PairingReject <$> rej @@ -108,10 +114,21 @@ instance PairingResult a => Service (PairingService a) where emptyServiceState _ = NoPairing serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case - (NoPairing, PairingRequest confirm) -> do + (NoPairing, PairingRequest pdata sdata confirm) -> do + self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata + self' <- maybe (throwError "failed to validate own identity") return . + validateIdentity . lsIdentity . fromStored =<< svcGetLocal + when (not $ self `sameIdentity` self') $ do + throwError "pairing request to different identity" + + peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata + peer' <- asks $ svcPeerIdentity + when (not $ peer `sameIdentity` peer') $ do + throwError "pairing request from different identity" + join $ asks $ pairingHookRequest . svcAttributes nonce <- liftIO $ getRandomBytes 32 - svcSet $ PeerRequest nonce confirm + svcSet $ PeerRequest peer self nonce confirm replyPacket $ PairingResponse nonce (NoPairing, _) -> return () @@ -120,15 +137,12 @@ instance PairingResult a => Service (PairingService a) where join $ asks $ pairingHookRejected . svcAttributes svcSet NoPairing - (OurRequest nonce, PairingResponse pnonce) -> do - peer <- asks $ svcPeerIdentity - self <- maybe (throwError "failed to validate own identity") return . - validateIdentity . lsIdentity . fromStored =<< svcGetLocal + (OurRequest self peer nonce, PairingResponse pnonce) -> do hook <- asks $ pairingHookResponse . svcAttributes hook $ confirmationNumber $ nonceDigest self peer nonce pnonce svcSet $ OurRequestConfirm Nothing replyPacket $ PairingRequestNonce nonce - x@(OurRequest _, _) -> reject $ uncurry PairingUnexpectedMessage x + x@(OurRequest {}, _) -> reject $ uncurry PairingUnexpectedMessage x (OurRequestConfirm _, PairingAccept x) -> do flip catchError (reject . PairingFailedOther) $ do @@ -155,10 +169,7 @@ instance PairingResult a => Service (PairingService a) where throwError "" x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x - (PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do - peer <- asks $ svcPeerIdentity - self <- maybe (throwError "failed to verify own identity") return . - validateIdentity . lsIdentity . fromStored =<< svcGetLocal + (PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do if dgst == nonceDigest peer self pnonce BA.empty then do hook <- asks $ pairingHookRequestNonce . svcAttributes hook $ confirmationNumber $ nonceDigest peer self pnonce nonce @@ -166,7 +177,7 @@ instance PairingResult a => Service (PairingService a) where else do join $ asks $ pairingHookRequestNonceFailed . svcAttributes svcSet NoPairing replyPacket PairingReject - x@(PeerRequest _ _, _) -> reject $ uncurry PairingUnexpectedMessage x + x@(PeerRequest {}, _) -> reject $ uncurry PairingUnexpectedMessage x x@(PeerRequestConfirm, _) -> reject $ uncurry PairingUnexpectedMessage x reject :: PairingResult a => PairingFailureReason a -> ServiceHandler (PairingService a) () @@ -177,11 +188,11 @@ reject reason = do nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest -nonceDigest id1 id2 nonce1 nonce2 = hashToRefDigest $ serializeObject $ Rec - [ (BC.pack "id", RecRef $ storedRef $ idData id1) - , (BC.pack "id", RecRef $ storedRef $ idData id2) - , (BC.pack "nonce", RecBinary $ convert nonce1) - , (BC.pack "nonce", RecBinary $ convert nonce2) +nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $ Rec + [ (BC.pack "id-req", RecRef $ storedRef $ idData idReq) + , (BC.pack "id-rsp", RecRef $ storedRef $ idData idRsp) + , (BC.pack "nonce-req", RecBinary $ convert nonceReq) + , (BC.pack "nonce-rsp", RecBinary $ convert nonceRsp) ] confirmationNumber :: RefDigest -> String @@ -198,7 +209,7 @@ pairingRequest _ peer = do PeerIdentityFull pid -> return pid _ -> throwError "incomplete peer identity" sendToPeerWith @(PairingService a) peer $ \case - NoPairing -> return (Just $ PairingRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce) + NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce) _ -> throwError "already in progress" pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () -- cgit v1.2.3