diff options
Diffstat (limited to 'src/Attach.hs')
| -rw-r--r-- | src/Attach.hs | 137 |
1 files changed, 58 insertions, 79 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 |