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' fnd [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