-- | Interface to B+ tree based DBM. See also,
-- <http://tokyocabinet.sourceforge.net/spex-en.html#tcbdbapi> for details
module Database.TokyoCabinet.BDB
    (
    -- $doc
    -- * Constructors
      BDB
    , ECODE(..)
    , OpenMode(..)
    , TuningOption(..)
    , CMP(..)
    -- * Basic API (tokyocabinet.idl compliant)
    , new
    , delete
    , ecode
    , errmsg
    , tune
    , setcache
    , setxmsiz
    , setcmpfunc
    , open
    , close
    , put
    , putkeep
    , putcat
    , putdup
    , putlist
    , out
    , outlist
    , get
    , getlist
    , vnum
    , vsiz
    , range
    , fwmkeys
    , addint
    , adddouble
    , sync
    , optimize
    , vanish
    , copy
    , tranbegin
    , trancommit
    , tranabort
    , path
    , rnum
    , fsiz
    ) where

import Data.Int
import Data.Word
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafePackCStringLen)

import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable (peek)
import Foreign.Marshal (alloca)

import Database.TokyoCabinet.Error
import Database.TokyoCabinet.BDB.C
import Database.TokyoCabinet.List.C
import Database.TokyoCabinet.Internal
import Database.TokyoCabinet.Storable
import Database.TokyoCabinet.Sequence

