diff options
Diffstat (limited to 'src/Erebos/Storage')
| -rw-r--r-- | src/Erebos/Storage/Disk.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Storage/Head.hs | 9 | ||||
| -rw-r--r-- | src/Erebos/Storage/Internal.hs | 76 | ||||
| -rw-r--r-- | src/Erebos/Storage/Memory.hs | 20 | ||||
| -rw-r--r-- | src/Erebos/Storage/Merge.hs | 45 |
5 files changed, 95 insertions, 57 deletions
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/Head.hs b/src/Erebos/Storage/Head.hs index 8f8e009..285902d 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.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..db211bb 100644 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -1,32 +1,55 @@ -module Erebos.Storage.Internal where +module Erebos.Storage.Internal ( + Storage'(..), Storage, PartialStorage, + Ref'(..), Ref, PartialRef, + RefDigest(..), + WatchID, startWatchID, nextWatchID, + WatchList(..), WatchListItem(..), watchListAdd, watchListDel, + + refStorage, + refDigest, refDigestFromByteString, + showRef, showRefDigest, showRefDigestParts, + readRefDigest, + hashToRefDigest, + + StorageCompleteness(..), + StorageBackend(..), + Complete, Partial, + + unsafeStoreRawBytes, + ioLoadBytesFromStorage, + + Generation(..), + HeadID(..), HeadTypeID(..), + Stored(..), storedStorage, +) 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.Function 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 @@ -196,35 +219,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,17 +240,20 @@ newtype HeadID = HeadID UUID newtype HeadTypeID = HeadTypeID UUID deriving (Eq, Ord) -data Stored' c a = Stored (Ref' c) a +data Stored a = Stored + { storedRef' :: Ref + , storedObject' :: a + } deriving (Show) -instance Eq (Stored' c a) where - Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2 +instance Eq (Stored a) where + (==) = (==) `on` (refDigest . storedRef') -instance Ord (Stored' c a) where - compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2) +instance Ord (Stored a) where + compare = compare `on` (refDigest . storedRef') -storedStorage :: Stored' c a -> Storage' c -storedStorage (Stored (Ref st _) _) = st +storedStorage :: Stored a -> Storage +storedStorage = refStorage . storedRef' type Complete = Identity 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..8221e91 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,6 +17,8 @@ module Erebos.Storage.Merge ( findProperty, findPropertyFirst, + + storedDifference, ) where import Control.Concurrent.MVar @@ -25,6 +27,8 @@ import Data.ByteString.Char8 qualified as BC import Data.HashTable.IO qualified as HT import Data.Kind import Data.List +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Set (Set) import Data.Set qualified as S @@ -52,7 +56,7 @@ 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 +storeMerge xs@(x : _) = wrappedStore (storedStorage x) $ mergeSorted $ filterAncestors xs previous :: Storable a => Stored a -> [Stored a] previous (Stored ref _) = case load ref of @@ -100,16 +104,24 @@ storedGeneration 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)) +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 ) -- |Returns set containing all given objects and their ancestors ancestors :: Storable a => [Stored a] -> Set (Stored a) -ancestors = last . (S.empty:) . generations +ancestors = NE.last . generations precedes :: Storable a => Stored a -> Stored a -> Bool precedes x y = not $ x `elem` filterAncestors [x, y] @@ -162,3 +174,18 @@ findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filte 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 |