Basic.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Basic tests
module Database.CouchDB.Enumerator.Test.Basic where

import           Control.Monad
import           Control.Monad.Trans.Class (lift)
import qualified Control.Exception.Lifted as E
import           Data.Aeson ((.=))
import qualified Data.Aeson as A
import qualified Data.HashMap.Lazy as M
import           Data.List (nubBy)

import Database.CouchDB.Enumerator
import Database.CouchDB.Enumerator.Test.Util

import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion)
import Test.QuickCheck (sample', arbitrary)

tests :: Test
tests = testGroup "Basic" [
      testGroup "DB" [
          testCouchCase "basic connection"        connectTest
        , testCouchCase "basic error"             missingObjectTest
        , testCouchCase "conflict"                conflictError
        --, testCouchProperty "single insert" (1,7) insertTest
        , testCouchCase "insert"                  insertTestCase
        , testCouchCase "basic delete"            deleteTest
        , testCase "Delete noexistent"            case_deleteNoexistentDb

        -- TODO: right now, the following test screws up other tests by deleting the db.
        -- Perhaps the code should be updated to put the database at the beginning of each test?
        --, testCouchCase "Double put and delete"   case_doublePutAndDel
      ]
    ]

connectTest :: CouchT IO ()
connectTest = do
    v <- couchGet "" []
    lift $ assertObjMember "db_name" (assertStr "testcouchenum") v

missingObjectTest :: CouchT IO ()
missingObjectTest = assertRecvError (Just 404) $ couchGet "jaosihaweoghaweiouhawef" []

conflictError :: CouchT IO ()
conflictError = do
    E.handle catch404 $ do rev <- couchRev "conflicttest"
                           couchDelete "conflicttest" rev
    --E.handle catch404 $ couchRev "somebadobject" >> return ()
    couchPut_ "conflicttest" [] $ A.object [ "foo" .= True ]
    return ()
  where catch404 e@(CouchError c _) = unless (c == Just 404) $ E.throwIO e

insertTestCase :: CouchT IO ()
insertTestCase = replicateM_ 20 $ do
    objs <- lift $ sample' arbitrary
    insertTest objs

insertTest :: [(Int,ArbitraryObject,ArbitraryObject,ArbitraryObject)] -> CouchT IO ()
insertTest objs = do
    let objs' = nubBy (\(a,_,_,_) (b,_,_,_) -> a == b) objs
    let keys  = map (("otest"++) . show . (\(a,_,_,_) -> a)) objs'
    let vals1 = map (\(_,ArbitraryObject a,_,_) -> a) objs'
    let vals2 = map (\(_,_,ArbitraryObject a,_) -> a) objs'
    let vals3 = map (\(_,_,_,ArbitraryObject a) -> a) objs'

    mapM_ clearObject keys

    rev <- forM (zip keys vals1) $ \(k,o) ->
        couchPut k [] o

    forM_ (zip3 rev keys vals1) $ \(r,k,o) -> do
        checkLoad k $ M.insert "_rev" (A.toJSON r) o
        checkRevision k r

    rev2 <- forM (zip3 rev keys vals2) $ \(r,k,o) ->
        couchPut k [] $ M.insert "_rev" (A.toJSON r) o

    forM_ (zip3 rev2 keys vals2) $ \(r,k,o) -> do
        checkLoad k $ M.insert "_rev" (A.toJSON r) o
        checkRevision k r

    rev3 <- forM (zip3 rev2 keys vals3) $ \(r,k,o) ->
        couchPutRev k r [] o

    forM_ (zip3 rev3 keys vals3) $ \(r,k,o) -> do
        checkLoad k $ M.insert "_rev" (A.toJSON r) o
        checkRevision k r

deleteTest :: CouchT IO ()
deleteTest = do
    (ArbitraryObject obj) <- liftM (head . drop 5) $ lift $ sample' arbitrary

    clearObject "deltest"

    rev <- couchPut "deltest" [] obj
    checkLoad "deltest" obj
    couchDelete "deltest" rev
    assertRecvError (Just 404) $ couchGet "deltest" []


case_doublePutAndDel :: CouchT IO ()
case_doublePutAndDel = do
    couchPutDb ""
    couchPutDb ""
    couchDeleteDb ""

-- | A test with an empty db
case_deleteNoexistentDb :: Assertion
case_deleteNoexistentDb = runCouch "localhost" 5984 "" $ 
    checkError (Just 404) $ couchDeleteDb "cdbe_noexistent"