summaryrefslogtreecommitdiff
path: root/src/Erebos/Storage
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Storage')
-rw-r--r--src/Erebos/Storage/Internal.hs282
-rw-r--r--src/Erebos/Storage/Key.hs85
-rw-r--r--src/Erebos/Storage/List.hs154
-rw-r--r--src/Erebos/Storage/Merge.hs160
4 files changed, 681 insertions, 0 deletions
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
new file mode 100644
index 0000000..a61e705
--- /dev/null
+++ b/src/Erebos/Storage/Internal.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE CPP #-}
+
+module Erebos.Storage.Internal where
+
+import Codec.Compression.Zlib
+
+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 qualified Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import Data.Char
+import Data.Function
+import Data.Hashable
+import qualified Data.HashTable.IO as HT
+import Data.Kind
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.UUID (UUID)
+
+import Foreign.Storable (peek)
+
+import System.Directory
+import System.FilePath
+import System.INotify (INotify)
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe (unsafePerformIO)
+import System.Posix.Files
+import System.Posix.IO
+
+
+data Storage' c = Storage
+ { stBacking :: StorageBacking c
+ , stParent :: Maybe (Storage' Identity)
+ , stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
+ , stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
+ }
+
+instance Eq (Storage' c) where
+ (==) = (==) `on` (stBacking &&& stParent)
+
+instance Show (Storage' c) where
+ show st@(Storage { stBacking = StorageDir { dirPath = path }}) = "dir" ++ showParentStorage st ++ ":" ++ path
+ show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st
+
+showParentStorage :: Storage' c -> String
+showParentStorage Storage { stParent = Nothing } = ""
+showParentStorage Storage { stParent = Just st } = "@" ++ show st
+
+data StorageBacking c
+ = StorageDir { dirPath :: FilePath
+ , dirWatchers :: MVar ([(HeadTypeID, INotify)], WatchList c)
+ }
+ | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)]
+ , memObjs :: MVar (Map RefDigest BL.ByteString)
+ , memKeys :: MVar (Map RefDigest ScrubbedBytes)
+ , memWatchers :: MVar (WatchList c)
+ }
+ deriving (Eq)
+
+newtype WatchID = WatchID Int
+ deriving (Eq, Ord, Num)
+
+data WatchList c = WatchList
+ { wlNext :: WatchID
+ , wlList :: [WatchListItem c]
+ }
+
+data WatchListItem c = WatchListItem
+ { wlID :: WatchID
+ , wlHead :: (HeadTypeID, HeadID)
+ , wlFun :: Ref' c -> IO ()
+ }
+
+
+newtype RefDigest = RefDigest (Digest Blake2b_256)
+ deriving (Eq, Ord, NFData, ByteArrayAccess)
+
+instance Show RefDigest where
+ show = BC.unpack . showRefDigest
+
+data Ref' c = Ref (Storage' c) RefDigest
+
+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)
+
+showRefDigest :: RefDigest -> ByteString
+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
+ _ -> Nothing
+
+refDigestFromByteString :: ByteArrayAccess ba => ba -> 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)
+
+data Head' c a = Head HeadID (Stored' c a)
+ deriving (Eq, Show)
+
+newtype HeadID = HeadID UUID
+ deriving (Eq, Ord, Show)
+
+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
+
+class (Traversable compl, Monad compl) => StorageCompleteness compl where
+ type LoadResult compl a :: Type
+ returnLoadResult :: compl a -> LoadResult compl a
+ ioLoadBytes :: Ref' compl -> 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
+ <$> 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 raw = do
+ let dgst = hashToRefDigest raw
+ case stBacking st of
+ StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw
+ StorageMemory { memObjs = tobjs } ->
+ dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
+ modifyMVar_ tobjs (return . M.insert dgst raw)
+ return $ Ref st dgst
+
+ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
+ioLoadBytesFromStorage st dgst = loadCurrent st >>=
+ \case Just bytes -> return $ Just bytes
+ Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst
+ | otherwise -> return Nothing
+ where loadCurrent Storage { stBacking = StorageDir { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+ Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath spath dgst)
+ loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs
+
+refPath :: FilePath -> RefDigest -> FilePath
+refPath spath rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, rest]
+ where (alg, dgst) = showRefDigestParts rdgst
+ (pref, rest) = splitAt 2 $ BC.unpack dgst
+
+
+openLockFile :: FilePath -> IO Handle
+openLockFile path = do
+ createDirectoryIfMissing True (takeDirectory path)
+ fd <- retry 10 $
+#if MIN_VERSION_unix(2,8,0)
+ openFd path WriteOnly defaultFileFlags
+ { creat = Just $ unionFileModes ownerReadMode ownerWriteMode
+ , exclusive = True
+ }
+#else
+ openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })
+#endif
+ fdToHandle fd
+ where
+ retry :: Int -> IO a -> IO a
+ retry 0 act = act
+ retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing)
+ act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act)
+
+writeFileOnce :: FilePath -> BL.ByteString -> IO ()
+writeFileOnce file content = bracket (openLockFile locked)
+ hClose $ \h -> do
+ fileExist file >>= \case
+ True -> removeLink locked
+ False -> do BL.hPut h content
+ hFlush h
+ rename locked file
+ where locked = file ++ ".lock"
+
+writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
+writeFileChecked file prev content = bracket (openLockFile locked)
+ hClose $ \h -> do
+ (prev,) <$> fileExist file >>= \case
+ (Nothing, True) -> do
+ current <- B.readFile file
+ removeLink locked
+ return $ Left $ Just current
+ (Nothing, False) -> do B.hPut h content
+ hFlush h
+ rename locked file
+ return $ Right ()
+ (Just expected, True) -> do
+ current <- B.readFile file
+ if current == expected then do B.hPut h content
+ hFlush h
+ rename locked file
+ return $ return ()
+ else do removeLink locked
+ return $ Left $ Just current
+ (Just _, False) -> do
+ removeLink locked
+ return $ Left Nothing
+ where locked = file ++ ".lock"
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
new file mode 100644
index 0000000..b6afc20
--- /dev/null
+++ b/src/Erebos/Storage/Key.hs
@@ -0,0 +1,85 @@
+module Erebos.Storage.Key (
+ KeyPair(..),
+ storeKey, loadKey, loadKeyMb,
+ moveKeys,
+) where
+
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+
+import Data.ByteArray
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
+
+import System.Directory
+import System.FilePath
+import System.IO.Error
+
+import Erebos.Storage
+import Erebos.Storage.Internal
+
+class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
+ generateKeys :: Storage -> IO (sec, Stored pub)
+ keyGetPublic :: sec -> Stored pub
+ keyGetData :: sec -> ScrubbedBytes
+ keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec
+
+
+keyFilePath :: KeyPair sec pub => FilePath -> Stored pub -> FilePath
+keyFilePath sdir pkey = sdir </> "keys" </> (BC.unpack $ showRef $ storedRef pkey)
+
+storeKey :: KeyPair sec pub => sec -> IO ()
+storeKey key = do
+ let spub = keyGetPublic key
+ case stBacking $ storedStorage spub of
+ StorageDir { dirPath = dir } -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key)
+ StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key)
+
+loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec
+loadKey pub = maybe (throwError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub
+
+loadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec)
+loadKeyMb spub = liftIO $ run $ storedStorage spub
+ where
+ run st = tryOneLevel (stBacking st) >>= \case
+ key@Just {} -> return key
+ Nothing | Just parent <- stParent st -> run parent
+ | otherwise -> return Nothing
+ tryOneLevel = \case
+ StorageDir { dirPath = dir } -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case
+ Right kdata -> return $ keyFromData (convert kdata) spub
+ Left _ -> return Nothing
+ StorageMemory { memKeys = kstore } -> (flip keyFromData spub <=< M.lookup (refDigest $ storedRef spub)) <$> readMVar kstore
+
+moveKeys :: MonadIO m => Storage -> Storage -> m ()
+moveKeys from to = liftIO $ do
+ case (stBacking from, stBacking to) of
+ (StorageDir { dirPath = fromPath }, StorageDir { dirPath = toPath }) -> do
+ files <- listDirectory (fromPath </> "keys")
+ forM_ files $ \file -> do
+ renameFile (fromPath </> "keys" </> file) (toPath </> "keys" </> file)
+
+ (StorageDir { dirPath = fromPath }, StorageMemory { memKeys = toKeys }) -> do
+ let move m file
+ | Just dgst <- readRefDigest (BC.pack file) = do
+ let path = fromPath </> "keys" </> file
+ key <- convert <$> BC.readFile path
+ removeFile path
+ return $ M.insert dgst key m
+ | otherwise = return m
+ files <- listDirectory (fromPath </> "keys")
+ modifyMVar_ toKeys $ \keys -> foldM move keys files
+
+ (StorageMemory { memKeys = fromKeys }, StorageDir { dirPath = toPath }) -> do
+ modifyMVar_ fromKeys $ \keys -> do
+ forM_ (M.assocs keys) $ \(dgst, key) ->
+ writeFileOnce (toPath </> "keys" </> (BC.unpack $ showRefDigest dgst)) (BL.fromStrict $ convert key)
+ return M.empty
+
+ (StorageMemory { memKeys = fromKeys }, StorageMemory { memKeys = toKeys }) -> do
+ modifyMVar_ fromKeys $ \fkeys -> do
+ modifyMVar_ toKeys $ return . M.union fkeys
+ return M.empty
diff --git a/src/Erebos/Storage/List.hs b/src/Erebos/Storage/List.hs
new file mode 100644
index 0000000..f0f8786
--- /dev/null
+++ b/src/Erebos/Storage/List.hs
@@ -0,0 +1,154 @@
+module Erebos.Storage.List (
+ StoredList,
+ emptySList, fromSList, storedFromSList,
+ slistAdd, slistAddS,
+ -- TODO slistInsert, slistInsertS,
+ slistRemove, slistReplace, slistReplaceS,
+ -- TODO mapFromSList, updateOld,
+
+ -- TODO StoreUpdate(..),
+ -- TODO withStoredListItem, withStoredListItemS,
+) where
+
+import Data.List
+import Data.Maybe
+import qualified Data.Set as S
+
+import Erebos.Storage
+import Erebos.Storage.Internal
+import Erebos.Storage.Merge
+
+data List a = ListNil
+ | ListItem { listPrev :: [StoredList a]
+ , listItem :: Maybe (Stored a)
+ , listRemove :: Maybe (Stored (List a))
+ }
+
+type StoredList a = Stored (List a)
+
+instance Storable a => Storable (List a) where
+ store' ListNil = storeZero
+ store' x@ListItem {} = storeRec $ do
+ mapM_ (storeRef "PREV") $ listPrev x
+ mapM_ (storeRef "item") $ listItem x
+ mapM_ (storeRef "remove") $ listRemove x
+
+ load' = loadCurrentObject >>= \case
+ ZeroObject -> return ListNil
+ _ -> loadRec $ ListItem <$> loadRefs "PREV"
+ <*> loadMbRef "item"
+ <*> loadMbRef "remove"
+
+instance Storable a => ZeroStorable (List a) where
+ fromZero _ = ListNil
+
+
+emptySList :: Storable a => Storage -> IO (StoredList a)
+emptySList st = wrappedStore st ListNil
+
+groupsFromSLists :: forall a. Storable a => StoredList a -> [[Stored a]]
+groupsFromSLists = helperSelect S.empty . (:[])
+ where
+ helperSelect :: S.Set (StoredList a) -> [StoredList a] -> [[Stored a]]
+ helperSelect rs xxs | x:xs <- sort $ filterRemoved rs xxs = helper rs x xs
+ | otherwise = []
+
+ helper :: S.Set (StoredList a) -> StoredList a -> [StoredList a] -> [[Stored a]]
+ helper rs x xs
+ | ListNil <- fromStored x
+ = []
+
+ | Just rm <- listRemove (fromStored x)
+ , ans <- ancestors [x]
+ , (other, collision) <- partition (S.null . S.intersection ans . ancestors . (:[])) xs
+ , cont <- helperSelect (rs `S.union` ancestors [rm]) $ concatMap (listPrev . fromStored) (x : collision) ++ other
+ = case catMaybes $ map (listItem . fromStored) (x : collision) of
+ [] -> cont
+ xis -> xis : cont
+
+ | otherwise = case listItem (fromStored x) of
+ Nothing -> helperSelect rs $ listPrev (fromStored x) ++ xs
+ Just xi -> [xi] : (helperSelect rs $ listPrev (fromStored x) ++ xs)
+
+ filterRemoved :: S.Set (StoredList a) -> [StoredList a] -> [StoredList a]
+ filterRemoved rs = filter (S.null . S.intersection rs . ancestors . (:[]))
+
+fromSList :: Mergeable a => StoredList (Component a) -> [a]
+fromSList = map merge . groupsFromSLists
+
+storedFromSList :: (Mergeable a, Storable a) => StoredList (Component a) -> IO [Stored a]
+storedFromSList = mapM storeMerge . groupsFromSLists
+
+slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a)
+slistAdd x prev@(Stored (Ref st _) _) = do
+ sx <- wrappedStore st x
+ slistAddS sx prev
+
+slistAddS :: Storable a => Stored a -> StoredList a -> IO (StoredList a)
+slistAddS sx prev@(Stored (Ref st _) _) = wrappedStore st (ListItem [prev] (Just sx) Nothing)
+
+{- TODO
+slistInsert :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a)
+slistInsert after x prev@(Stored (Ref st _) _) = do
+ sx <- wrappedStore st x
+ slistInsertS after sx prev
+
+slistInsertS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a)
+slistInsertS after sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem Nothing (findSListRef after prev) (Just sx) prev
+-}
+
+slistRemove :: Storable a => Stored a -> StoredList a -> IO (StoredList a)
+slistRemove rm prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] Nothing (findSListRef rm prev)
+
+slistReplace :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a)
+slistReplace rm x prev@(Stored (Ref st _) _) = do
+ sx <- wrappedStore st x
+ slistReplaceS rm sx prev
+
+slistReplaceS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a)
+slistReplaceS rm sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] (Just sx) (findSListRef rm prev)
+
+findSListRef :: Stored a -> StoredList a -> Maybe (StoredList a)
+findSListRef _ (Stored _ ListNil) = Nothing
+findSListRef x cur | listItem (fromStored cur) == Just x = Just cur
+ | otherwise = listToMaybe $ catMaybes $ map (findSListRef x) $ listPrev $ fromStored cur
+
+{- TODO
+mapFromSList :: Storable a => StoredList a -> Map RefDigest (Stored a)
+mapFromSList list = helper list M.empty
+ where helper :: Storable a => StoredList a -> Map RefDigest (Stored a) -> Map RefDigest (Stored a)
+ helper (Stored _ ListNil) cur = cur
+ helper (Stored _ (ListItem (Just rref) _ (Just x) rest)) cur =
+ let rxref = case load rref of
+ ListItem _ _ (Just rx) _ -> sameType rx x $ storedRef rx
+ _ -> error "mapFromSList: malformed list"
+ in helper rest $ case M.lookup (refDigest $ storedRef x) cur of
+ Nothing -> M.insert (refDigest rxref) x cur
+ Just x' -> M.insert (refDigest rxref) x' cur
+ helper (Stored _ (ListItem _ _ _ rest)) cur = helper rest cur
+ sameType :: a -> a -> b -> b
+ sameType _ _ x = x
+
+updateOld :: Map RefDigest (Stored a) -> Stored a -> Stored a
+updateOld m x = fromMaybe x $ M.lookup (refDigest $ storedRef x) m
+
+
+data StoreUpdate a = StoreKeep
+ | StoreReplace a
+ | StoreRemove
+
+withStoredListItem :: (Storable a) => (a -> Bool) -> StoredList a -> (a -> IO (StoreUpdate a)) -> IO (StoredList a)
+withStoredListItem p list f = withStoredListItemS (p . fromStored) list (suMap (wrappedStore $ storedStorage list) <=< f . fromStored)
+ where suMap :: Monad m => (a -> m b) -> StoreUpdate a -> m (StoreUpdate b)
+ suMap _ StoreKeep = return StoreKeep
+ suMap g (StoreReplace x) = return . StoreReplace =<< g x
+ suMap _ StoreRemove = return StoreRemove
+
+withStoredListItemS :: (Storable a) => (Stored a -> Bool) -> StoredList a -> (Stored a -> IO (StoreUpdate (Stored a))) -> IO (StoredList a)
+withStoredListItemS p list f = do
+ case find p $ storedFromSList list of
+ Just sx -> f sx >>= \case StoreKeep -> return list
+ StoreReplace nx -> slistReplaceS sx nx list
+ StoreRemove -> slistRemove sx list
+ Nothing -> return list
+-}
diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
new file mode 100644
index 0000000..9d9db13
--- /dev/null
+++ b/src/Erebos/Storage/Merge.hs
@@ -0,0 +1,160 @@
+module Erebos.Storage.Merge (
+ Mergeable(..),
+ merge, storeMerge,
+
+ Generation,
+ showGeneration,
+ compareGeneration, generationMax,
+ storedGeneration,
+
+ generations,
+ ancestors,
+ precedes,
+ precedesOrEquals,
+ filterAncestors,
+ storedRoots,
+ walkAncestors,
+
+ findProperty,
+ findPropertyFirst,
+) where
+
+import Control.Concurrent.MVar
+
+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.Storage
+import Erebos.Storage.Internal
+import Erebos.Util
+
+class Storable (Component a) => Mergeable a where
+ type Component a :: Type
+ mergeSorted :: [Stored (Component a)] -> a
+ toComponents :: a -> [Stored (Component a)]
+
+instance Mergeable [Stored Object] where
+ type Component [Stored Object] = Object
+ mergeSorted = id
+ toComponents = id
+
+merge :: Mergeable a => [Stored (Component a)] -> a
+merge [] = error "merge: empty list"
+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
+
+
+generations :: Storable a => [Stored a] -> [Set (Stored a)]
+generations = unfoldr gen . (,S.empty)
+ where gen (hs, cur) = case filter (`S.notMember` cur) $ previous =<< hs of
+ [] -> Nothing
+ added -> let next = foldr S.insert cur added
+ in Just (next, (added, next))
+
+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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-08 21:27:43 +0000