summaryrefslogtreecommitdiff
path: root/src/Erebos/Storage
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Storage')
-rw-r--r--src/Erebos/Storage/Backend.hs12
-rw-r--r--src/Erebos/Storage/Disk.hs2
-rw-r--r--src/Erebos/Storage/Graph.hs248
-rw-r--r--src/Erebos/Storage/Head.hs13
-rw-r--r--src/Erebos/Storage/Internal.hs106
-rw-r--r--src/Erebos/Storage/Key.hs4
-rw-r--r--src/Erebos/Storage/Memory.hs20
-rw-r--r--src/Erebos/Storage/Merge.hs131
8 files changed, 319 insertions, 217 deletions
diff --git a/src/Erebos/Storage/Backend.hs b/src/Erebos/Storage/Backend.hs
index 620d423..07bd63e 100644
--- a/src/Erebos/Storage/Backend.hs
+++ b/src/Erebos/Storage/Backend.hs
@@ -9,12 +9,17 @@ module Erebos.Storage.Backend (
Complete, Partial,
Storage, PartialStorage,
newStorage,
+ withStorageBackend,
+
+ refDigestBytes,
WatchID, startWatchID, nextWatchID,
) where
import Control.Concurrent.MVar
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
import Data.HashTable.IO qualified as HT
import Erebos.Object.Internal
@@ -26,3 +31,10 @@ newStorage stBackend = do
stRefGeneration <- newMVar =<< HT.new
stRefRoots <- newMVar =<< HT.new
return Storage {..}
+
+withStorageBackend :: Storage' c -> (forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => bck -> IO a) -> IO a
+withStorageBackend Storage {..} f = f stBackend
+
+
+refDigestBytes :: RefDigest -> ByteString
+refDigestBytes = BA.convert
diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs
index 370c584..8e35940 100644
--- a/src/Erebos/Storage/Disk.hs
+++ b/src/Erebos/Storage/Disk.hs
@@ -18,7 +18,6 @@ import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Function
import Data.List
import Data.Maybe
-import Data.UUID qualified as U
import System.Directory
import System.FSNotify
@@ -31,6 +30,7 @@ import Erebos.Storage.Backend
import Erebos.Storage.Head
import Erebos.Storage.Internal
import Erebos.Storage.Platform
+import Erebos.UUID qualified as U
data DiskStorage = StorageDir
diff --git a/src/Erebos/Storage/Graph.hs b/src/Erebos/Storage/Graph.hs
new file mode 100644
index 0000000..815e0f7
--- /dev/null
+++ b/src/Erebos/Storage/Graph.hs
@@ -0,0 +1,248 @@
+module Erebos.Storage.Graph (
+ Generation,
+ showGeneration,
+ compareGeneration, generationMax,
+ storedGeneration,
+
+ generations, generationsBy,
+ ancestors,
+ precedes,
+ precedesOrEquals,
+ filterAncestors,
+ commonAncestors,
+ storedRoots,
+ walkAncestors,
+
+ findProperty,
+ findPropertyFirst,
+
+ storedDifference,
+
+ Graph,
+ graphFromTips, graphRemoveTips,
+ graphSize,
+ graphToList,
+) where
+
+import Control.Arrow
+import Control.Concurrent.MVar
+
+import Data.ByteString.Char8 qualified as BC
+import Data.HashTable.IO qualified as HT
+import Data.List
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe
+import Data.Ord
+import Data.Set (Set)
+import Data.Set qualified as S
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Erebos.Object.Internal
+import Erebos.Storable.Internal
+import Erebos.Storage.Internal
+import Erebos.Util
+
+
+previous :: Storable a => Stored a -> [Stored a]
+previous (Stored ref _) = case load ref of
+ Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items
+ , Rec ditems <- load dref ->
+ map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $
+ map snd $ filter ((`elem` [ BC.pack "SPREV", BC.pack "SBASE" ]) . fst) ditems
+
+ | otherwise ->
+ map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $
+ map snd $ filter ((`elem` [ BC.pack "PREV", BC.pack "BASE" ]) . fst) items
+ _ -> []
+
+
+nextGeneration :: [Generation] -> Generation
+nextGeneration = foldl' helper (Generation 0)
+ where helper (Generation c) (Generation n) | c <= n = Generation (n + 1)
+ | otherwise = Generation c
+
+showGeneration :: Generation -> String
+showGeneration (Generation x) = show x
+
+compareGeneration :: Generation -> Generation -> Maybe Ordering
+compareGeneration (Generation x) (Generation y) = Just $ compare x y
+
+generationMax :: Storable a => [Stored a] -> Maybe (Stored a)
+generationMax (x : xs) = Just $ snd $ foldl' helper (storedGeneration x, x) xs
+ where helper (mg, mx) y = let yg = storedGeneration y
+ in case compareGeneration mg yg of
+ Just LT -> (yg, y)
+ _ -> (mg, mx)
+generationMax [] = Nothing
+
+storedGeneration :: Storable a => Stored a -> Generation
+storedGeneration x =
+ unsafePerformIO $ withMVar (stRefGeneration $ refStorage $ storedRef x) $ \ht -> do
+ let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case
+ Just gen -> return gen
+ Nothing -> do
+ gen <- nextGeneration <$> mapM doLookup (previous y)
+ HT.insert ht (refDigest $ storedRef y) gen
+ return gen
+ doLookup x
+
+
+-- |Returns list of sets starting with the set of given objects and
+-- intcrementally adding parents.
+generations :: Storable a => [ Stored a ] -> NonEmpty (Set (Stored a))
+generations = generationsBy previous
+
+-- |Returns list of sets starting with the set of given objects and
+-- intcrementally adding parents, with the first parameter being
+-- a function to get all the parents of given object.
+generationsBy :: Ord a => (a -> [ a ]) -> [ a ] -> NonEmpty (Set a)
+generationsBy parents xs = NE.unfoldr gen ( xs, S.fromList xs )
+ where
+ gen ( hs, cur ) = ( cur, ) $
+ case filter (`S.notMember` cur) (parents =<< hs) of
+ [] -> Nothing
+ added -> let next = foldr S.insert cur added
+ in Just ( added, next )
+
+
+type StoredTips a = [ Stored a ]
+
+-- |Returns set containing all given objects and their ancestors
+ancestors :: Storable a => [Stored a] -> Set (Stored a)
+ancestors = NE.last . generations
+
+precedes :: Storable a => Stored a -> Stored a -> Bool
+precedes x y = not $ x `elem` filterAncestors [x, y]
+
+precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool
+precedesOrEquals x y = filterAncestors [ x, y ] == [ y ]
+
+filterAncestors :: Storable a => [ Stored a ] -> StoredTips a
+filterAncestors [ x ] = [ x ]
+filterAncestors xs = let xs' = uniq $ sort xs
+ in helper xs' xs'
+ where helper remains walk = case generationMax walk of
+ Just x -> let px = previous x
+ remains' = filter (\r -> all (/=r) px) remains
+ in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)
+ Nothing -> remains
+
+commonAncestors :: Storable a => [ Stored a ] -> [ Stored a ] -> StoredTips a
+commonAncestors [] _ = []
+commonAncestors _ [] = []
+commonAncestors oxs oys = sort $ gom oxs' oys'
+ where
+ maximumGen = maximumBy (comparing (\(Generation n) -> n))
+ oxs' = map (storedGeneration &&& id) oxs
+ oys' = map (storedGeneration &&& id) oys
+
+ gom [] _ = []
+ gom _ [] = []
+ gom xs ys = go (maximumGen (map fst xs ++ map fst ys)) xs ys
+
+ go g xs ys =
+ let ( cxs, nxs ) = partition ((g ==) . fst) xs
+ ( cys, nys ) = partition ((g ==) . fst) ys
+ ( common, ( cxs', cys' ) ) = takeCommon (uniq $ sort $ map snd cxs) (uniq $ sort $ map snd cys)
+ pxs = map (storedGeneration &&& id) $ concatMap previous cxs'
+ pys = map (storedGeneration &&& id) $ concatMap previous cys'
+ in case ( pxs, pys ) of
+ ( [], [] ) -> common ++ gom nxs nys
+ ( _ , _ ) -> common ++ go (maximumGen (map fst pxs ++ map fst pys)) (pxs ++ nxs) (pys ++ nys)
+
+ takeCommon (x : xs) (y : ys)
+ | x < y = second (first (x :)) $ takeCommon xs (y : ys)
+ | y < x = second (second (y :)) $ takeCommon (x : xs) ys
+ | otherwise = first (x :) $ takeCommon xs ys
+ takeCommon [] ys = ( [], ( [], ys ))
+ takeCommon xs [] = ( [], ( xs, [] ))
+
+
+storedRoots :: Storable a => Stored a -> [ Stored a ]
+storedRoots x = do
+ let st = refStorage $ storedRef x
+ unsafePerformIO $ withMVar (stRefRoots st) $ \ht -> do
+ let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case
+ Just roots -> return roots
+ Nothing -> do
+ roots <- case previous y of
+ [] -> return [ refDigest $ storedRef y ]
+ ps -> foldl' mergeUniq [] <$> mapM doLookup ps
+ HT.insert ht (refDigest $ storedRef y) roots
+ return roots
+ map (wrappedLoad . Ref st) <$> doLookup x
+
+walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m
+walkAncestors f = helper . sortBy cmp
+ where
+ helper (x : y : xs) | x == y = helper (x : xs)
+ helper (x : xs) = f x <> helper (mergeBy cmp (sortBy cmp (previous x)) xs)
+ helper [] = mempty
+
+ cmp x y = case compareGeneration (storedGeneration x) (storedGeneration y) of
+ Just LT -> GT
+ Just GT -> LT
+ _ -> compare x y
+
+findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
+findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads sel =<<)
+
+findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b
+findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filterAncestors . (findPropHeads sel =<<)
+
+findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
+findPropHeads sel sobj | Just _ <- sel $ fromStored sobj = [sobj]
+ | otherwise = findPropHeads sel =<< previous sobj
+
+
+-- | Compute symmetrict difference between two stored histories. In other
+-- words, return all 'Stored a' objects reachable (via 'previous') from first
+-- given set, but not from the second; and vice versa.
+storedDifference :: Storable a => [ Stored a ] -> [ Stored a ] -> [ Stored a ]
+storedDifference xs' ys' =
+ let xs = filterAncestors xs'
+ ys = filterAncestors ys'
+
+ filteredPrevious blocked zs = filterAncestors (previous zs ++ blocked) `diffSorted` blocked
+ xg = S.toAscList $ NE.last $ generationsBy (filteredPrevious ys) $ filterAncestors (xs ++ ys) `diffSorted` ys
+ yg = S.toAscList $ NE.last $ generationsBy (filteredPrevious xs) $ filterAncestors (ys ++ xs) `diffSorted` xs
+
+ in xg `mergeUniq` yg
+
+
+data Graph a = Graph
+ { graphHead :: StoredTips a
+ , graphTail :: StoredTips a
+ }
+
+graphFromTips :: StoredTips a -> Graph a
+graphFromTips h = Graph h []
+
+graphRemoveTips :: Storable a => StoredTips a -> Graph a -> Graph a
+graphRemoveTips remove g =
+ let gheads = filter (\h -> not $ any (h `precedesOrEquals`) remove) (graphHead g)
+ gtails = commonAncestors gheads $ graphTail g ++ remove
+ in Graph { graphHead = gheads, graphTail = gtails }
+
+graphSize :: Storable a => Graph a -> Int
+graphSize = length . graphToList (\_ _ -> EQ)
+
+graphToList :: Storable a => (Stored a -> Stored a -> Ordering) -> Graph a -> [ Stored a ]
+graphToList cmp Graph {..} = go S.empty graphHead
+ where
+ go _ [] = []
+ go used (x : xs)
+ | ( x', xs' ) <- selectMax x xs
+ = x' : go (S.insert x used) (xs' ++ filter (\(p :: Stored a) -> not $ p `S.member` used || any (p `precedesOrEquals`) graphTail) (previous x))
+
+ cmp' x y = case cmp x y of EQ -> compare x y
+ o -> o
+
+ selectMax y (x : xs)
+ = case cmp' y x of
+ LT -> (y :) <$> selectMax x xs
+ EQ -> selectMax y xs
+ GT -> (x :) <$> selectMax y xs
+ selectMax y [] = ( y, [] )
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
index 8f8e009..f6ddcfa 100644
--- a/src/Erebos/Storage/Head.hs
+++ b/src/Erebos/Storage/Head.hs
@@ -28,13 +28,12 @@ import Control.Monad.Reader
import Data.Bifunctor
import Data.Typeable
-import Data.UUID qualified as U
-import Data.UUID.V4 qualified as U
-import Erebos.Object
-import Erebos.Storable
+import Erebos.Object.Internal
+import Erebos.Storable.Internal
import Erebos.Storage.Backend
import Erebos.Storage.Internal
+import Erebos.UUID qualified as U
-- | Represents loaded Erebos storage head, along with the object it pointed to
@@ -114,7 +113,7 @@ loadHeadRaw st@Storage {..} tid hid = do
-- | Reload the given head from storage, returning `Head' with updated object,
-- or `Nothing' if there is no longer head with the particular ID in storage.
reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a))
-reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid
+reloadHead (Head hid val) = loadHead (storedStorage val) hid
-- | Store a new `Head' of type 'a' in the storage.
storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a)
@@ -233,8 +232,8 @@ watchHeadWith
-> (Head a -> b) -- ^ Selector function
-> (b -> IO ()) -- ^ Callback
-> IO WatchedHead -- ^ Watched head handle
-watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
- watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb
+watchHeadWith (Head hid val) sel cb = do
+ watchHeadRaw (storedStorage val) (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb
-- | Watch the given head using raw IDs and a selector from `Ref'.
watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 6df1410..e6fafe4 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -1,32 +1,49 @@
-module Erebos.Storage.Internal where
+module Erebos.Storage.Internal (
+ Storage'(..), Storage, PartialStorage,
+ RefDigest(..),
+ WatchID, startWatchID, nextWatchID,
+ WatchList(..), WatchListItem(..), watchListAdd, watchListDel,
+
+ refDigestFromByteString,
+ showRefDigest, showRefDigestParts,
+ readRefDigest,
+ hashToRefDigest,
+
+ StorageCompleteness(..),
+ StorageBackend(..),
+ Complete, Partial,
+
+ ioLoadBytesFromStorage,
+
+ Generation(..),
+ HeadID(..), HeadTypeID(..),
+) where
import Control.Arrow
import Control.Concurrent
import Control.DeepSeq
-import Control.Exception
-import Control.Monad
import Control.Monad.Identity
import Crypto.Hash
import Data.Bits
-import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
+import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
-import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
-import Data.Char
import Data.HashTable.IO qualified as HT
import Data.Hashable
import Data.Kind
import Data.Typeable
-import Data.UUID (UUID)
import Foreign.Storable (peek)
import System.IO.Unsafe (unsafePerformIO)
+import Erebos.UUID (UUID)
+import Erebos.Util
+
data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage
{ stBackend :: bck
@@ -157,36 +174,9 @@ newtype RefDigest = RefDigest (Digest Blake2b_256)
instance Show RefDigest where
show = BC.unpack . showRefDigest
-data Ref' c = Ref (Storage' c) RefDigest
-
-type Ref = Ref' Complete
-type PartialRef = Ref' Partial
-
-instance Eq (Ref' c) where
- Ref _ d1 == Ref _ d2 = d1 == d2
-
-instance Show (Ref' c) where
- show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref)
-
-instance ByteArrayAccess (Ref' c) where
- length (Ref _ dgst) = BA.length dgst
- withByteArray (Ref _ dgst) = BA.withByteArray dgst
-
instance Hashable RefDigest where
hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek)
-instance Hashable (Ref' c) where
- hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek)
-
-refStorage :: Ref' c -> Storage' c
-refStorage (Ref st _) = st
-
-refDigest :: Ref' c -> RefDigest
-refDigest (Ref _ dgst) = dgst
-
-showRef :: Ref' c -> ByteString
-showRef = showRefDigest . refDigest
-
showRefDigestParts :: RefDigest -> (ByteString, ByteString)
showRefDigestParts x = (BC.pack "blake2", showHex x)
@@ -196,35 +186,15 @@ showRefDigest = showRefDigestParts >>> \(alg, hex) -> alg <> BC.pack "#" <> hex
readRefDigest :: ByteString -> Maybe RefDigest
readRefDigest x = case BC.split '#' x of
[alg, dgst] | BA.convert alg == BC.pack "blake2" ->
- refDigestFromByteString =<< readHex @ByteString dgst
+ refDigestFromByteString =<< readHex dgst
_ -> Nothing
-refDigestFromByteString :: ByteArrayAccess ba => ba -> Maybe RefDigest
+refDigestFromByteString :: ByteString -> Maybe RefDigest
refDigestFromByteString = fmap RefDigest . digestFromByteString
hashToRefDigest :: BL.ByteString -> RefDigest
hashToRefDigest = RefDigest . hashFinalize . hashUpdates hashInit . BL.toChunks
-showHex :: ByteArrayAccess ba => ba -> ByteString
-showHex = B.concat . map showHexByte . BA.unpack
- where showHexChar x | x < 10 = x + o '0'
- | otherwise = x + o 'a' - 10
- showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ]
- o = fromIntegral . ord
-
-readHex :: ByteArray ba => ByteString -> Maybe ba
-readHex = return . BA.concat <=< readHex'
- where readHex' bs | B.null bs = Just []
- readHex' bs = do (bx, bs') <- B.uncons bs
- (by, bs'') <- B.uncons bs'
- x <- hexDigit bx
- y <- hexDigit by
- (B.singleton (x * 16 + y) :) <$> readHex' bs''
- hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0'
- | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10
- | otherwise = Nothing
- o = fromIntegral . ord
-
newtype Generation = Generation Int
deriving (Eq, Show)
@@ -237,18 +207,6 @@ newtype HeadID = HeadID UUID
newtype HeadTypeID = HeadTypeID UUID
deriving (Eq, Ord)
-data Stored' c a = Stored (Ref' c) a
- deriving (Show)
-
-instance Eq (Stored' c a) where
- Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2
-
-instance Ord (Stored' c a) where
- compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2)
-
-storedStorage :: Stored' c a -> Storage' c
-storedStorage (Stored (Ref st _) _) = st
-
type Complete = Identity
type Partial = Either RefDigest
@@ -256,24 +214,18 @@ type Partial = Either RefDigest
class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where
type LoadResult compl a :: Type
returnLoadResult :: compl a -> LoadResult compl a
- ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)
+ unsafeLoadBytes :: Storage' compl -> RefDigest -> IO (compl BL.ByteString)
instance StorageCompleteness Complete where
type LoadResult Complete a = a
returnLoadResult = runIdentity
- ioLoadBytes ref@(Ref st dgst) = maybe (error $ "Ref not found in complete storage: "++show ref) Identity
+ unsafeLoadBytes st dgst = maybe (error $ "Ref not found in complete storage: "++show dgst) Identity
<$> ioLoadBytesFromStorage st dgst
instance StorageCompleteness Partial where
type LoadResult Partial a = Either RefDigest a
returnLoadResult = id
- ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
-
-unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st@Storage {..} raw = do
- dgst <- evaluate $ force $ hashToRefDigest raw
- backendStoreBytes stBackend dgst raw
- return $ Ref st dgst
+ unsafeLoadBytes st dgst = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
ioLoadBytesFromStorage Storage {..} dgst =
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index b615f16..85ebded 100644
--- a/src/Erebos/Storage/Key.hs
+++ b/src/Erebos/Storage/Key.hs
@@ -11,7 +11,9 @@ import Control.Monad.IO.Class
import Data.ByteArray
import Data.Typeable
-import Erebos.Storable
+import Erebos.Error
+import Erebos.Object.Internal
+import Erebos.Storable.Internal
import Erebos.Storage.Internal
class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
diff --git a/src/Erebos/Storage/Memory.hs b/src/Erebos/Storage/Memory.hs
index 677e8c5..26bb181 100644
--- a/src/Erebos/Storage/Memory.hs
+++ b/src/Erebos/Storage/Memory.hs
@@ -4,7 +4,8 @@ module Erebos.Storage.Memory (
derivePartialStorage,
) where
-import Control.Concurrent.MVar
+import Control.Concurrent
+import Control.Monad
import Data.ByteArray (ScrubbedBytes)
import Data.ByteString.Lazy qualified as BL
@@ -62,14 +63,19 @@ instance (StorageCompleteness c, Typeable p) => StorageBackend (MemoryStorage p
backendReplaceHead StorageMemory {..} tid hid expected new = do
res <- modifyMVar memHeads $ \hs -> do
- ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers
- return $ case partition ((==(tid, hid)) . fst) hs of
- ( [] , _ ) -> ( hs, Left Nothing )
+ case partition ((==(tid, hid)) . fst) hs of
+ ( [] , _ ) -> return ( hs, Left Nothing )
(( _, dgst ) : _, hs' )
- | dgst == expected -> ((( tid, hid ), new ) : hs', Right ( new, ws ))
- | otherwise -> ( hs, Left $ Just dgst )
+ | dgst == expected -> do
+ ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers
+ return ((( tid, hid ), new ) : hs', Right ( new, ws ))
+ | otherwise -> do
+ return ( hs, Left $ Just dgst )
case res of
- Right ( dgst, ws ) -> mapM_ ($ dgst) ws >> return (Right dgst)
+ Right ( dgst, ws ) -> do
+ void $ forkIO $ do
+ mapM_ ($ dgst) ws
+ return (Right dgst)
Left x -> return $ Left x
backendWatchHead StorageMemory {..} tid hid cb = modifyMVar memWatchers $ return . watchListAdd tid hid cb
diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
index 41725af..ebb14bd 100644
--- a/src/Erebos/Storage/Merge.hs
+++ b/src/Erebos/Storage/Merge.hs
@@ -7,7 +7,7 @@ module Erebos.Storage.Merge (
compareGeneration, generationMax,
storedGeneration,
- generations,
+ generations, generationsBy,
ancestors,
precedes,
precedesOrEquals,
@@ -17,24 +17,16 @@ module Erebos.Storage.Merge (
findProperty,
findPropertyFirst,
-) where
-import Control.Concurrent.MVar
+ storedDifference,
+) where
-import Data.ByteString.Char8 qualified as BC
-import Data.HashTable.IO qualified as HT
import Data.Kind
-import Data.List
-import Data.Maybe
-import Data.Set (Set)
-import Data.Set qualified as S
-
-import System.IO.Unsafe (unsafePerformIO)
import Erebos.Object
-import Erebos.Storable
-import Erebos.Storage.Internal
-import Erebos.Util
+import Erebos.Storable.Internal
+import Erebos.Storage.Graph
+
class Storable (Component a) => Mergeable a where
type Component a :: Type
@@ -52,113 +44,4 @@ merge xs = mergeSorted $ filterAncestors xs
storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a)
storeMerge [] = error "merge: empty list"
-storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs
-
-previous :: Storable a => Stored a -> [Stored a]
-previous (Stored ref _) = case load ref of
- Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items
- , Rec ditems <- load dref ->
- map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $
- map snd $ filter ((`elem` [ BC.pack "SPREV", BC.pack "SBASE" ]) . fst) ditems
-
- | otherwise ->
- map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $
- map snd $ filter ((`elem` [ BC.pack "PREV", BC.pack "BASE" ]) . fst) items
- _ -> []
-
-
-nextGeneration :: [Generation] -> Generation
-nextGeneration = foldl' helper (Generation 0)
- where helper (Generation c) (Generation n) | c <= n = Generation (n + 1)
- | otherwise = Generation c
-
-showGeneration :: Generation -> String
-showGeneration (Generation x) = show x
-
-compareGeneration :: Generation -> Generation -> Maybe Ordering
-compareGeneration (Generation x) (Generation y) = Just $ compare x y
-
-generationMax :: Storable a => [Stored a] -> Maybe (Stored a)
-generationMax (x : xs) = Just $ snd $ foldl' helper (storedGeneration x, x) xs
- where helper (mg, mx) y = let yg = storedGeneration y
- in case compareGeneration mg yg of
- Just LT -> (yg, y)
- _ -> (mg, mx)
-generationMax [] = Nothing
-
-storedGeneration :: Storable a => Stored a -> Generation
-storedGeneration x =
- unsafePerformIO $ withMVar (stRefGeneration $ refStorage $ storedRef x) $ \ht -> do
- let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case
- Just gen -> return gen
- Nothing -> do
- gen <- nextGeneration <$> mapM doLookup (previous y)
- HT.insert ht (refDigest $ storedRef y) gen
- return gen
- doLookup x
-
-
--- |Returns list of sets starting with the set of given objects and
--- intcrementally adding parents.
-generations :: Storable a => [Stored a] -> [Set (Stored a)]
-generations = unfoldr gen . (,S.empty)
- where gen (hs, cur) = case filter (`S.notMember` cur) hs of
- [] -> Nothing
- added -> let next = foldr S.insert cur added
- in Just (next, (previous =<< added, next))
-
--- |Returns set containing all given objects and their ancestors
-ancestors :: Storable a => [Stored a] -> Set (Stored a)
-ancestors = last . (S.empty:) . generations
-
-precedes :: Storable a => Stored a -> Stored a -> Bool
-precedes x y = not $ x `elem` filterAncestors [x, y]
-
-precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool
-precedesOrEquals x y = filterAncestors [ x, y ] == [ y ]
-
-filterAncestors :: Storable a => [Stored a] -> [Stored a]
-filterAncestors [x] = [x]
-filterAncestors xs = let xs' = uniq $ sort xs
- in helper xs' xs'
- where helper remains walk = case generationMax walk of
- Just x -> let px = previous x
- remains' = filter (\r -> all (/=r) px) remains
- in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)
- Nothing -> remains
-
-storedRoots :: Storable a => Stored a -> [Stored a]
-storedRoots x = do
- let st = refStorage $ storedRef x
- unsafePerformIO $ withMVar (stRefRoots st) $ \ht -> do
- let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case
- Just roots -> return roots
- Nothing -> do
- roots <- case previous y of
- [] -> return [refDigest $ storedRef y]
- ps -> map (refDigest . storedRef) . filterAncestors . map (wrappedLoad @Object . Ref st) . concat <$> mapM doLookup ps
- HT.insert ht (refDigest $ storedRef y) roots
- return roots
- map (wrappedLoad . Ref st) <$> doLookup x
-
-walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m
-walkAncestors f = helper . sortBy cmp
- where
- helper (x : y : xs) | x == y = helper (x : xs)
- helper (x : xs) = f x <> helper (mergeBy cmp (sortBy cmp (previous x)) xs)
- helper [] = mempty
-
- cmp x y = case compareGeneration (storedGeneration x) (storedGeneration y) of
- Just LT -> GT
- Just GT -> LT
- _ -> compare x y
-
-findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
-findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads sel =<<)
-
-findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b
-findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filterAncestors . (findPropHeads sel =<<)
-
-findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
-findPropHeads sel sobj | Just _ <- sel $ fromStored sobj = [sobj]
- | otherwise = findPropHeads sel =<< previous sobj
+storeMerge xs@(x : _) = wrappedStore (storedStorage x) $ mergeSorted $ filterAncestors xs
generated by cgit v1.2.3 (git 2.25.1) at 2026-06-20 03:40:12 +0000