diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 5465f777..f748744c 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/hbs2-core/lib/HBS2/Storage.hs @@ -3,16 +3,22 @@ module HBS2.Storage where import Data.Kind import Data.Hashable hiding (Hashed) +import Prettyprinter import HBS2.Hash import HBS2.Prelude.Plated +class Pretty (Hash h) => IsKey h where + type Key h :: Type + +instance Key HbSync ~ Hash HbSync => IsKey HbSync where + type instance Key HbSync = Hash HbSync + newtype StoragePrefix = StoragePrefix { fromPrefix :: FilePath } deriving stock (Data,Show) deriving newtype (IsString) type family Block block :: Type -type family Key block :: Type newtype Offset = Offset Integer deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable) @@ -22,24 +28,22 @@ newtype Size = Size Integer deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable) deriving stock (Show) - class ( Monad m - , Hashed (StorageHash a block) block - ) => Storage a block m | a -> block where + , IsKey h + , Hashed h block + ) => Storage a h block m | a -> block, a -> h where - type family StorageHash a block :: Type + putBlock :: a -> Block block -> m (Maybe (Key h)) - putBlock :: a -> Block block -> m (Maybe (Key block)) + enqueueBlock :: a -> Block block -> m (Maybe (Key h)) - enqueueBlock :: a -> Block block -> m (Maybe (Key block)) + getBlock :: a -> Key h -> m (Maybe (Block block)) - getBlock :: a -> Key block -> m (Maybe (Block block)) + getChunk :: a -> Key h -> Offset -> Size -> m (Maybe (Block block)) - getChunk :: a -> Key block -> Offset -> Size -> m (Maybe (Block block)) + hasBlock :: a -> Key h -> m Bool - hasBlock :: a -> Key block -> m Bool - - listBlocks :: a -> ( Key block -> m () ) -> m () + -- listBlocks :: a -> ( Key block -> m () ) -> m () diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 32c0d58e..7b917a56 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -48,17 +48,16 @@ import HBS2.Storage -- in order to make the disk access in this fashion safe + newtype Raw a = Raw { fromRaw :: a } type instance Block (Raw LBS.ByteString) = LBS.ByteString -type instance Key (Raw LBS.ByteString) = Hash HbSync newtype StorageQueueSize = StorageQueueSize { fromQueueSize :: Int } deriving stock (Data,Show) deriving newtype (Eq,Ord,Enum,Num,Integral,Real) - data SimpleStorage a = SimpleStorage { _storageDir :: FilePath @@ -147,8 +146,9 @@ simpleStorageWorker ss = do pure () -simpleChunkLookup :: SimpleStorage h - -> Key (Raw LBS.ByteString) +simpleChunkLookup :: IsKey h + => SimpleStorage h + -> Hash h -> Offset -> Size -> IO (Maybe LBS.ByteString) @@ -158,8 +158,9 @@ simpleChunkLookup s k off size = do let cache = s ^. storageChunksCache Cache.lookup cache (fn, off, size) <&> fmap LBS.fromStrict -simpleChunkCache :: SimpleStorage h - -> Key (Raw LBS.ByteString) +simpleChunkCache :: IsKey h + => SimpleStorage h + -> Hash h -> Offset -> Size -> LBS.ByteString @@ -171,12 +172,17 @@ simpleChunkCache s k off size bs = do -- print ("caching!", fn, off, size) Cache.insert cache (fn, off, size) (LBS.toStrict bs) -simpleBlockFileName :: SimpleStorage h -> Hash HbSync -> FilePath +simpleBlockFileName :: Pretty (Hash h) => SimpleStorage h -> Hash h -> FilePath simpleBlockFileName ss h = path where (pref,suf) = splitAt 1 (show (pretty h)) path = view storageBlocks ss pref suf +simpleRefFileName :: Pretty (Hash h) => SimpleStorage h -> Hash h -> FilePath +simpleRefFileName ss h = path + where + (pref,suf) = splitAt 1 (show (pretty h)) + path = view storageRefs ss pref suf -- NOTE: reads a whole file into memory! @@ -189,8 +195,9 @@ simpleBlockFileName ss h = path -- -- So, the block MUST be small -- -simpleGetBlockLazy :: SimpleStorage h - -> Key (Raw LBS.ByteString) +simpleGetBlockLazy :: IsKey h + => SimpleStorage h + -> Hash h -> IO (Maybe LBS.ByteString) simpleGetBlockLazy s key = do @@ -213,8 +220,9 @@ simpleGetBlockLazy s key = do atomically $ TBMQ.readTBMQueue resQ >>= maybe (pure Nothing) pure -simpleGetChunkLazy :: SimpleStorage h - -> Key (Raw LBS.ByteString) +simpleGetChunkLazy :: IsKey h + => SimpleStorage h + -> Hash h -> Offset -> Size -> IO (Maybe LBS.ByteString) @@ -268,14 +276,15 @@ simpleGetChunkLazy s key off size = do atomically $ TBMQ.readTBMQueue resQ >>= maybe (pure Nothing) pure -simplePutBlockLazy :: Bool -- | wait +simplePutBlockLazy :: (IsKey h, Hashed h LBS.ByteString) + => Bool -- | wait -> SimpleStorage h - -> LBS.ByteString - -> IO (Maybe (Key (Raw LBS.ByteString))) + -> (Raw LBS.ByteString) + -> IO (Maybe (Hash h)) -simplePutBlockLazy doWait s lbs = do +simplePutBlockLazy doWait s (Raw lbs) = do - let hash = hashObject lbs :: Key (Raw LBS.ByteString) + let hash = hashObject lbs let fn = simpleBlockFileName s hash stop <- atomically $ TV.readTVar ( s ^. storageStopWriting ) @@ -302,23 +311,41 @@ simplePutBlockLazy doWait s lbs = do pure $ Just hash -simpleBlockExists :: SimpleStorage h - -> Key (Raw LBS.ByteString) +simpleBlockExists :: IsKey h + => SimpleStorage h + -> Hash h -> IO Bool simpleBlockExists ss hash = doesFileExist $ simpleBlockFileName ss hash -instance Hashed HbSync (Raw LBS.ByteString) where + +simpleWriteLinkRaw :: IsKey h + => SimpleStorage h + -> Hash h + -> Raw LBS.ByteString + -> IO () + +simpleWriteLinkRaw ss hash (Raw lbs) = do + let fn = simpleRefFileName ss hash + simpleAddTask ss $ do + LBS.writeFile fn lbs + +simpleReadLinkRaw :: SimpleStorage h -> Hash h -> IO (Maybe LBS.ByteString) +simpleReadLinkRaw s k = undefined + +instance Hashed hash LBS.ByteString => Hashed hash (Raw LBS.ByteString) where hashObject (Raw s) = hashObject s -instance (MonadIO m, (Hashed hash (Raw LBS.ByteString))) - => Storage (SimpleStorage hash) (Raw LBS.ByteString) m where +instance ( MonadIO m, IsKey hash + , Hashed hash (Raw LBS.ByteString) + , Hashed hash LBS.ByteString + , Key hash ~ Hash hash + ) + => Storage (SimpleStorage hash) hash (Raw LBS.ByteString) m where - type instance StorageHash (SimpleStorage hash) (Raw LBS.ByteString) = hash + putBlock s lbs = liftIO $ simplePutBlockLazy True s (Raw lbs) - putBlock s lbs = liftIO $ simplePutBlockLazy True s lbs - - enqueueBlock s lbs = liftIO $ simplePutBlockLazy False s lbs + enqueueBlock s lbs = liftIO $ simplePutBlockLazy False s (Raw lbs) getBlock s key = liftIO $ simpleGetBlockLazy s key diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 06b5a89d..ee38ba0d 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -27,7 +27,6 @@ import HBS2.Merkle import HBS2.Data.Types import HBS2.Defaults - newtype OptInputFile = OptInputFile { unOptFile :: FilePath } deriving newtype (Eq,Ord,IsString) deriving stock (Data)