diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Identity.hs | 243 | ||||
| -rw-r--r-- | src/PubKey.hs | 9 | ||||
| -rw-r--r-- | src/State.hs | 2 | ||||
| -rw-r--r-- | src/Storage.hs | 5 | ||||
| -rw-r--r-- | src/Util.hs | 23 |
5 files changed, 219 insertions, 63 deletions
diff --git a/src/Identity.hs b/src/Identity.hs index 8bee231..e9216fb 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -1,12 +1,18 @@ {-# LANGUAGE UndecidableInstances #-} module Identity ( - Identity, ComposedIdentity, UnifiedIdentity, IdentityData(..), - idData, idDataF, idName, idOwner, idUpdates, idKeyIdentity, idKeyMessage, + Identity, ComposedIdentity, UnifiedIdentity, + IdentityData(..), ExtendedIdentityData(..), IdentityExtension(..), + idData, idDataF, idExtData, idExtDataF, + idName, idOwner, idUpdates, idKeyIdentity, idKeyMessage, + eiddBase, eiddStoredBase, + eiddName, eiddOwner, eiddKeyIdentity, eiddKeyMessage, emptyIdentityData, + emptyIdentityExtension, createIdentity, validateIdentity, validateIdentityF, validateIdentityFE, + validateExtendedIdentity, validateExtendedIdentityF, validateExtendedIdentityFE, loadIdentity, loadUnifiedIdentity, mergeIdentity, toUnifiedIdentity, toComposedIdentity, @@ -38,22 +44,32 @@ import qualified Data.Text as T import PubKey import Storage import Storage.Merge +import Util -data Identity m = Identity - { idData_ :: m (Stored (Signed IdentityData)) +data Identity m = IdentityKind m => Identity + { idData_ :: m (Stored (Signed ExtendedIdentityData)) , idName_ :: Maybe Text , idOwner_ :: Maybe ComposedIdentity - , idUpdates_ :: [Stored (Signed IdentityData)] + , idUpdates_ :: [Stored (Signed ExtendedIdentityData)] , idKeyIdentity_ :: Stored PublicKey , idKeyMessage_ :: Stored PublicKey } -deriving instance Show (m (Stored (Signed IdentityData))) => Show (Identity m) +deriving instance Show (m (Stored (Signed ExtendedIdentityData))) => Show (Identity m) + +class (Functor f, Foldable f) => IdentityKind f where + ikFilterAncestors :: Storable a => f (Stored a) -> f (Stored a) + +instance IdentityKind I.Identity where + ikFilterAncestors = id + +instance IdentityKind [] where + ikFilterAncestors = filterAncestors type ComposedIdentity = Identity [] type UnifiedIdentity = Identity I.Identity -instance Eq (m (Stored (Signed IdentityData))) => Eq (Identity m) where +instance Eq (m (Stored (Signed ExtendedIdentityData))) => Eq (Identity m) where (==) = (==) `on` (idData_ &&& idUpdates_) data IdentityData = IdentityData @@ -65,6 +81,21 @@ data IdentityData = IdentityData } deriving (Show) +data IdentityExtension = IdentityExtension + { idePrev :: [Stored (Signed ExtendedIdentityData)] + , ideBase :: Stored (Signed IdentityData) + , ideName :: Maybe Text + , ideOwner :: Maybe (Stored (Signed ExtendedIdentityData)) + } + deriving (Show) + +data ExtendedIdentityData = BaseIdentityData IdentityData + | ExtendedIdentityData IdentityExtension + deriving (Show) + +baseToExtended :: Stored (Signed IdentityData) -> Stored (Signed ExtendedIdentityData) +baseToExtended = unsafeMapStored (unsafeMapSigned BaseIdentityData) + instance Storable IdentityData where store' idt = storeRec $ do mapM_ (storeRef "SPREV") $ iddPrev idt @@ -80,16 +111,44 @@ instance Storable IdentityData where <*> loadRef "key-id" <*> loadMbRef "key-msg" +instance Storable IdentityExtension where + store' IdentityExtension {..} = storeRec $ do + mapM_ (storeRef "SPREV") idePrev + storeRef "SBASE" ideBase + storeMbText "name" ideName + storeMbRef "owner" ideOwner + + load' = loadRec $ IdentityExtension + <$> loadRefs "SPREV" + <*> loadRef "SBASE" + <*> loadMbText "name" + <*> loadMbRef "owner" + +instance Storable ExtendedIdentityData where + store' (BaseIdentityData idata) = store' idata + store' (ExtendedIdentityData idata) = store' idata + + load' = msum + [ BaseIdentityData <$> load' + , ExtendedIdentityData <$> load' + ] + instance Mergeable (Maybe ComposedIdentity) where - type Component (Maybe ComposedIdentity) = Signed IdentityData - mergeSorted = validateIdentityF - toComponents = maybe [] idDataF + type Component (Maybe ComposedIdentity) = Signed ExtendedIdentityData + mergeSorted = validateExtendedIdentityF + toComponents = maybe [] idExtDataF idData :: UnifiedIdentity -> Stored (Signed IdentityData) idData = I.runIdentity . idDataF idDataF :: Identity m -> m (Stored (Signed IdentityData)) -idDataF = idData_ +idDataF idt@Identity {} = ikFilterAncestors . fmap eiddStoredBase . idData_ $ idt + +idExtData :: UnifiedIdentity -> Stored (Signed ExtendedIdentityData) +idExtData = I.runIdentity . idExtDataF + +idExtDataF :: Identity m -> m (Stored (Signed ExtendedIdentityData)) +idExtDataF = idData_ idName :: Identity m -> Maybe Text idName = idName_ @@ -97,7 +156,7 @@ idName = idName_ idOwner :: Identity m -> Maybe ComposedIdentity idOwner = idOwner_ -idUpdates :: Identity m -> [Stored (Signed IdentityData)] +idUpdates :: Identity m -> [Stored (Signed ExtendedIdentityData)] idUpdates = idUpdates_ idKeyIdentity :: Identity m -> Stored PublicKey @@ -106,6 +165,33 @@ idKeyIdentity = idKeyIdentity_ idKeyMessage :: Identity m -> Stored PublicKey idKeyMessage = idKeyMessage_ +eiddPrev :: ExtendedIdentityData -> [Stored (Signed ExtendedIdentityData)] +eiddPrev (BaseIdentityData idata) = baseToExtended <$> iddPrev idata +eiddPrev (ExtendedIdentityData IdentityExtension {..}) = baseToExtended ideBase : idePrev + +eiddBase :: ExtendedIdentityData -> IdentityData +eiddBase (BaseIdentityData idata) = idata +eiddBase (ExtendedIdentityData IdentityExtension {..}) = fromSigned ideBase + +eiddStoredBase :: Stored (Signed ExtendedIdentityData) -> Stored (Signed IdentityData) +eiddStoredBase ext = case fromSigned ext of + (BaseIdentityData idata) -> unsafeMapStored (unsafeMapSigned (const idata)) ext + (ExtendedIdentityData IdentityExtension {..}) -> ideBase + +eiddName :: ExtendedIdentityData -> Maybe Text +eiddName (BaseIdentityData idata) = iddName idata +eiddName (ExtendedIdentityData IdentityExtension {..}) = ideName + +eiddOwner :: ExtendedIdentityData -> Maybe (Stored (Signed ExtendedIdentityData)) +eiddOwner (BaseIdentityData idata) = baseToExtended <$> iddOwner idata +eiddOwner (ExtendedIdentityData IdentityExtension {..}) = ideOwner + +eiddKeyIdentity :: ExtendedIdentityData -> Stored PublicKey +eiddKeyIdentity = iddKeyIdentity . eiddBase + +eiddKeyMessage :: ExtendedIdentityData -> Maybe (Stored PublicKey) +eiddKeyMessage = iddKeyMessage . eiddBase + emptyIdentityData :: Stored PublicKey -> IdentityData emptyIdentityData key = IdentityData @@ -116,6 +202,19 @@ emptyIdentityData key = IdentityData , iddKeyMessage = Nothing } +emptyIdentityExtension :: Stored (Signed IdentityData) -> IdentityExtension +emptyIdentityExtension base = IdentityExtension + { idePrev = [] + , ideBase = base + , ideName = Nothing + , ideOwner = Nothing + } + +isExtension :: Stored (Signed ExtendedIdentityData) -> Bool +isExtension x = case fromSigned x of BaseIdentityData {} -> False + _ -> True + + createIdentity :: Storage -> Maybe Text -> Maybe UnifiedIdentity -> IO UnifiedIdentity createIdentity st name owner = do (secret, public) <- generateKeys st @@ -123,7 +222,7 @@ createIdentity st name owner = do let signOwner idd | Just o <- owner = do - Just ownerSecret <- loadKeyMb (iddKeyIdentity $ fromStored $ signedData $ fromStored $ idData o) + Just ownerSecret <- loadKeyMb (iddKeyIdentity $ fromSigned $ idData o) signAdd ownerSecret idd | otherwise = return idd @@ -139,62 +238,71 @@ createIdentity st name owner = do validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity validateIdentity = validateIdentityF . I.Identity -validateIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m) +validateIdentityF :: IdentityKind m => m (Stored (Signed IdentityData)) -> Maybe (Identity m) validateIdentityF = either (const Nothing) Just . runExcept . validateIdentityFE -validateIdentityFE :: Foldable m => m (Stored (Signed IdentityData)) -> Except String (Identity m) -validateIdentityFE mdata = do - let idata = filterAncestors $ toList mdata +validateIdentityFE :: IdentityKind m => m (Stored (Signed IdentityData)) -> Except String (Identity m) +validateIdentityFE = validateExtendedIdentityFE . fmap baseToExtended + +validateExtendedIdentity :: Stored (Signed ExtendedIdentityData) -> Maybe UnifiedIdentity +validateExtendedIdentity = validateExtendedIdentityF . I.Identity + +validateExtendedIdentityF :: IdentityKind m => m (Stored (Signed ExtendedIdentityData)) -> Maybe (Identity m) +validateExtendedIdentityF = either (const Nothing) Just . runExcept . validateExtendedIdentityFE + +validateExtendedIdentityFE :: IdentityKind m => m (Stored (Signed ExtendedIdentityData)) -> Except String (Identity m) +validateExtendedIdentityFE mdata = do + let idata = ikFilterAncestors mdata when (null idata) $ throwError "null data" - mapM_ verifySignatures $ gatherPrevious S.empty idata + mapM_ verifySignatures $ gatherPrevious S.empty $ toList idata Identity - <$> pure mdata - <*> pure (lookupProperty iddName idata) - <*> case lookupProperty iddOwner idata of + <$> pure idata + <*> pure (lookupProperty eiddName idata) + <*> case lookupProperty eiddOwner idata of Nothing -> return Nothing - Just owner -> return <$> validateIdentityFE [owner] + Just owner -> return <$> validateExtendedIdentityFE [owner] <*> pure [] - <*> pure (iddKeyIdentity $ fromStored $ signedData $ fromStored $ minimum idata) - <*> case lookupProperty iddKeyMessage idata of + <*> pure (eiddKeyIdentity $ fromSigned $ minimum idata) + <*> case lookupProperty eiddKeyMessage idata of Nothing -> throwError "no message key" Just mk -> return mk loadIdentity :: String -> LoadRec ComposedIdentity -loadIdentity name = maybe (throwError "identity validation failed") return . validateIdentityF =<< loadRefs name +loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity -loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateIdentity =<< loadRef name +loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name -gatherPrevious :: Set (Stored (Signed IdentityData)) -> [Stored (Signed IdentityData)] -> Set (Stored (Signed IdentityData)) +gatherPrevious :: Set (Stored (Signed ExtendedIdentityData)) -> [Stored (Signed ExtendedIdentityData)] -> Set (Stored (Signed ExtendedIdentityData)) gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns - | otherwise = gatherPrevious (S.insert n res) $ (iddPrev $ fromStored $ signedData $ fromStored n) ++ ns + | otherwise = gatherPrevious (S.insert n res) $ (eiddPrev $ fromSigned n) ++ ns gatherPrevious res [] = res -verifySignatures :: Stored (Signed IdentityData) -> Except String () +verifySignatures :: Stored (Signed ExtendedIdentityData) -> Except String () verifySignatures sidd = do - let idd = fromStored $ signedData $ fromStored sidd + let idd = fromSigned sidd required = concat - [ [ iddKeyIdentity idd ] - , map (iddKeyIdentity . fromStored . signedData . fromStored) $ iddPrev idd - , map (iddKeyIdentity . fromStored . signedData . fromStored) $ toList $ iddOwner idd + [ [ eiddKeyIdentity idd ] + , map (eiddKeyIdentity . fromSigned) $ eiddPrev idd + , map (eiddKeyIdentity . fromSigned) $ toList $ eiddOwner idd ] unless (all (fromStored sidd `isSignedBy`) required) $ do throwError "signature verification failed" -lookupProperty :: forall a. (IdentityData -> Maybe a) -> [Stored (Signed IdentityData)] -> Maybe a +lookupProperty :: forall a m. Foldable m => (ExtendedIdentityData -> Maybe a) -> m (Stored (Signed ExtendedIdentityData)) -> Maybe a lookupProperty sel topHeads = findResult filteredLayers - where findPropHeads :: Stored (Signed IdentityData) -> [(Stored (Signed IdentityData), a)] - findPropHeads sobj | Just x <- sel $ fromStored $ signedData $ fromStored sobj = [(sobj, x)] - | otherwise = findPropHeads =<< (iddPrev $ fromStored $ signedData $ fromStored sobj) + where findPropHeads :: Stored (Signed ExtendedIdentityData) -> [(Stored (Signed ExtendedIdentityData), a)] + findPropHeads sobj | Just x <- sel $ fromSigned sobj = [(sobj, x)] + | otherwise = findPropHeads =<< (eiddPrev $ fromSigned sobj) - propHeads :: [(Stored (Signed IdentityData), a)] - propHeads = findPropHeads =<< topHeads + propHeads :: [(Stored (Signed ExtendedIdentityData), a)] + propHeads = findPropHeads =<< toList topHeads - historyLayers :: [Set (Stored (Signed IdentityData))] + historyLayers :: [Set (Stored (Signed ExtendedIdentityData))] historyLayers = generations $ map fst propHeads - filteredLayers :: [[(Stored (Signed IdentityData), a)]] + filteredLayers :: [[(Stored (Signed ExtendedIdentityData), a)]] filteredLayers = scanl (\cur obsolete -> filter ((`S.notMember` obsolete) . fst) cur) propHeads historyLayers findResult ([(_, x)] : _) = Just x @@ -203,10 +311,10 @@ lookupProperty sel topHeads = findResult filteredLayers findResult [xs] = Just $ snd $ minimumBy (comparing fst) xs findResult (_:rest) = findResult rest -mergeIdentity :: (Foldable f, MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity +mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' -mergeIdentity idt = do - (owner, ownerData) <- case idOwner_ idt of +mergeIdentity idt@Identity {..} = do + (owner, ownerData) <- case idOwner_ of Nothing -> return (Nothing, Nothing) Just cowner | Just owner <- toUnifiedIdentity cowner -> return (Just owner, Nothing) | otherwise -> do owner <- mergeIdentity cowner @@ -214,40 +322,51 @@ mergeIdentity idt = do let public = idKeyIdentity idt secret <- loadKey public - sdata <- mstore =<< sign secret =<< mstore (emptyIdentityData public) - { iddPrev = toList $ idDataF idt, iddOwner = ownerData } - return $ idt { idData_ = I.Identity sdata, idOwner_ = toComposedIdentity <$> owner } -toUnifiedIdentity :: Foldable m => Identity m -> Maybe UnifiedIdentity -toUnifiedIdentity idt - | [sdata] <- toList $ idDataF idt = Just idt { idData_ = I.Identity sdata } - | otherwise = Nothing + unifiedBaseData <- + case toList $ idDataF idt of + [idata] -> return idata + idatas -> mstore =<< sign secret =<< mstore (emptyIdentityData public) + { iddPrev = idatas, iddOwner = ownerData } + + case filter isExtension $ toList $ idExtDataF idt of + [] -> return Identity { idData_ = I.Identity (baseToExtended unifiedBaseData), idOwner_ = toComposedIdentity <$> owner, .. } + extdata -> do + unifiedExtendedData <- mstore =<< sign secret =<< + (mstore . ExtendedIdentityData) (emptyIdentityExtension unifiedBaseData) + { idePrev = extdata } + return Identity { idData_ = I.Identity unifiedExtendedData, idOwner_ = toComposedIdentity <$> owner, .. } -toComposedIdentity :: Foldable m => Identity m -> ComposedIdentity -toComposedIdentity idt = idt { idData_ = toList $ idDataF idt - , idOwner_ = toComposedIdentity <$> idOwner_ idt - } +toUnifiedIdentity :: Identity m -> Maybe UnifiedIdentity +toUnifiedIdentity Identity {..} + | [sdata] <- toList idData_ = Just Identity { idData_ = I.Identity sdata, .. } + | otherwise = Nothing + +toComposedIdentity :: Identity m -> ComposedIdentity +toComposedIdentity Identity {..} = Identity { idData_ = toList idData_ + , idOwner_ = toComposedIdentity <$> idOwner_ + , .. + } -updateIdentity :: Foldable m => [Stored (Signed IdentityData)] -> Identity m -> ComposedIdentity +updateIdentity :: [Stored (Signed ExtendedIdentityData)] -> Identity m -> ComposedIdentity updateIdentity [] orig = toComposedIdentity orig -updateIdentity updates orig = - case validateIdentityF $ filterAncestors (ourUpdates ++ idata) of - -- need to filter ancestors here as validateIdentityF currently stores the whole list in idData_ +updateIdentity updates orig@Identity {} = + case validateExtendedIdentityF $ ourUpdates ++ idata of Just updated -> updated { idOwner_ = updateIdentity ownerUpdates <$> idOwner_ updated , idUpdates_ = ownerUpdates } Nothing -> toComposedIdentity orig where idata = toList $ idData_ orig - ilen = length idata + idataRoots = foldl' mergeUniq [] $ map storedRoots idata (ourUpdates, ownerUpdates) = partitionEithers $ flip map (filterAncestors $ updates ++ idUpdates_ orig) $ -- if an update is related to anything in idData_, use it here, otherwise push to owners - \u -> if length (filterAncestors (u : idata)) < ilen + 1 + \u -> if storedRoots u `intersectsSorted` idataRoots then Left u else Right u -updateOwners :: [Stored (Signed IdentityData)] -> Identity m -> Identity m +updateOwners :: [Stored (Signed ExtendedIdentityData)] -> Identity m -> Identity m updateOwners updates orig@Identity { idOwner_ = Just owner, idUpdates_ = cupdates } = orig { idOwner_ = Just $ updateIdentity updates owner, idUpdates_ = filterAncestors (updates ++ cupdates) } updateOwners _ orig@Identity { idOwner_ = Nothing } = orig diff --git a/src/PubKey.hs b/src/PubKey.hs index f69d739..5f235eb 100644 --- a/src/PubKey.hs +++ b/src/PubKey.hs @@ -3,6 +3,8 @@ module PubKey ( KeyPair(generateKeys), loadKey, loadKeyMb, Signature(sigKey), Signed, signedData, signedSignature, sign, signAdd, isSignedBy, + fromSigned, + unsafeMapSigned, PublicKexKey, SecretKexKey, dhSecret, @@ -110,6 +112,13 @@ signAdd (SecretKey secret spublic) (Signed val sigs) = do isSignedBy :: Signed a -> Stored PublicKey -> Bool isSignedBy sig key = key `elem` map (sigKey . fromStored) (signedSignature sig) +fromSigned :: Stored (Signed a) -> a +fromSigned = fromStored . signedData . fromStored + +-- |Passed function needs to preserve the object representation to be safe +unsafeMapSigned :: (a -> b) -> Signed a -> Signed b +unsafeMapSigned f signed = signed { signedData_ = unsafeMapStored f (signedData_ signed) } + data PublicKexKey = PublicKexKey CX.PublicKey deriving (Show) diff --git a/src/State.hs b/src/State.hs index b575ffa..207030c 100644 --- a/src/State.hs +++ b/src/State.hs @@ -126,7 +126,7 @@ loadLocalStateHead st = loadHeads st >>= \case localIdentity :: LocalState -> UnifiedIdentity localIdentity ls = maybe (error "failed to verify local identity") - (updateOwners $ maybe [] idDataF $ lookupSharedValue $ lsShared ls) + (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) (validateIdentity $ lsIdentity ls) headLocalIdentity :: Head LocalState -> UnifiedIdentity diff --git a/src/Storage.hs b/src/Storage.hs index 69e8ab6..7edae8b 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -46,6 +46,7 @@ module Storage ( fromStored, storedRef, wrappedStore, wrappedLoad, copyStored, + unsafeMapStored, StoreInfo(..), makeStoreInfo, @@ -891,6 +892,10 @@ copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', M Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' +-- |Passed function needs to preserve the object representation to be safe +unsafeMapStored :: (a -> b) -> Stored a -> Stored b +unsafeMapStored f (Stored ref x) = Stored ref (f x) + data StoreInfo = StoreInfo { infoDate :: ZonedTime diff --git a/src/Util.hs b/src/Util.hs index fe802e2..c69adee 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -12,3 +12,26 @@ mergeBy cmp (x : xs) (y : ys) = case cmp x y of GT -> y : mergeBy cmp (x : xs) ys mergeBy _ xs [] = xs mergeBy _ [] ys = ys + +mergeUniqBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeUniqBy cmp (x : xs) (y : ys) = case cmp x y of + LT -> x : mergeBy cmp xs (y : ys) + EQ -> x : mergeBy cmp xs ys + GT -> y : mergeBy cmp (x : xs) ys +mergeUniqBy _ xs [] = xs +mergeUniqBy _ [] ys = ys + +mergeUniq :: Ord a => [a] -> [a] -> [a] +mergeUniq = mergeUniqBy compare + +diffSorted :: Ord a => [a] -> [a] -> [a] +diffSorted (x:xs) (y:ys) | x < y = x : diffSorted xs (y:ys) + | x > y = diffSorted (x:xs) ys + | otherwise = diffSorted xs (y:ys) +diffSorted xs _ = xs + +intersectsSorted :: Ord a => [a] -> [a] -> Bool +intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys) + | x > y = intersectsSorted (x:xs) ys + | otherwise = True +intersectsSorted _ _ = False |