~singpolyma/tokyocabinet-haskell

b346fe793c6806f50f9a717bd8cd53e80f76a628 — tom.lpsd 11 years ago 6fec2a0
Implemented ADB interface.

Ignore-this: d4d6613384f10198463b84824c317111

darcs-hash:20090507142119-69edc-d4b6138218d38c02a2609e4dc30f4813c5d542c6.gz
4 files changed, 580 insertions(+), 260 deletions(-)

M Database/TokyoCabinet/ADB.hs
M tests/ADBTest.hs
A tests/TCDBTest.hs
M tokyocabinet-haskell.cabal
M Database/TokyoCabinet/ADB.hs => Database/TokyoCabinet/ADB.hs +133 -27
@@ 1,6 1,8 @@
module Database.TokyoCabinet.ADB
    (
      new
      ADB
    , ECODE(..)
    , new
    , delete
    , open
    , close


@@ 28,29 30,133 @@ module Database.TokyoCabinet.ADB
    , misc
    ) where

new = undefined
delete = undefined
open = undefined
close = undefined
put = undefined
putkeep = undefined
putcat = undefined
out = undefined
get = undefined
vsiz = undefined
iterinit = undefined
iternext = undefined
fwmkeys = undefined
addint = undefined
adddouble = undefined
sync = undefined
optimize = undefined
vanish = undefined
copy = undefined
tranbegin = undefined
trancommit = undefined
tranabort = undefined
path = undefined
rnum = undefined
size = undefined
misc = undefined
import Data.Word

import Foreign.C.String
import Foreign.ForeignPtr

import Database.TokyoCabinet.ADB.C
import Database.TokyoCabinet.Error
import Database.TokyoCabinet.Internal
import Database.TokyoCabinet.Storable
import Database.TokyoCabinet.Sequence

