module Database.LevelDB (
DB
, BatchOp(..)
, Comparator(..)
, Compression(..)
, Options(..)
, ReadOptions(..)
, Snapshot
, WriteBatch
, WriteOptions(..)
, Range
, defaultOptions
, defaultWriteOptions
, defaultReadOptions
, withSnapshot
, open
, put
, delete
, write
, get
, createSnapshot
, createSnapshot'
, FilterPolicy(..)
, bloomFilter
, Property(..), getProperty
, destroy
, repair
, approximateSize
, version
, Iterator
, withIterator
, iterOpen
, iterOpen'
, iterValid
, iterSeek
, iterFirst
, iterLast
, iterNext
, iterPrev
, iterKey
, iterValue
, iterGetError
, mapIter
, iterItems
, iterKeys
, iterValues
, MonadResource(..)
, runResourceT
, resourceForkIO
) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (MVar, withMVar, newMVar)
import Control.Exception (throwIO)
import Control.Monad (liftM, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.ByteString.Internal (ByteString(..))
import Data.Default
import Data.Maybe (catMaybes)
import Foreign
import Foreign.C.Error (throwErrnoIfNull)
import Foreign.C.String (withCString, peekCString)
import Foreign.C.Types (CSize, CInt)
import Database.LevelDB.Base
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Unsafe as BU
newtype DB = DB LevelDBPtr deriving (Eq)
data Iterator = Iterator
{ _iterPtr :: !IteratorPtr
, _iterLock :: !(MVar ())
} deriving (Eq)
newtype Snapshot = Snapshot SnapshotPtr deriving (Eq)
data Compression = NoCompression | Snappy deriving (Eq, Show)
newtype Comparator = Comparator (ByteString -> ByteString -> Ordering)
data Comparator' = Comparator' (FunPtr CompareFun)
(FunPtr Destructor)
(FunPtr NameFun)
ComparatorPtr
data FilterPolicy = FilterPolicy
{ fpName :: String
, createFilter :: [ByteString] -> ByteString
, keyMayMatch :: ByteString -> ByteString -> Bool
}
data FilterPolicy' = FilterPolicy' (FunPtr CreateFilterFun)
(FunPtr KeyMayMatchFun)
(FunPtr Destructor)
(FunPtr NameFun)
FilterPolicyPtr
newtype BloomFilter = BloomFilter FilterPolicyPtr
bloomFilter :: MonadResource m => Int -> m BloomFilter
bloomFilter i = do
let i' = fromInteger . toInteger $ i
fp_ptr <- snd <$> allocate (c_leveldb_filterpolicy_create_bloom i')
(c_leveldb_filterpolicy_destroy)
return . BloomFilter $ fp_ptr
data Options = Options
{ blockRestartInterval :: !Int
, blockSize :: !Int
, cacheSize :: !Int
, comparator :: !(Maybe Comparator)
, compression :: !Compression
, createIfMissing :: !Bool
, errorIfExists :: !Bool
, maxOpenFiles :: !Int
, paranoidChecks :: !Bool
, writeBufferSize :: !Int
, filterPolicy :: !(Maybe (Either BloomFilter FilterPolicy))
}
defaultOptions :: Options
defaultOptions = Options
{ blockRestartInterval = 16
, blockSize = 4096
, cacheSize = 0
, comparator = Nothing
, compression = Snappy
, createIfMissing = False
, errorIfExists = False
, maxOpenFiles = 1000
, paranoidChecks = False
, writeBufferSize = 4 `shift` 20
, filterPolicy = Nothing
}
instance Default Options where
def = defaultOptions
data Options' = Options'
{ _optsPtr :: !OptionsPtr
, _cachePtr :: !(Maybe CachePtr)
, _comp :: !(Maybe Comparator')
, _fpPtr :: !(Maybe (Either FilterPolicyPtr FilterPolicy'))
}
data WriteOptions = WriteOptions
{ sync :: !Bool
} deriving (Eq, Show)
defaultWriteOptions :: WriteOptions
defaultWriteOptions = WriteOptions { sync = False }
instance Default WriteOptions where
def = defaultWriteOptions
data ReadOptions = ReadOptions
{ verifyCheckSums :: !Bool
, fillCache :: !Bool
, useSnapshot :: !(Maybe Snapshot)
} deriving (Eq)
defaultReadOptions :: ReadOptions
defaultReadOptions = ReadOptions
{ verifyCheckSums = False
, fillCache = True
, useSnapshot = Nothing
}
instance Default ReadOptions where
def = defaultReadOptions
type WriteBatch = [BatchOp]
data BatchOp = Put ByteString ByteString | Del ByteString
deriving (Eq, Show)
data Property = NumFilesAtLevel Int | Stats | SSTables
deriving (Eq, Show)
open :: MonadResource m => FilePath -> Options -> m DB
open path opts = snd <$> open' path opts
open' :: MonadResource m => FilePath -> Options -> m (ReleaseKey, DB)
open' path opts = do
opts' <- snd <$> allocate (mkOpts opts) freeOpts
allocate (mkDB opts') freeDB
where
mkDB (Options' opts_ptr _ _ _) =
withCString path $ \path_ptr ->
liftM DB
$ throwIfErr "open"
$ c_leveldb_open opts_ptr path_ptr
freeDB (DB db_ptr) = c_leveldb_close db_ptr
withSnapshot :: MonadResource m => DB -> (Snapshot -> m a) -> m a
withSnapshot db f = do
(rk, snap) <- createSnapshot' db
res <- f snap
release rk
return res
createSnapshot :: MonadResource m => DB -> m Snapshot
createSnapshot db = snd <$> createSnapshot' db
createSnapshot' :: MonadResource m => DB -> m (ReleaseKey, Snapshot)
createSnapshot' db = allocate (mkSnap db) (freeSnap db)
where
mkSnap (DB db_ptr) =
Snapshot <$> c_leveldb_create_snapshot db_ptr
freeSnap (DB db_ptr) (Snapshot snap) =
c_leveldb_release_snapshot db_ptr snap
getProperty :: MonadResource m => DB -> Property -> m (Maybe ByteString)
getProperty (DB db_ptr) p = liftIO $
withCString (prop p) $ \prop_ptr -> do
val_ptr <- c_leveldb_property_value db_ptr prop_ptr
if val_ptr == nullPtr
then return Nothing
else do res <- Just <$> BS.packCString val_ptr
free val_ptr
return res
where
prop (NumFilesAtLevel i) = "leveldb.num-files-at-level" ++ show i
prop Stats = "leveldb.stats"
prop SSTables = "leveldb.sstables"
destroy :: MonadResource m => FilePath -> Options -> m ()
destroy path opts = do
(rk, opts') <- allocate (mkOpts opts) freeOpts
liftIO $ destroy' opts'
release rk
where
destroy' (Options' opts_ptr _ _ _) =
withCString path $ \path_ptr ->
throwIfErr "destroy" $ c_leveldb_destroy_db opts_ptr path_ptr
repair :: MonadResource m => FilePath -> Options -> m ()
repair path opts = do
(rk, opts') <- allocate (mkOpts opts) freeOpts
liftIO $ repair' opts'
release rk
where
repair' (Options' opts_ptr _ _ _) =
withCString path $ \path_ptr ->
throwIfErr "repair" $ c_leveldb_repair_db opts_ptr path_ptr
type Range = (ByteString, ByteString)
approximateSize :: MonadResource m => DB -> Range -> m Int64
approximateSize (DB db_ptr) (from, to) = liftIO $
BU.unsafeUseAsCStringLen from $ \(from_ptr, flen) ->
BU.unsafeUseAsCStringLen to $ \(to_ptr, tlen) ->
withArray [from_ptr] $ \from_ptrs ->
withArray [intToCSize flen] $ \flen_ptrs ->
withArray [to_ptr] $ \to_ptrs ->
withArray [intToCSize tlen] $ \tlen_ptrs ->
allocaArray 1 $ \size_ptrs -> do
c_leveldb_approximate_sizes db_ptr 1
from_ptrs flen_ptrs
to_ptrs tlen_ptrs
size_ptrs
liftM head $ peekArray 1 size_ptrs >>= mapM toInt64
where
toInt64 = return . fromIntegral
put :: MonadResource m => DB -> WriteOptions -> ByteString -> ByteString -> m ()
put (DB db_ptr) opts key value = do
(rk, opts_ptr) <- mkCWriteOpts opts
liftIO $
BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
BU.unsafeUseAsCStringLen value $ \(val_ptr, vlen) ->
throwIfErr "put"
$ c_leveldb_put db_ptr opts_ptr
key_ptr (intToCSize klen)
val_ptr (intToCSize vlen)
release rk
get :: MonadResource m => DB -> ReadOptions -> ByteString -> m (Maybe ByteString)
get (DB db_ptr) opts key = do
(rk, opts_ptr) <- mkCReadOptions opts
res <- liftIO $
BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
alloca $ \vlen_ptr -> do
val_ptr <- throwIfErr "get" $
c_leveldb_get db_ptr opts_ptr key_ptr (intToCSize klen) vlen_ptr
vlen <- peek vlen_ptr
if val_ptr == nullPtr
then return Nothing
else do
res' <- Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen)
free val_ptr
return res'
release rk
return res
delete :: MonadResource m => DB -> WriteOptions -> ByteString -> m ()
delete (DB db_ptr) opts key = do
(rk, opts_ptr) <- mkCWriteOpts opts
liftIO $ BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
throwIfErr "delete"
$ c_leveldb_delete db_ptr opts_ptr key_ptr (intToCSize klen)
release rk
write :: MonadResource m => DB -> WriteOptions -> WriteBatch -> m ()
write (DB db_ptr) opts batch = do
(rk_opts, opts_ptr) <- mkCWriteOpts opts
(rk_batch, batch_ptr) <- allocate c_leveldb_writebatch_create
c_leveldb_writebatch_destroy
mapM_ (liftIO . batchAdd batch_ptr) batch
liftIO
$ throwIfErr "write"
$ c_leveldb_write db_ptr opts_ptr batch_ptr
mapM_ (liftIO . touch) batch
release rk_opts
release rk_batch
where
batchAdd batch_ptr (Put key val) =
BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
BU.unsafeUseAsCStringLen val $ \(val_ptr, vlen) ->
c_leveldb_writebatch_put batch_ptr
key_ptr (intToCSize klen)
val_ptr (intToCSize vlen)
batchAdd batch_ptr (Del key) =
BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
c_leveldb_writebatch_delete batch_ptr key_ptr (intToCSize klen)
touch (Put (PS p _ _) (PS p' _ _)) = do
touchForeignPtr p
touchForeignPtr p'
touch (Del (PS p _ _)) = touchForeignPtr p
withIterator :: MonadResource m => DB -> ReadOptions -> (Iterator -> m a) -> m a
withIterator db opts f = do
(rk, iter) <- iterOpen' db opts
res <- f iter
release rk
return res
iterOpen :: MonadResource m => DB -> ReadOptions -> m Iterator
iterOpen db opts = snd <$> iterOpen' db opts
iterOpen' :: MonadResource m => DB -> ReadOptions -> m (ReleaseKey, Iterator)
iterOpen' db opts = do
(rk, opts_ptr) <- mkCReadOptions opts
iter <- allocate (mkIter db opts_ptr) freeIter
release rk
return iter
where
mkIter (DB db_ptr) opts_ptr = do
lock <- liftIO $ newMVar ()
it_ptr <- liftIO
$ throwErrnoIfNull "create_iterator"
$ c_leveldb_create_iterator db_ptr opts_ptr
return $ Iterator it_ptr lock
freeIter (Iterator iter lck) =
withMVar lck (\_ -> c_leveldb_iter_destroy iter)
iterValid :: MonadResource m => Iterator -> m Bool
iterValid (Iterator iter _) = do
x <- liftIO $ c_leveldb_iter_valid iter
return (x /= 0)
iterSeek :: MonadResource m => Iterator -> ByteString -> m ()
iterSeek (Iterator iter lck) key = liftIO $ withMVar lck go
where
go _ = BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
c_leveldb_iter_seek iter key_ptr (intToCSize klen)
iterFirst :: MonadResource m => Iterator -> m ()
iterFirst (Iterator iter lck) = liftIO $ withMVar lck go
where
go _ = c_leveldb_iter_seek_to_first iter
iterLast :: MonadResource m => Iterator -> m ()
iterLast (Iterator iter lck) = liftIO $ withMVar lck go
where
go _ = c_leveldb_iter_seek_to_last iter
iterNext :: MonadResource m => Iterator -> m ()
iterNext iter@(Iterator iter_ptr lck) = do
valid <- iterValid iter
when valid $ liftIO $ withMVar lck go
where
go _ = c_leveldb_iter_next iter_ptr
iterPrev :: MonadResource m => Iterator -> m ()
iterPrev iter@(Iterator iter_ptr lck) = do
valid <- iterValid iter
when valid $ liftIO $ withMVar lck go
where
go _ = c_leveldb_iter_prev iter_ptr
iterKey :: MonadResource m => Iterator -> m (Maybe ByteString)
iterKey iter = do
valid <- iterValid iter
if not valid
then return Nothing
else iterKey' iter
where
iterKey' (Iterator iter_ptr _) = liftIO $
alloca $ \len_ptr -> do
key_ptr <- c_leveldb_iter_key iter_ptr len_ptr
if key_ptr == nullPtr
then return Nothing
else do
klen <- peek len_ptr
Just <$> BS.packCStringLen (key_ptr, cSizeToInt klen)
iterValue :: MonadResource m => Iterator -> m (Maybe ByteString)
iterValue iter = do
valid <- iterValid iter
if not valid
then return Nothing
else iterValue' iter
where
iterValue' (Iterator iter_ptr _) = liftIO $
alloca $ \len_ptr -> do
val_ptr <- c_leveldb_iter_value iter_ptr len_ptr
if val_ptr == nullPtr
then return Nothing
else do
vlen <- peek len_ptr
Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen)
iterGetError :: MonadResource m => Iterator -> m (Maybe ByteString)
iterGetError (Iterator iter_ptr _) = liftIO $
alloca $ \err_ptr -> do
poke err_ptr nullPtr
c_leveldb_iter_get_error iter_ptr err_ptr
erra <- peek err_ptr
if erra == nullPtr
then return Nothing
else do
err <- peekCString erra
return . Just . BC.pack $ err
mapIter :: MonadResource m => (Iterator -> m a) -> Iterator -> m [a]
mapIter = go []
where
go acc f iter = do
valid <- iterValid iter
if not valid
then return acc
else do
val <- f iter
_ <- iterNext iter
go (val : acc) f iter
iterItems :: MonadResource m => Iterator -> m [(ByteString, ByteString)]
iterItems iter = catMaybes <$> mapIter iterItems' iter
where
iterItems' iter' = do
mkey <- iterKey iter'
mval <- iterValue iter'
return $ (,) <$> mkey <*> mval
iterKeys :: MonadResource m => Iterator -> m [ByteString]
iterKeys iter = catMaybes <$> mapIter iterKey iter
iterValues :: MonadResource m => Iterator -> m [ByteString]
iterValues iter = catMaybes <$> mapIter iterValue iter
version :: MonadResource m => m (Int, Int)
version = do
major <- liftIO c_leveldb_major_version
minor <- liftIO c_leveldb_minor_version
return (cIntToInt major, cIntToInt minor)
mkOpts :: Options -> IO Options'
mkOpts Options{..} = do
opts_ptr <- c_leveldb_options_create
c_leveldb_options_set_block_restart_interval opts_ptr
$ intToCInt blockRestartInterval
c_leveldb_options_set_block_size opts_ptr
$ intToCSize blockSize
c_leveldb_options_set_compression opts_ptr
$ ccompression compression
c_leveldb_options_set_create_if_missing opts_ptr
$ boolToNum createIfMissing
c_leveldb_options_set_error_if_exists opts_ptr
$ boolToNum errorIfExists
c_leveldb_options_set_max_open_files opts_ptr
$ intToCInt maxOpenFiles
c_leveldb_options_set_paranoid_checks opts_ptr
$ boolToNum paranoidChecks
c_leveldb_options_set_write_buffer_size opts_ptr
$ intToCSize writeBufferSize
cache <- maybeSetCache opts_ptr cacheSize
cmp <- maybeSetCmp opts_ptr comparator
fp <- maybeSetFilterPolicy opts_ptr filterPolicy
return (Options' opts_ptr cache cmp fp)
where
ccompression NoCompression = noCompression
ccompression Snappy = snappyCompression
maybeSetCache :: OptionsPtr -> Int -> IO (Maybe CachePtr)
maybeSetCache opts_ptr size =
if size <= 0
then return Nothing
else do
cache_ptr <- c_leveldb_cache_create_lru $ intToCSize size
c_leveldb_options_set_cache opts_ptr cache_ptr
return . Just $ cache_ptr
maybeSetCmp :: OptionsPtr -> Maybe Comparator -> IO (Maybe Comparator')
maybeSetCmp opts_ptr (Just mcmp) = Just <$> setcmp opts_ptr mcmp
maybeSetCmp _ Nothing = return Nothing
setcmp :: OptionsPtr -> Comparator -> IO Comparator'
setcmp opts_ptr (Comparator cmp) = do
cmp'@(Comparator' _ _ _ cmp_ptr) <- mkComparator "user-defined" cmp
c_leveldb_options_set_comparator opts_ptr cmp_ptr
return cmp'
maybeSetFilterPolicy :: OptionsPtr
-> Maybe (Either BloomFilter FilterPolicy)
-> IO (Maybe (Either FilterPolicyPtr FilterPolicy'))
maybeSetFilterPolicy _ Nothing = return Nothing
maybeSetFilterPolicy opts_ptr (Just (Left (BloomFilter bloom_ptr))) = do
c_leveldb_options_set_filter_policy opts_ptr bloom_ptr
return Nothing
maybeSetFilterPolicy opts_ptr (Just (Right fp)) = do
fp'@(FilterPolicy' _ _ _ _ fp_ptr) <- mkFilterPolicy fp
c_leveldb_options_set_filter_policy opts_ptr fp_ptr
return . Just . Right $ fp'
freeOpts :: Options' -> IO ()
freeOpts (Options' opts_ptr mcache_ptr mcmp_ptr mfp) = do
c_leveldb_options_destroy opts_ptr
maybe (return ()) c_leveldb_cache_destroy mcache_ptr
maybe (return ()) freeComparator mcmp_ptr
maybe (return ())
(either c_leveldb_filterpolicy_destroy freeFilterPolicy)
mfp
return ()
mkCWriteOpts :: MonadResource m => WriteOptions -> m (ReleaseKey, WriteOptionsPtr)
mkCWriteOpts WriteOptions{..} = do
(rk, opts_ptr) <- allocate c_leveldb_writeoptions_create
c_leveldb_writeoptions_destroy
liftIO
$ c_leveldb_writeoptions_set_sync opts_ptr
$ boolToNum sync
return (rk, opts_ptr)
mkCReadOptions:: MonadResource m => ReadOptions -> m (ReleaseKey, ReadOptionsPtr)
mkCReadOptions ReadOptions{..} = do
(rk, opts_ptr) <- allocate c_leveldb_readoptions_create
c_leveldb_readoptions_destroy
liftIO
$ c_leveldb_readoptions_set_verify_checksums opts_ptr
$ boolToNum verifyCheckSums
liftIO
$ c_leveldb_readoptions_set_verify_checksums opts_ptr
$ boolToNum fillCache
maybeSetSnapshot opts_ptr useSnapshot
return (rk, opts_ptr)
where
maybeSetSnapshot opts_ptr (Just (Snapshot snap_ptr)) =
liftIO $ c_leveldb_readoptions_set_snapshot opts_ptr snap_ptr
maybeSetSnapshot _ Nothing = return ()
throwIfErr :: String -> (ErrPtr -> IO a) -> IO a
throwIfErr s f = alloca $ \err_ptr -> do
poke err_ptr nullPtr
res <- f err_ptr
erra <- peek err_ptr
when (erra /= nullPtr) $ do
err <- peekCString erra
throwIO $ userError $ s ++ ": " ++ err
return res
cSizeToInt :: CSize -> Int
cSizeToInt = fromIntegral
intToCSize :: Int -> CSize
intToCSize = fromIntegral
intToCInt :: Int -> CInt
intToCInt = fromIntegral
cIntToInt :: CInt -> Int
cIntToInt = fromIntegral
boolToNum :: Num b => Bool -> b
boolToNum True = fromIntegral (1 :: Int)
boolToNum False = fromIntegral (0 :: Int)
mkCompareFun :: (ByteString -> ByteString -> Ordering) -> CompareFun
mkCompareFun cmp = cmp'
where
cmp' _ a alen b blen = do
a' <- BS.packCStringLen (a, fromInteger . toInteger $ alen)
b' <- BS.packCStringLen (b, fromInteger . toInteger $ blen)
return $ case cmp a' b' of
EQ -> 0
GT -> 1
LT -> 1
mkComparator :: String -> (ByteString -> ByteString -> Ordering) -> IO Comparator'
mkComparator name f =
withCString name $ \cs -> do
ccmpfun <- mkCmp . mkCompareFun $ f
cdest <- mkDest $ \_ -> ()
cname <- mkName $ \_ -> cs
ccmp <- c_leveldb_comparator_create nullPtr cdest ccmpfun cname
return $ Comparator' ccmpfun cdest cname ccmp
freeComparator :: Comparator' -> IO ()
freeComparator (Comparator' ccmpfun cdest cname ccmp) = do
c_leveldb_comparator_destroy ccmp
freeHaskellFunPtr ccmpfun
freeHaskellFunPtr cdest
freeHaskellFunPtr cname
mkCreateFilterFun :: ([ByteString] -> ByteString) -> CreateFilterFun
mkCreateFilterFun f = f'
where
f' _ ks ks_lens n_ks flen = do
let n_ks' = fromInteger . toInteger $ n_ks
ks' <- peekArray n_ks' ks
ks_lens' <- peekArray n_ks' ks_lens
keys <- mapM bstr (zip ks' ks_lens')
let res = f keys
poke flen (fromIntegral . BS.length $ res)
BS.useAsCString res $ \cstr -> return cstr
bstr (x,len) = BS.packCStringLen (x, fromInteger . toInteger $ len)
mkKeyMayMatchFun :: (ByteString -> ByteString -> Bool) -> KeyMayMatchFun
mkKeyMayMatchFun g = g'
where
g' _ k klen f flen = do
k' <- BS.packCStringLen (k, fromInteger . toInteger $ klen)
f' <- BS.packCStringLen (f, fromInteger . toInteger $ flen)
return . boolToNum $ g k' f'
mkFilterPolicy :: FilterPolicy -> IO FilterPolicy'
mkFilterPolicy FilterPolicy{..} =
withCString fpName $ \cs -> do
cname <- mkName $ \_ -> cs
cdest <- mkDest $ \_ -> ()
ccffun <- mkCF . mkCreateFilterFun $ createFilter
ckmfun <- mkKMM . mkKeyMayMatchFun $ keyMayMatch
cfp <- c_leveldb_filterpolicy_create nullPtr cdest ccffun ckmfun cname
return $ FilterPolicy' ccffun ckmfun cdest cname cfp
freeFilterPolicy :: FilterPolicy' -> IO ()
freeFilterPolicy (FilterPolicy' ccffun ckmfun cdest cname cfp) = do
c_leveldb_filterpolicy_destroy cfp
freeHaskellFunPtr ccffun
freeHaskellFunPtr ckmfun
freeHaskellFunPtr cdest
freeHaskellFunPtr cname