{-# 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 #-}