From e9760baab9608419565e253cae101b24f87eb8e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Mon, 27 Dec 2021 22:46:21 +0100 Subject: Pairing: refactor common logic into the base module --- src/Attach.hs | 137 ++++++++++++++++++++++++--------------------------------- src/Contact.hs | 55 ++++++++++++----------- src/Main.hs | 14 ++---- src/Pairing.hs | 64 ++++++++++++++++++++++----- 4 files changed, 141 insertions(+), 129 deletions(-) (limited to 'src') diff --git a/src/Attach.hs b/src/Attach.hs index e028718..c220e14 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -22,20 +22,56 @@ import Storage.Key type AttachService = PairingService AttachIdentity -data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] (Maybe UnifiedIdentity) +data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] instance Storable AttachIdentity where - store' (AttachIdentity x keys _) = storeRec $ do + store' (AttachIdentity x keys) = storeRec $ do storeRef "identity" x mapM_ (storeBinary "skey") keys load' = loadRec $ AttachIdentity <$> loadRef "identity" <*> loadBinaries "skey" - <*> pure Nothing instance PairingResult AttachIdentity where pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f" + + type PairingVerifiedResult AttachIdentity = (UnifiedIdentity, [ScrubbedBytes]) + + pairingVerifyResult (AttachIdentity sdata keys) = do + curid <- lsIdentity . fromStored <$> svcGetLocal + secret <- maybe (throwError "failed to load own secret key") return =<< + liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid) + sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata) + return $ do + guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) == + iddKeyIdentity (fromStored $ signedData $ fromStored curid) + identity <- validateIdentity sdata' + guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid] + return (identity, keys) + + pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do + let owner = finalOwner identity + st = storedStorage slocal + pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ] + mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ] + + shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal) + wrappedStore st (fromStored slocal) + { lsIdentity = idData identity + , lsShared = [ shared ] + } + + pairingFinalizeResponse = do + st <- storedStorage <$> svcGetLocal + owner <- mergeSharedIdentity + pid <- asks svcPeerIdentity + secret <- maybe (throwError "failed to load secret key") return =<< liftIO (loadKey $ idKeyIdentity owner) + identity <- liftIO $ wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid) + { iddPrev = [idData pid], iddOwner = Just (idData owner) } + skeys <- liftIO $ map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ] + return $ AttachIdentity identity skeys + defaultPairingAttributes _ = PairingAttributes { pairingHookRequest = do peer <- asks $ svcPeerIdentity @@ -53,81 +89,24 @@ instance PairingResult AttachIdentity where peer <- asks $ svcPeerIdentity svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer) - , pairingHookConfirm = \(AttachIdentity sdata keys _) -> do - verifyAttachedIdentity sdata >>= \case - Just identity -> do - svcPrint $ "Attachment confirmed by peer" - return $ Just $ AttachIdentity sdata keys (Just identity) - Nothing -> do - svcPrint $ "Failed to verify new identity" - throwError "Failed to verify new identity" - - , pairingHookAccept = \(AttachIdentity sdata keys _) -> do - verifyAttachedIdentity sdata >>= \case - Just identity -> do - svcPrint $ "Accepted updated identity" - svcSetLocal =<< finalizeAttach identity keys =<< svcGetLocal - Nothing -> do - svcPrint $ "Failed to verify new identity" - throwError "Failed to verify new identity" - } + , pairingHookConfirmedResponse = do + svcPrint $ "Confirmed peer, waiting for updated identity" + + , pairingHookConfirmedRequest = do + svcPrint $ "Attachment confirmed by peer" -attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m () -attachToOwner _ = pairingRequest @AttachIdentity Proxy - -attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m () -attachAccept printMsg h peer = do - let st = refStorage $ headRef h - sendToPeerWith peer $ \case - NoPairing -> throwError $ "none in progress" - OurRequest {} -> throwError $ "waiting for peer" - OurRequestConfirm Nothing -> do - liftIO $ printMsg $ "Confirmed peer, waiting for updated identity" - return (Nothing, OurRequestReady) - OurRequestConfirm (Just (AttachIdentity _ _ Nothing)) -> do - liftIO $ printMsg $ "Confirmed peer, but verification of received identity failed" - return (Nothing, NoPairing) - OurRequestConfirm (Just (AttachIdentity _ keys (Just identity))) -> do - liftIO $ printMsg $ "Accepted updated identity" - flip runReaderT h $ updateLocalState_ $ finalizeAttach identity keys - return (Nothing, PairingDone) - OurRequestReady -> throwError $ "alredy accepted, waiting for peer" - PeerRequest {} -> throwError $ "waiting for peer" - PeerRequestConfirm -> do - liftIO $ printMsg $ "Accepted new attached device, seding updated identity" - owner <- runReaderT mergeSharedIdentity h - PeerIdentityFull pid <- peerIdentity peer - Just secret <- liftIO $ loadKey $ idKeyIdentity owner - liftIO $ do - identity <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid) - { iddPrev = [idData pid], iddOwner = Just (idData owner) } - skeys <- map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ] - return (Just $ PairingAccept $ AttachIdentity identity skeys Nothing, PairingDone) - PairingDone -> throwError $ "alredy done" - PairingFailed -> throwError $ "alredy failed" - -verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity) -verifyAttachedIdentity sdata = do - curid <- lsIdentity . fromStored <$> svcGetLocal - secret <- maybe (throwError "failed to load own secret key") return =<< - liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid) - sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata) - return $ do - guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) == - iddKeyIdentity (fromStored $ signedData $ fromStored curid) - identity <- validateIdentity sdata' - guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid] - return identity - -finalizeAttach :: MonadIO m => UnifiedIdentity -> [ScrubbedBytes] -> Stored LocalState -> m (Stored LocalState) -finalizeAttach identity skeys slocal = liftIO $ do - let owner = finalOwner identity - st = storedStorage slocal - pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ] - mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- skeys, pub <- pkeys ] - - shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal) - wrappedStore st (fromStored slocal) - { lsIdentity = idData identity - , lsShared = [ shared ] + , pairingHookAcceptedResponse = do + svcPrint $ "Accepted updated identity" + + , pairingHookAcceptedRequest = do + svcPrint $ "Accepted new attached device, seding updated identity" + + , pairingHookVerifyFailed = do + svcPrint $ "Failed to verify new identity" } + +attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m () +attachToOwner = pairingRequest @AttachIdentity Proxy + +attachAccept :: (MonadIO m, MonadError String m) => Peer -> m () +attachAccept = pairingAccept @AttachIdentity Proxy diff --git a/src/Contact.hs b/src/Contact.hs index e0f1a74..a4b5cf2 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -86,6 +86,17 @@ instance Storable ContactAccepted where instance PairingResult ContactAccepted where pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084" + pairingVerifyResult = return . Just + + pairingFinalizeRequest ContactAccepted = do + pid <- asks svcPeerIdentity + updateLocalState_ $ finalizeContact pid + + pairingFinalizeResponse = do + pid <- asks svcPeerIdentity + updateLocalState_ $ finalizeContact pid + return ContactAccepted + defaultPairingAttributes _ = PairingAttributes { pairingHookRequest = do peer <- asks $ svcPeerIdentity @@ -103,38 +114,26 @@ instance PairingResult ContactAccepted where peer <- asks $ svcPeerIdentity svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer) - , pairingHookConfirm = \ContactAccepted -> do + , pairingHookConfirmedResponse = do + svcPrint $ "Contact accepted, waiting for peer confirmation" + + , pairingHookConfirmedRequest = do svcPrint $ "Contact confirmed by peer" - return $ Just ContactAccepted - , pairingHookAccept = \ContactAccepted -> return () + , pairingHookAcceptedResponse = do + svcPrint $ "Contact accepted" + + , pairingHookAcceptedRequest = do + svcPrint $ "Contact accepted" + + , pairingHookVerifyFailed = return () } -contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m () -contactRequest _ = pairingRequest @ContactAccepted Proxy - -contactAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m () -contactAccept printMsg h peer = do - sendToPeerWith peer $ \case - NoPairing -> throwError $ "none in progress" - OurRequest {} -> throwError $ "waiting for peer" - OurRequestConfirm Nothing -> do - liftIO $ printMsg $ "Contact accepted, waiting for peer confirmation" - return (Nothing, OurRequestReady) - OurRequestConfirm (Just ContactAccepted) -> do - PeerIdentityFull pid <- peerIdentity peer - liftIO $ printMsg $ "Contact accepted" - flip runReaderT h $ updateLocalState_ $ finalizeContact pid - return (Nothing, PairingDone) - OurRequestReady -> throwError $ "alredy accepted, waiting for peer" - PeerRequest {} -> throwError $ "waiting for peer" - PeerRequestConfirm -> do - PeerIdentityFull pid <- peerIdentity peer - liftIO $ printMsg $ "Contact accepted" - flip runReaderT h $ updateLocalState_ $ finalizeContact pid - return (Just $ PairingAccept ContactAccepted, PairingDone) - PairingDone -> throwError $ "alredy done" - PairingFailed -> throwError $ "alredy failed" +contactRequest :: (MonadIO m, MonadError String m) => Peer -> m () +contactRequest = pairingRequest @ContactAccepted Proxy + +contactAccept :: (MonadIO m, MonadError String m) => Peer -> m () +contactAccept = pairingAccept @ContactAccepted Proxy finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState) finalizeContact identity slocal = liftIO $ do diff --git a/src/Main.hs b/src/Main.hs index 1515648..3045f94 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -294,14 +294,11 @@ cmdUpdateIdentity = void $ do cmdAttach :: Command cmdAttach = join $ attachToOwner - <$> asks ciPrint - <*> (maybe (throwError "no peer selected") return =<< gets csPeer) + <$> (maybe (throwError "no peer selected") return =<< gets csPeer) cmdAttachAccept :: Command cmdAttachAccept = join $ attachAccept - <$> asks ciPrint - <*> asks ciHead - <*> (maybe (throwError "no peer selected") return =<< gets csPeer) + <$> (maybe (throwError "no peer selected") return =<< gets csPeer) cmdContacts :: Command cmdContacts = do @@ -315,14 +312,11 @@ cmdContacts = do cmdContactAdd :: Command cmdContactAdd = join $ contactRequest - <$> asks ciPrint - <*> (maybe (throwError "no peer selected") return =<< gets csPeer) + <$> (maybe (throwError "no peer selected") return =<< gets csPeer) cmdContactAccept :: Command cmdContactAccept = join $ contactAccept - <$> asks ciPrint - <*> asks ciHead - <*> (maybe (throwError "no peer selected") return =<< gets csPeer) + <$> (maybe (throwError "no peer selected") return =<< gets csPeer) cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do diff --git a/src/Pairing.hs b/src/Pairing.hs index d2f4b31..a30615a 100644 --- a/src/Pairing.hs +++ b/src/Pairing.hs @@ -5,6 +5,7 @@ module Pairing ( PairingResult(..), pairingRequest, + pairingAccept, ) where import Control.Monad.Except @@ -35,7 +36,7 @@ data PairingService a = PairingRequest RefDigest data PairingState a = NoPairing | OurRequest Bytes - | OurRequestConfirm (Maybe a) + | OurRequestConfirm (Maybe (PairingVerifiedResult a)) | OurRequestReady | PeerRequest Bytes RefDigest | PeerRequestConfirm @@ -47,12 +48,21 @@ data PairingAttributes a = PairingAttributes , pairingHookResponse :: String -> ServiceHandler (PairingService a) () , pairingHookRequestNonce :: String -> ServiceHandler (PairingService a) () , pairingHookRequestNonceFailed :: ServiceHandler (PairingService a) () - , pairingHookConfirm :: a -> ServiceHandler (PairingService a) (Maybe a) - , pairingHookAccept :: a -> ServiceHandler (PairingService a) () + , pairingHookConfirmedResponse :: ServiceHandler (PairingService a) () + , pairingHookConfirmedRequest :: ServiceHandler (PairingService a) () + , pairingHookAcceptedResponse :: ServiceHandler (PairingService a) () + , pairingHookAcceptedRequest :: ServiceHandler (PairingService a) () + , pairingHookVerifyFailed :: ServiceHandler (PairingService a) () } class (Typeable a, Storable a) => PairingResult a where + type PairingVerifiedResult a :: * + type PairingVerifiedResult a = a + pairingServiceID :: proxy a -> ServiceID + pairingVerifyResult :: a -> ServiceHandler (PairingService a) (Maybe (PairingVerifiedResult a)) + pairingFinalizeRequest :: PairingVerifiedResult a -> ServiceHandler (PairingService a) () + pairingFinalizeResponse :: ServiceHandler (PairingService a) a defaultPairingAttributes :: proxy (PairingService a) -> PairingAttributes a @@ -110,20 +120,29 @@ instance PairingResult a => Service (PairingService a) where replyPacket PairingDecline (OurRequestConfirm _, PairingAccept x) -> do - hook <- asks $ pairingHookConfirm . svcAttributes - (svcSet . OurRequestConfirm =<< hook x) `catchError` \_ -> do - svcSet $ PairingFailed - replyPacket PairingDecline + flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do + pairingVerifyResult x >>= \case + Just x' -> do + join $ asks $ pairingHookConfirmedRequest . svcAttributes + svcSet $ OurRequestConfirm (Just x') + Nothing -> do + join $ asks $ pairingHookVerifyFailed . svcAttributes + throwError "" (OurRequestConfirm _, _) -> do svcSet $ PairingFailed replyPacket PairingDecline (OurRequestReady, PairingAccept x) -> do - hook <- asks $ pairingHookAccept . svcAttributes - hook x `catchError` \_ -> do - svcSet $ PairingFailed - replyPacket PairingDecline + flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do + pairingVerifyResult x >>= \case + Just x' -> do + pairingFinalizeRequest x' + join $ asks $ pairingHookAcceptedResponse . svcAttributes + svcSet $ PairingDone + Nothing -> do + join $ asks $ pairingHookVerifyFailed . svcAttributes + throwError "" (OurRequestReady, _) -> do svcSet $ PairingFailed replyPacket PairingDecline @@ -173,4 +192,25 @@ pairingRequest _ peer = do _ -> throwError "incomplete peer identity" sendToPeerWith @(PairingService a) peer $ \case NoPairing -> return (Just $ PairingRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce) - _ -> throwError "alredy in progress" + _ -> throwError "already in progress" + +pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingAccept _ peer = runPeerService @(PairingService a) peer $ do + svcGet >>= \case + NoPairing -> throwError $ "none in progress" + OurRequest {} -> throwError $ "waiting for peer" + OurRequestConfirm Nothing -> do + join $ asks $ pairingHookConfirmedResponse . svcAttributes + svcSet OurRequestReady + OurRequestConfirm (Just verified) -> do + join $ asks $ pairingHookAcceptedResponse . svcAttributes + pairingFinalizeRequest verified + svcSet PairingDone + OurRequestReady -> throwError $ "already accepted, waiting for peer" + PeerRequest {} -> throwError $ "waiting for peer" + PeerRequestConfirm -> do + join $ asks $ pairingHookAcceptedRequest . svcAttributes + replyPacket . PairingAccept =<< pairingFinalizeResponse + svcSet PairingDone + PairingDone -> throwError $ "already done" + PairingFailed -> throwError $ "already failed" -- cgit v1.2.3