{-# LANGUAGE RecordWildCards #-}
module Database.RocksDB.Internal
( Config (..)
, DB (..)
, withOptions
, withOptionsCF
, withReadOpts
, withWriteOpts
, freeCString
, throwIfErr
, cSizeToInt
, intToCSize
, intToCInt
, cIntToInt
, boolToNum
) where
import Control.Monad
import Data.Default
import Database.RocksDB.C
import UnliftIO
import UnliftIO.Foreign
data DB = DB { DB -> RocksDB
rocksDB :: !RocksDB
, DB -> [ColumnFamily]
columnFamilies :: ![ColumnFamily]
, DB -> ReadOpts
readOpts :: !ReadOpts
, DB -> WriteOpts
writeOpts :: !WriteOpts
}
data Config = Config { Config -> Bool
createIfMissing :: !Bool
, Config -> Bool
errorIfExists :: !Bool
, Config -> Bool
paranoidChecks :: !Bool
, Config -> Maybe Int
maxFiles :: !(Maybe Int)
, Config -> Maybe Int
prefixLength :: !(Maybe Int)
, Config -> Bool
bloomFilter :: !Bool
} deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)
instance Default Config where
def :: Config
def = Config :: Bool -> Bool -> Bool -> Maybe Int -> Maybe Int -> Bool -> Config
Config { createIfMissing :: Bool
createIfMissing = Bool
False
, errorIfExists :: Bool
errorIfExists = Bool
False
, paranoidChecks :: Bool
paranoidChecks = Bool
False
, maxFiles :: Maybe Int
maxFiles = Maybe Int
forall a. Maybe a
Nothing
, prefixLength :: Maybe Int
prefixLength = Maybe Int
forall a. Maybe a
Nothing
, bloomFilter :: Bool
bloomFilter = Bool
False
}
withOptions :: MonadUnliftIO m => Config -> (Options -> m a) -> m a
withOptions :: Config -> (Options -> m a) -> m a
withOptions Config {Bool
Maybe Int
bloomFilter :: Bool
prefixLength :: Maybe Int
maxFiles :: Maybe Int
paranoidChecks :: Bool
errorIfExists :: Bool
createIfMissing :: Bool
bloomFilter :: Config -> Bool
prefixLength :: Config -> Maybe Int
maxFiles :: Config -> Maybe Int
paranoidChecks :: Config -> Bool
errorIfExists :: Config -> Bool
createIfMissing :: Config -> Bool
..} Options -> m a
f =
(Options -> m a) -> m a
forall c. (Options -> m c) -> m c
with_opts ((Options -> m a) -> m a) -> (Options -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Options
opts -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe FilterPolicy
slice <- IO (Maybe FilterPolicy)
bloom
Options -> Maybe FilterPolicy -> IO ()
forall (m :: * -> *).
MonadIO m =>
Options -> Maybe FilterPolicy -> m ()
block_opts Options
opts Maybe FilterPolicy
slice
Options -> IO ()
forall (m :: * -> *). MonadIO m => Options -> m ()
pfx_extract Options
opts
Options -> IO ()
max_files Options
opts
Options -> CBool -> IO ()
c_rocksdb_options_set_create_if_missing
Options
opts (Bool -> CBool
boolToCBool Bool
createIfMissing)
Options -> CBool -> IO ()
c_rocksdb_options_set_error_if_exists
Options
opts (Bool -> CBool
boolToCBool Bool
errorIfExists)
Options -> CBool -> IO ()
c_rocksdb_options_set_paranoid_checks
Options
opts (Bool -> CBool
boolToCBool Bool
paranoidChecks)
Options -> m a
f Options
opts
where
with_opts :: (Options -> m c) -> m c
with_opts =
m Options -> (Options -> m ()) -> (Options -> m c) -> m c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(IO Options -> m Options
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Options
c_rocksdb_options_create)
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Options -> IO ()) -> Options -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> IO ()
c_rocksdb_options_destroy)
block_opts :: Options -> Maybe FilterPolicy -> m ()
block_opts Options
_ Maybe FilterPolicy
Nothing = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
block_opts Options
opts (Just FilterPolicy
slice) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
BlockBasedOptions
block <- IO BlockBasedOptions
c_rocksdb_block_based_options_create
BlockBasedOptions -> FilterPolicy -> IO ()
c_rocksdb_block_based_options_set_filter_policy BlockBasedOptions
block FilterPolicy
slice
Options -> BlockBasedOptions -> IO ()
c_rocksdb_options_set_block_based_table_factory Options
opts BlockBasedOptions
block
bloom :: IO (Maybe FilterPolicy)
bloom =
if Bool
bloomFilter
then FilterPolicy -> Maybe FilterPolicy
forall a. a -> Maybe a
Just (FilterPolicy -> Maybe FilterPolicy)
-> IO FilterPolicy -> IO (Maybe FilterPolicy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt -> IO FilterPolicy
c_rocksdb_filterpolicy_create_bloom_full CInt
10
else Maybe FilterPolicy -> IO (Maybe FilterPolicy)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilterPolicy
forall a. Maybe a
Nothing
pfx_extract :: Options -> m ()
pfx_extract Options
opts =
case Maybe Int
prefixLength of
Maybe Int
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
len -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
SliceTransform
p <- CSize -> IO SliceTransform
c_rocksdb_slicetransform_create_fixed_prefix
(Int -> CSize
intToCSize Int
len)
Options -> SliceTransform -> IO ()
c_rocksdb_options_set_prefix_extractor Options
opts SliceTransform
p
max_files :: Options -> IO ()
max_files Options
opts =
case Maybe Int
maxFiles of
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
i -> Options -> CInt -> IO ()
c_rocksdb_options_set_max_open_files Options
opts (Int -> CInt
intToCInt Int
i)
withOptionsCF :: MonadUnliftIO m => [Config] -> ([Options] -> m a) -> m a
withOptionsCF :: [Config] -> ([Options] -> m a) -> m a
withOptionsCF [Config]
cfgs [Options] -> m a
f =
[Options] -> [Config] -> m a
go [] [Config]
cfgs
where
go :: [Options] -> [Config] -> m a
go [Options]
acc [] = [Options] -> m a
f ([Options] -> [Options]
forall a. [a] -> [a]
reverse [Options]
acc)
go [Options]
acc (Config
c:[Config]
cs) = Config -> (Options -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Config -> (Options -> m a) -> m a
withOptions Config
c ((Options -> m a) -> m a) -> (Options -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Options
o -> [Options] -> [Config] -> m a
go (Options
oOptions -> [Options] -> [Options]
forall a. a -> [a] -> [a]
:[Options]
acc) [Config]
cs
withReadOpts :: MonadUnliftIO m => Maybe Snapshot -> (ReadOpts -> m a) -> m a
withReadOpts :: Maybe Snapshot -> (ReadOpts -> m a) -> m a
withReadOpts Maybe Snapshot
maybe_snap_ptr =
m ReadOpts -> (ReadOpts -> m ()) -> (ReadOpts -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
m ReadOpts
create_read_opts
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ReadOpts -> IO ()) -> ReadOpts -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadOpts -> IO ()
c_rocksdb_readoptions_destroy)
where
create_read_opts :: m ReadOpts
create_read_opts = IO ReadOpts -> m ReadOpts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ReadOpts -> m ReadOpts) -> IO ReadOpts -> m ReadOpts
forall a b. (a -> b) -> a -> b
$ do
ReadOpts
read_opts_ptr <- IO ReadOpts
c_rocksdb_readoptions_create
Maybe Snapshot -> (Snapshot -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Snapshot
maybe_snap_ptr ((Snapshot -> IO ()) -> IO ()) -> (Snapshot -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ReadOpts -> Snapshot -> IO ()
c_rocksdb_readoptions_set_snapshot ReadOpts
read_opts_ptr
ReadOpts -> IO ReadOpts
forall (m :: * -> *) a. Monad m => a -> m a
return ReadOpts
read_opts_ptr
withWriteOpts :: MonadUnliftIO m => (WriteOpts -> m a) -> m a
withWriteOpts :: (WriteOpts -> m a) -> m a
withWriteOpts =
m WriteOpts -> (WriteOpts -> m ()) -> (WriteOpts -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(IO WriteOpts -> m WriteOpts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO WriteOpts
c_rocksdb_writeoptions_create)
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (WriteOpts -> IO ()) -> WriteOpts -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteOpts -> IO ()
c_rocksdb_writeoptions_destroy)
freeCString :: CString -> IO ()
freeCString :: CString -> IO ()
freeCString = CString -> IO ()
c_rocksdb_free
throwIfErr :: MonadUnliftIO m => String -> (ErrPtr -> m a) -> m a
throwIfErr :: String -> (ErrPtr -> m a) -> m a
throwIfErr String
s ErrPtr -> m a
f = (ErrPtr -> m a) -> m a
forall (m :: * -> *) a b.
(MonadUnliftIO m, Storable a) =>
(Ptr a -> m b) -> m b
alloca ((ErrPtr -> m a) -> m a) -> (ErrPtr -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ErrPtr
err_ptr -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ErrPtr -> CString -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke ErrPtr
err_ptr CString
forall a. Ptr a
nullPtr
a
res <- ErrPtr -> m a
f ErrPtr
err_ptr
CString
erra <- IO CString -> m CString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CString -> m CString) -> IO CString -> m CString
forall a b. (a -> b) -> a -> b
$ ErrPtr -> IO CString
forall a. Storable a => Ptr a -> IO a
peek ErrPtr
err_ptr
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CString
erra CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
/= CString
forall a. Ptr a
nullPtr) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
String
err <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ CString -> IO String
forall (m :: * -> *). MonadIO m => CString -> m String
peekCString CString
erra
IOError -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (IOError -> m ()) -> IOError -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
boolToCBool :: Bool -> CBool
boolToCBool :: Bool -> CBool
boolToCBool Bool
True = CBool
1
boolToCBool Bool
False = CBool
0
{-# INLINE boolToCBool #-}
cSizeToInt :: CSize -> Int
cSizeToInt :: CSize -> Int
cSizeToInt = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE cSizeToInt #-}
intToCSize :: Int -> CSize
intToCSize :: Int -> CSize
intToCSize = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE intToCSize #-}
intToCInt :: Int -> CInt
intToCInt :: Int -> CInt
intToCInt = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE intToCInt #-}
cIntToInt :: CInt -> Int
cIntToInt :: CInt -> Int
cIntToInt = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE cIntToInt #-}
boolToNum :: Num b => Bool -> b
boolToNum :: Bool -> b
boolToNum Bool
True = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
1 :: Int)
boolToNum Bool
False = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
0 :: Int)
{-# INLINE boolToNum #-}