{-# LANGUAGE RecordWildCards #-}
-- |
-- Module      : Database.RocksDB.Internal
-- Copyright   : (c) 2012-2013 The leveldb-haskell Authors
--               (c) 2014-2020 The rocksdb-haskell Authors
-- License     : BSD3
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : non-portable
--

module Database.RocksDB.Internal
    ( Config (..)
    , DB (..)

    -- * Smart constructors & extractors
    , withOptions
    , withOptionsCF
    , withReadOpts
    , withWriteOpts

    -- * Utilities
    , 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 #-}