summaryrefslogtreecommitdiff
path: root/src/Storage
diff options
context:
space:
mode:
Diffstat (limited to 'src/Storage')
-rw-r--r--src/Storage/Internal.hs273
-rw-r--r--src/Storage/Key.hs84
-rw-r--r--src/Storage/List.hs156
-rw-r--r--src/Storage/Merge.hs156
4 files changed, 0 insertions, 669 deletions
diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
deleted file mode 100644
index 7b29193..0000000
--- a/src/Storage/Internal.hs
+++ /dev/null
@@ -1,273 +0,0 @@
-module 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 $
- openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })
- 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/Storage/Key.hs b/src/Storage/Key.hs
deleted file mode 100644
index 7730f9f..0000000
--- a/src/Storage/Key.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-module Storage.Key (
- KeyPair(..),
- storeKey, loadKey, loadKeyMb,
- moveKeys,
-) where
-
-import Control.Concurrent.MVar
-import Control.Monad
-import Control.Monad.Except
-
-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 Storage
-import 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/Storage/List.hs b/src/Storage/List.hs
deleted file mode 100644
index 2bef401..0000000
--- a/src/Storage/List.hs
+++ /dev/null
@@ -1,156 +0,0 @@
-module Storage.List (
- StoredList,
- emptySList, fromSList, storedFromSList,
- slistAdd, slistAddS,
- -- TODO slistInsert, slistInsertS,
- slistRemove, slistReplace, slistReplaceS,
- -- TODO mapFromSList, updateOld,
-
- -- TODO StoreUpdate(..),
- -- TODO withStoredListItem, withStoredListItemS,
-) where
-
-import Control.Monad.Reader
-
-import Data.List
-import Data.Maybe
-import qualified Data.Set as S
-
-import Storage
-import Storage.Internal
-import 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' = asks snd >>= \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/Storage/Merge.hs b/src/Storage/Merge.hs
deleted file mode 100644
index 7c6992f..0000000
--- a/src/Storage/Merge.hs
+++ /dev/null
@@ -1,156 +0,0 @@
-module Storage.Merge (
- Mergeable(..),
- merge, storeMerge,
-
- Generation,
- showGeneration,
- compareGeneration, generationMax,
- storedGeneration,
-
- generations,
- ancestors,
- precedes,
- 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 Storage
-import Storage.Internal
-import 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]
-
-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-11-07 20:58:01 +0000