diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -3,6 +3,14 @@ ## History +Version 0.2.0: + +* requires LevelDB v1.7 +* support for filter policy (LevelDB v1.5), either custom or using the built-in + bloom filter implementation +* write batch values no longer require a `memcpy` to be early-finalizer-safe + (introduced in 0.1.1) + Version 0.1.0: * memory (foreign pointers) is managed through diff --git a/examples/features.hs b/examples/features.hs --- a/examples/features.hs +++ b/examples/features.hs @@ -16,6 +16,8 @@ main :: IO () main = runResourceT $ do + printVersion + db <- open "/tmp/leveltest" defaultOptions{ createIfMissing = True , cacheSize= 2048 @@ -65,3 +67,14 @@ printProperty l p = liftIO $ do putStrLn l maybe (putStrLn "n/a") putStrLn $ p + + printVersion = do + v <- versionBS + liftIO . putStrLn $ "LevelDB Version: " `append` v + + versionBS = do + (major, minor) <- version + return $ intToBs major `append` "." `append` intToBs minor + + intToBs :: Int -> ByteString + intToBs = pack . show diff --git a/examples/filterpolicy.hs b/examples/filterpolicy.hs --- a/examples/filterpolicy.hs +++ b/examples/filterpolicy.hs @@ -5,19 +5,13 @@ module Main where import Control.Monad.IO.Class (liftIO) -import Data.BloomFilter -import Data.BloomFilter.Easy (easyList) -import Data.BloomFilter.Hash (cheapHashes) -import Data.ByteString.Char8 (take) import Data.Default import Database.LevelDB -import qualified Data.Serialize as S - -builtinBloom :: IO () -builtinBloom = runResourceT $ do +main :: IO () +main = runResourceT $ do bloom <- bloomFilter 10 db <- open "/tmp/lvlbloomtest" defaultOptions { createIfMissing = True @@ -32,33 +26,3 @@ get db def "xxx" >>= liftIO . print return () - -customFilterPolicy :: IO () -customFilterPolicy = runResourceT $ do - let create bs = S.encode . bitArrayB $ easyList 0.01 bs - maymatch k bs = False - fp = FilterPolicy - { fpName = "custom.filter.policy" - , createFilter = create - , keyMayMatch = maymatch - } - - db <- open "/tmp/lvlfptest" - defaultOptions { createIfMissing = True - , filterPolicy = Just . Right $ fp - } - - put db def "zzz" "zzz" - put db def "yyy" "yyy" - put db def "xxx" "xxx" - - get db def "yyy" >>= liftIO . print - get db def "xxx" >>= liftIO . print - - return () - - -main :: IO () -main = do - builtinBloom - customFilterPolicy diff --git a/examples/giantwrite.hs b/examples/giantwrite.hs --- a/examples/giantwrite.hs +++ b/examples/giantwrite.hs @@ -21,6 +21,6 @@ defaultOptions { createIfMissing = True } let w x = put db def x x - mapM_ (w . BC.pack . show) [1..10000000] + mapM_ (w . BC.pack . show) [1..100000] approximateSize db ("0", "z") >>= liftIO . print diff --git a/leveldb-haskell.cabal b/leveldb-haskell.cabal --- a/leveldb-haskell.cabal +++ b/leveldb-haskell.cabal @@ -1,5 +1,5 @@ name: leveldb-haskell -version: 0.1.1 +version: 0.2.0 synopsis: Haskell bindings to LevelDB homepage: http://github.com/kim/leveldb-haskell bug-reports: http://github.com/kim/leveldb-haskell/issues @@ -28,7 +28,7 @@ . Note: as of v1.3, LevelDB can be built as a shared library. Thus, as of v0.1.0 of this library, LevelDB is no longer bundled and must be installed - on the target system (version 1.3 or greater). + on the target system (version 1.7 or greater is required). extra-source-files: Readme.md, examples/*.hs diff --git a/src/Database/LevelDB.hs b/src/Database/LevelDB.hs --- a/src/Database/LevelDB.hs +++ b/src/Database/LevelDB.hs @@ -40,11 +40,16 @@ , createSnapshot , createSnapshot' + -- * Filter Policy / Bloom Filter + , FilterPolicy(..) + , bloomFilter + -- * Administrative Functions , Property(..), getProperty , destroy , repair , approximateSize + , version -- * Iteration , Iterator @@ -78,6 +83,7 @@ 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 @@ -116,6 +122,30 @@ (FunPtr NameFun) ComparatorPtr +-- | User-defined filter policy +data FilterPolicy = FilterPolicy + { fpName :: String + , createFilter :: [ByteString] -> ByteString + , keyMayMatch :: ByteString -> ByteString -> Bool + } + +data FilterPolicy' = FilterPolicy' (FunPtr CreateFilterFun) + (FunPtr KeyMayMatchFun) + (FunPtr Destructor) + (FunPtr NameFun) + FilterPolicyPtr + +-- | Represents the built-in Bloom Filter +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 + + -- | Options when opening a database data Options = Options { blockRestartInterval :: !Int @@ -195,6 +225,7 @@ -- database is opened. -- -- Default: 4MB + , filterPolicy :: !(Maybe (Either BloomFilter FilterPolicy)) } defaultOptions :: Options @@ -209,6 +240,7 @@ , maxOpenFiles = 1000 , paranoidChecks = False , writeBufferSize = 4 `shift` 20 + , filterPolicy = Nothing } instance Default Options where @@ -218,6 +250,7 @@ { _optsPtr :: !OptionsPtr , _cachePtr :: !(Maybe CachePtr) , _comp :: !(Maybe Comparator') + , _fpPtr :: !(Maybe (Either FilterPolicyPtr FilterPolicy')) } -- | Options for write operations @@ -298,7 +331,7 @@ allocate (mkDB opts') freeDB where - mkDB (Options' opts_ptr _ _) = + mkDB (Options' opts_ptr _ _ _) = withCString path $ \path_ptr -> liftM DB $ throwIfErr "open" @@ -362,7 +395,7 @@ release rk where - destroy' (Options' opts_ptr _ _) = + destroy' (Options' opts_ptr _ _ _) = withCString path $ \path_ptr -> throwIfErr "destroy" $ c_leveldb_destroy_db opts_ptr path_ptr @@ -374,7 +407,7 @@ release rk where - repair' (Options' opts_ptr _ _) = + repair' (Options' opts_ptr _ _ _) = withCString path $ \path_ptr -> throwIfErr "repair" $ c_leveldb_repair_db opts_ptr path_ptr @@ -460,21 +493,31 @@ $ throwIfErr "write" $ c_leveldb_write db_ptr opts_ptr batch_ptr + -- ensure @ByteString@s (and respective shared @CStringLen@s) aren't GC'ed + -- until here + mapM_ (liftIO . touch) batch + release rk_opts release rk_batch where batchAdd batch_ptr (Put key val) = - BS.useAsCStringLen key $ \(key_ptr, klen) -> - BS.useAsCStringLen val $ \(val_ptr, vlen) -> + 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) = - BS.useAsCStringLen key $ \(key_ptr, klen) -> + 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 + -- | Run an action with an Iterator. The iterator will be closed after the -- action returns or an error is thrown. Thus, the iterator will /not/ be valid -- after this function terminates. @@ -676,6 +719,16 @@ iterValues :: MonadResource m => Iterator -> m [ByteString] iterValues iter = catMaybes <$> mapIter iterValue iter + +-- | Return the runtime version of the underlying LevelDB library as a (major, +-- minor) pair. +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) + -- -- Internal -- @@ -703,8 +756,9 @@ cache <- maybeSetCache opts_ptr cacheSize cmp <- maybeSetCmp opts_ptr comparator + fp <- maybeSetFilterPolicy opts_ptr filterPolicy - return (Options' opts_ptr cache cmp) + return (Options' opts_ptr cache cmp fp) where ccompression NoCompression = noCompression @@ -729,11 +783,27 @@ 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 -- bloom filter is freed automatically + 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) = do +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) @@ -792,6 +862,10 @@ intToCInt = fromIntegral {-# INLINE intToCInt #-} +cIntToInt :: CInt -> Int +cIntToInt = fromIntegral +{-# INLINE cIntToInt #-} + boolToNum :: Num b => Bool -> b boolToNum True = fromIntegral (1 :: Int) boolToNum False = fromIntegral (0 :: Int) @@ -799,6 +873,7 @@ mkCompareFun :: (ByteString -> ByteString -> Ordering) -> CompareFun mkCompareFun cmp = cmp' + where cmp' _ a alen b blen = do a' <- BS.packCStringLen (a, fromInteger . toInteger $ alen) @@ -811,7 +886,7 @@ mkComparator :: String -> (ByteString -> ByteString -> Ordering) -> IO Comparator' mkComparator name f = withCString name $ \cs -> do - ccmpfun <- mkCmp $ mkCompareFun f + ccmpfun <- mkCmp . mkCompareFun $ f cdest <- mkDest $ \_ -> () cname <- mkName $ \_ -> cs ccmp <- c_leveldb_comparator_create nullPtr cdest ccmpfun cname @@ -822,5 +897,49 @@ 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 diff --git a/src/Database/LevelDB/Base.hsc b/src/Database/LevelDB/Base.hsc --- a/src/Database/LevelDB/Base.hsc +++ b/src/Database/LevelDB/Base.hsc @@ -26,6 +26,7 @@ data LSnapshot data LWriteBatch data LWriteOptions +data LFilterPolicy type LevelDBPtr = Ptr LevelDB type CachePtr = Ptr LCache @@ -37,18 +38,7 @@ type SnapshotPtr = Ptr LSnapshot type WriteBatchPtr = Ptr LWriteBatch type WriteOptionsPtr = Ptr LWriteOptions - --- custom env from haskell doesn't make too much sense -data LEnv -data LFileLock -data LRandomFile -data LSeqfile -data LWritableFile -type EnvPtr = Ptr LEnv -type FileLockPtr = Ptr LFileLock -type RandomFilePtr = Ptr LRandomFile -type WritableFilePtr = Ptr LWritableFile -type SeqfilePtr = Ptr LSeqfile +type FilterPolicyPtr = Ptr LFilterPolicy type DBName = CString type ErrPtr = Ptr CString @@ -113,7 +103,6 @@ foreign import ccall safe "leveldb/c.h leveldb_property_value" c_leveldb_property_value :: LevelDBPtr -> CString -> IO CString --- not sure why this needs to be imported safe foreign import ccall safe "leveldb/c.h leveldb_approximate_sizes" c_leveldb_approximate_sizes :: LevelDBPtr -> CInt -- ^ num ranges @@ -128,8 +117,11 @@ foreign import ccall safe "leveldb/c.h leveldb_repair_db" c_leveldb_repair_db :: OptionsPtr -> DBName -> ErrPtr -> IO () --- ^ Iterator +-- +-- Iterator +-- + foreign import ccall safe "leveldb/c.h leveldb_create_iterator" c_leveldb_create_iterator :: LevelDBPtr -> ReadOptionsPtr -> IO IteratorPtr @@ -163,8 +155,11 @@ foreign import ccall safe "leveldb/c.h leveldb_iter_get_error" c_leveldb_iter_get_error :: IteratorPtr -> ErrPtr -> IO () --- ^ Write batch +-- +-- Write batch +-- + foreign import ccall safe "leveldb/c.h leveldb_writebatch_create" c_leveldb_writebatch_create :: IO WriteBatchPtr @@ -190,8 +185,11 @@ -> FunPtr (Ptr () -> Key -> CSize) -- ^ delete -> IO () --- ^ Options +-- +-- Options +-- + foreign import ccall safe "leveldb/c.h leveldb_options_create" c_leveldb_options_create :: IO OptionsPtr @@ -201,6 +199,9 @@ foreign import ccall safe "leveldb/c.h leveldb_options_set_comparator" c_leveldb_options_set_comparator :: OptionsPtr -> ComparatorPtr -> IO () +foreign import ccall safe "leveldb/c.h leveldb_options_set_filter_policy" + c_leveldb_options_set_filter_policy :: OptionsPtr -> FilterPolicyPtr -> IO () + foreign import ccall safe "leveldb/c.h leveldb_options_set_create_if_missing" c_leveldb_options_set_create_if_missing :: OptionsPtr -> CUChar -> IO () @@ -210,9 +211,6 @@ foreign import ccall safe "leveldb/c.h leveldb_options_set_paranoid_checks" c_leveldb_options_set_paranoid_checks :: OptionsPtr -> CUChar -> IO () -foreign import ccall safe "leveldb/c.h leveldb_options_set_env" - c_leveldb_options_set_env :: OptionsPtr -> EnvPtr -> IO () - foreign import ccall safe "leveldb/c.h leveldb_options_set_info_log" c_leveldb_options_set_info_log :: OptionsPtr -> LoggerPtr -> IO () @@ -234,9 +232,11 @@ foreign import ccall safe "leveldb/c.h leveldb_options_set_cache" c_leveldb_options_set_cache :: OptionsPtr -> CachePtr -> IO () + -- -- Comparator -- + type StatePtr = Ptr () type Destructor = StatePtr -> () type CompareFun = StatePtr -> CString -> CSize -> CString -> CSize -> IO CInt @@ -261,8 +261,48 @@ foreign import ccall safe "leveldb/c.h leveldb_comparator_destroy" c_leveldb_comparator_destroy :: ComparatorPtr -> IO () --- ^ Read options +-- +-- Filter Policy +-- + +type CreateFilterFun = StatePtr + -> Ptr CString -- ^ key array + -> Ptr CSize -- ^ key length array + -> CInt -- ^ num keys + -> Ptr CSize -- ^ filter length + -> IO CString -- ^ the filter +type KeyMayMatchFun = StatePtr + -> CString -- ^ key + -> CSize -- ^ key length + -> CString -- ^ filter + -> CSize -- ^ filter length + -> IO CUChar -- ^ whether key is in filter + +-- | Make a FunPtr to a user-defined create_filter function +foreign import ccall "wrapper" mkCF :: CreateFilterFun -> IO (FunPtr CreateFilterFun) + +-- | Make a FunPtr to a user-defined key_may_match function +foreign import ccall "wrapper" mkKMM :: KeyMayMatchFun -> IO (FunPtr KeyMayMatchFun) + +foreign import ccall safe "leveldb/c.h leveldb_filterpolicy_create" + c_leveldb_filterpolicy_create :: StatePtr + -> FunPtr Destructor + -> FunPtr CreateFilterFun + -> FunPtr KeyMayMatchFun + -> FunPtr NameFun + -> IO FilterPolicyPtr + +foreign import ccall safe "leveldb/c.h leveldb_filterpolicy_destroy" + c_leveldb_filterpolicy_destroy :: FilterPolicyPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_filterpolicy_create_bloom" + c_leveldb_filterpolicy_create_bloom :: CInt -> IO FilterPolicyPtr + +-- +-- Read options +-- + foreign import ccall safe "leveldb/c.h leveldb_readoptions_create" c_leveldb_readoptions_create :: IO ReadOptionsPtr @@ -278,8 +318,11 @@ foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_snapshot" c_leveldb_readoptions_set_snapshot :: ReadOptionsPtr -> SnapshotPtr -> IO () --- ^ Write options +-- +-- Write options +-- + foreign import ccall safe "leveldb/c.h leveldb_writeoptions_create" c_leveldb_writeoptions_create :: IO WriteOptionsPtr @@ -289,18 +332,24 @@ foreign import ccall safe "leveldb/c.h leveldb_writeoptions_set_sync" c_leveldb_writeoptions_set_sync :: WriteOptionsPtr -> CUChar -> IO () --- ^ Cache +-- +-- Cache +-- + foreign import ccall safe "leveldb/c.h leveldb_cache_create_lru" c_leveldb_cache_create_lru :: CSize -> IO CachePtr foreign import ccall safe "leveldb/c.h leveldb_cache_destroy" c_leveldb_cache_destroy :: CachePtr -> IO () --- ^ Env -foreign import ccall safe "leveldb/c.h leveldb_create_default_env" - c_leveldb_create_default_env :: IO EnvPtr +-- +-- Version +-- -foreign import ccall safe "leveldb/c.h leveldb_env_destroy" - c_leveldb_env_destroy :: EnvPtr -> IO () +foreign import ccall unsafe "leveldb/c.h leveldb_major_version" + c_leveldb_major_version :: IO CInt + +foreign import ccall unsafe "leveldb/c.h leveldb_minor_version" + c_leveldb_minor_version :: IO CInt