Untitled

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad.Trans.Control
import Control.Monad
import Control.Monad.Trans
import Control.Exception(bracket_)
import Test.Hspec
import Test.Hspec.HUnit ()
import Test.HUnit (assertBool, assertFailure, Assertion)
import Data.UString hiding(any)
import Database.MongoDB

-- DBアクセスする
withDB :: MonadIO m => String -> Action m a -> m (Either Failure a)
withDB name action = do
  pipe <- liftIO $ runIOE $ connect (host "127.0.0.1")
  access pipe master (u name) action

-- テストしたい関数
includeOhtaRina:: [Document] -> Bool
includeOhtaRina = any isOhtaRina
    where
      isOhtaRina doc = (at $ "name") doc == "Ohta Rina"

-- テストデータを作って消すsetup/teardown
withUsers = bracket_ setup teardown
    where
      setup = withDB "test" $ insertMany (u "users")
                  [[ "user_id" =: "1", "name" =: "Abbey Lee Kershaw"],
                   [ "user_id" =: "2", "name" =: "Miyamoto Rie"]]
      teardown = withDB "test" $ delete (select [] $ "users")

withUsersIncludeOhtaRina = bracket_ setup teardown
    where
      setup = withDB "test" $ insertMany (u "users")
                  [[ "user_id" =: "1", "name" =: "Ohta Rina"],
                   [ "user_id" =: "2", "name" =: "Miyamoto Rie"]]
      teardown = withDB "test" $ delete (select [] $ "users")

-- 実際のSpec
specs :: Specs
specs = describe "includeOhtaRina" [

  it "should be true with Ohta Rina" $
    withUsersIncludeOhtaRina $ do
       documents <- withDB "test" $
         rest =<< Database.MongoDB.find (select [] ("users"))
       case documents of
         Right docs -> assertBool "OK" $ includeOhtaRina docs
         Left  _    -> assertFailure "DB access failed",

  it "should be false if Ohta Rina is not there" $
    withUsers $ do
       documents <- withDB "test" $
         rest =<< Database.MongoDB.find (select [] "users")
       case documents of
         Right docs -> assertBool "OK" $ not $ includeOhtaRina docs
         Left  _    -> assertFailure "DB access failed"
        ]

main = hspec specs