Generic.hs

{-# LANGUAGE OverloadedStrings #-} 
{-# LANGUAGE DeriveDataTypeable #-} 

{-# OPTIONS_GHC -fno-warn-unused-binds #-}

module Database.CouchDB.Conduit.Test.Generic (tests) where

import Test.Framework (testGroup, mutuallyExclusive, Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, (@=?))
import Database.CouchDB.Conduit.Test.Util

import Control.Exception.Lifted (bracket_)
import Control.Monad.IO.Class (liftIO)

import Data.ByteString (ByteString)
import Data.Generics (Data, Typeable)
import Data.ByteString.UTF8 (fromString)
import Database.CouchDB.Conduit
import Database.CouchDB.Conduit.Generic

tests :: Test
tests = mutuallyExclusive $ testGroup "Generic" [
    testCase "Just put-get-delete" case_justPutGet,
--    testCase "Mass flow" case_massFlow,
    testCase "Mass Iter" case_massIter
    ]
    
data TestDoc = TestDoc { kind :: String, intV :: Int, strV :: String } 
    deriving (Show, Eq, Data, Typeable)

case_justPutGet :: Assertion
case_justPutGet = bracket_
    setup teardown $ 
    runCouch conn $ do
        rev <- couchPut "doc-just" "" [] $ TestDoc "doc" 1 "1"
        rev' <- couchPut "doc-just" rev [] $ TestDoc "doc" 2 "2"
        rev'' <- couchRev "doc-just"
        liftIO $ rev' @=? rev''
        couchDelete "doc-just" rev''

case_massFlow :: Assertion
case_massFlow = bracket_
    setup teardown $ 
    runCouch conn $ do
        revs <- mapM (\n -> 
                couchPut (docn n) "" [] $ TestDoc "doc" n $ show n
            ) [1..100]
        liftIO $ length revs @=? 100
        revs' <- mapM (\n -> couchRev $ docn n) [1..100]
        liftIO $ revs @=? revs'
        liftIO $ length revs' @=? 100
        mapM_ (\(n,r) ->
            couchDelete (docn n) r) $ zip [1..100] revs'
  where
    docn n = fromString $ "doc-" ++ show (n :: Int)    


case_massIter :: Assertion
case_massIter = bracket_
    setup teardown $ 
    runCouch conn $ 
        mapM_ (\n -> do
            let name = docn n 
            let d = TestDoc "doc" n $ show n
            rev <- couchPut name "" [] d
            couchDelete (docn n) rev
            _ <- couchPut name "" [] d
            rev'' <- couchPut' name [] d
            (_, d') <- couchGet name []
            liftIO $ d @=? d'
            couchDelete (docn n) rev''
         ) [1..100]
  where
    docn n = fromString $ "doc-" ++ show (n :: Int)
    
setup :: IO ()
setup = setupDB dbName
teardown :: IO ()
teardown = tearDB dbName
    
conn :: CouchConnection
conn = def {couchDB = dbName} 

dbName :: ByteString
dbName = "cdbc_test_generic"