Split to library and executable parts

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