summaryrefslogtreecommitdiff
path: root/src/Identity.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Identity.hs')
-rw-r--r--src/Identity.hs195
1 files changed, 159 insertions, 36 deletions
diff --git a/src/Identity.hs b/src/Identity.hs
index 96346d8..5a7f8fc 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -1,62 +1,185 @@
+{-# LANGUAGE UndecidableInstances #-}
+
module Identity (
- Identity, IdentityData(..),
- emptyIdentity,
+ Identity, ComposedIdentity, UnifiedIdentity, IdentityData(..),
+ idData, idDataF, idName, idOwner, idKeyIdentity, idKeyMessage,
+
+ emptyIdentityData,
+ verifyIdentity, verifyIdentityF,
+ mergeIdentity, toComposedIdentity,
+
finalOwner,
displayIdentity,
) where
+import Control.Monad
+import qualified Control.Monad.Identity as I
+
+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
-type Identity = Signed IdentityData
-
-data IdentityData = Identity
- { idName :: Maybe Text
- , idPrev :: Maybe (Stored Identity)
- , idOwner :: Maybe (Stored Identity)
- , idKeyIdentity :: Stored PublicKey
- , idKeyMessage :: Stored PublicKey
+data Identity m = Identity
+ { idData_ :: m (Stored (Signed IdentityData))
+ , idName_ :: Maybe Text
+ , idOwner_ :: Maybe UnifiedIdentity
+ , idKeyIdentity_ :: Stored PublicKey
+ , idKeyMessage_ :: Stored PublicKey
}
- deriving (Show)
-emptyIdentity :: Stored PublicKey -> Stored PublicKey -> IdentityData
-emptyIdentity key kmsg = Identity
- { idName = Nothing
- , idPrev = Nothing
- , idOwner = Nothing
- , idKeyIdentity = key
- , idKeyMessage = kmsg
+deriving instance Show (m (Stored (Signed IdentityData))) => Show (Identity m)
+
+type ComposedIdentity = Identity []
+type UnifiedIdentity = Identity I.Identity
+
+instance Eq UnifiedIdentity where
+ (==) = (==) `on` idData
+
+data IdentityData = IdentityData
+ { iddPrev :: [Stored (Signed IdentityData)]
+ , iddName :: Maybe Text
+ , iddOwner :: Maybe (Stored (Signed IdentityData))
+ , iddKeyIdentity :: Stored PublicKey
+ , iddKeyMessage :: Maybe (Stored PublicKey)
}
+ deriving (Show)
instance Storable IdentityData where
store' idt = storeRec $ do
- storeMbText "name" $ idName idt
- storeMbRef "prev" $ idPrev idt
- storeMbRef "owner" $ idOwner idt
- storeRef "key-id" $ idKeyIdentity idt
- storeRef "key-msg" $ idKeyMessage idt
-
- load' = loadRec $ Identity
- <$> loadMbText "name"
- <*> loadMbRef "prev"
+ mapM_ (storeRef "PREV") $ iddPrev idt
+ storeMbText "name" $ iddName idt
+ storeMbRef "owner" $ iddOwner idt
+ storeRef "key-id" $ iddKeyIdentity idt
+ storeMbRef "key-msg" $ iddKeyMessage idt
+
+ load' = loadRec $ IdentityData
+ <$> loadRefs "PREV"
+ <*> loadMbText "name"
<*> loadMbRef "owner"
<*> loadRef "key-id"
- <*> loadRef "key-msg"
+ <*> loadMbRef "key-msg"
+
+idData :: UnifiedIdentity -> Stored (Signed IdentityData)
+idData = I.runIdentity . idDataF
+
+idDataF :: Identity m -> m (Stored (Signed IdentityData))
+idDataF = idData_
+
+idName :: Identity m -> Maybe Text
+idName = idName_
+
+idOwner :: Identity m -> Maybe UnifiedIdentity
+idOwner = idOwner_
+
+idKeyIdentity :: Identity m -> Stored PublicKey
+idKeyIdentity = idKeyIdentity_
+
+idKeyMessage :: Identity m -> Stored PublicKey
+idKeyMessage = idKeyMessage_
+
+
+emptyIdentityData :: Stored PublicKey -> IdentityData
+emptyIdentityData key = IdentityData
+ { iddName = Nothing
+ , iddPrev = []
+ , iddOwner = Nothing
+ , iddKeyIdentity = key
+ , iddKeyMessage = Nothing
+ }
+
+verifyIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity
+verifyIdentity = verifyIdentityF . I.Identity
+
+verifyIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m)
+verifyIdentityF mdata = do
+ let idata = toList mdata -- TODO: eliminate ancestors
+ guard $ not $ null idata
+ mapM_ verifySignatures $ gatherPrevious S.empty idata
+ Identity
+ <$> pure mdata
+ <*> pure (lookupProperty iddName idata)
+ <*> case lookupProperty iddOwner idata of
+ Nothing -> return Nothing
+ Just owner -> Just <$> verifyIdentity owner
+ <*> pure (iddKeyIdentity $ fromStored $ signedData $ fromStored $ minimum idata)
+ <*> lookupProperty iddKeyMessage idata
+
+gatherPrevious :: Set (Stored (Signed IdentityData)) -> [Stored (Signed IdentityData)] -> Set (Stored (Signed IdentityData))
+gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns
+ | otherwise = gatherPrevious (S.insert n res) $ (iddPrev $ fromStored $ signedData $ fromStored n) ++ ns
+gatherPrevious res [] = res
+
+verifySignatures :: Stored (Signed IdentityData) -> Maybe ()
+verifySignatures sidd = do
+ let idd = fromStored $ signedData $ fromStored sidd
+ required = concat
+ [ [ iddKeyIdentity idd ]
+ , map (iddKeyIdentity . fromStored . signedData . fromStored) $ iddPrev idd
+ , map (iddKeyIdentity . fromStored . signedData . fromStored) $ toList $ iddOwner idd
+ ]
+ guard $ all (fromStored sidd `isSignedBy`) required
+
+lookupProperty :: forall a. (IdentityData -> Maybe a) -> [Stored (Signed IdentityData)] -> 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)
+
+ propHeads :: [(Stored (Signed IdentityData), a)]
+ propHeads = findPropHeads =<< topHeads
+
+ historyLayers :: [Set (Stored (Signed IdentityData))]
+ historyLayers = flip unfoldr (map fst propHeads, S.empty) $ \(hs, cur) ->
+ case filter (`S.notMember` cur) $ (iddPrev . fromStored . signedData . fromStored) =<< hs of
+ [] -> Nothing
+ added -> let next = foldr S.insert cur added
+ in Just (next, (added, next))
+
+ filteredLayers :: [[(Stored (Signed IdentityData), 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 :: Foldable m => Identity m -> IO UnifiedIdentity
+mergeIdentity idt | [sdata] <- toList $ idDataF idt = return $ idt { idData_ = I.Identity sdata }
+mergeIdentity idt = do
+ (sid:_) <- return $ toList $ idDataF idt
+ let st = storedStorage sid
+ public = idKeyIdentity idt
+ Just secret <- loadKey public
+ sdata <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
+ { iddPrev = toList $ idDataF idt }
+ return $ idt { idData_ = I.Identity sdata }
+
+
+toComposedIdentity :: Foldable m => Identity m -> ComposedIdentity
+toComposedIdentity idt = idt { idData_ = toList $ idDataF idt }
+
-unfoldOwners :: Stored Identity -> [Stored Identity]
-unfoldOwners cur = cur : case idOwner $ fromStored $ signedData $ fromStored cur of
+unfoldOwners :: (Foldable m, Applicative m) => Identity m -> [Identity m]
+unfoldOwners cur = cur : case idOwner cur of
Nothing -> []
- Just prev -> unfoldOwners prev
+ Just owner@Identity { idData_ = I.Identity pid } ->
+ unfoldOwners owner { idData_ = pure pid }
-finalOwner :: Stored Identity -> Stored Identity
+finalOwner :: (Foldable m, Applicative m) => Identity m -> Identity m
finalOwner = last . unfoldOwners
-displayIdentity :: Stored Identity -> Text
-displayIdentity sidentity = T.concat
- [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName . fromStored . signedData . fromStored) owners
+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 sidentity
+ where owners = reverse $ unfoldOwners identity
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 18:33:23 +0000