From 88a7bb50033baab3c2d0eed7e4be868e8966300a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Fri, 17 Nov 2023 20:28:44 +0100 Subject: Split to library and executable parts --- src/Storage/Internal.hs | 273 ------------------------------------------------ src/Storage/Key.hs | 84 --------------- src/Storage/List.hs | 156 --------------------------- src/Storage/Merge.hs | 156 --------------------------- 4 files changed, 669 deletions(-) delete mode 100644 src/Storage/Internal.hs delete mode 100644 src/Storage/Key.hs delete mode 100644 src/Storage/List.hs delete mode 100644 src/Storage/Merge.hs (limited to 'src/Storage') 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 -- cgit v1.2.3