From 5b908c86320ee73f2722c85f8a47fa03ec093c6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 10 Oct 2023 21:36:58 +0200 Subject: Use extended identity data for name --- src/Attach.hs | 11 ++++++----- src/Contact.hs | 6 +++--- src/Identity.hs | 21 +++++++++++++++++---- src/Message.hs | 2 +- src/Network.hs | 4 ++-- src/Pairing.hs | 2 +- src/Service.hs | 2 +- src/State.hs | 8 ++++---- src/Test.hs | 21 +++++++++++---------- 9 files changed, 46 insertions(+), 31 deletions(-) diff --git a/src/Attach.hs b/src/Attach.hs index 48d18d8..436f786 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -42,13 +42,13 @@ instance PairingResult AttachIdentity where pairingVerifyResult (AttachIdentity sdata keys) = do curid <- lsIdentity . fromStored <$> svcGetLocal - secret <- loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid + secret <- loadKey $ eiddKeyIdentity $ fromSigned curid sdata' <- mstore =<< signAdd secret (fromStored sdata) return $ do - guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) == - iddKeyIdentity (fromStored $ signedData $ fromStored curid) + guard $ iddKeyIdentity (fromSigned sdata) == + eiddKeyIdentity (fromSigned curid) identity <- validateIdentity sdata' - guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid] + guard $ iddPrev (fromSigned $ idData identity) == [eiddStoredBase curid] return (identity, keys) pairingFinalizeRequest (identity, keys) = updateLocalHead_ $ \slocal -> do @@ -57,9 +57,10 @@ instance PairingResult AttachIdentity where pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ] liftIO $ mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ] + identity' <- mergeIdentity $ updateIdentity [ lsIdentity $ fromStored slocal ] identity shared <- makeSharedStateUpdate st (Just owner) (lsShared $ fromStored slocal) mstore (fromStored slocal) - { lsIdentity = idData identity + { lsIdentity = idExtData identity' , lsShared = [ shared ] } diff --git a/src/Contact.hs b/src/Contact.hs index 2d1e2a9..a232b8c 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -39,7 +39,7 @@ data Contact = Contact data ContactData = ContactData { cdPrev :: [Stored ContactData] - , cdIdentity :: [Stored (Signed IdentityData)] + , cdIdentity :: [Stored (Signed ExtendedIdentityData)] , cdName :: Maybe Text } @@ -59,7 +59,7 @@ instance Mergeable Contact where mergeSorted cdata = Contact { contactData = cdata - , contactIdentity_ = validateIdentityF $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . cdIdentity) cdata + , contactIdentity_ = validateExtendedIdentityF $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . cdIdentity) cdata , contactCustomName_ = findPropertyFirst cdName cdata } @@ -169,7 +169,7 @@ finalizeContact identity = updateLocalHead_ $ updateSharedState_ $ \contacts -> st <- getStorage cdata <- wrappedStore st ContactData { cdPrev = [] - , cdIdentity = idDataF $ finalOwner identity + , cdIdentity = idExtDataF $ finalOwner identity , cdName = Nothing } storeSetAdd st (mergeSorted @Contact [cdata]) contacts diff --git a/src/Identity.hs b/src/Identity.hs index e9216fb..7c49c9f 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -220,19 +220,32 @@ createIdentity st name owner = do (secret, public) <- generateKeys st (_secretMsg, publicMsg) <- generateKeys st - let signOwner idd + let signOwner :: Signed a -> ReaderT Storage IO (Signed a) + signOwner idd | Just o <- owner = do Just ownerSecret <- loadKeyMb (iddKeyIdentity $ fromSigned $ idData o) signAdd ownerSecret idd | otherwise = return idd Just identity <- flip runReaderT st $ do - return . validateIdentity =<< mstore =<< signOwner =<< sign secret =<< + baseData <- mstore =<< signOwner =<< sign secret =<< mstore (emptyIdentityData public) - { iddName = name - , iddOwner = idData <$> owner + { iddOwner = idData <$> owner , iddKeyMessage = Just publicMsg } + let extOwner = do + odata <- idExtData <$> owner + guard $ isExtension odata + return odata + + validateExtendedIdentityF . I.Identity <$> + if isJust name || isJust extOwner + then mstore =<< signOwner =<< sign secret =<< + mstore . ExtendedIdentityData =<< return (emptyIdentityExtension baseData) + { ideName = name + , ideOwner = extOwner + } + else return $ baseToExtended baseData return identity validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity diff --git a/src/Message.hs b/src/Message.hs index ac67f07..334cd1e 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -43,7 +43,7 @@ data DirectMessage = DirectMessage instance Storable DirectMessage where store' msg = storeRec $ do - mapM_ (storeRef "from") $ idDataF $ msgFrom msg + mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg mapM_ (storeRef "PREV") $ msgPrev msg storeDate "time" $ msgTime msg storeText "text" $ msgText msg diff --git a/src/Network.hs b/src/Network.hs index 1d28d68..58e9816 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -223,7 +223,7 @@ startServer opt serverOrigHead logd' serverServices = do let announceUpdate identity = do st <- derivePartialStorage serverStorage - let selfRef = partialRef st $ storedRef $ idData identity + let selfRef = partialRef st $ storedRef $ idExtData identity updateRefs = map refDigest $ selfRef : map (partialRef st . storedRef) (idUpdates identity) ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- updateRefs ] hitems = map AnnounceUpdate updateRefs @@ -585,7 +585,7 @@ finalizedChannel peer@Peer {..} ch self = do -- Identity update writeTQueue (serverIOActions peerServer_) $ liftIO $ atomically $ do - let selfRef = refDigest $ storedRef $ idData $ self + let selfRef = refDigest $ storedRef $ idExtData $ self updateRefs = selfRef : map (refDigest . storedRef) (idUpdates self) ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- updateRefs ] sendToPeerS peer ackedBy $ flip TransportPacket [] $ TransportHeader $ map AnnounceUpdate updateRefs diff --git a/src/Pairing.hs b/src/Pairing.hs index 8567168..0b31625 100644 --- a/src/Pairing.hs +++ b/src/Pairing.hs @@ -116,7 +116,7 @@ instance PairingResult a => Service (PairingService a) where (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 + validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal when (not $ self `sameIdentity` self') $ do throwError "pairing request to different identity" diff --git a/src/Service.hs b/src/Service.hs index 580c17d..f15662e 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -172,7 +172,7 @@ svcSetLocal x = modify $ \st -> st { svcLocal = x } svcSelf :: ServiceHandler s UnifiedIdentity svcSelf = maybe (throwError "failed to validate own identity") return . - validateIdentity . lsIdentity . fromStored =<< svcGetLocal + validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal svcPrint :: String -> ServiceHandler s () svcPrint str = afterCommit . ($ str) =<< asks svcPrintOp diff --git a/src/State.hs b/src/State.hs index 207030c..e1ddcea 100644 --- a/src/State.hs +++ b/src/State.hs @@ -38,7 +38,7 @@ import Storage import Storage.Merge data LocalState = LocalState - { lsIdentity :: Stored (Signed IdentityData) + { lsIdentity :: Stored (Signed ExtendedIdentityData) , lsShared :: [Stored SharedState] } @@ -117,17 +117,17 @@ loadLocalStateHead st = loadHeads st >>= \case shared <- wrappedStore st $ SharedState { ssPrev = [] , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy - , ssValue = [storedRef $ idData $ fromMaybe identity owner] + , ssValue = [storedRef $ idExtData $ fromMaybe identity owner] } storeHead st $ LocalState - { lsIdentity = idData identity + { lsIdentity = idExtData identity , lsShared = [shared] } localIdentity :: LocalState -> UnifiedIdentity localIdentity ls = maybe (error "failed to verify local identity") (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) - (validateIdentity $ lsIdentity ls) + (validateExtendedIdentity $ lsIdentity ls) headLocalIdentity :: Head LocalState -> UnifiedIdentity headLocalIdentity = localIdentity . headObject diff --git a/src/Test.hs b/src/Test.hs index 3f59239..ab9a78c 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -321,7 +321,7 @@ cmdCreateIdentity = do _ -> return [] storeHead st $ LocalState - { lsIdentity = idData identity + { lsIdentity = idExtData identity , lsShared = shared } @@ -427,14 +427,14 @@ cmdUpdateLocalIdentity :: Command cmdUpdateLocalIdentity = do [name] <- asks tiParams updateLocalHead_ $ \ls -> do - Just identity <- return $ validateIdentity $ lsIdentity $ fromStored ls + Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls let public = idKeyIdentity identity secret <- loadKey public - nidata <- maybe (error "created invalid identity") (return . idData) . validateIdentity =<< - mstore =<< sign secret =<< mstore (emptyIdentityData public) - { iddPrev = toList $ idDataF identity - , iddName = Just name + nidata <- maybe (error "created invalid identity") (return . idExtData) . validateExtendedIdentity =<< + mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity) + { idePrev = toList $ idExtDataF identity + , ideName = Just name } mstore (fromStored ls) { lsIdentity = nidata } @@ -446,10 +446,11 @@ cmdUpdateSharedIdentity = do Just identity -> do let public = idKeyIdentity identity secret <- loadKey public - maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateIdentity =<< - mstore =<< sign secret =<< mstore (emptyIdentityData public) - { iddPrev = toList $ idDataF identity - , iddName = Just name + uidentity <- mergeIdentity identity + maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateExtendedIdentity =<< + mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData uidentity) + { idePrev = toList $ idExtDataF identity + , ideName = Just name } cmdAttachTo :: Command -- cgit v1.2.3