{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP             #-}

-- |
-- 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' (..)

    , unsafeClose

    -- * \"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, finally, onException, throwIO)
import           Control.Monad          (when)
import           Data.ByteString        (ByteString)
import           Data.IORef
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' (IORef Bool)

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'))
    }


-- | Closes the database.
--
-- The function is safe in that it doesn't double-free the pointer, but is
-- /unsafe/ because other functions which use the 'DB' handle do /not/ check if
-- the handle is live. If the handle is used after it was freed, the program
-- will segfault (internally, leveldb performs a @delete@ on the pointer).
unsafeClose :: DB -> IO ()
unsafeClose (DB db_ptr opts_ptr ref) = do
    alive <- modify ref ((,) False)
    when alive $
        c_leveldb_close db_ptr `finally` freeOpts opts_ptr

modify :: IORef a -> (a -> (a,b)) -> IO b
#if MIN_VERSION_base(4,6,0)
modify = atomicModifyIORef'
#else
modify ref f = do
    b <- atomicModifyIORef ref
            (\x -> let (a, b) = f x
                    in (a, a `seq` b))
    b `seq` return b
#endif

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