summaryrefslogtreecommitdiff
path: root/src/Erebos/Storage
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Storage')
-rw-r--r--src/Erebos/Storage/Disk.hs2
-rw-r--r--src/Erebos/Storage/Head.hs9
-rw-r--r--src/Erebos/Storage/Internal.hs76
-rw-r--r--src/Erebos/Storage/Merge.hs18
4 files changed, 58 insertions, 47 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/Merge.hs b/src/Erebos/Storage/Merge.hs
index 41725af..819d918 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,
@@ -52,7 +52,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,12 +100,18 @@ 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
+generations :: Storable a => [ Stored a ] -> [ 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 ] -> [ Set a ]
+generationsBy parents = 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))
+ in Just ( next, ( parents =<< added, next ) )
-- |Returns set containing all given objects and their ancestors
ancestors :: Storable a => [Stored a] -> Set (Stored a)
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-19 00:34:56 +0000