wip

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 ()
 
 
 

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
 

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)