From 6cc15c6cd859070fda1b46995108fbfc3e13a5db Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 7 Dec 2024 20:01:55 +0100
Subject: StorageBackend type class
Changelog: API: Added `StorageBackend` type class to allow custom storage implementation
---
src/Erebos/Storage/Backend.hs | 28 +++++
src/Erebos/Storage/Disk.hs | 230 +++++++++++++++++++++++++++++++++++++++
src/Erebos/Storage/Head.hs | 131 ++++-------------------
src/Erebos/Storage/Internal.hs | 236 ++++++++++++++++++++++-------------------
src/Erebos/Storage/Key.hs | 72 ++++---------
src/Erebos/Storage/Memory.hs | 103 ++++++++++++++++++
6 files changed, 526 insertions(+), 274 deletions(-)
create mode 100644 src/Erebos/Storage/Backend.hs
create mode 100644 src/Erebos/Storage/Disk.hs
create mode 100644 src/Erebos/Storage/Memory.hs
(limited to 'src/Erebos/Storage')
diff --git a/src/Erebos/Storage/Backend.hs b/src/Erebos/Storage/Backend.hs
new file mode 100644
index 0000000..620d423
--- /dev/null
+++ b/src/Erebos/Storage/Backend.hs
@@ -0,0 +1,28 @@
+{-|
+Description: Implement custom storage backend
+
+Exports type class, which can be used to create custom 'Storage' backend.
+-}
+
+module Erebos.Storage.Backend (
+ StorageBackend(..),
+ Complete, Partial,
+ Storage, PartialStorage,
+ newStorage,
+
+ WatchID, startWatchID, nextWatchID,
+) where
+
+import Control.Concurrent.MVar
+
+import Data.HashTable.IO qualified as HT
+
+import Erebos.Object.Internal
+import Erebos.Storage.Internal
+
+
+newStorage :: StorageBackend bck => bck -> IO (Storage' (BackendCompleteness bck))
+newStorage stBackend = do
+ stRefGeneration <- newMVar =<< HT.new
+ stRefRoots <- newMVar =<< HT.new
+ return Storage {..}
diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs
new file mode 100644
index 0000000..01821f7
--- /dev/null
+++ b/src/Erebos/Storage/Disk.hs
@@ -0,0 +1,230 @@
+module Erebos.Storage.Disk (
+ openStorage,
+) where
+
+import Codec.Compression.Zlib
+
+import Control.Arrow
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.UUID qualified as U
+
+import System.Directory
+import System.FSNotify
+import System.FilePath
+import System.IO
+import System.IO.Error
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+import Erebos.Storage.Internal
+import Erebos.Storage.Platform
+
+
+data DiskStorage = StorageDir
+ { dirPath :: FilePath
+ , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList )
+ }
+
+instance Eq DiskStorage where
+ (==) = (==) `on` dirPath
+
+instance Show DiskStorage where
+ show StorageDir { dirPath = path } = "dir:" ++ path
+
+instance StorageBackend DiskStorage where
+ backendLoadBytes StorageDir {..} dgst =
+ handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+ Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath dirPath dgst)
+ backendStoreBytes StorageDir {..} dgst = writeFileOnce (refPath dirPath dgst) . compress
+
+
+ backendLoadHeads StorageDir {..} tid = do
+ let hpath = headTypePath dirPath tid
+
+ files <- filterM (doesFileExist . (hpath </>)) =<<
+ handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
+ (getDirectoryContents hpath)
+ fmap catMaybes $ forM files $ \hname -> do
+ case U.fromString hname of
+ Just hid -> do
+ content <- B.readFile (hpath </> hname)
+ return $ do
+ (h : _) <- Just (BC.lines content)
+ dgst <- readRefDigest h
+ Just $ ( HeadID hid, dgst )
+ Nothing -> return Nothing
+
+ backendLoadHead StorageDir {..} tid hid = do
+ handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
+ (h:_) <- BC.lines <$> B.readFile (headPath dirPath tid hid)
+ return $ readRefDigest h
+
+ backendStoreHead StorageDir {..} tid hid dgst = do
+ Right () <- writeFileChecked (headPath dirPath tid hid) Nothing $
+ showRefDigest dgst `B.append` BC.singleton '\n'
+ return ()
+
+ backendReplaceHead StorageDir {..} tid hid expected new = do
+ let filename = headPath dirPath tid hid
+ showDgstL r = showRefDigest r `B.append` BC.singleton '\n'
+
+ writeFileChecked filename (Just $ showDgstL expected) (showDgstL new) >>= \case
+ Left Nothing -> return $ Left Nothing
+ Left (Just bs) -> do Just cur <- return $ readRefDigest $ BC.takeWhile (/='\n') bs
+ return $ Left $ Just cur
+ Right () -> return $ Right new
+
+ backendWatchHead st@StorageDir {..} tid hid cb = do
+ modifyMVar dirWatchers $ \( mbmanager, ilist, wl ) -> do
+ manager <- maybe startManager return mbmanager
+ ilist' <- case tid `elem` ilist of
+ True -> return ilist
+ False -> do
+ void $ watchDir manager (headTypePath dirPath tid) (const True) $ \case
+ Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
+ backendLoadHead st tid ihid >>= \case
+ Just dgst -> do
+ (_, _, iwl) <- readMVar dirWatchers
+ mapM_ ($ dgst) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
+ Nothing -> return ()
+ _ -> return ()
+ return $ tid : ilist
+ return $ first ( Just manager, ilist', ) $ watchListAdd tid hid cb wl
+
+ backendUnwatchHead StorageDir {..} wid = do
+ modifyMVar_ dirWatchers $ \( mbmanager, ilist, wl ) -> do
+ return ( mbmanager, ilist, watchListDel wid wl )
+
+
+ backendListKeys StorageDir {..} = do
+ catMaybes . map (readRefDigest . BC.pack) <$>
+ listDirectory (keyDirPath dirPath)
+
+ backendLoadKey StorageDir {..} dgst = do
+ tryIOError (BC.readFile (keyFilePath dirPath dgst)) >>= \case
+ Right kdata -> return $ Just $ BA.convert kdata
+ Left _ -> return Nothing
+
+ backendStoreKey StorageDir {..} dgst key = do
+ writeFileOnce (keyFilePath dirPath dgst) (BL.fromStrict $ BA.convert key)
+
+ backendRemoveKey StorageDir {..} dgst = do
+ void $ tryIOError (removeFile $ keyFilePath dirPath dgst)
+
+
+storageVersion :: String
+storageVersion = "0.1"
+
+openStorage :: FilePath -> IO Storage
+openStorage path = modifyIOError annotate $ do
+ let versionFileName = "erebos-storage"
+ let versionPath = path </> versionFileName
+ let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n"
+
+ maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+ Just <$> readFile versionPath
+ version <- case maybeVersion of
+ Just versionContent -> do
+ return $ takeWhile (/= '\n') versionContent
+
+ Nothing -> do
+ files <- handleJust (guard . isDoesNotExistError) (const $ return []) $
+ listDirectory path
+ when (not $ or
+ [ null files
+ , versionFileName `elem` files
+ , (versionFileName ++ ".lock") `elem` files
+ , "objects" `elem` files && "heads" `elem` files
+ ]) $ do
+ fail "directory is neither empty, nor an existing erebos storage"
+
+ createDirectoryIfMissing True $ path
+ writeVersionFile
+ takeWhile (/= '\n') <$> readFile versionPath
+
+ when (version /= storageVersion) $ do
+ fail $ "unsupported storage version " <> version
+
+ createDirectoryIfMissing True $ path </> "objects"
+ createDirectoryIfMissing True $ path </> "heads"
+ watchers <- newMVar ( Nothing, [], WatchList startWatchID [] )
+ newStorage $ StorageDir path watchers
+ where
+ annotate e = annotateIOError e "failed to open storage" Nothing (Just path)
+
+
+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
+
+headTypePath :: FilePath -> HeadTypeID -> FilePath
+headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
+
+headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
+headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
+
+keyDirPath :: FilePath -> FilePath
+keyDirPath sdir = sdir </> "keys"
+
+keyFilePath :: FilePath -> RefDigest -> FilePath
+keyFilePath sdir dgst = keyDirPath sdir </> (BC.unpack $ showRefDigest dgst)
+
+
+openLockFile :: FilePath -> IO Handle
+openLockFile path = do
+ createDirectoryIfMissing True (takeDirectory path)
+ retry 10 $ createFileExclusive path
+ 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
+ doesFileExist file >>= \case
+ True -> removeFile locked
+ False -> do BL.hPut h content
+ hClose h
+ renameFile 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,) <$> doesFileExist file >>= \case
+ (Nothing, True) -> do
+ current <- B.readFile file
+ removeFile locked
+ return $ Left $ Just current
+ (Nothing, False) -> do B.hPut h content
+ hClose h
+ renameFile locked file
+ return $ Right ()
+ (Just expected, True) -> do
+ current <- B.readFile file
+ if current == expected then do B.hPut h content
+ hClose h
+ renameFile locked file
+ return $ return ()
+ else do removeFile locked
+ return $ Left $ Just current
+ (Just _, False) -> do
+ removeFile locked
+ return $ Left Nothing
+ where locked = file ++ ".lock"
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
index dc8b7bc..8f8e009 100644
--- a/src/Erebos/Storage/Head.hs
+++ b/src/Erebos/Storage/Head.hs
@@ -23,27 +23,17 @@ module Erebos.Storage.Head (
) where
import Control.Concurrent
-import Control.Exception
import Control.Monad
-import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Bifunctor
-import Data.ByteString qualified as B
-import Data.ByteString.Char8 qualified as BC
-import Data.List
-import Data.Maybe
import Data.Typeable
import Data.UUID qualified as U
import Data.UUID.V4 qualified as U
-import System.Directory
-import System.FSNotify
-import System.FilePath
-import System.IO.Error
-
import Erebos.Object
import Erebos.Storable
+import Erebos.Storage.Backend
import Erebos.Storage.Internal
@@ -97,31 +87,11 @@ mkHeadTypeID :: String -> HeadTypeID
mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString
-headTypePath :: FilePath -> HeadTypeID -> FilePath
-headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
-
-headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
-headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
-
-- | Load all `Head's of type @a@ from storage.
loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a]
-loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do
- let hpath = headTypePath spath $ headTypeID @a Proxy
-
- files <- filterM (doesFileExist . (hpath </>)) =<<
- handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
- (getDirectoryContents hpath)
- fmap catMaybes $ forM files $ \hname -> do
- case U.fromString hname of
- Just hid -> do
- (h:_) <- BC.lines <$> B.readFile (hpath </> hname)
- Just ref <- readRef s h
- return $ Just $ Head (HeadID hid) $ wrappedLoad ref
- Nothing -> return Nothing
-loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do
- let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref
- | otherwise = Nothing
- catMaybes . map toHead <$> readMVar theads
+loadHeads st@Storage {..} =
+ map (uncurry Head . fmap (wrappedLoad . Ref st))
+ <$> liftIO (backendLoadHeads stBackend (headTypeID @a Proxy))
-- | Try to load a `Head' of type @a@ from storage.
loadHead
@@ -138,13 +108,8 @@ loadHeadRaw
-> HeadTypeID -- ^ ID of the head type
-> HeadID -- ^ ID of the particular head
-> m (Maybe Ref) -- ^ `Ref' pointing to the head object, or `Nothing' if not found
-loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do
- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
- (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid)
- Just ref <- readRef s h
- return $ Just ref
-loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do
- lookup (tid, hid) <$> readMVar theads
+loadHeadRaw st@Storage {..} tid hid = do
+ fmap (Ref st) <$> liftIO (backendLoadHead stBackend tid hid)
-- | Reload the given head from storage, returning `Head' with updated object,
-- or `Nothing' if there is no longer head with the particular ID in storage.
@@ -162,15 +127,9 @@ storeHead st obj = do
-- | Store a new `Head' in the storage, using the raw `HeadTypeID' and `Ref',
-- the function returns the assigned `HeadID' of the new head.
storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID
-storeHeadRaw st tid ref = liftIO $ do
+storeHeadRaw Storage {..} tid ref = liftIO $ do
hid <- HeadID <$> U.nextRandom
- case stBacking st of
- StorageDir { dirPath = spath } -> do
- Right () <- writeFileChecked (headPath spath tid hid) Nothing $
- showRef ref `B.append` BC.singleton '\n'
- return ()
- StorageMemory { memHeads = theads } -> do
- modifyMVar_ theads $ return . (((tid, hid), ref) :)
+ backendStoreHead stBackend tid hid (refDigest ref)
return hid
-- | Try to replace existing `Head' of type @a@ in the storage. Function fails
@@ -216,29 +175,9 @@ replaceHeadRaw
-- [@`Right' r@]:
-- Head value was updated in storage, the new head value is @r@
-- (which is the same as the indended value).
-replaceHeadRaw st tid hid prev new = liftIO $ do
- case stBacking st of
- StorageDir { dirPath = spath } -> do
- let filename = headPath spath tid hid
- showRefL r = showRef r `B.append` BC.singleton '\n'
-
- writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case
- Left Nothing -> return $ Left Nothing
- Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs
- return $ Left $ Just oref
- Right () -> return $ Right new
-
- StorageMemory { memHeads = theads, memWatchers = twatch } -> do
- res <- modifyMVar theads $ \hs -> do
- ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch
- return $ case partition ((==(tid, hid)) . fst) hs of
- ([] , _ ) -> (hs, Left Nothing)
- ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs',
- Right (new, ws))
- | otherwise -> (hs, Left $ Just r)
- case res of
- Right (r, ws) -> mapM_ ($ r) ws >> return (Right r)
- Left x -> return $ Left x
+replaceHeadRaw st@Storage {..} tid hid prev new = liftIO $ do
+ _ <- copyRef st new
+ bimap (fmap $ Ref st) (Ref st) <$> backendReplaceHead stBackend tid hid (refDigest prev) (refDigest new)
-- | Update existing existing `Head' of type @a@ in the storage, using a given
-- function. The update function may be called multiple times in case the head
@@ -299,50 +238,22 @@ watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
-- | Watch the given head using raw IDs and a selector from `Ref'.
watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead
-watchHeadRaw st tid hid sel cb = do
+watchHeadRaw st@Storage {..} tid hid sel cb = do
memo <- newEmptyMVar
- let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)
- where wl' = wl { wlNext = wlNext wl + 1
- , wlList = WatchListItem
- { wlID = wlNext wl
- , wlHead = (tid, hid)
- , wlFun = \r -> do
- let x = sel r
- modifyMVar_ memo $ \prev -> do
- when (Just x /= prev) $ cb x
- return $ Just x
- } : wlList wl
- }
-
- watched <- case stBacking st of
- StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do
- manager <- maybe startManager return mbmanager
- ilist' <- case tid `elem` ilist of
- True -> return ilist
- False -> do
- void $ watchDir manager (headTypePath spath tid) (const True) $ \case
- Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
- loadHeadRaw st tid ihid >>= \case
- Just ref -> do
- (_, _, iwl) <- readMVar mvar
- mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
- Nothing -> return ()
- _ -> return ()
- return $ tid : ilist
- return $ first ( Just manager, ilist', ) $ addWatcher wl
-
- StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher
+ let cb' dgst = do
+ let x = sel (Ref st dgst)
+ modifyMVar_ memo $ \prev -> do
+ when (Just x /= prev) $ cb x
+ return $ Just x
+ wid <- backendWatchHead stBackend tid hid cb'
cur <- fmap sel <$> loadHeadRaw st tid hid
maybe (return ()) cb cur
putMVar memo cur
- return watched
+ return $ WatchedHead st wid memo
-- | Stop watching previously watched head.
unwatchHead :: WatchedHead -> IO ()
-unwatchHead (WatchedHead st wid _) = do
- let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl }
- case stBacking st of
- StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher
- StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher
+unwatchHead (WatchedHead Storage {..} wid _) = do
+ backendUnwatchHead stBackend wid
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 3e8d8b6..59d0af0 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -1,11 +1,8 @@
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
@@ -13,76 +10,145 @@ import Crypto.Hash
import Data.Bits
import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
-import qualified Data.ByteArray as BA
+import Data.ByteArray qualified 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.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
import Data.Char
-import Data.Function
+import Data.HashTable.IO qualified as HT
import Data.Hashable
-import qualified Data.HashTable.IO as HT
import Data.Kind
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Typeable
import Data.UUID (UUID)
import Foreign.Storable (peek)
-import System.Directory
-import System.FSNotify (WatchManager)
-import System.FilePath
-import System.IO
-import System.IO.Error
import System.IO.Unsafe (unsafePerformIO)
-import Erebos.Storage.Platform
-
-data Storage' c = Storage
- { stBacking :: StorageBacking c
- , stParent :: Maybe (Storage' Identity)
+data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage
+ { stBackend :: bck
, stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
, stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
}
+type Storage = Storage' Complete
+type PartialStorage = Storage' Partial
+
instance Eq (Storage' c) where
- (==) = (==) `on` (stBacking &&& stParent)
+ Storage { stBackend = b } == Storage { stBackend = b' }
+ | Just b'' <- cast b' = b == b''
+ | otherwise = False
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 ( Maybe WatchManager, [ HeadTypeID ], 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)
+ show Storage { stBackend = b } = show b ++ showParentStorage b
+
+showParentStorage :: StorageBackend bck => bck -> String
+showParentStorage bck
+ | Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st
+ | Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st
+ | otherwise = ""
+
+
+class (Eq bck, Show bck, Typeable bck, Typeable (BackendParent bck)) => StorageBackend bck where
+ type BackendCompleteness bck :: Type -> Type
+ type BackendCompleteness bck = Complete
+
+ type BackendParent bck :: Type
+ type BackendParent bck = ()
+ backendParent :: bck -> BackendParent bck
+ default backendParent :: BackendParent bck ~ () => bck -> BackendParent bck
+ backendParent _ = ()
+
+
+ backendLoadBytes :: bck -> RefDigest -> IO (Maybe BL.ByteString)
+ default backendLoadBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe BL.ByteString)
+ backendLoadBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadBytes bck'
+
+ backendStoreBytes :: bck -> RefDigest -> BL.ByteString -> IO ()
+ default backendStoreBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> BL.ByteString -> IO ()
+ backendStoreBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreBytes bck'
+
+
+ backendLoadHeads :: bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
+ default backendLoadHeads :: BackendParent bck ~ Storage => bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
+ backendLoadHeads bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHeads bck'
+
+ backendLoadHead :: bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
+ default backendLoadHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
+ backendLoadHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHead bck'
+
+ backendStoreHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
+ default backendStoreHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
+ backendStoreHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreHead bck'
+
+ backendReplaceHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
+ default backendReplaceHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
+ backendReplaceHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendReplaceHead bck'
+
+ backendWatchHead :: bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
+ default backendWatchHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
+ backendWatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendWatchHead bck'
+
+ backendUnwatchHead :: bck -> WatchID -> IO ()
+ default backendUnwatchHead :: BackendParent bck ~ Storage => bck -> WatchID -> IO ()
+ backendUnwatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendUnwatchHead bck'
+
+
+ backendListKeys :: bck -> IO [ RefDigest ]
+ default backendListKeys :: BackendParent bck ~ Storage => bck -> IO [ RefDigest ]
+ backendListKeys bck = case backendParent bck of Storage { stBackend = bck' } -> backendListKeys bck'
+
+ backendLoadKey :: bck -> RefDigest -> IO (Maybe ScrubbedBytes)
+ default backendLoadKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe ScrubbedBytes)
+ backendLoadKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadKey bck'
+
+ backendStoreKey :: bck -> RefDigest -> ScrubbedBytes -> IO ()
+ default backendStoreKey :: BackendParent bck ~ Storage => bck -> RefDigest -> ScrubbedBytes -> IO ()
+ backendStoreKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreKey bck'
+
+ backendRemoveKey :: bck -> RefDigest -> IO ()
+ default backendRemoveKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO ()
+ backendRemoveKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendRemoveKey bck'
+
+
newtype WatchID = WatchID Int
- deriving (Eq, Ord, Num)
+ deriving (Eq, Ord)
+
+startWatchID :: WatchID
+startWatchID = WatchID 1
-data WatchList c = WatchList
+nextWatchID :: WatchID -> WatchID
+nextWatchID (WatchID n) = WatchID (n + 1)
+
+data WatchList = WatchList
{ wlNext :: WatchID
- , wlList :: [WatchListItem c]
+ , wlList :: [ WatchListItem ]
}
-data WatchListItem c = WatchListItem
+data WatchListItem = WatchListItem
{ wlID :: WatchID
- , wlHead :: (HeadTypeID, HeadID)
- , wlFun :: Ref' c -> IO ()
+ , wlHead :: ( HeadTypeID, HeadID )
+ , wlFun :: RefDigest -> IO ()
}
+watchListAdd :: HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> WatchList -> ( WatchList, WatchID )
+watchListAdd tid hid cb wl = ( wl', wlNext wl )
+ where
+ wl' = wl
+ { wlNext = nextWatchID (wlNext wl)
+ , wlList = WatchListItem
+ { wlID = wlNext wl
+ , wlHead = (tid, hid)
+ , wlFun = cb
+ } : wlList wl
+ }
+
+watchListDel :: WatchID -> WatchList -> WatchList
+watchListDel wid wl = wl { wlList = filter ((/= wid) . wlID) $ wlList wl }
+
newtype RefDigest = RefDigest (Digest Blake2b_256)
deriving (Eq, Ord, NFData, ByteArrayAccess)
@@ -92,6 +158,9 @@ instance Show RefDigest where
data Ref' c = Ref (Storage' c) RefDigest
+type Ref = Ref' Complete
+type PartialRef = Ref' Partial
+
instance Eq (Ref' c) where
Ref _ d1 == Ref _ d2 = d1 == d2
@@ -183,7 +252,7 @@ storedStorage (Stored (Ref st _) _) = st
type Complete = Identity
type Partial = Either RefDigest
-class (Traversable compl, Monad compl) => StorageCompleteness compl where
+class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where
type LoadResult compl a :: Type
returnLoadResult :: compl a -> LoadResult compl a
ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)
@@ -200,71 +269,16 @@ instance StorageCompleteness Partial where
ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st raw = do
+unsafeStoreRawBytes st@Storage {..} 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)
+ backendStoreBytes stBackend 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)
- retry 10 $ createFileExclusive path
- 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
- doesFileExist file >>= \case
- True -> removeFile locked
- False -> do BL.hPut h content
- hClose h
- renameFile 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,) <$> doesFileExist file >>= \case
- (Nothing, True) -> do
- current <- B.readFile file
- removeFile locked
- return $ Left $ Just current
- (Nothing, False) -> do B.hPut h content
- hClose h
- renameFile locked file
- return $ Right ()
- (Just expected, True) -> do
- current <- B.readFile file
- if current == expected then do B.hPut h content
- hClose h
- renameFile locked file
- return $ return ()
- else do removeFile locked
- return $ Left $ Just current
- (Just _, False) -> do
- removeFile locked
- return $ Left Nothing
- where locked = file ++ ".lock"
+ioLoadBytesFromStorage Storage {..} dgst =
+ backendLoadBytes stBackend dgst >>= \case
+ Just bytes -> return $ Just bytes
+ Nothing
+ | Just (parent :: Storage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
+ | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
+ | otherwise -> return Nothing
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index 626d684..fab2103 100644
--- a/src/Erebos/Storage/Key.hs
+++ b/src/Erebos/Storage/Key.hs
@@ -4,19 +4,12 @@ module Erebos.Storage.Key (
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 Data.Typeable
import Erebos.Storable
import Erebos.Storage.Internal
@@ -28,59 +21,32 @@ class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
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)
+ case storedStorage spub of
+ Storage {..} -> backendStoreKey stBackend (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 :: forall sec pub m. (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
+ run :: Storage' c -> IO (Maybe sec)
+ run Storage {..} = backendLoadKey stBackend (refDigest $ storedRef spub) >>= \case
+ Just bytes -> return $ keyFromData bytes spub
+ Nothing
+ | Just (parent :: Storage) <- cast (backendParent stBackend) -> run parent
+ | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> run parent
+ | otherwise -> return Nothing
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
- when (fromKeys /= toKeys) $ do
- modifyMVar_ fromKeys $ \fkeys -> do
- modifyMVar_ toKeys $ return . M.union fkeys
- return M.empty
+moveKeys Storage { stBackend = from } Storage { stBackend = to } = liftIO $ do
+ keys <- backendListKeys from
+ forM_ keys $ \key -> do
+ backendLoadKey from key >>= \case
+ Just sec -> do
+ backendStoreKey to key sec
+ backendRemoveKey from key
+ Nothing -> return ()
diff --git a/src/Erebos/Storage/Memory.hs b/src/Erebos/Storage/Memory.hs
new file mode 100644
index 0000000..dd382b6
--- /dev/null
+++ b/src/Erebos/Storage/Memory.hs
@@ -0,0 +1,103 @@
+module Erebos.Storage.Memory (
+ memoryStorage,
+ deriveEphemeralStorage,
+ derivePartialStorage,
+) where
+
+import Control.Concurrent.MVar
+import Control.DeepSeq
+
+import Data.ByteArray (ScrubbedBytes)
+import Data.ByteString.Lazy qualified as BL
+import Data.Function
+import Data.Kind
+import Data.List
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Typeable
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+import Erebos.Storage.Internal
+
+
+data MemoryStorage p (c :: Type -> Type) = StorageMemory
+ { memParent :: p
+ , memHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ]
+ , memObjs :: MVar (Map RefDigest BL.ByteString)
+ , memKeys :: MVar (Map RefDigest ScrubbedBytes)
+ , memWatchers :: MVar WatchList
+ }
+
+instance Eq (MemoryStorage p c) where
+ (==) = (==) `on` memObjs
+
+instance Show (MemoryStorage p c) where
+ show StorageMemory {} = "mem"
+
+instance (StorageCompleteness c, Typeable p) => StorageBackend (MemoryStorage p c) where
+ type BackendCompleteness (MemoryStorage p c) = c
+ type BackendParent (MemoryStorage p c) = p
+ backendParent = memParent
+
+ backendLoadBytes StorageMemory {..} dgst =
+ M.lookup dgst <$> readMVar memObjs
+
+ backendStoreBytes StorageMemory {..} dgst raw =
+ dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
+ modifyMVar_ memObjs (return . M.insert dgst raw)
+
+
+ backendLoadHeads StorageMemory {..} tid = do
+ let toRes ( ( tid', hid ), dgst )
+ | tid' == tid = Just ( hid, dgst )
+ | otherwise = Nothing
+ catMaybes . map toRes <$> readMVar memHeads
+
+ backendLoadHead StorageMemory {..} tid hid =
+ lookup (tid, hid) <$> readMVar memHeads
+
+ backendStoreHead StorageMemory {..} tid hid dgst =
+ modifyMVar_ memHeads $ return . (( ( tid, hid ), dgst ) :)
+
+ backendReplaceHead StorageMemory {..} tid hid expected new = do
+ res <- modifyMVar memHeads $ \hs -> do
+ ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers
+ return $ case partition ((==(tid, hid)) . fst) hs of
+ ( [] , _ ) -> ( hs, Left Nothing )
+ (( _, dgst ) : _, hs' )
+ | dgst == expected -> ((( tid, hid ), new ) : hs', Right ( new, ws ))
+ | otherwise -> ( hs, Left $ Just dgst )
+ case res of
+ Right ( dgst, ws ) -> mapM_ ($ dgst) ws >> return (Right dgst)
+ Left x -> return $ Left x
+
+ backendWatchHead StorageMemory {..} tid hid cb = modifyMVar memWatchers $ return . watchListAdd tid hid cb
+
+ backendUnwatchHead StorageMemory {..} wid = modifyMVar_ memWatchers $ return . watchListDel wid
+
+
+ backendListKeys StorageMemory {..} = M.keys <$> readMVar memKeys
+ backendLoadKey StorageMemory {..} dgst = M.lookup dgst <$> readMVar memKeys
+ backendStoreKey StorageMemory {..} dgst key = modifyMVar_ memKeys $ return . M.insert dgst key
+ backendRemoveKey StorageMemory {..} dgst = modifyMVar_ memKeys $ return . M.delete dgst
+
+
+memoryStorage' :: (StorageCompleteness c, Typeable p) => p -> IO (Storage' c)
+memoryStorage' memParent = do
+ memHeads <- newMVar []
+ memObjs <- newMVar M.empty
+ memKeys <- newMVar M.empty
+ memWatchers <- newMVar (WatchList startWatchID [])
+ newStorage $ StorageMemory {..}
+
+memoryStorage :: IO Storage
+memoryStorage = memoryStorage' ()
+
+deriveEphemeralStorage :: Storage -> IO Storage
+deriveEphemeralStorage parent = memoryStorage' parent
+
+derivePartialStorage :: Storage -> IO PartialStorage
+derivePartialStorage parent = memoryStorage' parent
--
cgit v1.2.3