diff --git a/examples/filterpolicy.hs b/examples/filterpolicy.hs new file mode 100644 --- /dev/null +++ b/examples/filterpolicy.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Demo filter policy / bloom filter + +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 + bloom <- bloomFilter 10 + db <- open "/tmp/lvlbloomtest" + defaultOptions { createIfMissing = True + , filterPolicy = Just . Left $ bloom + } + + 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 () + +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 new file mode 100644 --- /dev/null +++ b/examples/giantwrite.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.Word +import Prelude hiding (putStrLn) +import System.FilePath + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC + +import Database.LevelDB +import Debug.Trace + + +main :: IO () +main = runResourceT $ do + db <- open "/tmp/giantwrite" + defaultOptions { createIfMissing = True } + + let w x = put db def x x + mapM_ (w . BC.pack . show) [1..10000000] + + 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.0 +version: 0.1.1 synopsis: Haskell bindings to LevelDB homepage: http://github.com/kim/leveldb-haskell bug-reports: http://github.com/kim/leveldb-haskell/issues diff --git a/src/Database/LevelDB.hs b/src/Database/LevelDB.hs --- a/src/Database/LevelDB.hs +++ b/src/Database/LevelDB.hs @@ -71,25 +71,25 @@ , 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.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 (ByteString) import Data.Default -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes) import Foreign -import Foreign.C.Error (throwErrnoIfNull) -import Foreign.C.String (withCString, peekCString) -import Foreign.C.Types (CSize, CInt) +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 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Unsafe as BU -- import Debug.Trace @@ -345,7 +345,7 @@ 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 + else do res <- Just <$> BS.packCString val_ptr free val_ptr return res @@ -384,12 +384,12 @@ -- | Inspect the approximate sizes of the different levels 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) -> + BU.unsafeUseAsCStringLen from $ \(from_ptr, flen) -> + BU.unsafeUseAsCStringLen to $ \(to_ptr, tlen) -> withArray [from_ptr] $ \from_ptrs -> - withArray [intToCSize flen] $ \flen_ptrs -> + withArray [intToCSize flen] $ \flen_ptrs -> withArray [to_ptr] $ \to_ptrs -> - withArray [intToCSize tlen] $ \tlen_ptrs -> + withArray [intToCSize tlen] $ \tlen_ptrs -> allocaArray 1 $ \size_ptrs -> do c_leveldb_approximate_sizes db_ptr 1 from_ptrs flen_ptrs @@ -406,8 +406,8 @@ (rk, opts_ptr) <- mkCWriteOpts opts liftIO $ - UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> - UB.unsafeUseAsCStringLen value $ \(val_ptr, vlen) -> + 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) @@ -421,7 +421,7 @@ (rk, opts_ptr) <- mkCReadOptions opts res <- liftIO $ - UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> + 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 @@ -429,7 +429,7 @@ if val_ptr == nullPtr then return Nothing else do - res' <- Just <$> SB.packCStringLen (val_ptr, cSizeToInt vlen) + res' <- Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen) free val_ptr return res' @@ -441,7 +441,7 @@ delete (DB db_ptr) opts key = do (rk, opts_ptr) <- mkCWriteOpts opts - liftIO $ UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> + liftIO $ BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> throwIfErr "delete" $ c_leveldb_delete db_ptr opts_ptr key_ptr (intToCSize klen) @@ -465,14 +465,14 @@ where batchAdd batch_ptr (Put key val) = - UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> - UB.unsafeUseAsCStringLen val $ \(val_ptr, vlen) -> + BS.useAsCStringLen key $ \(key_ptr, klen) -> + BS.useAsCStringLen 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) -> + BS.useAsCStringLen key $ \(key_ptr, klen) -> c_leveldb_writebatch_delete batch_ptr key_ptr (intToCSize klen) -- | Run an action with an Iterator. The iterator will be closed after the @@ -530,7 +530,7 @@ iterSeek :: MonadResource m => Iterator -> ByteString -> m () iterSeek (Iterator iter lck) key = liftIO $ withMVar lck go where - go _ = UB.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> + go _ = BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> c_leveldb_iter_seek iter key_ptr (intToCSize klen) -- | Position at the first key in the source. The iterator is /valid/ after this @@ -592,7 +592,7 @@ then return Nothing else do klen <- peek len_ptr - Just <$> SB.packCStringLen (key_ptr, cSizeToInt klen) + Just <$> BS.packCStringLen (key_ptr, cSizeToInt klen) -- | Return the value for the current entry if the iterator is currently -- positioned at an entry, ie. 'iterValid'. @@ -611,7 +611,7 @@ then return Nothing else do vlen <- peek len_ptr - Just <$> SB.packCStringLen (val_ptr, cSizeToInt vlen) + Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen) -- | Check for errors -- @@ -801,8 +801,8 @@ mkCompareFun cmp = cmp' where cmp' _ a alen b blen = do - a' <- SB.packCStringLen (a, fromInteger . toInteger $ alen) - b' <- SB.packCStringLen (b, fromInteger . toInteger $ blen) + a' <- BS.packCStringLen (a, fromInteger . toInteger $ alen) + b' <- BS.packCStringLen (b, fromInteger . toInteger $ blen) return $ case cmp a' b' of EQ -> 0 GT -> 1