data ADB = ADB { unTCADB :: !(ForeignPtr ADB') }

-- | Create a Abstract database object. 
new :: IO ADB
new = ADB `fmap` (c_tcadbnew >>= newForeignPtr tcadbFinalizer)

-- | Free ADB resource forcibly. 
-- HDB 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 ADB object. Its behavior is undefined.
delete :: ADB -> IO ()
delete adb = finalizeForeignPtr (unTCADB adb)

-- | Open an abstract dataabse.
open :: ADB -> String -> IO Bool
open adb name = withForeignPtr (unTCADB adb) $ (withCString name) . c_tcadbopen

-- | Close an abstract database object.
close :: ADB -> IO Bool
close adb = withForeignPtr (unTCADB adb) c_tcadbclose

-- | Stora a record into an abstract database object. 
put :: (Storable k, Storable v) => ADB -> k -> v -> IO Bool
put = putHelper c_tcadbput unTCADB

-- | Store a new record into an abstract database object.
putkeep :: (Storable k, Storable v) => ADB -> k -> v -> IO Bool
putkeep = putHelper c_tcadbputkeep unTCADB

-- | Concatenate a value at the end of the existing record in an
-- abstract database object.
putcat :: (Storable k, Storable v) => ADB -> k -> v -> IO Bool
putcat = putHelper c_tcadbputcat unTCADB

-- | Remove a record of an abstract database object.
out :: (Storable k) => ADB -> k -> IO Bool
out = outHelper c_tcadbout unTCADB

-- | Retrieve a record in an abstract database object.
get :: (Storable k, Storable v) => ADB -> k -> IO (Maybe v)
get = getHelper c_tcadbget unTCADB

-- | Get the size of the value of a record in an abstract database object.
vsiz :: (Storable k) => ADB -> k -> IO (Maybe Int)
vsiz = vsizHelper c_tcadbvsiz unTCADB

-- | Initialize the iterator of an abstract database object.
iterinit :: ADB -> IO Bool
iterinit adb = withForeignPtr (unTCADB adb) c_tcadbiterinit

-- | Get the next key of the iterator of an abstract database object.
iternext :: (Storable k) => ADB -> IO (Maybe k)
iternext = iternextHelper c_tcadbiternext unTCADB

-- | Get forward matching keys in an abstract database object.
fwmkeys :: (Storable k1, Storable k2, Sequence q) =>
           ADB -> k1 -> Int -> IO (q k2)
fwmkeys = fwmHelper c_tcadbfwmkeys unTCADB

-- | Add an integer to a record in an abstract database object.
addint :: (Storable k) => ADB -> k -> Int -> IO (Maybe Int)
addint = addHelper c_tcadbaddint unTCADB fromIntegral fromIntegral (== cINT_MIN)

-- | Add a real number to a record in an abstract database object.
adddouble :: (Storable k) => ADB -> k -> Double -> IO (Maybe Double)
adddouble = addHelper c_tcadbadddouble unTCADB realToFrac realToFrac isNaN

-- | Synchronize updated contents of an abstract database object with
-- the file and the device.
sync :: ADB -> IO Bool
sync adb = withForeignPtr (unTCADB adb) c_tcadbsync

-- | Optimize the storage of an abstract database object.
optimize :: ADB -> String -> IO Bool
optimize adb params =
    withForeignPtr (unTCADB adb) $ (withCString params) . c_tcadboptimize

-- | Remove all records of an abstract database object.
vanish :: ADB -> IO Bool
vanish adb = withForeignPtr (unTCADB adb) c_tcadbvanish

-- | Copy the database file of an abstract database object.
copy :: ADB -> String -> IO Bool
copy = copyHelper c_tcadbcopy unTCADB

-- | Begin the transaction of an abstract database object.
tranbegin :: ADB -> IO Bool
tranbegin adb = withForeignPtr (unTCADB adb) c_tcadbtranbegin

-- | Commit the transaction of an abstract database object.
trancommit :: ADB -> IO Bool
trancommit adb = withForeignPtr (unTCADB adb) c_tcadbtrancommit

-- | Abort the transaction of an abstract database object.
tranabort :: ADB -> IO Bool
tranabort adb = withForeignPtr (unTCADB adb) c_tcadbtranabort

-- | Get the file path of an abstract database object.
path :: ADB -> IO (Maybe String)
path = pathHelper c_tcadbpath unTCADB

-- | Get the number of records of an abstract database object.
rnum :: ADB -> IO Word64
rnum adb = withForeignPtr (unTCADB adb) c_tcadbrnum

-- | Get the size of the database of an abstract database object.
size :: ADB -> IO Word64
size adb = withForeignPtr (unTCADB adb) c_tcadbsize

-- | Call a versatile function for miscellaneous operations of an
-- abstract database object.
misc :: (Storable a, Storable b, Sequence q1, Sequence q2) =>
        ADB -> String -> q1 a -> IO (q2 b)
misc adb name args =
    withForeignPtr (unTCADB adb) $ \adb' ->
        withCString name $ \name' ->
            withList args $ \args' -> do
              ret <- c_tcadbmisc adb' name' args'
              peekList' ret

M tests/ADBTest.hs => tests/ADBTest.hs +167 -233
@@ 1,260 1,194 @@
module Main where

import TestUtil
import Test.HUnit hiding (path)
import Database.TokyoCabinet
import qualified Database.TokyoCabinet.BDB as B
import TestUtil
import Database.TokyoCabinet.ADB

import Data.Maybe (catMaybes)
import Data.List (sort)

import Control.Monad
import Control.Exception
import Control.Monad.Trans (liftIO)

withoutFileM :: String -> (String -> TCM a) -> TCM a
withoutFileM fn action = liftIO $ bracket (setupFile fn) teardownFile
                         (runTCM . action)
dbname :: String
dbname = "+"

withOpenedTC :: (TCDB tc) => String -> tc -> (tc -> TCM a) -> TCM a
withOpenedTC name tc action = do
  open tc name [OREADER, OWRITER, OCREAT]
  res <- action tc
  close tc
withOpenedADB :: String -> (ADB -> IO a) -> IO a
withOpenedADB name action = do
  a <- new
  open a name
  res <- action a
  close a
  return res

tcdb :: (TCDB tc) => (tc -> TCM a) -> TCM a
tcdb = (new >>=)

bdb :: (BDB -> TCM a) -> TCM a
bdb = tcdb

hdb :: (HDB -> TCM a) -> TCM a
hdb = tcdb

fdb :: (FDB -> TCM a) -> TCM a
fdb = tcdb

tdb :: (TDB -> TCM a) -> TCM a
tdb = tcdb

bbdb :: (B.BDB -> TCM a) -> TCM a
bbdb = tcdb

dbname tc = "foo" ++ (defaultExtension tc)

test_new_delete tc = delete tc

e @=?: a = liftIO $ e @=? a
e @?=: a = liftIO $ e @?= a
e @?: msg = liftIO $ runTCM e @? msg

test_ecode tc =
    withoutFileM (dbname tc) $ \fn -> do
        open tc fn [OREADER]
        ecode tc >>= (ENOFILE @=?:)

test_open_close tc =
    withoutFileM (dbname tc) $ \fn -> do
      not `liftM` open tc fn [OREADER] @?: "file does not exist"
      open tc fn [OREADER, OWRITER, OCREAT] @?: "open"
      close tc @?: "close"
      not `liftM` close tc @?: "cannot close closed file"

test_putxx tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "bar"
          get tc' "1" >>= (Just "bar" @=?:)
          putkeep tc' "1" "baz"
          get tc' "1" >>= (Just "bar" @=?:)
          putcat tc' "1" "baz"
          get tc' "1" >>= (Just "barbaz" @=?:)

test_out tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "bar"
          get tc' "1" >>= (Just "bar" @=?:)
          out tc' "1" @?: "out succeeded"
          get tc' "1" >>= ((Nothing :: Maybe String) @=?:)

test_put_get tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "foo"
          put tc' "2" "bar"
          put tc' "3" "baz"
          get tc' "1" >>= (Just "foo" @=?:)
          get tc' "2" >>= (Just "bar" @=?:)
          get tc' "3" >>= (Just "baz" @=?:)

test_vsiz tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "bar"
          vsiz tc' "1" >>= (Just 3 @=?:)
          vsiz tc' "2" >>= ((Nothing :: Maybe Int) @=?:)

test_iterate tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          let keys = [1..3] :: [Int]
test_new_delete = new >>= delete

{-
test_open_close =
    withoutFile dbname $ \fn -> do
      adb <- new
      not `fmap` open adb fn [OREADER] @? "file does not exist"
      open adb fn [OREADER, OWRITER, OCREAT] @? "open"
      close adb @? "close"
      not `fmap` close adb @? "cannot close closed file"

test_putxx =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          put adb "foo" "bar"
          get adb "foo" >>= (Just "bar" @=?)
          putkeep adb "foo" "baz"
          get adb "foo" >>= (Just "bar" @=?)
          putcat adb "foo" "baz"
          get adb "foo" >>= (Just "barbaz" @=?)
          putasync adb "bar" "baz"
          sync adb
          get adb "bar" >>= (Just "baz" @=?)

test_out =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          put adb "foo" "bar"
          get adb "foo" >>= (Just "bar" @=?)
          out adb "foo" @? "out succeeded"
          get adb "foo" >>= ((Nothing :: Maybe String) @=?)

test_put_get =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          put adb "1" "foo"
          put adb "2" "bar"
          put adb "3" "baz"
          get adb "1" >>= (Just "foo" @=?)
          get adb "2" >>= (Just "bar" @=?)
          get adb "3" >>= (Just "baz" @=?)

test_vsiz =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          put adb "foo" "bar"
          vsiz adb "foo" >>= (Just 3 @=?)
          vsiz adb "bar" >>= ((Nothing :: Maybe Int) @=?)

test_iterate =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          let keys = [1, 2, 3] :: [Int]
              vals = ["foo", "bar", "baz"]
          zipWithM_ (put tc') keys vals
          iterinit tc'
          keys' <- sequence $ replicate (length keys) (iternext tc')
          (sort $ catMaybes keys') @?=: (sort keys)

test_fwmkeys tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          mapM_ (uncurry (put tc')) ([ ("foo", 100)
          zipWithM_ (put adb) keys vals
          iterinit adb
          keys' <- sequence $ replicate (length keys) (iternext adb)
          (sort $ catMaybes keys') @?= (sort keys)

test_fwmkeys =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          mapM_ (uncurry (put adb)) ([ ("foo", 100)
                                     , ("bar", 200)
                                     , ("baz", 201)
                                     , ("jkl", 300)] :: [(String, Int)])
          fwmkeys tc' "ba" 10 >>= (["bar", "baz"] @=?:) . sort
          fwmkeys tc' "ba" 1 >>= (["bar"] @=?:)
          fwmkeys tc' "" 10 >>= (["bar", "baz", "foo", "jkl"] @=?:) . sort
          fwmkeys adb "ba" 10 >>= (["bar", "baz"] @=?) . sort
          fwmkeys adb "ba" 1 >>= (["bar"] @=?)
          fwmkeys adb "" 10 >>= (["bar", "baz", "foo", "jkl"] @=?) . sort

test_fwmkeys_fdb tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          zipWithM_ (put tc') ([1..10] :: [Int]) ([100, 200..1000] :: [Int])
          fwmkeys tc' "[min,max]" 10 >>= (([1..10] :: [Int]) @=?:)

test_addint tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
test_addint =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          let ini = 32 :: Int
          put tc' "100" ini
          get tc' "100" >>= (Just ini @=?:)
          addint tc' "100" 3
          get tc' "100" >>= (Just (ini+3) @=?:)
          addint tc' "200" 1 >>= (Just 1 @=?:)
          put tc' "200" "foo"
          addint tc' "200" 1 >>= (Nothing @=?:)

test_adddouble tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put adb "foo" ini
          get adb "foo" >>= (Just ini @=?)
          addint adb "foo" 3
          get adb "foo" >>= (Just (ini+3) @=?)
          addint adb "bar" 1 >>= (Just 1 @=?)
          put adb "bar" "foo"
          addint adb "bar" 1 >>= (Nothing @=?)

test_adddouble =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          let ini = 0.003 :: Double
          put tc' "100" ini
          get tc' "100" >>= (Just ini @=?:)
          adddouble tc' "100" 0.3
          (get tc' "100" >>= (return . isIn (ini+0.3))) @?: "isIn"
          adddouble tc' "200" 0.5 >>= (Just 0.5 @=?:)
          put tc' "200" "foo"
          adddouble tc' "200" 1.2 >>= (Nothing @=?:)
          put adb "foo" ini
          get adb "foo" >>= (Just ini @=?)
          adddouble adb "foo" 0.3
          (get adb "foo" >>= (isIn (ini+0.3))) @? "isIn"
          adddouble adb "bar" 0.5 >>= (Just 0.5 @=?)
          put adb "bar" "foo"
          adddouble adb "bar" 1.2 >>= (Nothing @=?)
    where
      margin = 1e-30
      isIn :: Double -> (Maybe Double) -> Bool
      isIn :: Double -> (Maybe Double) -> IO Bool
      isIn expected (Just actual) =
          let diff = expected - actual
          in abs diff <= margin

test_vanish tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
            put tc' "100" "111"
            put tc' "200" "222"
            put tc' "300" "333"
            rnum tc' >>= (3 @=?:)
            vanish tc'
            rnum tc' >>= (0 @=?:)

test_copy tc =
    withoutFileM (dbname tc) $ \fns ->    
        withoutFileM ("bar" ++ defaultExtension tc) $ \fnd ->
            withOpenedTC fns tc $ \tc' -> do
                put tc' "100" "bar"
                copy tc' fnd
                close tc'
                open tc' fns [OREADER]
                get tc' "100" >>= (Just "bar" @=?:)

test_path tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' ->
            path tc' >>= (Just (dbname tc) @=?:)

test_util tc =
    withoutFileM (dbname tc) $ \fn -> do
      open tc fn [OWRITER, OCREAT]
      path tc >>= (Just fn @=?:)
      rnum tc >>= (0 @=?:)
      ((> 0) `liftM` size tc) @?: "fsiz"
      sync tc @?: "sync"
      close tc
          in return $ abs diff <= margin

test_vanish =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
            put adb "foo" "111"
            put adb "bar" "222"
            put adb "baz" "333"
            rnum adb >>= (3 @=?)
            vanish adb
            rnum adb >>= (0 @=?)

test_copy =
    withoutFile dbname $ \fns ->
        withoutFile "bar.tch" $ \fnd ->
            withOpenedADB fns $ \adb -> do
                put adb "foo" "bar"
                copy adb fnd
                close adb
                open adb fns [OREADER]
                get adb "foo" >>= (Just "bar" @=?)

test_txn =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb -> do
          tranbegin adb
          put adb "foo" "bar"
          get adb "foo" >>= (Just "bar" @=?)
          tranabort adb
          get adb "foo" >>= ((Nothing :: Maybe String) @=?)
          tranbegin adb
          put adb "foo" "baz"
          get adb "foo" >>= (Just "baz" @=?)
          trancommit adb
          get adb "foo" >>= (Just "baz" @=?)

test_path =
    withoutFile dbname $ \fn ->
        withOpenedADB fn $ \adb ->
            path adb >>= (Just dbname @=?)

test_util =
    withoutFile dbname $ \fn -> do
      adb <- new
      setcache adb 1000000 @? "setcache"
      setxmsiz adb 1000000 @? "setxmsiz"
      tune adb 150000 5 11 [TLARGE, TBZIP] @? "tune"
      open adb fn [OREADER, OWRITER, OCREAT]
      path adb >>= (Just fn @=?)
      rnum adb >>= (0 @=?)
      ((> 0) `fmap` fsiz adb) @? "fsiz"
      sync adb @? "sync"
      optimize adb 0 (-1) (-1) [] @? "optimize"
      close adb
-}

tests = test [
          "new delete BDB" ~: (runTCM $ bdb test_new_delete)
        , "new delete HDB" ~: (runTCM $ hdb test_new_delete)
        , "new delete FDB" ~: (runTCM $ fdb test_new_delete)
        , "new delete B.BDB" ~: (runTCM $ bbdb test_new_delete)
        , "ecode BDB" ~: (runTCM $ bdb test_ecode)
        , "ecode HDB" ~: (runTCM $ hdb test_ecode)
        , "ecode FDB" ~: (runTCM $ fdb test_ecode)
        , "ecode B.BDB" ~: (runTCM $ bbdb test_ecode)
        , "open close BDB" ~: (runTCM $ bdb test_open_close)
        , "open close HDB" ~: (runTCM $ hdb test_open_close)
        , "open close FDB" ~: (runTCM $ fdb test_open_close)
        , "open close B.BDB" ~: (runTCM $ bbdb test_open_close)
        , "putxxx BDB" ~: (runTCM $ bdb test_putxx)
        , "putxxx HDB" ~: (runTCM $ hdb test_putxx)
        , "putxxx FDB" ~: (runTCM $ fdb test_putxx)
        , "putxxx B.BDB" ~: (runTCM $ bbdb test_putxx)
        , "out BDB" ~: (runTCM $ bdb test_out)
        , "out HDB" ~: (runTCM $ hdb test_out)
        , "out FDB" ~: (runTCM $ fdb test_out)
        , "out B.BDB" ~: (runTCM $ bbdb test_out)
        , "put get BDB" ~: (runTCM $ bdb test_put_get)
        , "put get HDB" ~: (runTCM $ hdb test_put_get)
        , "put get FDB" ~: (runTCM $ fdb test_put_get)
        , "put get B.BDB" ~: (runTCM $ bbdb test_put_get)
        , "vsiz BDB" ~: (runTCM $ bdb test_vsiz)
        , "vsiz HDB" ~: (runTCM $ hdb test_vsiz)
        , "vsiz FDB" ~: (runTCM $ fdb test_vsiz)
        , "vsiz B.BDB" ~: (runTCM $ bbdb test_vsiz)
        , "iterate BDB" ~: (runTCM $ bdb test_iterate)
        , "iterate HDB" ~: (runTCM $ hdb test_iterate)
        , "iterate FDB" ~: (runTCM $ fdb test_iterate)
        , "fwmkeys BDB" ~: (runTCM $ bdb test_fwmkeys)
        , "fwmkeys HDB" ~: (runTCM $ hdb test_fwmkeys)
        , "fwmkeys FDB" ~: (runTCM $ fdb test_fwmkeys_fdb)
        , "fwmkeys B.BDB" ~: (runTCM $ bbdb test_fwmkeys)
        , "addint BDB" ~: (runTCM $ bdb test_addint)
        , "addint HDB" ~: (runTCM $ hdb test_addint)
        , "addint FDB" ~: (runTCM $ fdb test_addint)
        , "addint B.BDB" ~: (runTCM $ bbdb test_addint)
        , "adddouble BDB" ~: (runTCM $ bdb test_adddouble)
        , "adddouble HDB" ~: (runTCM $ hdb test_adddouble)
        , "adddouble FDB" ~: (runTCM $ fdb test_adddouble)
        , "adddouble B.BDB" ~: (runTCM $ bbdb test_adddouble)
        , "vanish BDB" ~: (runTCM $ bdb test_vanish)
        , "vanish HDB" ~: (runTCM $ hdb test_vanish)
        , "vanish FDB" ~: (runTCM $ fdb test_vanish)
        , "vanish B.BDB" ~: (runTCM $ bbdb test_vanish)
        , "copy BDB" ~: (runTCM $ bdb test_copy)
        , "copy HDB" ~: (runTCM $ hdb test_copy)
        , "copy FDB" ~: (runTCM $ fdb test_copy)
        , "copy B.BDB" ~: (runTCM $ bbdb test_copy)
        , "path BDB" ~: (runTCM $ bdb test_path)
        , "path HDB" ~: (runTCM $ hdb test_path)
        , "path FDB" ~: (runTCM $ fdb test_path)
        , "path B.BDB" ~: (runTCM $ bbdb test_path)
        , "util BDB" ~: (runTCM $ bdb test_util)
        , "util HDB" ~: (runTCM $ hdb test_util)
        , "util FDB" ~: (runTCM $ fdb test_util)
        , "util B.BDB" ~: (runTCM $ bbdb test_util)
        , "new delete TDB" ~: (runTCM $ tdb test_new_delete)
        , "ecode TDB" ~: (runTCM $ tdb test_ecode)
        , "open close TDB" ~: (runTCM $ tdb test_open_close)
        , "iterate TDB" ~: (runTCM $ tdb test_iterate)
        , "fwmkeys B.BDB" ~: (runTCM $ bbdb test_fwmkeys)
        , "vanish TDB" ~: (runTCM $ tdb test_vanish)
        , "path TDB" ~: (runTCM $ tdb test_path)
        , "util TDB" ~: (runTCM $ tdb test_util)
          "new delete" ~: test_new_delete
--        , "open close"  ~: test_open_close
--        , "put get" ~: test_put_get
--        , "out" ~: test_out
--        , "putxx" ~: test_putxx
--        , "copy" ~: test_copy
--        , "transaction" ~: test_txn
--        , "fwmkeys" ~: test_fwmkeys
--        , "path" ~: test_path
--        , "addint" ~: test_addint
--        , "adddouble" ~: test_adddouble
--        , "util" ~: test_util
--        , "vsiz" ~: test_vsiz
--        , "vanish" ~: test_vanish
--        , "iterate" ~: test_iterate
        ]

main = runTestTT tests

A tests/TCDBTest.hs => tests/TCDBTest.hs +260 -0
@@ 0,0 1,260 @@
module Main where

import TestUtil
import Test.HUnit hiding (path)
import Database.TokyoCabinet
import qualified Database.TokyoCabinet.BDB as B

import Data.Maybe (catMaybes)
import Data.List (sort)

import Control.Monad
import Control.Exception
import Control.Monad.Trans (liftIO)

withoutFileM :: String -> (String -> TCM a) -> TCM a
withoutFileM fn action = liftIO $ bracket (setupFile fn) teardownFile
                         (runTCM . action)

withOpenedTC :: (TCDB tc) => String -> tc -> (tc -> TCM a) -> TCM a
withOpenedTC name tc action = do
  open tc name [OREADER, OWRITER, OCREAT]
  res <- action tc
  close tc
  return res

tcdb :: (TCDB tc) => (tc -> TCM a) -> TCM a
tcdb = (new >>=)

bdb :: (BDB -> TCM a) -> TCM a
bdb = tcdb

hdb :: (HDB -> TCM a) -> TCM a
hdb = tcdb

fdb :: (FDB -> TCM a) -> TCM a
fdb = tcdb

tdb :: (TDB -> TCM a) -> TCM a
tdb = tcdb

bbdb :: (B.BDB -> TCM a) -> TCM a
bbdb = tcdb

dbname tc = "foo" ++ (defaultExtension tc)

test_new_delete tc = delete tc

e @=?: a = liftIO $ e @=? a
e @?=: a = liftIO $ e @?= a
e @?: msg = liftIO $ runTCM e @? msg

test_ecode tc =
    withoutFileM (dbname tc) $ \fn -> do
        open tc fn [OREADER]
        ecode tc >>= (ENOFILE @=?:)

test_open_close tc =
    withoutFileM (dbname tc) $ \fn -> do
      not `liftM` open tc fn [OREADER] @?: "file does not exist"
      open tc fn [OREADER, OWRITER, OCREAT] @?: "open"
      close tc @?: "close"
      not `liftM` close tc @?: "cannot close closed file"

test_putxx tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "bar"
          get tc' "1" >>= (Just "bar" @=?:)
          putkeep tc' "1" "baz"
          get tc' "1" >>= (Just "bar" @=?:)
          putcat tc' "1" "baz"
          get tc' "1" >>= (Just "barbaz" @=?:)

test_out tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "bar"
          get tc' "1" >>= (Just "bar" @=?:)
          out tc' "1" @?: "out succeeded"
          get tc' "1" >>= ((Nothing :: Maybe String) @=?:)

test_put_get tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "foo"
          put tc' "2" "bar"
          put tc' "3" "baz"
          get tc' "1" >>= (Just "foo" @=?:)
          get tc' "2" >>= (Just "bar" @=?:)
          get tc' "3" >>= (Just "baz" @=?:)

test_vsiz tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          put tc' "1" "bar"
          vsiz tc' "1" >>= (Just 3 @=?:)
          vsiz tc' "2" >>= ((Nothing :: Maybe Int) @=?:)

test_iterate tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          let keys = [1..3] :: [Int]
              vals = ["foo", "bar", "baz"]
          zipWithM_ (put tc') keys vals
          iterinit tc'
          keys' <- sequence $ replicate (length keys) (iternext tc')
          (sort $ catMaybes keys') @?=: (sort keys)

test_fwmkeys tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          mapM_ (uncurry (put tc')) ([ ("foo", 100)
                                     , ("bar", 200)
                                     , ("baz", 201)
                                     , ("jkl", 300)] :: [(String, Int)])
          fwmkeys tc' "ba" 10 >>= (["bar", "baz"] @=?:) . sort
          fwmkeys tc' "ba" 1 >>= (["bar"] @=?:)
          fwmkeys tc' "" 10 >>= (["bar", "baz", "foo", "jkl"] @=?:) . sort

test_fwmkeys_fdb tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          zipWithM_ (put tc') ([1..10] :: [Int]) ([100, 200..1000] :: [Int])
          fwmkeys tc' "[min,max]" 10 >>= (([1..10] :: [Int]) @=?:)

test_addint tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          let ini = 32 :: Int
          put tc' "100" ini
          get tc' "100" >>= (Just ini @=?:)
          addint tc' "100" 3
          get tc' "100" >>= (Just (ini+3) @=?:)
          addint tc' "200" 1 >>= (Just 1 @=?:)
          put tc' "200" "foo"
          addint tc' "200" 1 >>= (Nothing @=?:)

test_adddouble tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
          let ini = 0.003 :: Double
          put tc' "100" ini
          get tc' "100" >>= (Just ini @=?:)
          adddouble tc' "100" 0.3
          (get tc' "100" >>= (return . isIn (ini+0.3))) @?: "isIn"
          adddouble tc' "200" 0.5 >>= (Just 0.5 @=?:)
          put tc' "200" "foo"
          adddouble tc' "200" 1.2 >>= (Nothing @=?:)
    where
      margin = 1e-30
      isIn :: Double -> (Maybe Double) -> Bool
      isIn expected (Just actual) =
          let diff = expected - actual
          in abs diff <= margin

test_vanish tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' -> do
            put tc' "100" "111"
            put tc' "200" "222"
            put tc' "300" "333"
            rnum tc' >>= (3 @=?:)
            vanish tc'
            rnum tc' >>= (0 @=?:)

test_copy tc =
    withoutFileM (dbname tc) $ \fns ->    
        withoutFileM ("bar" ++ defaultExtension tc) $ \fnd ->
            withOpenedTC fns tc $ \tc' -> do
                put tc' "100" "bar"
                copy tc' fnd
                close tc'
                open tc' fns [OREADER]
                get tc' "100" >>= (Just "bar" @=?:)

test_path tc =
    withoutFileM (dbname tc) $ \fn ->
        withOpenedTC fn tc $ \tc' ->
            path tc' >>= (Just (dbname tc) @=?:)

test_util tc =
    withoutFileM (dbname tc) $ \fn -> do
      open tc fn [OWRITER, OCREAT]
      path tc >>= (Just fn @=?:)
      rnum tc >>= (0 @=?:)
      ((> 0) `liftM` size tc) @?: "fsiz"
      sync tc @?: "sync"
      close tc

tests = test [
          "new delete BDB" ~: (runTCM $ bdb test_new_delete)
        , "new delete HDB" ~: (runTCM $ hdb test_new_delete)
        , "new delete FDB" ~: (runTCM $ fdb test_new_delete)
        , "new delete B.BDB" ~: (runTCM $ bbdb test_new_delete)
        , "ecode BDB" ~: (runTCM $ bdb test_ecode)
        , "ecode HDB" ~: (runTCM $ hdb test_ecode)
        , "ecode FDB" ~: (runTCM $ fdb test_ecode)
        , "ecode B.BDB" ~: (runTCM $ bbdb test_ecode)
        , "open close BDB" ~: (runTCM $ bdb test_open_close)
        , "open close HDB" ~: (runTCM $ hdb test_open_close)
        , "open close FDB" ~: (runTCM $ fdb test_open_close)
        , "open close B.BDB" ~: (runTCM $ bbdb test_open_close)
        , "putxxx BDB" ~: (runTCM $ bdb test_putxx)
        , "putxxx HDB" ~: (runTCM $ hdb test_putxx)
        , "putxxx FDB" ~: (runTCM $ fdb test_putxx)
        , "putxxx B.BDB" ~: (runTCM $ bbdb test_putxx)
        , "out BDB" ~: (runTCM $ bdb test_out)
        , "out HDB" ~: (runTCM $ hdb test_out)
        , "out FDB" ~: (runTCM $ fdb test_out)
        , "out B.BDB" ~: (runTCM $ bbdb test_out)
        , "put get BDB" ~: (runTCM $ bdb test_put_get)
        , "put get HDB" ~: (runTCM $ hdb test_put_get)
        , "put get FDB" ~: (runTCM $ fdb test_put_get)
        , "put get B.BDB" ~: (runTCM $ bbdb test_put_get)
        , "vsiz BDB" ~: (runTCM $ bdb test_vsiz)
        , "vsiz HDB" ~: (runTCM $ hdb test_vsiz)
        , "vsiz FDB" ~: (runTCM $ fdb test_vsiz)
        , "vsiz B.BDB" ~: (runTCM $ bbdb test_vsiz)
        , "iterate BDB" ~: (runTCM $ bdb test_iterate)
        , "iterate HDB" ~: (runTCM $ hdb test_iterate)
        , "iterate FDB" ~: (runTCM $ fdb test_iterate)
        , "fwmkeys BDB" ~: (runTCM $ bdb test_fwmkeys)
        , "fwmkeys HDB" ~: (runTCM $ hdb test_fwmkeys)
        , "fwmkeys FDB" ~: (runTCM $ fdb test_fwmkeys_fdb)
        , "fwmkeys B.BDB" ~: (runTCM $ bbdb test_fwmkeys)
        , "addint BDB" ~: (runTCM $ bdb test_addint)
        , "addint HDB" ~: (runTCM $ hdb test_addint)
        , "addint FDB" ~: (runTCM $ fdb test_addint)
        , "addint B.BDB" ~: (runTCM $ bbdb test_addint)
        , "adddouble BDB" ~: (runTCM $ bdb test_adddouble)
        , "adddouble HDB" ~: (runTCM $ hdb test_adddouble)
        , "adddouble FDB" ~: (runTCM $ fdb test_adddouble)
        , "adddouble B.BDB" ~: (runTCM $ bbdb test_adddouble)
        , "vanish BDB" ~: (runTCM $ bdb test_vanish)
        , "vanish HDB" ~: (runTCM $ hdb test_vanish)
        , "vanish FDB" ~: (runTCM $ fdb test_vanish)
        , "vanish B.BDB" ~: (runTCM $ bbdb test_vanish)
        , "copy BDB" ~: (runTCM $ bdb test_copy)
        , "copy HDB" ~: (runTCM $ hdb test_copy)
        , "copy FDB" ~: (runTCM $ fdb test_copy)
        , "copy B.BDB" ~: (runTCM $ bbdb test_copy)
        , "path BDB" ~: (runTCM $ bdb test_path)
        , "path HDB" ~: (runTCM $ hdb test_path)
        , "path FDB" ~: (runTCM $ fdb test_path)
        , "path B.BDB" ~: (runTCM $ bbdb test_path)
        , "util BDB" ~: (runTCM $ bdb test_util)
        , "util HDB" ~: (runTCM $ hdb test_util)
        , "util FDB" ~: (runTCM $ fdb test_util)
        , "util B.BDB" ~: (runTCM $ bbdb test_util)
        , "new delete TDB" ~: (runTCM $ tdb test_new_delete)
        , "ecode TDB" ~: (runTCM $ tdb test_ecode)
        , "open close TDB" ~: (runTCM $ tdb test_open_close)
        , "iterate TDB" ~: (runTCM $ tdb test_iterate)
        , "fwmkeys B.BDB" ~: (runTCM $ bbdb test_fwmkeys)
        , "vanish TDB" ~: (runTCM $ tdb test_vanish)
        , "path TDB" ~: (runTCM $ tdb test_path)
        , "util TDB" ~: (runTCM $ tdb test_util)
        ]

main = runTestTT tests

M tokyocabinet-haskell.cabal => tokyocabinet-haskell.cabal +20 -0
@@ 207,6 207,26 @@ Executable ADBTest
  Build-depends:        HUnit >= 1.2, base >= 4.0, directory >= 1.0
  Extensions:           CPP, ForeignFunctionInterface,
                        EmptyDataDecls, TypeSynonymInstances
  GHC-Options:          -fhpc
  Other-modules:
    TestUtil
    Database.TokyoCabinet.ADB
    Database.TokyoCabinet.ADB.C
    Database.TokyoCabinet.Error
    Database.TokyoCabinet.List
    Database.TokyoCabinet.List.C
    Database.TokyoCabinet.Storable

Executable TCDBTest
  if flag(BuildTest)
    Buildable:            True
  else
    Buildable:            False
  Main-Is:              tests/TCDBTest.hs
  Extra-libraries:      tokyocabinet
  Build-depends:        HUnit >= 1.2, base >= 4.0, directory >= 1.0
  Extensions:           CPP, ForeignFunctionInterface,
                        EmptyDataDecls, TypeSynonymInstances
  Other-modules:
    TestUtil
    Database.TokyoCabinet