summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs11
-rw-r--r--src/Contact.hs6
-rw-r--r--src/Identity.hs21
-rw-r--r--src/Message.hs2
-rw-r--r--src/Network.hs4
-rw-r--r--src/Pairing.hs2
-rw-r--r--src/Service.hs2
-rw-r--r--src/State.hs8
-rw-r--r--src/Test.hs21
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-30 15:16:59 +0000