mirror of https://github.com/voidlizard/hbs2
103 lines
3.1 KiB
Haskell
103 lines
3.1 KiB
Haskell
{-# Language FunctionalDependencies #-}
|
|
{-# Language DefaultSignatures #-}
|
|
module HBS2.Storage where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Hash
|
|
import HBS2.Data.Types.Refs (RefMetaData(..))
|
|
|
|
import Data.Kind
|
|
import Lens.Micro.Platform
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Word
|
|
|
|
import Codec.Serialise()
|
|
|
|
class Pretty (Hash h) => IsKey h where
|
|
type family 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,Pretty)
|
|
|
|
newtype Offset = Offset Integer
|
|
deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty,Serialise)
|
|
deriving stock (Show)
|
|
|
|
newtype Size = Size Integer
|
|
deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty,Serialise)
|
|
deriving stock (Show)
|
|
|
|
data ExpiredAfter a = ExpiredAfter Word64 a
|
|
deriving stock (Generic)
|
|
|
|
instance Serialise a => Serialise (ExpiredAfter a)
|
|
|
|
|
|
class ( Monad m
|
|
, IsKey h
|
|
, Hashed h block
|
|
) => Storage a h block m | a -> block, a -> h where
|
|
|
|
putBlock :: a -> block -> m (Maybe (Key h))
|
|
|
|
enqueueBlock :: a -> block -> m (Maybe (Key h))
|
|
|
|
getBlock :: a -> Key h -> m (Maybe block)
|
|
|
|
delBlock :: a -> Key h -> m ()
|
|
|
|
getChunk :: a -> Key h -> Offset -> Size -> m (Maybe block)
|
|
|
|
hasBlock :: a -> Key h -> m (Maybe Integer)
|
|
|
|
updateRef :: (Hashed h k, RefMetaData k) => a -> k -> Key h -> m ()
|
|
|
|
getRef :: (Hashed h k, Pretty k, RefMetaData k) => a -> k -> m (Maybe (Key h))
|
|
|
|
delRef :: (Hashed h k, RefMetaData k) => a -> k -> m ()
|
|
|
|
data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
|
|
) => AnyStorage zu
|
|
|
|
class HasStorage m where
|
|
getStorage :: m AnyStorage
|
|
|
|
instance (Monad m, HasStorage m) => HasStorage (MaybeT m) where
|
|
getStorage = lift getStorage
|
|
|
|
instance Hashed h a => Hashed h (ExpiredAfter a) where
|
|
hashObject (ExpiredAfter _ a) = hashObject a
|
|
|
|
instance RefMetaData a => RefMetaData (ExpiredAfter a) where
|
|
refMetaData (ExpiredAfter t x) = [("expires", show t)] <> refMetaData x
|
|
|
|
instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m where
|
|
putBlock (AnyStorage s) = liftIO . putBlock s
|
|
enqueueBlock (AnyStorage s) = liftIO . enqueueBlock s
|
|
getBlock (AnyStorage s) = liftIO . getBlock s
|
|
getChunk (AnyStorage s) h a b = liftIO $ getChunk s h a b
|
|
hasBlock (AnyStorage s) = liftIO . hasBlock s
|
|
updateRef (AnyStorage s) r v = liftIO $ updateRef s r v
|
|
getRef (AnyStorage s) = liftIO . getRef s
|
|
delBlock (AnyStorage s) = liftIO . delBlock s
|
|
delRef (AnyStorage s) = liftIO . delRef s
|
|
|
|
|
|
calcChunks :: forall a b . (Integral a, Integral b)
|
|
=> Integer -- | block size
|
|
-> Integer -- | chunk size
|
|
-> [(a, b)]
|
|
|
|
calcChunks s1 s2 = fmap (over _1 fromIntegral . over _2 fromIntegral) chu
|
|
where
|
|
(n,rest) = s1 `divMod` s2
|
|
chu = [ (x*s2,s2) | x <- [0..n-1] ] <> [(n * s2, rest) | rest > 0]
|
|
|
|
|
|
|