summaryrefslogtreecommitdiff
path: root/src/Erebos/State.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/State.hs')
-rw-r--r--src/Erebos/State.hs259
1 files changed, 259 insertions, 0 deletions
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
new file mode 100644
index 0000000..3774d87
--- /dev/null
+++ b/src/Erebos/State.hs
@@ -0,0 +1,259 @@
+module Erebos.State (
+ LocalState(..),
+ SharedState(..), SharedType(..),
+ SharedTypeID, mkSharedTypeID,
+
+ MonadStorage(..),
+ MonadHead(..),
+ updateLocalHead_,
+ LocalHeadT, runLocalHeadT, runLocalHeadT',
+ LocalHead, runLocalHead, runLocalHead',
+
+ updateLocalState, updateLocalState_,
+ updateSharedState, updateSharedState_,
+ lookupSharedValueH, lookupSharedValueHC, lookupSharedValueM,
+ lookupSharedValue, makeSharedStateUpdate,
+
+ localIdentity,
+ headLocalIdentity,
+
+ mergeSharedIdentity,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Identity qualified as CMI
+import Control.Monad.Reader
+
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BC
+import Data.Foldable
+import Data.Map.Strict qualified as MS
+import Data.Maybe
+import Data.Typeable
+
+import Erebos.Identity
+import Erebos.Object
+import Erebos.PubKey
+import Erebos.Storable
+import Erebos.Storage.Head
+import Erebos.Storage.Merge
+import Erebos.UUID (UUID)
+import Erebos.UUID qualified as U
+import Erebos.Util
+
+data LocalState = LocalState
+ { lsPrev :: Maybe RefDigest
+ , lsIdentity :: Stored (Signed ExtendedIdentityData)
+ , lsShared :: [ Stored SharedState ]
+ , lsOther :: [ ( ByteString, RecItem ) ]
+ }
+
+data SharedState = SharedState
+ { ssPrev :: [Stored SharedState]
+ , ssType :: Maybe SharedTypeID
+ , ssValue :: [Ref]
+ }
+
+newtype SharedTypeID = SharedTypeID UUID
+ deriving (Eq, Ord, StorableUUID)
+
+mkSharedTypeID :: String -> SharedTypeID
+mkSharedTypeID = maybe (error "Invalid shared type ID") SharedTypeID . U.fromString
+
+class Mergeable a => SharedType a where
+ sharedTypeID :: proxy a -> SharedTypeID
+
+instance Storable LocalState where
+ store' LocalState {..} = storeRec $ do
+ mapM_ (storeRawWeak "PREV") lsPrev
+ storeRef "id" lsIdentity
+ mapM_ (storeRef "shared") lsShared
+ storeRecItems lsOther
+
+ load' = loadRec $ do
+ lsPrev <- loadMbRawWeak "PREV"
+ lsIdentity <- loadRef "id"
+ lsShared <- loadRefs "shared"
+ lsOther <- filter ((`notElem` [ BC.pack "PREV", BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems
+ return LocalState {..}
+
+instance HeadType LocalState where
+ headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e"
+ type HeadCacheType LocalState = LocalStateCache
+ headCacheInit sls =
+ let LocalState {..} = fromStored sls
+ sharedCache = MS.fromAscList $ map (\sid -> ( sid, lookupSharedValueObjects sid [] lsShared )) $ collectSharedTypeIDs [] lsShared
+ in LocalStateCache lsShared sharedCache
+ headCacheUpdate sls prev =
+ let LocalState {..} = fromStored sls
+ sids = collectSharedTypeIDs (lscSharedTips prev) lsShared
+ upd cache sid = MS.insertWith (\ss ss' -> filterAncestors (ss ++ ss')) sid (lookupSharedValueObjects sid (lscSharedTips prev) lsShared) cache
+ in LocalStateCache lsShared (foldl' upd (lscSharedCache prev) sids)
+
+data LocalStateCache = LocalStateCache
+ { lscSharedTips :: [ Stored SharedState ]
+ , lscSharedCache :: MS.Map SharedTypeID (StoredTips SharedState)
+ }
+
+instance Storable SharedState where
+ store' st = storeRec $ do
+ mapM_ (storeRef "PREV") $ ssPrev st
+ storeMbUUID "type" $ ssType st
+ mapM_ (storeRawRef "value") $ ssValue st
+
+ load' = loadRec $ SharedState
+ <$> loadRefs "PREV"
+ <*> loadMbUUID "type"
+ <*> loadRawRefs "value"
+
+instance SharedType (Maybe ComposedIdentity) where
+ sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
+
+
+class (MonadStorage m, HeadType a) => MonadHead a m where
+ updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b
+ getLocalHead :: m (Stored a)
+ getLocalHead = updateLocalHead $ \x -> return (x, x)
+ getLocalHeadCache :: proxy a -> m (HeadCacheType a)
+ getLocalHeadCache _ = headCacheInit @a <$> getLocalHead
+
+updateLocalHead_ :: MonadHead a m => (Stored a -> m (Stored a)) -> m ()
+updateLocalHead_ f = updateLocalHead (fmap (,()) . f)
+
+instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
+ updateLocalHead f = do
+ h <- ask
+ snd <$> updateHead' h (\h' -> local (const h') (f $ headStoredObject h'))
+ getLocalHeadCache _ = asks headCache
+
+
+newtype LocalHeadT h m a = LocalHeadT { runLocalHeadT_ :: Storage -> ( Stored h, HeadCacheType h ) -> m ( a, ( Stored h, HeadCacheType h ) ) }
+
+runLocalHeadT :: forall h m a. (HeadType h, Monad m) => LocalHeadT h m a -> Storage -> Stored h -> m ( a, Stored h )
+runLocalHeadT act st h = fmap fst <$> runLocalHeadT_ act st ( h, headCacheInit h )
+
+runLocalHeadT' :: forall h m a. (HeadType h, Monad m) => LocalHeadT h m a -> Head h -> m ( a, Stored h )
+runLocalHeadT' act h = fmap fst <$> runLocalHeadT_ act (headStorage h) ( headStoredObject h, headCache h )
+
+type LocalHead h a = LocalHeadT h CMI.Identity a
+
+runLocalHead :: forall h a. HeadType h => LocalHead h a -> Storage -> Stored h -> ( a, Stored h )
+runLocalHead act st h = CMI.runIdentity $ runLocalHeadT act st h
+
+runLocalHead' :: forall h a. HeadType h => LocalHead h a -> Head h -> ( a, Stored h )
+runLocalHead' act h = CMI.runIdentity $ runLocalHeadT' act h
+
+
+instance Functor m => Functor (LocalHeadT h m) where
+ fmap f (LocalHeadT act) = LocalHeadT $ \st h -> first f <$> act st h
+
+instance Monad m => Applicative (LocalHeadT h m) where
+ pure x = LocalHeadT $ \_ h -> pure ( x, h )
+ (<*>) = ap
+
+instance Monad m => Monad (LocalHeadT h m) where
+ return = pure
+ LocalHeadT act >>= f = LocalHeadT $ \st h -> do
+ ( x, h' ) <- act st h
+ let (LocalHeadT act') = f x
+ act' st h'
+
+instance MonadIO m => MonadIO (LocalHeadT h m) where
+ liftIO act = LocalHeadT $ \_ h -> ( , h ) <$> liftIO act
+
+instance MonadIO m => MonadStorage (LocalHeadT h m) where
+ getStorage = LocalHeadT $ \st h -> return ( st, h )
+
+instance (HeadType h, MonadIO m) => MonadHead h (LocalHeadT h m) where
+ updateLocalHead f = LocalHeadT $ \st ( h, c ) -> do
+ let LocalHeadT act = f h
+ ( ( h'', x ), ( _, c' ) ) <- act st ( h, c )
+ let c'' = headCacheUpdate h'' c'
+ return ( x, ( h'', c'' ) )
+
+ getLocalHeadCache _ = LocalHeadT $ \_ hc@( _, c ) -> return ( c, hc )
+
+
+localIdentity :: LocalState -> UnifiedIdentity
+localIdentity ls = maybe (error "failed to verify local identity")
+ (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls)
+ (validateExtendedIdentity $ lsIdentity ls)
+
+headLocalIdentity :: Head LocalState -> UnifiedIdentity
+headLocalIdentity = localIdentity . headObject
+
+
+updateLocalState :: forall m b. MonadHead LocalState m => (Stored LocalState -> m ( Stored LocalState, b )) -> m b
+updateLocalState f = updateLocalHead $ \ls -> do
+ ( ls', x ) <- f ls
+ (, x) <$> if ls' == ls
+ then return ls'
+ else mstore (fromStored ls') { lsPrev = Just $ refDigest (storedRef ls) }
+
+updateLocalState_ :: forall m. MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState)) -> m ()
+updateLocalState_ f = updateLocalState (fmap (,()) . f)
+
+
+updateSharedState_ :: forall a m. (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState)
+updateSharedState_ f = fmap fst <$> updateSharedState (fmap (,()) . f)
+
+updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
+updateSharedState f = \ls -> do
+ let shared = lsShared $ fromStored ls
+ val <- lookupSharedValueM
+ (val', x) <- f val
+ (,x) <$> if toComponents val' == toComponents val
+ then return ls
+ else do shared' <- makeSharedStateUpdate val' shared
+ mstore (fromStored ls) { lsShared = [shared'] }
+
+
+collectSharedTypeIDs :: [ Stored SharedState ] -> [ Stored SharedState ] -> [ SharedTypeID ]
+collectSharedTypeIDs since (x : xs)
+ | any (x `precedesOrEquals`) since
+ = collectSharedTypeIDs since xs
+ | otherwise
+ = maybeToList (ssType (fromStored x)) `mergeUniq` collectSharedTypeIDs since (ssPrev (fromStored x) ++ xs)
+collectSharedTypeIDs _ [] = []
+
+lookupSharedValueObjects :: SharedTypeID -> [ Stored SharedState ] -> [ Stored SharedState ] -> StoredTips SharedState
+lookupSharedValueObjects sid since = filterAncestors . helper
+ where
+ helper (x : xs)
+ | any (x `precedesOrEquals`) since = helper xs
+ | ssType (fromStored x) == Just sid = x : helper xs
+ | otherwise = helper $ ssPrev (fromStored x) ++ xs
+ helper [] = []
+
+lookupSharedValueC :: forall a. SharedType a => HeadCacheType LocalState -> a
+lookupSharedValueC = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) .
+ fromMaybe [] . MS.lookup (sharedTypeID @a Proxy) . lscSharedCache
+
+lookupSharedValueH :: forall a. SharedType a => Head LocalState -> a
+lookupSharedValueH = lookupSharedValueC . headCache
+
+lookupSharedValueHC :: forall a. SharedType a => Stored LocalState -> HeadCacheType LocalState -> a
+lookupSharedValueHC _ = lookupSharedValueC
+
+lookupSharedValueM :: forall a m. (SharedType a, MonadHead LocalState m) => m a
+lookupSharedValueM = lookupSharedValueC <$> getLocalHeadCache @LocalState Proxy
+
+lookupSharedValue :: forall a. SharedType a => [ Stored SharedState ] -> a
+lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) . lookupSharedValueObjects (sharedTypeID @a Proxy) []
+
+makeSharedStateUpdate :: forall a m. (SharedType a, MonadStorage m) => a -> [ Stored SharedState ] -> m (Stored SharedState)
+makeSharedStateUpdate val prev = mstore SharedState
+ { ssPrev = prev
+ , ssType = Just $ sharedTypeID @a Proxy
+ , ssValue = storedRef <$> toComponents val
+ }
+
+
+mergeSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m UnifiedIdentity
+mergeSharedIdentity = updateLocalState $ updateSharedState $ \case
+ Just cidentity -> do
+ identity <- mergeIdentity cidentity
+ return (Just $ toComposedIdentity identity, identity)
+ Nothing -> throwOtherError "no existing shared identity"
generated by cgit v1.2.3 (git 2.25.1) at 2026-08-19 20:27:54 +0000