diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,8 @@ +# The following people, listed in alphabetical order, contributed to the +# leveldb-haskell library: + +Austin Seipp +Kim Altintop +Michael Lazarev +Nicolas Trangez +Will Moss diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,28 @@ +[0.3.0]: + +* ResourceT is no longer compulsory + + +[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) + + +[0.1.0]: + +* memory (foreign pointers) is managed through + [ResourceT](http://hackage.haskell.org/package/resourcet). Note that this + requires to lift monadic actions inside the `MonadResource` monad, see the + examples. +* links against shared library (LevelDB v1.3 or higher) +* LevelDB 1.3 API fully supported (including custom comparators, excluding + custom environments) + + +[0.0.x]: + +* experimental releases diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -1,7 +1,13 @@ This library provides Haskell bindings to [LevelDB](http://leveldb.googlecode.com) +[![Build Status](https://secure.travis-ci.org/kim/leveldb-haskell.png)](http://travis-ci.org/kim/leveldb-haskell) + ## History + +Version 0.3.0: + +* ResourceT is no longer compulsory Version 0.2.0: diff --git a/examples/comparator.hs b/examples/comparator.hs --- a/examples/comparator.hs +++ b/examples/comparator.hs @@ -5,7 +5,6 @@ module Main where import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Char8 (take) import Data.Default import Database.LevelDB diff --git a/examples/features.hs b/examples/features.hs --- a/examples/features.hs +++ b/examples/features.hs @@ -6,10 +6,10 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (release) import Data.ByteString.Char8 hiding (take) import Data.Default import Prelude hiding (putStrLn) -import System.FilePath import Database.LevelDB @@ -33,8 +33,7 @@ , Put "c" "three" ] - withIterator db def{useSnapshot = Just snap} $ \iter -> - dumpEntries iter + withIterator db def{useSnapshot = Just snap} $ \iter -> dumpEntries iter -- early release snapshot release releaseSnap @@ -59,22 +58,23 @@ return () - where - dumpEntries iter = do - iterFirst iter - iterItems iter >>= liftIO . print + where - printProperty l p = liftIO $ do - putStrLn l - maybe (putStrLn "n/a") putStrLn $ p + dumpEntries iter = do + iterFirst iter + iterItems iter >>= liftIO . print - printVersion = do - v <- versionBS - liftIO . putStrLn $ "LevelDB Version: " `append` v + printProperty l p = liftIO $ do + putStrLn l + maybe (putStrLn "n/a") putStrLn p - versionBS = do - (major, minor) <- version - return $ intToBs major `append` "." `append` intToBs minor + printVersion = do + v <- versionBS + liftIO . putStrLn $ "LevelDB Version: " `append` v - intToBs :: Int -> ByteString - intToBs = pack . show + versionBS = do + (major, minor) <- version + return $ intToBs major `append` "." `append` intToBs minor + + intToBs :: Int -> ByteString + intToBs = pack . show diff --git a/examples/giantwrite.hs b/examples/giantwrite.hs deleted file mode 100644 --- a/examples/giantwrite.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# 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..100000] - - approximateSize db ("0", "z") >>= liftIO . print diff --git a/examples/iterforkio.hs b/examples/iterforkio.hs new file mode 100644 --- /dev/null +++ b/examples/iterforkio.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- | +-- Simplistic demo of 'Iterator' synchronization, using the 'Base" API +-- +module Main where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Data.Default + +import Database.LevelDB.Base + +import qualified Data.ByteString.Char8 as BS + +main :: IO () +main = bracket (open "/tmp/leveltest" def{ createIfMissing = True }) close $ \ db -> do + + let xs = [1..100] :: [Int] + + write db def (map (\ x -> Put (BS.pack . show $ x) "") xs) + + bracket (createIter db def) releaseIter $ \ iter -> do + _ <- iterFirst iter + lck <- newMVar iter + es <- mapConcurrently (getEntry lck) xs + mapM (\ (i,e) -> putStrLn $ "#" ++ show i ++ ": " ++ show e) es + + return () + where + getEntry lck i = withMVar lck $ \ iter -> do + entry <- iterEntry iter + iterNext iter + return (i, entry) diff --git a/leveldb-haskell.cabal b/leveldb-haskell.cabal --- a/leveldb-haskell.cabal +++ b/leveldb-haskell.cabal @@ -1,21 +1,18 @@ name: leveldb-haskell -version: 0.2.0 +version: 0.3.0 synopsis: Haskell bindings to LevelDB homepage: http://github.com/kim/leveldb-haskell bug-reports: http://github.com/kim/leveldb-haskell/issues license: BSD3 license-file: LICENSE -author: Kim Altintop - , Austin Seipp - , Michael Lazarev - , Will Moss +author: Kim Altintop et.al. (see AUTHORS file) maintainer: kim.altintop@gmail.com -copyright: Copyright (c) 2012 The leveldb-haskell Authors +copyright: Copyright (c) 2012-2014 The leveldb-haskell Authors category: Database, FFI stability: Experimental build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 7.2.2, GHC == 7.4.1 +tested-with: GHC == 7.2.2, GHC == 7.4.1, GHC == 7.6.3 description: From : . @@ -30,34 +27,125 @@ v0.1.0 of this library, LevelDB is no longer bundled and must be installed on the target system (version 1.7 or greater is required). -extra-source-files: Readme.md, examples/*.hs +extra-source-files: Readme.md, AUTHORS, CHANGELOG examples/*.hs source-repository head type: git location: git://github.com/kim/leveldb-haskell.git +Flag Examples + description: Build examples + default: False + manual: True + library exposed-modules: Database.LevelDB - other-modules: Database.LevelDB.Base + , Database.LevelDB.Base + , Database.LevelDB.C + , Database.LevelDB.Internal + , Database.LevelDB.Iterator + , Database.LevelDB.MonadResource + , Database.LevelDB.Types default-language: Haskell2010 - default-extensions: - CPP + other-extensions: CPP , ForeignFunctionInterface , EmptyDataDecls , RecordWildCards build-depends: base >= 3 && < 5 , bytestring + , data-default , filepath - , transformers , resourcet > 0.3.2 - , data-default + , transformers - ghc-options: -Wall -O2 -rtsopts - -funbox-strict-fields + ghc-options: -Wall -rtsopts -funbox-strict-fields ghc-prof-options: -prof -auto-all hs-source-dirs: src extra-libraries: leveldb + +executable leveldb-example-comparator + main-is: comparator.hs + + default-language: Haskell2010 + + build-depends: base >= 3 && < 5 + , transformers + , data-default + , leveldb-haskell + + ghc-options: -Wall -Werror -O -rtsopts + ghc-prof-options: -prof -auto-all + + hs-source-dirs: examples + + if flag(Examples) + buildable: True + else + buildable: False + +executable leveldb-example-features + main-is: features.hs + + default-language: Haskell2010 + + build-depends: base >= 3 && < 5 + , bytestring + , transformers + , resourcet > 0.3.2 + , data-default + , leveldb-haskell + + ghc-options: -Wall -Werror -O -rtsopts + ghc-prof-options: -prof -auto-all + + hs-source-dirs: examples + + if flag(Examples) + buildable: True + else + buildable: False + +executable leveldb-example-filterpolicy + main-is: filterpolicy.hs + + default-language: Haskell2010 + + build-depends: base >= 3 && < 5 + , transformers + , data-default + , leveldb-haskell + + ghc-options: -Wall -Werror -O -rtsopts + ghc-prof-options: -prof -auto-all + + hs-source-dirs: examples + + if flag(Examples) + buildable: True + else + buildable: False + +executable leveldb-example-iterforkio + main-is: iterforkio.hs + + default-language: Haskell2010 + + build-depends: base >= 3 && < 5 + , async + , bytestring + , data-default + , leveldb-haskell + + ghc-options: -Wall -Werror -O -rtsopts + ghc-prof-options: -prof -auto-all + + hs-source-dirs: examples + + if flag(Examples) + buildable: True + else + buildable: False diff --git a/src/Database/LevelDB.hs b/src/Database/LevelDB.hs --- a/src/Database/LevelDB.hs +++ b/src/Database/LevelDB.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE RecordWildCards #-} -- | -- Module : Database.LevelDB --- Copyright : (c) 2012 Kim Altintop +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors -- License : BSD3 -- Maintainer : kim.altintop@gmail.com -- Stability : experimental @@ -12,934 +11,6 @@ -- The API closely follows the C-API of LevelDB. -- For more information, see: -module Database.LevelDB ( - -- * Exported Types - DB - , BatchOp(..) - , Comparator(..) - , Compression(..) - , Options(..) - , ReadOptions(..) - , Snapshot - , WriteBatch - , WriteOptions(..) - , Range - - -- * Defaults - , defaultOptions - , defaultWriteOptions - , defaultReadOptions - - -- * Basic Database Manipulation - , withSnapshot - , open - , put - , delete - , write - , get - , createSnapshot - , createSnapshot' - - -- * Filter Policy / Bloom Filter - , FilterPolicy(..) - , bloomFilter - - -- * Administrative Functions - , Property(..), getProperty - , destroy - , repair - , approximateSize - , version - - -- * Iteration - , Iterator - , withIterator - , iterOpen - , iterOpen' - , iterValid - , iterSeek - , iterFirst - , iterLast - , iterNext - , iterPrev - , iterKey - , iterValue - , iterGetError - , mapIter - , iterItems - , iterKeys - , iterValues - - -- * Re-exports - , 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 - --- import Debug.Trace - --- | Database handle -newtype DB = DB LevelDBPtr deriving (Eq) - --- | Iterator handle -data Iterator = Iterator - { _iterPtr :: !IteratorPtr - , _iterLock :: !(MVar ()) - } deriving (Eq) - --- | Snapshot handle -newtype Snapshot = Snapshot SnapshotPtr deriving (Eq) - --- | Compression setting -data Compression = NoCompression | Snappy deriving (Eq, Show) - --- | User-defined comparator -newtype Comparator = Comparator (ByteString -> ByteString -> Ordering) - -data Comparator' = Comparator' (FunPtr CompareFun) - (FunPtr Destructor) - (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 - -- ^ Number of keys between restart points for delta encoding of keys. - -- - -- This parameter can be changed dynamically. Most clients should leave - -- this parameter alone. - -- - -- Default: 16 - , blockSize :: !Int - -- ^ Approximate size of user data packed per block. - -- - -- Note that the block size specified here corresponds to uncompressed - -- data. The actual size of the unit read from disk may be smaller if - -- compression is enabled. - -- - -- This parameter can be changed dynamically. - -- - -- Default: 4k - , cacheSize :: !Int - -- ^ Control over blocks (user data is stored in a set of blocks, and a - -- block is the unit of reading from disk). - -- - -- If > 0, use the specified cache (in bytes) for blocks. If 0, leveldb - -- will automatically create and use an 8MB internal cache. - -- - -- Default: 0 - , comparator :: !(Maybe Comparator) - -- ^ Comparator used to defined the order of keys in the table. - -- - -- If 'Nothing', the default comparator is used, which uses lexicographic - -- bytes-wise ordering. - -- - -- NOTE: the client must ensure that the comparator supplied here has the - -- same name and orders keys /exactly/ the same as the comparator provided - -- to previous open calls on the same DB. - -- - -- Default: Nothing - , compression :: !Compression - -- ^ Compress blocks using the specified compression algorithm. - -- - -- This parameter can be changed dynamically. - -- - -- Default: 'Snappy' - , createIfMissing :: !Bool - -- ^ If true, the database will be created if it is missing. - -- - -- Default: False - , errorIfExists :: !Bool - -- ^ It true, an error is raised if the database already exists. - -- - -- Default: False - , maxOpenFiles :: !Int - -- ^ Number of open files that can be used by the DB. - -- - -- You may need to increase this if your database has a large working set - -- (budget one open file per 2MB of working set). - -- - -- Default: 1000 - , paranoidChecks :: !Bool - -- ^ If true, the implementation will do aggressive checking of the data - -- it is processing and will stop early if it detects any errors. - -- - -- This may have unforeseen ramifications: for example, a corruption of - -- one DB entry may cause a large number of entries to become unreadable - -- or for the entire DB to become unopenable. - -- - -- Default: False - , writeBufferSize :: !Int - -- ^ Amount of data to build up in memory (backed by an unsorted log on - -- disk) before converting to a sorted on-disk file. - -- - -- Larger values increase performance, especially during bulk loads. Up to - -- to write buffers may be held in memory at the same time, so you may - -- with to adjust this parameter to control memory usage. Also, a larger - -- write buffer will result in a longer recovery time the next time the - -- database is opened. - -- - -- Default: 4MB - , 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')) - } - --- | Options for write operations -data WriteOptions = WriteOptions - { sync :: !Bool - -- ^ If true, the write will be flushed from the operating system buffer - -- cache (by calling WritableFile::Sync()) before the write is considered - -- complete. If this flag is true, writes will be slower. - -- - -- If this flag is false, and the machine crashes, some recent writes may - -- be lost. Note that if it is just the process that crashes (i.e., the - -- machine does not reboot), no writes will be lost even if sync==false. - -- - -- In other words, a DB write with sync==false has similar crash semantics - -- as the "write()" system call. A DB write with sync==true has similar - -- crash semantics to a "write()" system call followed by "fsync()". - -- - -- Default: False - } deriving (Eq, Show) - -defaultWriteOptions :: WriteOptions -defaultWriteOptions = WriteOptions { sync = False } - -instance Default WriteOptions where - def = defaultWriteOptions - --- | Options for read operations -data ReadOptions = ReadOptions - { verifyCheckSums :: !Bool - -- ^ If true, all data read from underlying storage will be verified - -- against corresponding checksuyms. - -- - -- Default: False - , fillCache :: !Bool - -- ^ Should the data read for this iteration be cached in memory? Callers - -- may with to set this field to false for bulk scans. - -- - -- Default: True - , useSnapshot :: !(Maybe Snapshot) - -- ^ If 'Just', read as of the supplied snapshot (which must belong to the - -- DB that is being read and which must not have been released). If - -- 'Nothing', use an implicit snapshot of the state at the beginning of - -- this read operation. - -- - -- Default: Nothing - } deriving (Eq) - -defaultReadOptions :: ReadOptions -defaultReadOptions = ReadOptions - { verifyCheckSums = False - , fillCache = True - , useSnapshot = Nothing - } - -instance Default ReadOptions where - def = defaultReadOptions - -type WriteBatch = [BatchOp] --- | Batch operation -data BatchOp = Put ByteString ByteString | Del ByteString - deriving (Eq, Show) - --- | Properties exposed by LevelDB -data Property = NumFilesAtLevel Int | Stats | SSTables - deriving (Eq, Show) - - --- | Open a database --- --- The returned handle will automatically be released when the enclosing --- 'runResourceT' terminates. -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 -{-# INLINE open' #-} - --- | Run an action with a snapshot of the database. --- --- The snapshot will be released when the action terminates or throws an --- exception. Note that this function is provided for convenience and does not --- prevent the 'Snapshot' handle to escape. It will, however, be invalid after --- this function returns and should not be used anymore. -withSnapshot :: MonadResource m => DB -> (Snapshot -> m a) -> m a -withSnapshot db f = do - (rk, snap) <- createSnapshot' db - res <- f snap - release rk - return res - --- | Create a snapshot of the database. --- --- The returned 'Snapshot' will be released automatically when the enclosing --- 'runResourceT' terminates. It is recommended to use 'createSnapshot'' instead --- and release the resource manually as soon as possible. -createSnapshot :: MonadResource m => DB -> m Snapshot -createSnapshot db = snd <$> createSnapshot' db - --- | Create a snapshot of the database which can (and should) be released early. -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 - --- | Get a DB property -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 the given leveldb database. -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 the given leveldb database. -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 - --- TODO: support [Range], like C API does -type Range = (ByteString, ByteString) - --- | Inspect the approximate sizes of the different levels -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 - --- | Write a key/value pair -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 - --- | Read a value by key -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 a key/value pair -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 - --- | Perform a batch mutation -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 - - -- 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) = - 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 - --- | 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. -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 - --- | Create an 'Iterator'. --- --- The iterator will be released when the enclosing 'runResourceT' terminates. --- You may consider to use 'iterOpen'' instead and manually release the iterator --- as soon as it is no longer needed (alternatively, use 'withIterator'). --- --- Note that an 'Iterator' creates a snapshot of the database implicitly, so --- updates written after the iterator was created are not visible. You may, --- however, specify an older 'Snapshot' in the 'ReadOptions'. -iterOpen :: MonadResource m => DB -> ReadOptions -> m Iterator -iterOpen db opts = snd <$> iterOpen' db opts - --- | Create an 'Iterator' which can be released early. -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) - --- | An iterator is either positioned at a key/value pair, or not valid. This --- function returns /true/ iff the iterator is valid. -iterValid :: MonadResource m => Iterator -> m Bool -iterValid (Iterator iter _) = do - x <- liftIO $ c_leveldb_iter_valid iter - return (x /= 0) - --- | Position at the first key in the source that is at or past target. The --- iterator is /valid/ after this call iff the source contains an entry that --- comes at or past target. -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) - --- | Position at the first key in the source. The iterator is /valid/ after this --- call iff the source is not empty. -iterFirst :: MonadResource m => Iterator -> m () -iterFirst (Iterator iter lck) = liftIO $ withMVar lck go - where - go _ = c_leveldb_iter_seek_to_first iter - --- | Position at the last key in the source. The iterator is /valid/ after this --- call iff the source is not empty. -iterLast :: MonadResource m => Iterator -> m () -iterLast (Iterator iter lck) = liftIO $ withMVar lck go - where - go _ = c_leveldb_iter_seek_to_last iter - --- | Moves to the next entry in the source. After this call, 'iterValid' is --- /true/ iff the iterator was not positioned at the last entry in the source. --- --- If the iterator is not valid, this function does nothing. Note that this is a --- shortcoming of the C API: an 'iterPrev' might still be possible, but we can't --- determine if we're at the last or first entry. -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 - --- | Moves to the previous entry in the source. After this call, 'iterValid' is --- /true/ iff the iterator was not positioned at the first entry in the source. --- --- If the iterator is not valid, this function does nothing. Note that this is a --- shortcoming of the C API: an 'iterNext' might still be possible, but we can't --- determine if we're at the last or first entry. -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 - --- | Return the key for the current entry if the iterator is currently --- positioned at an entry, ie. 'iterValid'. -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) - --- | Return the value for the current entry if the iterator is currently --- positioned at an entry, ie. 'iterValid'. -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) - --- | Check for errors --- --- Note that this captures somewhat severe errors such as a corrupted database. -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 - --- | Map a function over an iterator, advancing the iterator forward and --- returning the value. The iterator should be put in the right position prior --- to calling the function. --- --- Note that this function accumulates the result strictly, ie. it reads all --- values into memory until the iterator is exhausted. This is most likely not --- what you want for large ranges. You may consider using conduits instead, for --- an example see: -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 - --- | Return a list of key and value tuples from an iterator. The iterator --- should be put in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter'. -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 - --- | Return a list of key from an iterator. The iterator should be put --- in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter' -iterKeys :: MonadResource m => Iterator -> m [ByteString] -iterKeys iter = catMaybes <$> mapIter iterKey iter - --- | Return a list of values from an iterator. The iterator should be put --- in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter' -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 --- - -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 -- 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 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 -{-# INLINE cSizeToInt #-} - -intToCSize :: Int -> CSize -intToCSize = fromIntegral -{-# INLINE intToCSize #-} - -intToCInt :: Int -> CInt -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) -{-# INLINE boolToNum #-} - -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 +module Database.LevelDB (module R) where -freeFilterPolicy :: FilterPolicy' -> IO () -freeFilterPolicy (FilterPolicy' ccffun ckmfun cdest cname cfp) = do - c_leveldb_filterpolicy_destroy cfp - freeHaskellFunPtr ccffun - freeHaskellFunPtr ckmfun - freeHaskellFunPtr cdest - freeHaskellFunPtr cname +import Database.LevelDB.MonadResource as R diff --git a/src/Database/LevelDB/Base.hs b/src/Database/LevelDB/Base.hs new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/Base.hs @@ -0,0 +1,254 @@ +-- | +-- Module : Database.LevelDB.Base +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- LevelDB Haskell binding. +-- +-- The API closely follows the C-API of LevelDB. +-- For more information, see: + +module Database.LevelDB.Base + ( -- * Exported Types + DB + , BatchOp (..) + , Comparator (..) + , Compression (..) + , Options (..) + , ReadOptions (..) + , Snapshot + , WriteBatch + , WriteOptions (..) + , Range + + -- * Defaults + , defaultOptions + , defaultReadOptions + , defaultWriteOptions + + -- * Basic Database Manipulations + , open + , close + , put + , delete + , write + , get + , withSnapshot + , createSnapshot + , releaseSnapshot + + -- * Filter Policy / Bloom Filter + , FilterPolicy (..) + , BloomFilter + , createBloomFilter + , releaseBloomFilter + + -- * Administrative Functions + , Property (..), getProperty + , destroy + , repair + , approximateSize + , version + + -- * Iteration + , module Database.LevelDB.Iterator + ) +where + +import Control.Applicative ((<$>)) +import Control.Exception (bracket, bracketOnError, finally) +import Control.Monad (liftM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (ByteString (..)) +import Foreign +import Foreign.C.String (withCString) + +import Database.LevelDB.C +import Database.LevelDB.Internal +import Database.LevelDB.Iterator +import Database.LevelDB.Types + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BU + + +-- | Open a database. +-- +-- The returned handle should be released with 'close'. +open :: MonadIO m => FilePath -> Options -> m DB +open path opts = liftIO $ bracketOnError (mkOpts opts) freeOpts mkDB + where + mkDB opts'@(Options' opts_ptr _ _ _) = + withCString path $ \path_ptr -> + liftM (`DB` opts') + $ throwIfErr "open" + $ c_leveldb_open opts_ptr path_ptr + +-- | Close a database. +-- +-- The handle will be invalid after calling this action and should no +-- longer be used. +close :: MonadIO m => DB -> m () +close (DB db_ptr opts_ptr) = liftIO $ + c_leveldb_close db_ptr `finally` freeOpts opts_ptr + + +-- | Run an action with a 'Snapshot' of the database. +withSnapshot :: MonadIO m => DB -> (Snapshot -> IO a) -> m a +withSnapshot db act = liftIO $ + bracket (createSnapshot db) (releaseSnapshot db) act + +-- | Create a snapshot of the database. +-- +-- The returned 'Snapshot' should be released with 'releaseSnapshot'. +createSnapshot :: MonadIO m => DB -> m Snapshot +createSnapshot (DB db_ptr _) = liftIO $ + Snapshot <$> c_leveldb_create_snapshot db_ptr + +-- | Release a snapshot. +-- +-- The handle will be invalid after calling this action and should no +-- longer be used. +releaseSnapshot :: MonadIO m => DB -> Snapshot -> m () +releaseSnapshot (DB db_ptr _) (Snapshot snap) = liftIO $ + c_leveldb_release_snapshot db_ptr snap + +-- | Get a DB property. +getProperty :: MonadIO 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 the given LevelDB database. +destroy :: MonadIO m => FilePath -> Options -> m () +destroy path opts = liftIO $ bracket (mkOpts opts) freeOpts destroy' + where + destroy' (Options' opts_ptr _ _ _) = + withCString path $ \path_ptr -> + throwIfErr "destroy" $ c_leveldb_destroy_db opts_ptr path_ptr + +-- | Repair the given LevelDB database. +repair :: MonadIO m => FilePath -> Options -> m () +repair path opts = liftIO $ bracket (mkOpts opts) freeOpts repair' + where + repair' (Options' opts_ptr _ _ _) = + withCString path $ \path_ptr -> + throwIfErr "repair" $ c_leveldb_repair_db opts_ptr path_ptr + + +-- TODO: support [Range], like C API does +type Range = (ByteString, ByteString) + +-- | Inspect the approximate sizes of the different levels. +approximateSize :: MonadIO 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 + + +-- | Write a key/value pair. +put :: MonadIO m => DB -> WriteOptions -> ByteString -> ByteString -> m () +put (DB db_ptr _) opts key value = liftIO $ withCWriteOpts opts $ \opts_ptr -> + 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) + +-- | Read a value by key. +get :: MonadIO m => DB -> ReadOptions -> ByteString -> m (Maybe ByteString) +get (DB db_ptr _) opts key = liftIO $ withCReadOpts opts $ \opts_ptr -> + 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' + +-- | Delete a key/value pair. +delete :: MonadIO m => DB -> WriteOptions -> ByteString -> m () +delete (DB db_ptr _) opts key = liftIO $ withCWriteOpts opts $ \opts_ptr -> + BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> + throwIfErr "delete" + $ c_leveldb_delete db_ptr opts_ptr key_ptr (intToCSize klen) + +-- | Perform a batch mutation. +write :: MonadIO m => DB -> WriteOptions -> WriteBatch -> m () +write (DB db_ptr _) opts batch = liftIO $ withCWriteOpts opts $ \opts_ptr -> + bracket c_leveldb_writebatch_create c_leveldb_writebatch_destroy $ \batch_ptr -> do + + mapM_ (batchAdd batch_ptr) batch + + 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 + + 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 + +-- | Return the runtime version of the underlying LevelDB library as a (major, +-- minor) pair. +version :: MonadIO m => m (Int, Int) +version = do + major <- liftIO c_leveldb_major_version + minor <- liftIO c_leveldb_minor_version + + return (cIntToInt major, cIntToInt minor) + +createBloomFilter :: MonadIO m => Int -> m BloomFilter +createBloomFilter i = do + let i' = fromInteger . toInteger $ i + fp_ptr <- liftIO $ c_leveldb_filterpolicy_create_bloom i' + return $ BloomFilter fp_ptr + +releaseBloomFilter :: MonadIO m => BloomFilter -> m () +releaseBloomFilter (BloomFilter fp) = liftIO $ c_leveldb_filterpolicy_destroy fp diff --git a/src/Database/LevelDB/Base.hsc b/src/Database/LevelDB/Base.hsc deleted file mode 100644 --- a/src/Database/LevelDB/Base.hsc +++ /dev/null @@ -1,355 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} --- | --- Module : Database.LevelDB.Base --- Copyright : (c) 2012 Kim Altintop --- License : BSD3 --- Maintainer : kim.altintop@gmail.com --- Stability : experimental --- Portability : non-portable --- - -module Database.LevelDB.Base where - -import Foreign -import Foreign.C.Types -import Foreign.C.String - -#include - -data LevelDB -data LCache -data LComparator -data LIterator -data LLogger -data LOptions -data LReadOptions -data LSnapshot -data LWriteBatch -data LWriteOptions -data LFilterPolicy - -type LevelDBPtr = Ptr LevelDB -type CachePtr = Ptr LCache -type ComparatorPtr = Ptr LComparator -type IteratorPtr = Ptr LIterator -type LoggerPtr = Ptr LLogger -type OptionsPtr = Ptr LOptions -type ReadOptionsPtr = Ptr LReadOptions -type SnapshotPtr = Ptr LSnapshot -type WriteBatchPtr = Ptr LWriteBatch -type WriteOptionsPtr = Ptr LWriteOptions -type FilterPolicyPtr = Ptr LFilterPolicy - -type DBName = CString -type ErrPtr = Ptr CString -type Key = CString -type Val = CString - -newtype CompressionOpt = CompressionOpt { compressionOpt :: CInt } - deriving (Eq, Show) -#{enum CompressionOpt, CompressionOpt - , noCompression = 0 - , snappyCompression = 1 - } - - -foreign import ccall safe "leveldb/c.h leveldb_open" - c_leveldb_open :: OptionsPtr -> DBName -> ErrPtr -> IO LevelDBPtr - -foreign import ccall safe "leveldb/c.h leveldb_close" - c_leveldb_close :: LevelDBPtr -> IO () - - -foreign import ccall safe "leveldb/c.h leveldb_put" - c_leveldb_put :: LevelDBPtr - -> WriteOptionsPtr - -> Key -> CSize - -> Val -> CSize - -> ErrPtr - -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_delete" - c_leveldb_delete :: LevelDBPtr - -> WriteOptionsPtr - -> Key -> CSize - -> ErrPtr - -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_write" - c_leveldb_write :: LevelDBPtr - -> WriteOptionsPtr - -> WriteBatchPtr - -> ErrPtr - -> IO () - --- | Returns NULL if not found. A malloc()ed array otherwise. Stores the length --- of the array in *vallen. -foreign import ccall safe "leveldb/c.h leveldb_get" - c_leveldb_get :: LevelDBPtr - -> ReadOptionsPtr - -> Key -> CSize - -> Ptr CSize -- ^ value length - -> ErrPtr - -> IO CString - -foreign import ccall safe "leveldb/c.h leveldb_create_snapshot" - c_leveldb_create_snapshot :: LevelDBPtr -> IO SnapshotPtr - -foreign import ccall safe "leveldb/c.h leveldb_release_snapshot" - c_leveldb_release_snapshot :: LevelDBPtr -> SnapshotPtr -> IO () - --- | Returns NULL if property name is unknown. Else returns a pointer to a --- malloc()-ed null-terminated value. -foreign import ccall safe "leveldb/c.h leveldb_property_value" - c_leveldb_property_value :: LevelDBPtr -> CString -> IO CString - -foreign import ccall safe "leveldb/c.h leveldb_approximate_sizes" - c_leveldb_approximate_sizes :: LevelDBPtr - -> CInt -- ^ num ranges - -> Ptr CString -> Ptr CSize -- ^ range start keys (array) - -> Ptr CString -> Ptr CSize -- ^ range limit keys (array) - -> Ptr Word64 -- ^ array of approx. sizes of ranges - -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_destroy_db" - c_leveldb_destroy_db :: OptionsPtr -> DBName -> ErrPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_repair_db" - c_leveldb_repair_db :: OptionsPtr -> DBName -> ErrPtr -> IO () - - --- --- Iterator --- - -foreign import ccall safe "leveldb/c.h leveldb_create_iterator" - c_leveldb_create_iterator :: LevelDBPtr -> ReadOptionsPtr -> IO IteratorPtr - -foreign import ccall safe "leveldb/c.h leveldb_iter_destroy" - c_leveldb_iter_destroy :: IteratorPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_iter_valid" - c_leveldb_iter_valid :: IteratorPtr -> IO CUChar - -foreign import ccall safe "leveldb/c.h leveldb_iter_seek_to_first" - c_leveldb_iter_seek_to_first :: IteratorPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_iter_seek_to_last" - c_leveldb_iter_seek_to_last :: IteratorPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_iter_seek" - c_leveldb_iter_seek :: IteratorPtr -> Key -> CSize -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_iter_next" - c_leveldb_iter_next :: IteratorPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_iter_prev" - c_leveldb_iter_prev :: IteratorPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_iter_key" - c_leveldb_iter_key :: IteratorPtr -> Ptr CSize -> IO Key - -foreign import ccall safe "leveldb/c.h leveldb_iter_value" - c_leveldb_iter_value :: IteratorPtr -> Ptr CSize -> IO Val - -foreign import ccall safe "leveldb/c.h leveldb_iter_get_error" - c_leveldb_iter_get_error :: IteratorPtr -> ErrPtr -> IO () - - --- --- Write batch --- - -foreign import ccall safe "leveldb/c.h leveldb_writebatch_create" - c_leveldb_writebatch_create :: IO WriteBatchPtr - -foreign import ccall safe "leveldb/c.h leveldb_writebatch_destroy" - c_leveldb_writebatch_destroy :: WriteBatchPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_writebatch_clear" - c_leveldb_writebatch_clear :: WriteBatchPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_writebatch_put" - c_leveldb_writebatch_put :: WriteBatchPtr - -> Key -> CSize - -> Val -> CSize - -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_writebatch_delete" - c_leveldb_writebatch_delete :: WriteBatchPtr -> Key -> CSize -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_writebatch_iterate" - c_leveldb_writebatch_iterate :: WriteBatchPtr - -> Ptr () -- ^ state - -> FunPtr (Ptr () -> Key -> CSize -> Val -> CSize) -- ^ put - -> FunPtr (Ptr () -> Key -> CSize) -- ^ delete - -> IO () - - --- --- Options --- - -foreign import ccall safe "leveldb/c.h leveldb_options_create" - c_leveldb_options_create :: IO OptionsPtr - -foreign import ccall safe "leveldb/c.h leveldb_options_destroy" - c_leveldb_options_destroy :: OptionsPtr -> IO () - -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 () - -foreign import ccall safe "leveldb/c.h leveldb_options_set_error_if_exists" - c_leveldb_options_set_error_if_exists :: OptionsPtr -> CUChar -> IO () - -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_info_log" - c_leveldb_options_set_info_log :: OptionsPtr -> LoggerPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_options_set_write_buffer_size" - c_leveldb_options_set_write_buffer_size :: OptionsPtr -> CSize -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_options_set_max_open_files" - c_leveldb_options_set_max_open_files :: OptionsPtr -> CInt -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_options_set_block_size" - c_leveldb_options_set_block_size :: OptionsPtr -> CSize -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_options_set_block_restart_interval" - c_leveldb_options_set_block_restart_interval :: OptionsPtr -> CInt -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_options_set_compression" - c_leveldb_options_set_compression :: OptionsPtr -> CompressionOpt -> IO () - -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 -type NameFun = StatePtr -> CString - --- | Make a FunPtr to a user-defined comparator function -foreign import ccall "wrapper" mkCmp :: CompareFun -> IO (FunPtr CompareFun) - --- | Make a destructor FunPtr -foreign import ccall "wrapper" mkDest :: Destructor -> IO (FunPtr Destructor) - --- | Make a name FunPtr -foreign import ccall "wrapper" mkName :: NameFun -> IO (FunPtr NameFun) - -foreign import ccall safe "leveldb/c.h leveldb_comparator_create" - c_leveldb_comparator_create :: StatePtr - -> FunPtr Destructor - -> FunPtr CompareFun - -> FunPtr NameFun - -> IO ComparatorPtr - -foreign import ccall safe "leveldb/c.h leveldb_comparator_destroy" - c_leveldb_comparator_destroy :: ComparatorPtr -> IO () - - --- --- 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 - -foreign import ccall safe "leveldb/c.h leveldb_readoptions_destroy" - c_leveldb_readoptions_destroy :: ReadOptionsPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_verify_checksums" - c_leveldb_readoptions_set_verify_checksums :: ReadOptionsPtr -> CUChar -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_fill_cache" - c_leveldb_readoptions_set_fill_cache :: ReadOptionsPtr -> CUChar -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_snapshot" - c_leveldb_readoptions_set_snapshot :: ReadOptionsPtr -> SnapshotPtr -> IO () - - --- --- Write options --- - -foreign import ccall safe "leveldb/c.h leveldb_writeoptions_create" - c_leveldb_writeoptions_create :: IO WriteOptionsPtr - -foreign import ccall safe "leveldb/c.h leveldb_writeoptions_destroy" - c_leveldb_writeoptions_destroy :: WriteOptionsPtr -> IO () - -foreign import ccall safe "leveldb/c.h leveldb_writeoptions_set_sync" - c_leveldb_writeoptions_set_sync :: WriteOptionsPtr -> CUChar -> IO () - - --- --- 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 () - - --- --- Version --- - -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 diff --git a/src/Database/LevelDB/C.hsc b/src/Database/LevelDB/C.hsc new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/C.hsc @@ -0,0 +1,355 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} +-- | +-- Module : Database.LevelDB.C +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- + +module Database.LevelDB.C where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +#include + +data LevelDB +data LCache +data LComparator +data LIterator +data LLogger +data LOptions +data LReadOptions +data LSnapshot +data LWriteBatch +data LWriteOptions +data LFilterPolicy + +type LevelDBPtr = Ptr LevelDB +type CachePtr = Ptr LCache +type ComparatorPtr = Ptr LComparator +type IteratorPtr = Ptr LIterator +type LoggerPtr = Ptr LLogger +type OptionsPtr = Ptr LOptions +type ReadOptionsPtr = Ptr LReadOptions +type SnapshotPtr = Ptr LSnapshot +type WriteBatchPtr = Ptr LWriteBatch +type WriteOptionsPtr = Ptr LWriteOptions +type FilterPolicyPtr = Ptr LFilterPolicy + +type DBName = CString +type ErrPtr = Ptr CString +type Key = CString +type Val = CString + +newtype CompressionOpt = CompressionOpt { compressionOpt :: CInt } + deriving (Eq, Show) +#{enum CompressionOpt, CompressionOpt + , noCompression = 0 + , snappyCompression = 1 + } + + +foreign import ccall safe "leveldb/c.h leveldb_open" + c_leveldb_open :: OptionsPtr -> DBName -> ErrPtr -> IO LevelDBPtr + +foreign import ccall safe "leveldb/c.h leveldb_close" + c_leveldb_close :: LevelDBPtr -> IO () + + +foreign import ccall safe "leveldb/c.h leveldb_put" + c_leveldb_put :: LevelDBPtr + -> WriteOptionsPtr + -> Key -> CSize + -> Val -> CSize + -> ErrPtr + -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_delete" + c_leveldb_delete :: LevelDBPtr + -> WriteOptionsPtr + -> Key -> CSize + -> ErrPtr + -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_write" + c_leveldb_write :: LevelDBPtr + -> WriteOptionsPtr + -> WriteBatchPtr + -> ErrPtr + -> IO () + +-- | Returns NULL if not found. A malloc()ed array otherwise. Stores the length +-- of the array in *vallen. +foreign import ccall safe "leveldb/c.h leveldb_get" + c_leveldb_get :: LevelDBPtr + -> ReadOptionsPtr + -> Key -> CSize + -> Ptr CSize -- ^ value length + -> ErrPtr + -> IO CString + +foreign import ccall safe "leveldb/c.h leveldb_create_snapshot" + c_leveldb_create_snapshot :: LevelDBPtr -> IO SnapshotPtr + +foreign import ccall safe "leveldb/c.h leveldb_release_snapshot" + c_leveldb_release_snapshot :: LevelDBPtr -> SnapshotPtr -> IO () + +-- | Returns NULL if property name is unknown. Else returns a pointer to a +-- malloc()-ed null-terminated value. +foreign import ccall safe "leveldb/c.h leveldb_property_value" + c_leveldb_property_value :: LevelDBPtr -> CString -> IO CString + +foreign import ccall safe "leveldb/c.h leveldb_approximate_sizes" + c_leveldb_approximate_sizes :: LevelDBPtr + -> CInt -- ^ num ranges + -> Ptr CString -> Ptr CSize -- ^ range start keys (array) + -> Ptr CString -> Ptr CSize -- ^ range limit keys (array) + -> Ptr Word64 -- ^ array of approx. sizes of ranges + -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_destroy_db" + c_leveldb_destroy_db :: OptionsPtr -> DBName -> ErrPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_repair_db" + c_leveldb_repair_db :: OptionsPtr -> DBName -> ErrPtr -> IO () + + +-- +-- Iterator +-- + +foreign import ccall safe "leveldb/c.h leveldb_create_iterator" + c_leveldb_create_iterator :: LevelDBPtr -> ReadOptionsPtr -> IO IteratorPtr + +foreign import ccall safe "leveldb/c.h leveldb_iter_destroy" + c_leveldb_iter_destroy :: IteratorPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_iter_valid" + c_leveldb_iter_valid :: IteratorPtr -> IO CUChar + +foreign import ccall safe "leveldb/c.h leveldb_iter_seek_to_first" + c_leveldb_iter_seek_to_first :: IteratorPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_iter_seek_to_last" + c_leveldb_iter_seek_to_last :: IteratorPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_iter_seek" + c_leveldb_iter_seek :: IteratorPtr -> Key -> CSize -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_iter_next" + c_leveldb_iter_next :: IteratorPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_iter_prev" + c_leveldb_iter_prev :: IteratorPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_iter_key" + c_leveldb_iter_key :: IteratorPtr -> Ptr CSize -> IO Key + +foreign import ccall safe "leveldb/c.h leveldb_iter_value" + c_leveldb_iter_value :: IteratorPtr -> Ptr CSize -> IO Val + +foreign import ccall safe "leveldb/c.h leveldb_iter_get_error" + c_leveldb_iter_get_error :: IteratorPtr -> ErrPtr -> IO () + + +-- +-- Write batch +-- + +foreign import ccall safe "leveldb/c.h leveldb_writebatch_create" + c_leveldb_writebatch_create :: IO WriteBatchPtr + +foreign import ccall safe "leveldb/c.h leveldb_writebatch_destroy" + c_leveldb_writebatch_destroy :: WriteBatchPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_writebatch_clear" + c_leveldb_writebatch_clear :: WriteBatchPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_writebatch_put" + c_leveldb_writebatch_put :: WriteBatchPtr + -> Key -> CSize + -> Val -> CSize + -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_writebatch_delete" + c_leveldb_writebatch_delete :: WriteBatchPtr -> Key -> CSize -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_writebatch_iterate" + c_leveldb_writebatch_iterate :: WriteBatchPtr + -> Ptr () -- ^ state + -> FunPtr (Ptr () -> Key -> CSize -> Val -> CSize) -- ^ put + -> FunPtr (Ptr () -> Key -> CSize) -- ^ delete + -> IO () + + +-- +-- Options +-- + +foreign import ccall safe "leveldb/c.h leveldb_options_create" + c_leveldb_options_create :: IO OptionsPtr + +foreign import ccall safe "leveldb/c.h leveldb_options_destroy" + c_leveldb_options_destroy :: OptionsPtr -> IO () + +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 () + +foreign import ccall safe "leveldb/c.h leveldb_options_set_error_if_exists" + c_leveldb_options_set_error_if_exists :: OptionsPtr -> CUChar -> IO () + +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_info_log" + c_leveldb_options_set_info_log :: OptionsPtr -> LoggerPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_options_set_write_buffer_size" + c_leveldb_options_set_write_buffer_size :: OptionsPtr -> CSize -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_options_set_max_open_files" + c_leveldb_options_set_max_open_files :: OptionsPtr -> CInt -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_options_set_block_size" + c_leveldb_options_set_block_size :: OptionsPtr -> CSize -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_options_set_block_restart_interval" + c_leveldb_options_set_block_restart_interval :: OptionsPtr -> CInt -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_options_set_compression" + c_leveldb_options_set_compression :: OptionsPtr -> CompressionOpt -> IO () + +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 +type NameFun = StatePtr -> CString + +-- | Make a FunPtr to a user-defined comparator function +foreign import ccall "wrapper" mkCmp :: CompareFun -> IO (FunPtr CompareFun) + +-- | Make a destructor FunPtr +foreign import ccall "wrapper" mkDest :: Destructor -> IO (FunPtr Destructor) + +-- | Make a name FunPtr +foreign import ccall "wrapper" mkName :: NameFun -> IO (FunPtr NameFun) + +foreign import ccall safe "leveldb/c.h leveldb_comparator_create" + c_leveldb_comparator_create :: StatePtr + -> FunPtr Destructor + -> FunPtr CompareFun + -> FunPtr NameFun + -> IO ComparatorPtr + +foreign import ccall safe "leveldb/c.h leveldb_comparator_destroy" + c_leveldb_comparator_destroy :: ComparatorPtr -> IO () + + +-- +-- 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 + +foreign import ccall safe "leveldb/c.h leveldb_readoptions_destroy" + c_leveldb_readoptions_destroy :: ReadOptionsPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_verify_checksums" + c_leveldb_readoptions_set_verify_checksums :: ReadOptionsPtr -> CUChar -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_fill_cache" + c_leveldb_readoptions_set_fill_cache :: ReadOptionsPtr -> CUChar -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_snapshot" + c_leveldb_readoptions_set_snapshot :: ReadOptionsPtr -> SnapshotPtr -> IO () + + +-- +-- Write options +-- + +foreign import ccall safe "leveldb/c.h leveldb_writeoptions_create" + c_leveldb_writeoptions_create :: IO WriteOptionsPtr + +foreign import ccall safe "leveldb/c.h leveldb_writeoptions_destroy" + c_leveldb_writeoptions_destroy :: WriteOptionsPtr -> IO () + +foreign import ccall safe "leveldb/c.h leveldb_writeoptions_set_sync" + c_leveldb_writeoptions_set_sync :: WriteOptionsPtr -> CUChar -> IO () + + +-- +-- 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 () + + +-- +-- Version +-- + +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 diff --git a/src/Database/LevelDB/Internal.hs b/src/Database/LevelDB/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/Internal.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Database.LevelDB.Internal +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- + +module Database.LevelDB.Internal + ( -- * Types + DB (..) + , Comparator' + , FilterPolicy' + , Options' (..) + + -- * "Smart" constructors and deconstructors + , freeCReadOpts + , freeComparator + , freeFilterPolicy + , freeOpts + , mkCReadOpts + , mkComparator + , mkCompareFun + , mkCreateFilterFun + , mkFilterPolicy + , mkKeyMayMatchFun + , mkOpts + + -- * combinators + , withCWriteOpts + , withCReadOpts + + -- * Utilities + , throwIfErr + , cSizeToInt + , intToCSize + , intToCInt + , cIntToInt + , boolToNum + ) +where + +import Control.Applicative ((<$>)) +import Control.Exception (bracket, onException, throwIO) +import Control.Monad (when) +import Data.ByteString (ByteString) +import Foreign +import Foreign.C.String (peekCString, withCString) +import Foreign.C.Types (CInt, CSize) + +import Database.LevelDB.C +import Database.LevelDB.Types + +import qualified Data.ByteString as BS + + +-- | Database handle +data DB = DB LevelDBPtr Options' + +instance Eq DB where + (DB pt1 _) == (DB pt2 _) = pt1 == pt2 + +-- | Internal representation of a 'Comparator' +data Comparator' = Comparator' (FunPtr CompareFun) + (FunPtr Destructor) + (FunPtr NameFun) + ComparatorPtr + +-- | Internal representation of a 'FilterPolicy' +data FilterPolicy' = FilterPolicy' (FunPtr CreateFilterFun) + (FunPtr KeyMayMatchFun) + (FunPtr Destructor) + (FunPtr NameFun) + FilterPolicyPtr + +-- | Internal representation of the 'Options' +data Options' = Options' + { _optsPtr :: !OptionsPtr + , _cachePtr :: !(Maybe CachePtr) + , _comp :: !(Maybe Comparator') + , _fpPtr :: !(Maybe (Either FilterPolicyPtr FilterPolicy')) + } + + +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 -- 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 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 () + +withCWriteOpts :: WriteOptions -> (WriteOptionsPtr -> IO a) -> IO a +withCWriteOpts WriteOptions{..} = bracket mkCWriteOpts freeCWriteOpts + where + mkCWriteOpts = do + opts_ptr <- c_leveldb_writeoptions_create + onException + (c_leveldb_writeoptions_set_sync opts_ptr $ boolToNum sync) + (c_leveldb_writeoptions_destroy opts_ptr) + return opts_ptr + + freeCWriteOpts = c_leveldb_writeoptions_destroy + +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 $ const () + cname <- mkName $ const 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 $ const cs + cdest <- mkDest $ const () + 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 + +mkCReadOpts :: ReadOptions -> IO ReadOptionsPtr +mkCReadOpts ReadOptions{..} = do + opts_ptr <- c_leveldb_readoptions_create + flip onException (c_leveldb_readoptions_destroy opts_ptr) $ do + c_leveldb_readoptions_set_verify_checksums opts_ptr $ boolToNum verifyCheckSums + c_leveldb_readoptions_set_fill_cache opts_ptr $ boolToNum fillCache + + case useSnapshot of + Just (Snapshot snap_ptr) -> c_leveldb_readoptions_set_snapshot opts_ptr snap_ptr + Nothing -> return () + + return opts_ptr + +freeCReadOpts :: ReadOptionsPtr -> IO () +freeCReadOpts = c_leveldb_readoptions_destroy + +withCReadOpts :: ReadOptions -> (ReadOptionsPtr -> IO a) -> IO a +withCReadOpts opts = bracket (mkCReadOpts opts) freeCReadOpts + +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 +{-# INLINE cSizeToInt #-} + +intToCSize :: Int -> CSize +intToCSize = fromIntegral +{-# INLINE intToCSize #-} + +intToCInt :: Int -> CInt +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) +{-# INLINE boolToNum #-} diff --git a/src/Database/LevelDB/Iterator.hs b/src/Database/LevelDB/Iterator.hs new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/Iterator.hs @@ -0,0 +1,227 @@ +-- | +-- Module : Database.LevelDB.Iterator +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Iterating over key ranges. +-- + +module Database.LevelDB.Iterator + ( Iterator + , createIter + , iterEntry + , iterFirst + , iterGetError + , iterItems + , iterKey + , iterKeys + , iterLast + , iterNext + , iterPrev + , iterSeek + , iterValid + , iterValue + , iterValues + , mapIter + , releaseIter + , withIter + ) +where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (bracket, finally, onException) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.ByteString (ByteString) +import Data.Maybe (catMaybes) +import Foreign +import Foreign.C.Error (throwErrnoIfNull) +import Foreign.C.String (CString, peekCString) +import Foreign.C.Types (CSize) + +import Database.LevelDB.C +import Database.LevelDB.Internal +import Database.LevelDB.Types + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Unsafe as BU + +-- | Iterator handle +-- +-- Note that an 'Iterator' requires external synchronization if it is shared +-- between multiple threads which mutate it's state. See +-- @examples/iterforkio.hs@ for a simple example of how to do that. +data Iterator = Iterator !IteratorPtr !ReadOptionsPtr deriving (Eq) + +-- | Create an 'Iterator'. +-- +-- The iterator should be released with 'releaseIter'. +-- +-- Note that an 'Iterator' creates a snapshot of the database implicitly, so +-- updates written after the iterator was created are not visible. You may, +-- however, specify an older 'Snapshot' in the 'ReadOptions'. +createIter :: MonadIO m => DB -> ReadOptions -> m Iterator +createIter (DB db_ptr _) opts = liftIO $ do + opts_ptr <- mkCReadOpts opts + flip onException (freeCReadOpts opts_ptr) $ do + iter_ptr <- throwErrnoIfNull "create_iterator" $ + c_leveldb_create_iterator db_ptr opts_ptr + return $ Iterator iter_ptr opts_ptr + +-- | Release an 'Iterator'. +-- +-- The handle will be invalid after calling this action and should no +-- longer be used. Calling this function with an already released 'Iterator' +-- will cause a double-free error! +releaseIter :: MonadIO m => Iterator -> m () +releaseIter (Iterator iter_ptr opts) = liftIO $ + c_leveldb_iter_destroy iter_ptr `finally` freeCReadOpts opts + +-- | Run an action with an 'Iterator' +withIter :: MonadIO m => DB -> ReadOptions -> (Iterator -> IO a) -> m a +withIter db opts = liftIO . bracket (createIter db opts) releaseIter + +-- | An iterator is either positioned at a key/value pair, or not valid. This +-- function returns /true/ iff the iterator is valid. +iterValid :: MonadIO m => Iterator -> m Bool +iterValid (Iterator iter_ptr _) = liftIO $ do + x <- c_leveldb_iter_valid iter_ptr + return (x /= 0) + +-- | Position at the first key in the source that is at or past target. The +-- iterator is /valid/ after this call iff the source contains an entry that +-- comes at or past target. +iterSeek :: MonadIO m => Iterator -> ByteString -> m () +iterSeek (Iterator iter_ptr _) key = liftIO $ + BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> + c_leveldb_iter_seek iter_ptr key_ptr (intToCSize klen) + +-- | Position at the first key in the source. The iterator is /valid/ after this +-- call iff the source is not empty. +iterFirst :: MonadIO m => Iterator -> m () +iterFirst (Iterator iter_ptr _) = liftIO $ c_leveldb_iter_seek_to_first iter_ptr + +-- | Position at the last key in the source. The iterator is /valid/ after this +-- call iff the source is not empty. +iterLast :: MonadIO m => Iterator -> m () +iterLast (Iterator iter_ptr _) = liftIO $ c_leveldb_iter_seek_to_last iter_ptr + +-- | Moves to the next entry in the source. After this call, 'iterValid' is +-- /true/ iff the iterator was not positioned at the last entry in the source. +-- +-- If the iterator is not valid, this function does nothing. Note that this is a +-- shortcoming of the C API: an 'iterPrev' might still be possible, but we can't +-- determine if we're at the last or first entry. +iterNext :: MonadIO m => Iterator -> m () +iterNext (Iterator iter_ptr _) = liftIO $ do + valid <- c_leveldb_iter_valid iter_ptr + when (valid /= 0) $ c_leveldb_iter_next iter_ptr + +-- | Moves to the previous entry in the source. After this call, 'iterValid' is +-- /true/ iff the iterator was not positioned at the first entry in the source. +-- +-- If the iterator is not valid, this function does nothing. Note that this is a +-- shortcoming of the C API: an 'iterNext' might still be possible, but we can't +-- determine if we're at the last or first entry. +iterPrev :: MonadIO m => Iterator -> m () +iterPrev (Iterator iter_ptr _) = liftIO $ do + valid <- c_leveldb_iter_valid iter_ptr + when (valid /= 0) $ c_leveldb_iter_prev iter_ptr + +-- | Return the key for the current entry if the iterator is currently +-- positioned at an entry, ie. 'iterValid'. +iterKey :: MonadIO m => Iterator -> m (Maybe ByteString) +iterKey = liftIO . flip iterString c_leveldb_iter_key + +-- | Return the value for the current entry if the iterator is currently +-- positioned at an entry, ie. 'iterValid'. +iterValue :: MonadIO m => Iterator -> m (Maybe ByteString) +iterValue = liftIO . flip iterString c_leveldb_iter_value + +-- | Return the current entry as a pair, if the iterator is currently positioned +-- at an entry, ie. 'iterValid'. +iterEntry :: MonadIO m => Iterator -> m (Maybe (ByteString, ByteString)) +iterEntry iter = liftIO $ do + mkey <- iterKey iter + mval <- iterValue iter + return $ (,) <$> mkey <*> mval + +-- | Check for errors +-- +-- Note that this captures somewhat severe errors such as a corrupted database. +iterGetError :: MonadIO 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 + +-- | Map a function over an iterator, advancing the iterator forward and +-- returning the value. The iterator should be put in the right position prior +-- to calling the function. +-- +-- Note that this function accumulates the result strictly, ie. it reads all +-- values into memory until the iterator is exhausted. This is most likely not +-- what you want for large ranges. You may consider using conduits instead, for +-- an example see: +mapIter :: MonadIO m => (Iterator -> m a) -> Iterator -> m [a] +mapIter f iter@(Iterator iter_ptr _) = go [] + where + go acc = do + valid <- liftIO $ c_leveldb_iter_valid iter_ptr + if valid == 0 + then return acc + else do + val <- f iter + () <- liftIO $ c_leveldb_iter_next iter_ptr + go (val : acc) + +-- | Return a list of key and value tuples from an iterator. The iterator +-- should be put in the right position prior to calling this with the iterator. +-- +-- See strictness remarks on 'mapIter'. +iterItems :: (Functor m, MonadIO m) => Iterator -> m [(ByteString, ByteString)] +iterItems iter = catMaybes <$> mapIter iterEntry iter + +-- | Return a list of key from an iterator. The iterator should be put +-- in the right position prior to calling this with the iterator. +-- +-- See strictness remarks on 'mapIter' +iterKeys :: (Functor m, MonadIO m) => Iterator -> m [ByteString] +iterKeys iter = catMaybes <$> mapIter iterKey iter + +-- | Return a list of values from an iterator. The iterator should be put +-- in the right position prior to calling this with the iterator. +-- +-- See strictness remarks on 'mapIter' +iterValues :: (Functor m, MonadIO m) => Iterator -> m [ByteString] +iterValues iter = catMaybes <$> mapIter iterValue iter + + +-- +-- Internal +-- + +iterString :: Iterator + -> (IteratorPtr -> Ptr CSize -> IO CString) + -> IO (Maybe ByteString) +iterString (Iterator iter_ptr _) f = do + valid <- c_leveldb_iter_valid iter_ptr + if valid == 0 + then return Nothing + else alloca $ \len_ptr -> do + ptr <- f iter_ptr len_ptr + if ptr == nullPtr + then return Nothing + else do + len <- peek len_ptr + Just <$> BS.packCStringLen (ptr, cSizeToInt len) diff --git a/src/Database/LevelDB/MonadResource.hs b/src/Database/LevelDB/MonadResource.hs new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/MonadResource.hs @@ -0,0 +1,285 @@ +-- | +-- Module : Database.LevelDB.MonadResource +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- + +module Database.LevelDB.MonadResource + ( -- * Exported Types + DB + , BatchOp(..) + , Comparator(..) + , Compression(..) + , Options(..) + , ReadOptions(..) + , Snapshot + , WriteBatch + , WriteOptions(..) + , Range + + -- * Defaults + , defaultOptions + , defaultWriteOptions + , defaultReadOptions + + -- * Basic Database Manipulation + , withSnapshot + , open + , put + , delete + , write + , get + , createSnapshot + , createSnapshot' + + -- * Filter Policy / Bloom Filter + , FilterPolicy(..) + , bloomFilter + + -- * Administrative Functions + , Property(..), getProperty + , destroy + , repair + , approximateSize + , version + + -- * Iteration + , Iterator + , withIterator + , iterOpen + , iterOpen' + , iterValid + , iterSeek + , iterFirst + , iterLast + , iterNext + , iterPrev + , iterKey + , iterValue + , iterGetError + , mapIter + , iterItems + , iterKeys + , iterValues + + -- * Re-exports + , MonadResource (..) + , runResourceT + , resourceForkIO + ) +where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import Data.Int (Int64) + +import Database.LevelDB.Base (BatchOp, BloomFilter, Comparator, + Compression, DB, FilterPolicy, + Iterator, Options, Property, + Range, ReadOptions, Snapshot, + WriteBatch, WriteOptions, + defaultOptions, + defaultReadOptions, + defaultWriteOptions) +import qualified Database.LevelDB.Base as Base + + +-- | Create a 'BloomFilter' +bloomFilter :: MonadResource m => Int -> m BloomFilter +bloomFilter i = + snd <$> allocate (Base.createBloomFilter i) + Base.releaseBloomFilter + +-- | Open a database +-- +-- The returned handle will automatically be released when the enclosing +-- 'runResourceT' terminates. +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 = allocate (Base.open path opts) Base.close +{-# INLINE open' #-} + +-- | Run an action with a snapshot of the database. +-- +-- The snapshot will be released when the action terminates or throws an +-- exception. Note that this function is provided for convenience and does not +-- prevent the 'Snapshot' handle to escape. It will, however, be invalid after +-- this function returns and should not be used anymore. +withSnapshot :: MonadResource m => DB -> (Snapshot -> m a) -> m a +withSnapshot db f = do + (rk, snap) <- createSnapshot' db + res <- f snap + release rk + return res + +-- | Create a snapshot of the database. +-- +-- The returned 'Snapshot' will be released automatically when the enclosing +-- 'runResourceT' terminates. It is recommended to use 'createSnapshot'' instead +-- and release the resource manually as soon as possible. +createSnapshot :: MonadResource m => DB -> m Snapshot +createSnapshot db = snd <$> createSnapshot' db + +-- | Create a snapshot of the database which can (and should) be released early. +createSnapshot' :: MonadResource m => DB -> m (ReleaseKey, Snapshot) +createSnapshot' db = allocate (Base.createSnapshot db) (Base.releaseSnapshot db) + +-- | Get a DB property +getProperty :: MonadResource m => DB -> Property -> m (Maybe ByteString) +getProperty = Base.getProperty + +-- | Destroy the given leveldb database. +destroy :: MonadResource m => FilePath -> Options -> m () +destroy = Base.destroy + +-- | Repair the given leveldb database. +repair :: MonadResource m => FilePath -> Options -> m () +repair = Base.repair + + +-- | Inspect the approximate sizes of the different levels +approximateSize :: MonadResource m => DB -> Range -> m Int64 +approximateSize = Base.approximateSize + +-- | Write a key/value pair +put :: MonadResource m => DB -> WriteOptions -> ByteString -> ByteString -> m () +put = Base.put + +-- | Read a value by key +get :: MonadResource m => DB -> ReadOptions -> ByteString -> m (Maybe ByteString) +get = Base.get + +-- | Delete a key/value pair +delete :: MonadResource m => DB -> WriteOptions -> ByteString -> m () +delete = Base.delete + +-- | Perform a batch mutation +write :: MonadResource m => DB -> WriteOptions -> WriteBatch -> m () +write = Base.write + + +-- | 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. +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 + +-- | Create an 'Iterator'. +-- +-- The iterator will be released when the enclosing 'runResourceT' terminates. +-- You may consider to use 'iterOpen'' instead and manually release the iterator +-- as soon as it is no longer needed (alternatively, use 'withIterator'). +-- +-- Note that an 'Iterator' creates a snapshot of the database implicitly, so +-- updates written after the iterator was created are not visible. You may, +-- however, specify an older 'Snapshot' in the 'ReadOptions'. +iterOpen :: MonadResource m => DB -> ReadOptions -> m Iterator +iterOpen db opts = snd <$> iterOpen' db opts + +-- | Create an 'Iterator' which can be released early. +iterOpen' :: MonadResource m => DB -> ReadOptions -> m (ReleaseKey, Iterator) +iterOpen' db opts = allocate (Base.createIter db opts) Base.releaseIter + +-- | An iterator is either positioned at a key/value pair, or not valid. This +-- function returns /true/ iff the iterator is valid. +iterValid :: MonadResource m => Iterator -> m Bool +iterValid = Base.iterValid + +-- | Position at the first key in the source that is at or past target. The +-- iterator is /valid/ after this call iff the source contains an entry that +-- comes at or past target. +iterSeek :: MonadResource m => Iterator -> ByteString -> m () +iterSeek = Base.iterSeek + +-- | Position at the first key in the source. The iterator is /valid/ after this +-- call iff the source is not empty. +iterFirst :: MonadResource m => Iterator -> m () +iterFirst = Base.iterFirst + +-- | Position at the last key in the source. The iterator is /valid/ after this +-- call iff the source is not empty. +iterLast :: MonadResource m => Iterator -> m () +iterLast = Base.iterLast + +-- | Moves to the next entry in the source. After this call, 'iterValid' is +-- /true/ iff the iterator was not positioned at the last entry in the source. +-- +-- If the iterator is not valid, this function does nothing. Note that this is a +-- shortcoming of the C API: an 'iterPrev' might still be possible, but we can't +-- determine if we're at the last or first entry. +iterNext :: MonadResource m => Iterator -> m () +iterNext = Base.iterNext + +-- | Moves to the previous entry in the source. After this call, 'iterValid' is +-- /true/ iff the iterator was not positioned at the first entry in the source. +-- +-- If the iterator is not valid, this function does nothing. Note that this is a +-- shortcoming of the C API: an 'iterNext' might still be possible, but we can't +-- determine if we're at the last or first entry. +iterPrev :: MonadResource m => Iterator -> m () +iterPrev = Base.iterPrev + +-- | Return the key for the current entry if the iterator is currently +-- positioned at an entry, ie. 'iterValid'. +iterKey :: MonadResource m => Iterator -> m (Maybe ByteString) +iterKey = Base.iterKey + +-- | Return the value for the current entry if the iterator is currently +-- positioned at an entry, ie. 'iterValid'. +iterValue :: MonadResource m => Iterator -> m (Maybe ByteString) +iterValue = Base.iterValue + +-- | Check for errors +-- +-- Note that this captures somewhat severe errors such as a corrupted database. +iterGetError :: MonadResource m => Iterator -> m (Maybe ByteString) +iterGetError = Base.iterGetError + + +-- | Map a function over an iterator, advancing the iterator forward and +-- returning the value. The iterator should be put in the right position prior +-- to calling the function. +-- +-- Note that this function accumulates the result strictly, ie. it reads all +-- values into memory until the iterator is exhausted. This is most likely not +-- what you want for large ranges. You may consider using conduits instead, for +-- an example see: +mapIter :: MonadResource m => (Iterator -> m a) -> Iterator -> m [a] +mapIter = Base.mapIter + +-- | Return a list of key and value tuples from an iterator. The iterator +-- should be put in the right position prior to calling this with the iterator. +-- +-- See strictness remarks on 'mapIter'. +iterItems :: MonadResource m => Iterator -> m [(ByteString, ByteString)] +iterItems = Base.iterItems + +-- | Return a list of key from an iterator. The iterator should be put +-- in the right position prior to calling this with the iterator. +-- +-- See strictness remarks on 'mapIter' +iterKeys :: MonadResource m => Iterator -> m [ByteString] +iterKeys = Base.iterKeys + +-- | Return a list of values from an iterator. The iterator should be put +-- in the right position prior to calling this with the iterator. +-- +-- See strictness remarks on 'mapIter' +iterValues :: MonadResource m => Iterator -> m [ByteString] +iterValues = Base.iterValues + + +-- | Return the runtime version of the underlying LevelDB library as a (major, +-- minor) pair. +version :: MonadResource m => m (Int, Int) +version = Base.version diff --git a/src/Database/LevelDB/Types.hs b/src/Database/LevelDB/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/Types.hs @@ -0,0 +1,217 @@ +-- | +-- Module : Database.LevelDB.Types +-- Copyright : (c) 2012-2013 The leveldb-haskell Authors +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- + +module Database.LevelDB.Types + ( BatchOp (..) + , BloomFilter (..) + , Comparator (..) + , Compression (..) + , FilterPolicy (..) + , Options (..) + , Property (..) + , ReadOptions (..) + , Snapshot (..) + , WriteBatch + , WriteOptions (..) + + , defaultOptions + , defaultReadOptions + , defaultWriteOptions + ) +where + +import Data.ByteString (ByteString) +import Data.Default +import Foreign + +import Database.LevelDB.C + +-- | Snapshot handle +newtype Snapshot = Snapshot SnapshotPtr deriving (Eq) + +-- | Compression setting +data Compression = NoCompression | Snappy deriving (Eq, Show) + +-- | User-defined comparator +newtype Comparator = Comparator (ByteString -> ByteString -> Ordering) + +-- | User-defined filter policy +data FilterPolicy = FilterPolicy + { fpName :: String + , createFilter :: [ByteString] -> ByteString + , keyMayMatch :: ByteString -> ByteString -> Bool + } + +-- | Represents the built-in Bloom Filter +newtype BloomFilter = BloomFilter FilterPolicyPtr + +-- | Options when opening a database +data Options = Options + { blockRestartInterval :: !Int + -- ^ Number of keys between restart points for delta encoding of keys. + -- + -- This parameter can be changed dynamically. Most clients should leave + -- this parameter alone. + -- + -- Default: 16 + , blockSize :: !Int + -- ^ Approximate size of user data packed per block. + -- + -- Note that the block size specified here corresponds to uncompressed + -- data. The actual size of the unit read from disk may be smaller if + -- compression is enabled. + -- + -- This parameter can be changed dynamically. + -- + -- Default: 4k + , cacheSize :: !Int + -- ^ Control over blocks (user data is stored in a set of blocks, and a + -- block is the unit of reading from disk). + -- + -- If > 0, use the specified cache (in bytes) for blocks. If 0, leveldb + -- will automatically create and use an 8MB internal cache. + -- + -- Default: 0 + , comparator :: !(Maybe Comparator) + -- ^ Comparator used to defined the order of keys in the table. + -- + -- If 'Nothing', the default comparator is used, which uses lexicographic + -- bytes-wise ordering. + -- + -- NOTE: the client must ensure that the comparator supplied here has the + -- same name and orders keys /exactly/ the same as the comparator provided + -- to previous open calls on the same DB. + -- + -- Default: Nothing + , compression :: !Compression + -- ^ Compress blocks using the specified compression algorithm. + -- + -- This parameter can be changed dynamically. + -- + -- Default: 'Snappy' + , createIfMissing :: !Bool + -- ^ If true, the database will be created if it is missing. + -- + -- Default: False + , errorIfExists :: !Bool + -- ^ It true, an error is raised if the database already exists. + -- + -- Default: False + , maxOpenFiles :: !Int + -- ^ Number of open files that can be used by the DB. + -- + -- You may need to increase this if your database has a large working set + -- (budget one open file per 2MB of working set). + -- + -- Default: 1000 + , paranoidChecks :: !Bool + -- ^ If true, the implementation will do aggressive checking of the data + -- it is processing and will stop early if it detects any errors. + -- + -- This may have unforeseen ramifications: for example, a corruption of + -- one DB entry may cause a large number of entries to become unreadable + -- or for the entire DB to become unopenable. + -- + -- Default: False + , writeBufferSize :: !Int + -- ^ Amount of data to build up in memory (backed by an unsorted log on + -- disk) before converting to a sorted on-disk file. + -- + -- Larger values increase performance, especially during bulk loads. Up to + -- to write buffers may be held in memory at the same time, so you may + -- with to adjust this parameter to control memory usage. Also, a larger + -- write buffer will result in a longer recovery time the next time the + -- database is opened. + -- + -- Default: 4MB + , 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 + +-- | Options for write operations +data WriteOptions = WriteOptions + { sync :: !Bool + -- ^ If true, the write will be flushed from the operating system buffer + -- cache (by calling WritableFile::Sync()) before the write is considered + -- complete. If this flag is true, writes will be slower. + -- + -- If this flag is false, and the machine crashes, some recent writes may + -- be lost. Note that if it is just the process that crashes (i.e., the + -- machine does not reboot), no writes will be lost even if sync==false. + -- + -- In other words, a DB write with sync==false has similar crash semantics + -- as the "write()" system call. A DB write with sync==true has similar + -- crash semantics to a "write()" system call followed by "fsync()". + -- + -- Default: False + } deriving (Eq, Show) + +defaultWriteOptions :: WriteOptions +defaultWriteOptions = WriteOptions { sync = False } + +instance Default WriteOptions where + def = defaultWriteOptions + +-- | Options for read operations +data ReadOptions = ReadOptions + { verifyCheckSums :: !Bool + -- ^ If true, all data read from underlying storage will be verified + -- against corresponding checksuyms. + -- + -- Default: False + , fillCache :: !Bool + -- ^ Should the data read for this iteration be cached in memory? Callers + -- may with to set this field to false for bulk scans. + -- + -- Default: True + , useSnapshot :: !(Maybe Snapshot) + -- ^ If 'Just', read as of the supplied snapshot (which must belong to the + -- DB that is being read and which must not have been released). If + -- 'Nothing', use an implicit snapshot of the state at the beginning of + -- this read operation. + -- + -- Default: Nothing + } deriving (Eq) + +defaultReadOptions :: ReadOptions +defaultReadOptions = ReadOptions + { verifyCheckSums = False + , fillCache = True + , useSnapshot = Nothing + } + +instance Default ReadOptions where + def = defaultReadOptions + +type WriteBatch = [BatchOp] + +-- | Batch operation +data BatchOp = Put ByteString ByteString | Del ByteString + deriving (Eq, Show) + +-- | Properties exposed by LevelDB +data Property = NumFilesAtLevel Int | Stats | SSTables + deriving (Eq, Show)