module Database.LevelDB (
DB
, BatchOp(..)
, Comparator(..)
, Compression(..)
, Options(..)
, ReadOptions(..)
, Snapshot
, WriteBatch
, WriteOptions(..)
, Range
, defaultOptions
, defaultWriteOptions
, defaultReadOptions
, withSnapshot
, open
, put
, delete
, write
, get
, createSnapshot
, createSnapshot'
, Property(..), getProperty
, destroy
, repair
, approximateSize
, 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.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 SB
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Unsafe as UB
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 Options = Options
{ blockRestartInterval :: !Int
, blockSize :: !Int
, cacheSize :: !Int
, comparator :: !(Maybe Comparator)
, compression :: !Compression
, createIfMissing :: !Bool
, errorIfExists :: !Bool
, maxOpenFiles :: !Int
, paranoidChecks :: !Bool
, writeBufferSize :: !Int
}
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
}
instance Default Options where
def = defaultOptions
data Options' = Options'
{ _optsPtr :: !OptionsPtr
, _cachePtr :: !(Maybe CachePtr)
, _comp :: !(Maybe Comparator')
}
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 <$> SB.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 $
UB.unsafeUseAsCStringLen from $ \(from_ptr, flen) ->
UB.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 $
UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
UB.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 $
UB.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 <$> SB.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 $ UB.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
release rk_opts
release rk_batch
where
batchAdd batch_ptr (Put key val) =
UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
UB.unsafeUseAsCStringLen val $ \(val_ptr, vlen) ->
c_leveldb_writebatch_put batch_ptr
key_ptr (intToCSize klen)
val_ptr (intToCSize vlen)
batchAdd batch_ptr (Del key) =
UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
c_leveldb_writebatch_delete batch_ptr key_ptr (intToCSize klen)
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 _ = UB.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 <$> SB.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 <$> SB.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
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
return (Options' opts_ptr cache cmp)
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'
freeOpts :: Options' -> IO ()
freeOpts (Options' opts_ptr mcache_ptr mcmp_ptr) = do
c_leveldb_options_destroy opts_ptr
maybe (return ()) c_leveldb_cache_destroy mcache_ptr
maybe (return ()) freeComparator mcmp_ptr
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
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' <- SB.packCStringLen (a, fromInteger . toInteger $ alen)
b' <- SB.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