Base.hs

-- |
-- 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: <http://leveldb.googlecode.com>

module Database.LevelDB.Base
    ( -- * Exported Types
      DB
    , BatchOp (..)
    , Comparator (..)
    , Compression (..)
    , Options (..)
    , ReadOptions (..)
    , Snapshot
    , WriteBatch
    , WriteOptions (..)
    , Range

    -- * Defaults
    , defaultOptions
    , defaultReadOptions
    , defaultWriteOptions

    -- * Basic Database Manipulations
    , withDB
    , open
    , put
    , delete
    , write
    , get
    , withSnapshot
    , createSnapshot
    , releaseSnapshot

    -- * Filter Policy / Bloom Filter
    , FilterPolicy (..)
    , BloomFilter
    , createBloomFilter
    , releaseBloomFilter

    -- * Administrative Functions
    , Property (..), getProperty
    , destroy
    , repair
    , approximateSize
    , compactRange
    , version

    -- * Iteration
    , module Database.LevelDB.Iterator
    )
where

import           Control.Applicative      ((<$>))
import           Control.Monad            (liftM, void)
import           Control.Monad.Catch
import           Control.Monad.IO.Class   (MonadIO (liftIO))
import           Data.ByteString          (ByteString)
import           Data.ByteString.Internal (ByteString (..))
import           Data.IORef
import           Foreign                  hiding (free, void)
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 has a finalizer attached which will free the underlying
-- pointers once it goes out of scope. Note, however, that finalizers are /not/
-- guaranteed to run, and may not run promptly if they do. Use 'unsafeClose' to
-- free the handle immediately, but ensure it is not used after that (otherwise,
-- the program will segault). Alternatively, use the
-- "Database.LevelDB.MonadResource" API, which will take care of resource
-- management automatically.
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 -> do
            db_ptr <- throwIfErr "open" $ c_leveldb_open opts_ptr path_ptr
            alive  <- newIORef True
            let db = DB db_ptr opts' alive
            addFinalizer alive $ unsafeClose db
            return db

    addFinalizer ref = void . mkWeakIORef ref

-- | Run an action with a 'DB'.
--
-- > withDB path opts = bracket (open path opts) unsafeClose
--
-- Note that the 'DB' handle will be released promptly when this function exits.
withDB :: (MonadMask m, MonadIO m) => FilePath -> Options -> (DB -> m a) -> m a
withDB path opts = bracket (open path opts) (liftIO . unsafeClose)

-- | Run an action with a 'Snapshot' of the database.
withSnapshot :: (MonadMask m, MonadIO m) => DB -> (Snapshot -> m a) -> m a
withSnapshot db = bracket (createSnapshot db) (releaseSnapshot db)

-- | 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
                    c_leveldb_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.
--
-- The database must not be in use during this operation.
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

-- | Compact the underlying storage for the given Range.
-- In particular this means discarding deleted and overwritten data as well as
-- rearranging the data to reduce the cost of operations accessing the data.
compactRange :: MonadIO m => DB -> Range -> m ()
compactRange (DB db_ptr _ _) (from, to) = liftIO $
    BU.unsafeUseAsCStringLen from $ \(from_ptr, flen) ->
    BU.unsafeUseAsCStringLen to $ \(to_ptr, tlen) ->
        c_leveldb_compact_range db_ptr from_ptr (intToCSize flen) to_ptr (intToCSize tlen)

-- | 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)
                c_leveldb_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