{-# 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
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: 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
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)
instance Default Config where
def :: Config
def = 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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Config -> (Options -> m a) -> m a
withOptions Config {Bool
Maybe Int
createIfMissing :: Config -> Bool
errorIfExists :: Config -> Bool
paranoidChecks :: Config -> Bool
maxFiles :: Config -> Maybe Int
prefixLength :: Config -> Maybe Int
bloomFilter :: Config -> Bool
createIfMissing :: Bool
errorIfExists :: Bool
paranoidChecks :: Bool
maxFiles :: Maybe Int
prefixLength :: Maybe Int
bloomFilter :: 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bloomFilter (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilterPolicy
fp <- CInt -> IO FilterPolicy
c_rocksdb_filterpolicy_create_bloom_full CInt
10
BlockBasedOptions
bo <- IO BlockBasedOptions
c_rocksdb_block_based_options_create
BlockBasedOptions -> FilterPolicy -> IO ()
c_rocksdb_block_based_options_set_filter_policy BlockBasedOptions
bo FilterPolicy
fp
Options -> BlockBasedOptions -> IO ()
c_rocksdb_options_set_block_based_table_factory Options
opts BlockBasedOptions
bo
Maybe Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
prefixLength ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
l -> do
SliceTransform
t <- CSize -> IO SliceTransform
c_rocksdb_slicetransform_create_fixed_prefix (Int -> CSize
intToCSize Int
l)
Options -> SliceTransform -> IO ()
c_rocksdb_options_set_prefix_extractor Options
opts SliceTransform
t
Maybe Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
maxFiles ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
Options -> CInt -> IO ()
c_rocksdb_options_set_max_open_files Options
opts (CInt -> IO ()) -> (Int -> CInt) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
intToCInt
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Options
c_rocksdb_options_create)
(IO () -> m ()
forall a. IO a -> m a
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)
withOptionsCF :: MonadUnliftIO m => [Config] -> ([Options] -> m a) -> m a
withOptionsCF :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
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 a. IO a -> m a
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 a. IO a -> m a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ReadOpts
read_opts_ptr
withWriteOpts :: MonadUnliftIO m => (WriteOpts -> m a) -> m a
withWriteOpts :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO WriteOpts
c_rocksdb_writeoptions_create)
(IO () -> m ()
forall a. IO a -> m a
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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
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 a. IO a -> m a
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
err_cstr <- IO CString -> m CString
forall a. IO a -> m a
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
err_cstr 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 a. IO a -> m a
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
err_cstr
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CString -> IO ()
forall (m :: * -> *) a. MonadIO m => Ptr a -> m ()
free CString
err_cstr
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 a. 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 :: forall b. Num b => 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 #-}