summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs137
-rw-r--r--src/Contact.hs55
-rw-r--r--src/Main.hs14
-rw-r--r--src/Pairing.hs64
4 files changed, 141 insertions, 129 deletions
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:02:10 +0000