diff options
Diffstat (limited to 'src/Identity.hs')
| -rw-r--r-- | src/Identity.hs | 402 |
1 files changed, 0 insertions, 402 deletions
diff --git a/src/Identity.hs b/src/Identity.hs deleted file mode 100644 index 7c49c9f..0000000 --- a/src/Identity.hs +++ /dev/null @@ -1,402 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Identity ( - 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, - updateIdentity, updateOwners, - sameIdentity, - - unfoldOwners, - finalOwner, - displayIdentity, -) where - -import Control.Arrow -import Control.Monad -import Control.Monad.Except -import Control.Monad.Identity qualified as I -import Control.Monad.Reader - -import Data.Either -import Data.Foldable -import Data.Function -import Data.List -import Data.Maybe -import Data.Ord -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T - -import PubKey -import Storage -import Storage.Merge -import Util - -data Identity m = IdentityKind m => Identity - { idData_ :: m (Stored (Signed ExtendedIdentityData)) - , idName_ :: Maybe Text - , idOwner_ :: Maybe ComposedIdentity - , idUpdates_ :: [Stored (Signed ExtendedIdentityData)] - , idKeyIdentity_ :: Stored PublicKey - , idKeyMessage_ :: Stored PublicKey - } - -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 ExtendedIdentityData))) => Eq (Identity m) where - (==) = (==) `on` (idData_ &&& idUpdates_) - -data IdentityData = IdentityData - { iddPrev :: [Stored (Signed IdentityData)] - , iddName :: Maybe Text - , iddOwner :: Maybe (Stored (Signed IdentityData)) - , iddKeyIdentity :: Stored PublicKey - , iddKeyMessage :: Maybe (Stored PublicKey) - } - 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 - storeMbText "name" $ iddName idt - storeMbRef "owner" $ iddOwner idt - storeRef "key-id" $ iddKeyIdentity idt - storeMbRef "key-msg" $ iddKeyMessage idt - - load' = loadRec $ IdentityData - <$> loadRefs "SPREV" - <*> loadMbText "name" - <*> loadMbRef "owner" - <*> 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 ExtendedIdentityData - mergeSorted = validateExtendedIdentityF - toComponents = maybe [] idExtDataF - -idData :: UnifiedIdentity -> Stored (Signed IdentityData) -idData = I.runIdentity . idDataF - -idDataF :: Identity m -> m (Stored (Signed IdentityData)) -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_ - -idOwner :: Identity m -> Maybe ComposedIdentity -idOwner = idOwner_ - -idUpdates :: Identity m -> [Stored (Signed ExtendedIdentityData)] -idUpdates = idUpdates_ - -idKeyIdentity :: Identity m -> Stored PublicKey -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 - { iddName = Nothing - , iddPrev = [] - , iddOwner = Nothing - , iddKeyIdentity = key - , 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 - (_secretMsg, publicMsg) <- generateKeys st - - 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 - baseData <- mstore =<< signOwner =<< sign secret =<< - mstore (emptyIdentityData public) - { 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 -validateIdentity = validateIdentityF . I.Identity - -validateIdentityF :: IdentityKind m => m (Stored (Signed IdentityData)) -> Maybe (Identity m) -validateIdentityF = either (const Nothing) Just . runExcept . validateIdentityFE - -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 $ toList idata - Identity - <$> pure idata - <*> pure (lookupProperty eiddName idata) - <*> case lookupProperty eiddOwner idata of - Nothing -> return Nothing - Just owner -> return <$> validateExtendedIdentityFE [owner] - <*> pure [] - <*> 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 . validateExtendedIdentityF =<< loadRefs name - -loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity -loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name - - -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) $ (eiddPrev $ fromSigned n) ++ ns -gatherPrevious res [] = res - -verifySignatures :: Stored (Signed ExtendedIdentityData) -> Except String () -verifySignatures sidd = do - let idd = fromSigned sidd - required = concat - [ [ 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 m. Foldable m => (ExtendedIdentityData -> Maybe a) -> m (Stored (Signed ExtendedIdentityData)) -> Maybe a -lookupProperty sel topHeads = findResult filteredLayers - 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 ExtendedIdentityData), a)] - propHeads = findPropHeads =<< toList topHeads - - historyLayers :: [Set (Stored (Signed ExtendedIdentityData))] - historyLayers = generations $ map fst propHeads - - filteredLayers :: [[(Stored (Signed ExtendedIdentityData), a)]] - filteredLayers = scanl (\cur obsolete -> filter ((`S.notMember` obsolete) . fst) cur) propHeads historyLayers - - findResult ([(_, x)] : _) = Just x - findResult ([] : _) = Nothing - findResult [] = Nothing - findResult [xs] = Just $ snd $ minimumBy (comparing fst) xs - findResult (_:rest) = findResult rest - -mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity -mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' -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 - return (Just owner, Just $ idData owner) - - let public = idKeyIdentity idt - secret <- loadKey public - - 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, .. } - - -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 :: [Stored (Signed ExtendedIdentityData)] -> Identity m -> ComposedIdentity -updateIdentity [] orig = toComposedIdentity orig -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 - 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 storedRoots u `intersectsSorted` idataRoots - then Left u - else Right u - -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 - -sameIdentity :: (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool -sameIdentity x y = not $ S.null $ S.intersection (refset x) (refset y) - where refset idt = foldr S.insert (ancestors $ toList $ idDataF idt) (idDataF idt) - - -unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity] -unfoldOwners = unfoldr (fmap (\i -> (i, idOwner i))) . Just . toComposedIdentity - -finalOwner :: (Foldable m, Applicative m) => Identity m -> ComposedIdentity -finalOwner = last . unfoldOwners - -displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text -displayIdentity identity = T.concat - [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName) owners - ] - where owners = reverse $ unfoldOwners identity |