diff options
Diffstat (limited to 'src/Erebos/Storage')
| -rw-r--r-- | src/Erebos/Storage/Backend.hs | 12 | ||||
| -rw-r--r-- | src/Erebos/Storage/Disk.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Storage/Graph.hs | 293 | ||||
| -rw-r--r-- | src/Erebos/Storage/Head.hs | 126 | ||||
| -rw-r--r-- | src/Erebos/Storage/Internal.hs | 106 | ||||
| -rw-r--r-- | src/Erebos/Storage/Key.hs | 4 | ||||
| -rw-r--r-- | src/Erebos/Storage/Memory.hs | 20 | ||||
| -rw-r--r-- | src/Erebos/Storage/Merge.hs | 132 | ||||
| -rw-r--r-- | src/Erebos/Storage/Monad.hs | 37 |
9 files changed, 497 insertions, 235 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..99ad3e6 --- /dev/null +++ b/src/Erebos/Storage/Graph.hs @@ -0,0 +1,293 @@ +module Erebos.Storage.Graph ( + Generation, + showGeneration, + compareGeneration, generationMax, + storedGeneration, + + StoredTips, + generations, generationsBy, + ancestors, + precedes, + precedesOrEquals, + filterAncestors, + commonAncestors, + storedRoots, + walkAncestors, + + Property, + emptyProperty, + propertyValue, propertyValueFirst, + findProperty', findPropertyUpdate, + 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 + + +data Property a b = Property + { propSelector :: Stored a -> Maybe b + , propSource :: [ Stored a ] + , propHeads :: StoredTips a + } + +emptyProperty :: (a -> Maybe b) -> Property a b +emptyProperty sel = Property + { propSelector = sel . fromStored + , propSource = [] + , propHeads = [] + } + +propertyValue :: Property a b -> [ b ] +propertyValue Property {..} = map (fromJust . propSelector) $ propHeads + +propertyValueFirst :: Property a b -> Maybe b +propertyValueFirst Property {..} = fmap (fromJust . propSelector) $ listToMaybe $ propHeads + +findProperty' :: forall a b. Storable a => (a -> Maybe b) -> [ Stored a ] -> Property a b +findProperty' sel propSource = + let propSelector = sel . fromStored + propHeads = filterAncestors $ findPropHeads (isJust . propSelector) =<< propSource + in Property {..} + +findPropertyUpdate :: forall a b. Storable a => Property a b -> [ Stored a ] -> Property a b +findPropertyUpdate prop source = prop + { propSource = source + , propHeads = secondPass + } + where + selectedOrOldSource x = x `elem` propSource prop || isJust (propSelector prop x) + firstPass = findPropHeads selectedOrOldSource =<< source + ( foundOldSource, foundNewHeads ) = partition (`elem` propSource prop) firstPass + secondPass = filterAncestors $ if + | sort foundOldSource == propSource prop -> propHeads prop ++ foundNewHeads + | otherwise -> (findPropHeads (isJust . propSelector prop) =<< foundOldSource) ++ foundNewHeads + +findProperty :: forall a b. Storable a => (a -> Maybe b) -> [ Stored a ] -> [ b ] +findProperty sel = propertyValue . findProperty' sel + +findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [ Stored a ] -> Maybe b +findPropertyFirst sel = propertyValueFirst . findProperty' sel + +findPropHeads :: forall a. Storable a => (Stored a -> Bool) -> Stored a -> [ Stored a ] +findPropHeads sel sobj + | sel 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..7e38af8 100644 --- a/src/Erebos/Storage/Head.hs +++ b/src/Erebos/Storage/Head.hs @@ -9,11 +9,13 @@ module Erebos.Storage.Head ( -- * Head type and accessors Head, HeadType(..), HeadID, HeadTypeID, mkHeadTypeID, - headId, headStorage, headRef, headObject, headStoredObject, + headId, headStorage, + headRef, headObject, headStoredObject, + headCache, -- * Loading and storing heads loadHeads, loadHead, reloadHead, - storeHead, replaceHead, updateHead, updateHead_, + storeHead, replaceHead, updateHead, updateHead', updateHead_, loadHeadRaw, storeHeadRaw, replaceHeadRaw, -- * Watching heads @@ -27,14 +29,15 @@ import Control.Monad import Control.Monad.Reader import Data.Bifunctor +import Data.Kind 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.Storage.Monad +import Erebos.UUID qualified as U -- | Represents loaded Erebos storage head, along with the object it pointed to @@ -43,8 +46,15 @@ import Erebos.Storage.Internal -- Each possible head type has associated unique ID, represented as -- `HeadTypeID'. For each type, there can be multiple individual heads in given -- storage, each also identified by unique ID (`HeadID'). -data Head a = Head HeadID (Stored a) - deriving (Eq, Show) +data Head a = Head HeadID (Stored a) !(HeadCacheType a) + +instance Eq (Head a) where + h == h' = headId h == headId h' && + headStorage h == headStorage h' && + headStoredObject h == headStoredObject h' + +instance Show (Head a) where + show h = "Head " <> show (headId h) <> " " <> show (storedRef $ headStoredObject h) -- | Instances of this class can be used as objects pointed to by heads in -- Erebos storage. Each such type must be `Storable' and have a unique ID. @@ -58,13 +68,28 @@ class Storable a => HeadType a where headTypeID :: proxy a -> HeadTypeID -- ^ Get the ID of the given head type; must be unique for each `HeadType' instance. + type HeadCacheType a :: Type + type HeadCacheType a = () + + headCacheInit :: Stored a -> HeadCacheType a + default headCacheInit :: HeadCacheType a ~ () => Stored a -> HeadCacheType a + headCacheInit _ = () + + headCacheUpdate :: Stored a -> HeadCacheType a -> HeadCacheType a + default headCacheUpdate :: HeadCacheType a ~ () => Stored a -> HeadCacheType a -> HeadCacheType a + headCacheUpdate _ _ = () + instance MonadIO m => MonadStorage (ReaderT (Head a) m) where getStorage = asks $ headStorage +initHead :: HeadType a => HeadID -> Stored a -> Head a +initHead hid obj = Head hid obj (headCacheInit obj) + + -- | Get `HeadID' associated with given `Head'. headId :: Head a -> HeadID -headId (Head uuid _) = uuid +headId (Head uuid _ _) = uuid -- | Get storage from which the `Head' was loaded. headStorage :: Head a -> Storage @@ -72,15 +97,18 @@ headStorage = refStorage . headRef -- | Get `Ref' of the `Head'\'s associated object. headRef :: Head a -> Ref -headRef (Head _ sx) = storedRef sx +headRef (Head _ sx _) = storedRef sx -- | Get the object the `Head' pointed to when it was loaded. headObject :: Head a -> a -headObject (Head _ sx) = fromStored sx +headObject (Head _ sx _) = fromStored sx -- | Get the object the `Head' pointed to when it was loaded as a `Stored' value. headStoredObject :: Head a -> Stored a -headStoredObject (Head _ sx) = sx +headStoredObject (Head _ sx _) = sx + +headCache :: Head a -> HeadCacheType a +headCache (Head _ _ cache) = cache -- | Create `HeadTypeID' from string representation of UUID. mkHeadTypeID :: String -> HeadTypeID @@ -90,7 +118,7 @@ mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString -- | Load all `Head's of type @a@ from storage. loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] loadHeads st@Storage {..} = - map (uncurry Head . fmap (wrappedLoad . Ref st)) + map (uncurry initHead . fmap (wrappedLoad . Ref st)) <$> liftIO (backendLoadHeads stBackend (headTypeID @a Proxy)) -- | Try to load a `Head' of type @a@ from storage. @@ -99,7 +127,7 @@ loadHead => Storage -- ^ Storage from which to load the head -> HeadID -- ^ ID of the particular head -> m (Maybe (Head a)) -- ^ Head object, or `Nothing' if not found -loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid +loadHead st hid = fmap (initHead hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid -- | Try to load `Head' using a raw head and type IDs, getting `Ref' if found. loadHeadRaw @@ -113,8 +141,15 @@ 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 :: forall a m. (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) +reloadHead orig@(Head hid val cache) = do + loadHeadRaw (storedStorage val) (headTypeID @a Proxy) hid >>= \case + Just ref + | ref == storedRef val -> return $ Just orig + | otherwise -> do + let obj = wrappedLoad ref + return $ Just $ Head hid obj (headCacheUpdate obj cache) + Nothing -> return Nothing -- | Store a new `Head' of type 'a' in the storage. storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) @@ -122,7 +157,7 @@ storeHead st obj = do let tid = headTypeID @a Proxy stored <- wrappedStore st obj hid <- storeHeadRaw st tid (storedRef stored) - return $ Head hid stored + return $ initHead hid stored -- | Store a new `Head' in the storage, using the raw `HeadTypeID' and `Ref', -- the function returns the assigned `HeadID' of the new head. @@ -150,12 +185,18 @@ replaceHead -- Head value was updated in storage, the new head is @h@ (which is -- the same as first parameter with associated object replaced by -- the second parameter). -replaceHead prev@(Head hid pobj) stored' = liftIO $ do +replaceHead prev@(Head hid pobj cache) stored' = liftIO $ do let st = headStorage prev tid = headTypeID @a Proxy stored <- copyStored st stored' - bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> - replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) + replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) >>= \case + Left Nothing -> do + return $ Left Nothing + Left (Just r) -> do + let obj = wrappedLoad r + return $ Left $ Just $ Head hid obj (headCacheUpdate obj cache) + Right _ -> do + return $ Right $ Head hid stored (headCacheUpdate stored cache) -- | Try to replace existing head using raw IDs and `Ref's. replaceHeadRaw @@ -193,12 +234,28 @@ updateHead -- ^ First element contains either the new head as @`Just' h@, or -- `Nothing' in case the head no longer exists in storage. Second -- element is the value from last call to the update function. -updateHead h f = do - (o, x) <- f $ headStoredObject h +updateHead h f = updateHead' h (f . headStoredObject) + +-- | Update existing existing `Head' of type @a@ in the storage, using a given +-- function. The update function may be called multiple times in case the head +-- content changes concurrently during evaluation. +updateHead' + :: (HeadType a, MonadIO m) + => Head a -- ^ Existing head to be updated + -> (Head a -> m ( Stored a, b )) + -- ^ Function that gets current value of the head and returns updated + -- value, along with a custom extra value to be returned from + -- `updateHead' call. The function may be called multiple times. + -> m ( Maybe (Head a), b ) + -- ^ First element contains either the new head as @`Just' h@, or + -- `Nothing' in case the head no longer exists in storage. Second + -- element is the value from last call to the update function. +updateHead' h f = do + (o, x) <- f h replaceHead h o >>= \case Right h' -> return (Just h', x) Left Nothing -> return (Nothing, x) - Left (Just h') -> updateHead h' f + Left (Just h') -> updateHead' h' f -- | Update existing existing `Head' of type @a@ in the storage, using a given -- function. The update function may be called multiple times in case the head @@ -233,8 +290,27 @@ 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 orig@(Head hid val _) sel cb = do + let st = storedStorage val + + memo <- newEmptyMVar + let cb' dgst = do + let obj = wrappedLoad $ Ref st dgst + modifyMVar_ memo $ \( cache, prev ) -> do + let cache' = maybe (headCacheInit obj) (headCacheUpdate obj) cache + let x = sel $ Head hid obj cache' + when (Just x /= prev) $ cb x + return ( Just cache', Just x ) + wid <- case storedStorage val of + Storage {..} -> backendWatchHead stBackend (headTypeID @a Proxy) hid cb' + + h <- reloadHead orig + let cur = sel <$> h + maybe (return ()) cb cur + putMVar memo ( headCache <$> h, cur ) + + return $ WatchedHead st wid memo + -- | 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..0867197 100644 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -7,7 +7,8 @@ module Erebos.Storage.Merge ( compareGeneration, generationMax, storedGeneration, - generations, + StoredTips, + generations, generationsBy, ancestors, precedes, precedesOrEquals, @@ -17,24 +18,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 +45,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 diff --git a/src/Erebos/Storage/Monad.hs b/src/Erebos/Storage/Monad.hs new file mode 100644 index 0000000..6af3ae1 --- /dev/null +++ b/src/Erebos/Storage/Monad.hs @@ -0,0 +1,37 @@ +module Erebos.Storage.Monad ( + MonadStorage(..), + mloadKey, +) where + +import Control.Monad.Except +import Control.Monad.Reader + +import Erebos.Error +import Erebos.Object.Internal +import Erebos.Storable.Internal +import Erebos.Storage.Key + + +class Monad m => MonadStorage m where + getStorage :: m Storage + mstore :: Storable a => a -> m (Stored a) + + default mstore :: MonadIO m => Storable a => a -> m (Stored a) + mstore x = do + st <- getStorage + wrappedStore st x + + mstoreKey :: KeyPair sec pub => sec -> m () + default mstoreKey :: (KeyPair sec pub, MonadIO m) => sec -> m () + mstoreKey = liftIO . storeKey + + mloadKeyMb :: KeyPair sec pub => Stored pub -> m (Maybe sec) + default mloadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) + mloadKeyMb = loadKeyMb + +mloadKey :: (KeyPair sec pub, MonadStorage m, MonadError e m, FromErebosError e) => Stored pub -> m sec +mloadKey pub = maybe (throwOtherError $ "secret key not found for " <> show (storedRef pub)) return =<< mloadKeyMb pub + + +instance MonadIO m => MonadStorage (ReaderT Storage m) where + getStorage = ask |