View.hs

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.CouchDB.Enumerator.Test.View(
    tests
) where

import           Control.Monad
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Trans.Reader
import           Data.Aeson ((.=))
import qualified Data.Aeson as A
import qualified Data.ByteString.UTF8 as BU8
import           Data.Enumerator hiding (map, length, head, run, drop)
import qualified Data.Enumerator.List as EL
import           Data.List (find, deleteBy)
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T

import Test.Framework (Test, testGroup)
import Test.QuickCheck (sample', arbitrary)

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

tests :: Test
tests = testGroup "Views" [
      --testCouchProperty "basic" (12,13) views
      testCouchCase "basic" viewCase
    ]

checkEqual :: (Monad m) => [A.Object] -> [A.Object] -> Iteratee a m ()
checkEqual []     []    = return ()
checkEqual []     (x:_) = error $ "Extra object in list 2  " ++ show (A.encode x)
checkEqual (x:xs) lst2  = case find (isSubmapOf x) lst2 of
                            Nothing -> error $ "Unable to find " ++ show (A.encode $ A.Object x)
                            Just _  -> checkEqual xs $ deleteBy isSubmapOf x lst2

assertViewRet :: (MonadIO m) => [A.Object] -> Enumerator A.Object m () -> m ()
assertViewRet lst e = run_ (e $$ EL.consume >>= checkEqual lst)

addKeys :: Int -> Int -> Int -> ArbitraryObject -> A.Object
addKeys u g t (ArbitraryObject o) = o `M.union` M.fromList [ ("user", A.toJSON u)
                                                           , ("group", A.toJSON g)
                                                           , ("otype", A.toJSON t)
                                                           ]

addView :: CouchT IO ()
addView = couchPut_ "_design/dataviews" [] viewObj where
   viewObj = A.object 
        [ "language"    .= ("javascript" :: T.Text)
        , "views"       .= A.object
            [ "bytype"  .= A.object
                [ "map" .= ("function(doc) {\
                              \   emit([doc.user,doc.group,doc.otype], doc); \
                              \}" :: T.Text)
                ]
            ]
        ]

queryByType :: Integer -> Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b
queryByType u g t = couchView path query $= extractViewValue
    where path  = "dataviews/_view/bytype"
          key   = "[" ++ show u ++ "," ++ show g ++ "," ++ show t ++ "]"
          query = [(BU8.fromString "key", Just $ BU8.fromString key)]

queryByGroup :: Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b
queryByGroup u g = couchView path query $= extractViewValue
    where path  = "dataviews/_view/bytype"
          skey  = "[" ++ show u ++ "," ++ show g ++ "]"
          ekey  = "[" ++ show u ++ "," ++ show g ++ ",{}]"
          query = [ (BU8.fromString "startkey", Just $ BU8.fromString skey)
                  , (BU8.fromString "endkey"  , Just $ BU8.fromString ekey)
                  ]

viewCase :: CouchT IO ()
viewCase = replicateM_ 20 $ do
    objs <- liftIO $ sample' arbitrary
    views objs

views :: [ArbitraryObject] -> CouchT IO ()
views lst = do
    let (group1,x1) = splitAt 3 lst
        (group2,x2) = splitAt 3 x1
        (group3,x3) = splitAt 3 x2
        (group4,_ ) = splitAt 3 x3

        g1key = map (("view"++) . show) ([0..2] :: [Int])
        g1obj = map (addKeys 0 0 0) group1
        g2key = map (("view"++) . show) ([5..7] :: [Int])
        g2obj = map (addKeys 0 0 1) group2
        g3key = map (("view"++) . show) ([10..12] :: [Int])
        g3obj = map (addKeys 0 1 0) group3
        g4key = map (("view"++) . show) ([15..17] :: [Int])
        g4obj = map (addKeys 1 0 0) group4

    mapM_ clearObject $ g1key ++ g2key ++ g3key ++ g4key

    checkError (Just 409) addView

    forM_ (zip g1key g1obj ++ zip g2key g2obj ++ zip g3key g3obj ++ zip g4key g4obj) $ \(k,o) ->
        couchPut_ k [] o

    assertViewRet []    $ queryByType 0 0 2
    assertViewRet []    $ queryByType 0 2 0
    assertViewRet []    $ queryByType 2 0 0

    assertViewRet g1obj $ queryByType 0 0 0
    assertViewRet g2obj $ queryByType 0 0 1
    assertViewRet g3obj $ queryByType 0 1 0
    assertViewRet g4obj $ queryByType 1 0 0

    assertViewRet (g1obj ++ g2obj) $ queryByGroup 0 0
    assertViewRet g3obj $ queryByGroup 0 1
    assertViewRet g4obj $ queryByGroup 1 0

    assertViewRet [] $ queryByGroup 0 2
    assertViewRet [] $ queryByGroup 2 0