-- $doc
-- Example
--
-- @
--    import Control.Monad
--    import Database.TokyoCabinet.BDB
--    import qualified Database.TokyoCabinet.BDB.Cursor as C
-- @
--
-- @  
--    main :: IO ()
--    main =
--        do bdb <- new
--           -- open the database
--           open bdb \"casket.tcb\" [OWRITER, OCREAT] >>= err bdb
--           -- store records
--           puts bdb [ (\"foo\", \"hop\"), (\"bar\", \"step\"), (\"baz\", \"jump\") ] >>=
--                    err bdb . (all id)
--           -- retrieve records
--           get bdb \"foo\" >>= maybe (error \"something goes wrong\") putStrLn
--           -- traverse records
--           cur <- C.new bdb
--           C.first cur >>= err bdb
--           iter cur >>= putStrLn . show
--           -- close the database
--           close bdb >>= err bdb
--        where
--          puts :: BDB -> [(String, String)] -> IO [Bool]
--          puts bdb = mapM (uncurry $ put bdb)
-- @
--
-- @
--          err :: BDB -> Bool -> IO ()
--          err bdb = flip unless $ ecode bdb >>= error . show
-- @
--
-- @  
--          iter :: C.BDBCUR -> IO [(String, String)]
--          iter cur = do
--            [key, value] <- sequence [C.key cur, C.val cur]
--            case (key, value) of
--              (Just k, Just v) -> C.next cur >> iter cur >>= return . ((k,v):)
--              _ -> return []
-- @
--

data CMP = CMPLEXICAL |
           CMPDECIMAL |
           CMPINT32 |
           CMPINT64 |
           CMP (ByteString -> ByteString -> Ordering)

-- | Create a B+ tree database object. 
new :: IO BDB
new = BDB `fmap` (c_tcbdbnew >>= newForeignPtr tcbdbFinalizer)

-- | Free BDB resource forcibly. 
-- BDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for
-- almost situation. Most always, you don't need to call this. 
-- After call this, you must not touch BDB object. Its behavior is undefined.
delete :: BDB -> IO ()
delete bdb = finalizeForeignPtr (unTCBDB bdb)

-- | Return the last happened error code.
ecode :: BDB -> IO ECODE
ecode bdb = cintToError `fmap` withForeignPtr (unTCBDB bdb) c_tcbdbecode

-- | Set the tuning parameters.
tune :: BDB   -- ^ BDB object
     -> Int32 -- ^ the number of members in each leaf page.
     -> Int32 -- ^ the number of members in each non-leaf page.
     -> Int64 -- ^ the number of elements of the bucket array. 
     -> Int8  -- ^ the size of record alignment by power of 2.
     -> Int8  -- ^ the maximum number of elements of the free block
              -- pool by power of 2.
     -> [TuningOption] -- ^ tuning options
     -> IO Bool -- ^ if successful, the return value is True.
tune bdb lmemb nmemb bnum apow fpow opts =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        c_tcbdbtune bdb' lmemb nmemb bnum apow fpow (combineTuningOption opts)

-- | Set the caching parameters.
setcache :: BDB   -- ^ BDB object
         -> Int32 -- ^ the maximum number of leaf nodes to be cached.
         -> Int32 -- ^ the maximum number of non-leaf nodes to be cached.
         -> IO Bool -- ^ if successful, the return value is True.
setcache bdb lcnum ncnum =
    withForeignPtr (unTCBDB bdb) $ \bdb' -> c_tcbdbsetcache bdb' lcnum ncnum

-- | Set the size of extra mapped memory.
setxmsiz :: BDB -> Int64 -> IO Bool
setxmsiz bdb xmsiz =
    withForeignPtr (unTCBDB bdb) $ \bdb' -> c_tcbdbsetxmsiz bdb' xmsiz

-- | Set the custom comparison function of a B+ tree database object.
setcmpfunc :: BDB -> CMP -> IO Bool
setcmpfunc bdb CMPLEXICAL =
    withForeignPtr (unTCBDB bdb) $ flip c_tcbdbsetcmpfunc c_tccmplexical
setcmpfunc bdb CMPDECIMAL =
    withForeignPtr (unTCBDB bdb) $ flip c_tcbdbsetcmpfunc c_tccmpdecimal
setcmpfunc bdb CMPINT32 =
    withForeignPtr (unTCBDB bdb) $ flip c_tcbdbsetcmpfunc c_tccmpint32
setcmpfunc bdb CMPINT64 =
    withForeignPtr (unTCBDB bdb) $ flip c_tcbdbsetcmpfunc c_tccmpint64
setcmpfunc bdb (CMP func) =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        do cmpfunc <- mkCMP mycmpfunc
           c_tcbdbsetcmpfunc bdb' cmpfunc
        where
          mycmpfunc :: TCCMP'
          mycmpfunc k1buf k1siz k2buf k2siz _ =
              do key1 <- unsafePackCStringLen (k1buf, fromIntegral k1siz)
                 key2 <- unsafePackCStringLen (k2buf, fromIntegral k2siz)
                 case func key1 key2 of
                   LT -> return (-1)
                   EQ -> return 0
                   GT -> return 1

-- | Open BDB database file.
open :: BDB -> String -> [OpenMode] -> IO Bool
open = openHelper c_tcbdbopen unTCBDB combineOpenMode

-- | Close the database file.
close :: BDB -> IO Bool
close bdb = withForeignPtr (unTCBDB bdb) c_tcbdbclose

-- | Stora a record (key-value pair) on BDB.  Key and value type must
-- be instance of Storable class.  Usually, we can use `String',
-- `ByteString' for key, `String', `ByteString', `Int', `Double' for
-- value.
put :: (Storable k, Storable v) => BDB -> k -> v -> IO Bool
put = putHelper c_tcbdbput unTCBDB

-- | Store a new record. If a record with the same key exists in the
-- database, this function has no effect.
putkeep :: (Storable k, Storable v) => BDB -> k -> v -> IO Bool
putkeep = putHelper c_tcbdbputkeep unTCBDB

-- | Concatenate a value at the end of the existing record.
putcat :: (Storable k, Storable v) => BDB -> k -> v -> IO Bool
putcat = putHelper c_tcbdbputcat unTCBDB

-- | Store a record with allowing duplication of keys. 
putdup :: (Storable k, Storable v) => BDB -> k -> v -> IO Bool
putdup = putHelper c_tcbdbputdup unTCBDB

-- | Store records with allowing duplication of keys. 
putlist :: (Storable k, Storable v, Sequence q) =>
           BDB -> k -> q v -> IO Bool
putlist bdb key vals =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        withList vals $ \tcls ->
            withPtrLen key $ \(kbuf, ksize) ->
                alloca $ \sizbuf -> do
                    num <- c_tclistnum tcls
                    putlist' bdb' (kbuf, ksize) tcls sizbuf num
    where
      putlist' bdb' (kbuf, ksize) tcls sizbuf = put' 0
          where
            put' n num
                | n < num = do vbuf  <- c_tclistval tcls n sizbuf
                               vsize <- fromIntegral `fmap` peek sizbuf
                               res <- c_tcbdbputdup bdb' kbuf ksize vbuf vsize
                               if res then put' (n+1) num else return False
                | otherwise = return True

-- | Delete a record. If the key of duplicated records is specified,
-- the first one is deleted. 
out :: (Storable k) => BDB -> k -> IO Bool
out = outHelper c_tcbdbout unTCBDB

-- | Delete records. If the key of duplicated records is specified,
-- all of them are deleted.
outlist :: (Storable k) => BDB -> k -> IO Bool
outlist = outHelper c_tcbdbout3 unTCBDB

-- | Return the value of record. If the key of duplicated records is
-- specified, the first one is returned.
get :: (Storable k, Storable v) => BDB -> k -> IO (Maybe v)
get = getHelper c_tcbdbget unTCBDB

-- | Retrieve records. 
getlist :: (Storable k, Storable v, Sequence q) => BDB -> k -> IO (q v)
getlist bdb key =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        withPtrLen key $ \(kbuf, ksize) -> do
          ptr <- c_tcbdbget4 bdb' kbuf ksize
          if ptr == nullPtr
            then empty
            else peekList' ptr

-- | Return the number of records corresponding to a key. 
vnum :: (Storable k) => BDB -> k -> IO (Maybe Int)
vnum bdb key =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        withPtrLen key $ \(kbuf, ksize) -> do
            res <- c_tcbdbvnum bdb' kbuf ksize
            return $ if res == 0
                       then Nothing
                       else Just $ fromIntegral res

-- | Return the size of the value of a record. If the key of duplicated
-- records is specified, the first one is selected.
vsiz :: (Storable k) => BDB -> k -> IO (Maybe Int)
vsiz = vsizHelper c_tcbdbvsiz unTCBDB

-- | Return list of keys in the specified range.
range :: (Storable k, Sequence q) =>
         BDB     -- ^ BDB object
      -> Maybe k -- ^ the key of the beginning border. If it is
                 -- Nothing, the first record in the database is
                 -- specified.
      -> Bool    -- ^ whether the beginning border is inclusive or not. 
      -> Maybe k -- ^ the key of the ending border. If it is Nothing,
                 -- the last record is specified.
      -> Bool    -- ^ whether the ending border is inclusive or not.
      -> Int     -- ^ the maximum number of keys to be fetched. If it
                 -- is negative value, no limit is specified.
      -> IO (q k)  -- ^ keys in the specified range.
range bdb bkey binc ekey einc maxn =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        withPtrLen' bkey $ \(bkbuf, bksiz) ->
        withPtrLen' ekey $ \(ekbuf, eksiz) ->
            c_tcbdbrange bdb' bkbuf bksiz binc ekbuf eksiz einc
                             (fromIntegral maxn) >>= peekList'
    where
      withPtrLen' (Just key) action = withPtrLen key action
      withPtrLen' Nothing action = action (nullPtr, 0)

-- | Return list of forward matched keys.
fwmkeys :: (Storable k1, Storable k2, Sequence q) =>
           BDB    -- ^ BDB object
        -> k1     -- ^ search string
        -> Int    -- ^ the maximum number of keys to be fetched. If it
                  -- is negative value, no limit is specified.
        -> IO (q k2) -- ^ keys matches specified string (in forward matching).
fwmkeys = fwmHelper c_tcbdbfwmkeys unTCBDB

-- | Increment the corresponding value. (The value specified by a key
-- is treated as integer.)
addint :: (Storable k) =>
          BDB   -- ^ BDB object.
       -> k     -- ^ Key.
       -> Int   -- ^ Amount of increment.
       -> IO (Maybe Int) -- ^ If successful, a new value is returned.
addint = addHelper c_tcbdbaddint unTCBDB fromIntegral fromIntegral (== cINT_MIN)

-- | Increment the corresponding value. (The value specified by a key
-- is treated as double.)
adddouble :: (Storable k) =>
             BDB    -- ^ BDB object.
          -> k      -- ^ Key.
          -> Double -- ^ Amount of increment.
          -> IO (Maybe Double) -- ^ If successful, a new value is returned.
adddouble = addHelper c_tcbdbadddouble unTCBDB realToFrac realToFrac isNaN

-- | Synchronize updated contents of a database object with the file
-- and the device.
sync :: BDB -> IO Bool
sync bdb = withForeignPtr (unTCBDB bdb) c_tcbdbsync

-- |  Optimize the file of a B+ tree database object.
optimize :: BDB
         -> Int32 -- ^ the number of members in each leaf page.
         -> Int32 -- ^ the number of members in each non-leaf page.
         -> Int64 -- ^ the number of elements of the bucket array. 
         -> Int8  -- ^ the size of record alignment by power of 2.
         -> Int8  -- ^ the maximum number of elements of the free block
                  -- pool by power of 2.
         -> [TuningOption] -- ^ tuning options
         -> IO Bool -- ^ if successful, the return value is True.
optimize bdb lmemb nmemb bnum apow fpow opts =
    withForeignPtr (unTCBDB bdb) $ \bdb' ->
        c_tcbdboptimize bdb' lmemb nmemb bnum apow fpow
                        (combineTuningOption opts)

-- | Delete all records.
vanish :: BDB -> IO Bool
vanish bdb = withForeignPtr (unTCBDB bdb) c_tcbdbvanish

-- | Copy the database file.
copy :: BDB -> String -> IO Bool
copy = copyHelper c_tcbdbcopy unTCBDB

-- | Begin the transaction.
tranbegin :: BDB -> IO Bool
tranbegin bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtranbegin

-- | Commit the transaction.
trancommit :: BDB -> IO Bool
trancommit bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtrancommit

-- | Abort the transaction.
tranabort :: BDB -> IO Bool
tranabort bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtranabort

-- | Return the file path of currentry opened database.
path :: BDB -> IO (Maybe String)
path = pathHelper c_tcbdbpath unTCBDB

-- | Return the number of records in the database.
rnum :: BDB -> IO Word64
rnum bdb = withForeignPtr (unTCBDB bdb) c_tcbdbrnum

-- | Return the size of the database file.
fsiz :: BDB -> IO Word64
fsiz bdb = withForeignPtr (unTCBDB bdb) c_tcbdbfsiz