riak-1.2.0.0: tests/Test.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Monad
#if __GLASGOW_HASKELL__ <= 708
import Control.Applicative
#endif
import qualified Data.Map as M
import qualified Data.Riak.Proto as Proto
import qualified Data.Set as S
import Data.List.NonEmpty (NonEmpty(..))
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
import Data.Text (Text)
import Data.Function ((&))
import Control.Concurrent (threadDelay)
import Control.Exception
import Lens.Micro ((^.), (.~))
import qualified Network.Riak as Riak
import Network.Riak.Admin.DSL
import qualified Network.Riak.Basic as B
import qualified Network.Riak.Content as B (binary,RpbContent)
import Network.Riak.Connection (exchange)
import qualified Network.Riak.CRDT as C
import qualified Network.Riak.CRDT.Riak as C
import qualified Network.Riak.Request as Req
import qualified Network.Riak.Response as Resp
import qualified Network.Riak.Search as S
import qualified Network.Riak.JSON as J
import Network.Riak.Resolvable (ResolvableMonoid (..))
import Network.Riak.Types
import qualified Properties
import qualified CRDTProperties as CRDT
import Utils
import Test.Tasty
import Test.Tasty.HUnit
main :: IO ()
main = do
setup
defaultMain tests
setup :: IO ()
setup = do
-- Create a "set-ix" index and wait for it to exist.
let createIxUrl :: String
createIxUrl = globalHost ++ ":" ++ show globalHttpPort ++ "/search/index/set-ix"
shell ("curl -sf -XPUT " ++ createIxUrl ++ " -H 'Content-Type: application/json'")
let loop =
try (shell ("curl -sf " ++ createIxUrl)) >>= \case
Left (_ :: ShellFailure) -> do
threadDelay (1*1000*1000)
loop
Right _ -> pure ()
loop
riakAdminWith globalAdmin
[ waitForService "riak_kv" Nothing
, waitForService "yokozuna" Nothing
, bucketTypeCreate "maps" (Just "'{\"props\":{\"datatype\":\"map\"}}'")
, bucketTypeCreate "sets" (Just "'{\"props\":{\"datatype\":\"set\",\"search_index\":\"set-ix\"}}'")
, bucketTypeCreate "counters" (Just "'{\"props\":{\"datatype\":\"counter\"}}'")
, bucketTypeActivate "maps"
, bucketTypeActivate "sets"
, bucketTypeActivate "counters"
, bucketTypeCreate "untyped-1" Nothing
, bucketTypeCreate "untyped-2" Nothing
, bucketTypeActivate "untyped-1"
, bucketTypeActivate "untyped-2"
]
tests :: TestTree
tests = testGroup "Tests" [properties,
integrationalTests,
ping'o'death,
exceptions,
crdts,
searches,
bucketTypes
]
properties :: TestTree
properties = testGroup "simple properties" Properties.tests
integrationalTests :: TestTree
integrationalTests = testGroup "integrational tests"
[ testClusterSimple
#ifdef TEST2I
, testIndexedPutGet
#endif
]
crdts :: TestTree
crdts = testGroup "CRDT" [
testGroup "simple" [counter, set, map_],
CRDT.tests
]
searches :: TestTree
searches = testGroup "Search" [
search1,
search2,
getIndex,
putIndex,
deleteIndex
]
testClusterSimple :: TestTree
testClusterSimple = testCase "testClusterSimple" $ withGlobalConn B.ping
testIndexedPutGet :: TestTree
testIndexedPutGet = testCase "testIndexedPutGet" $ do
let bt = Nothing
b = "riak-haskell-client-test"
k = "test"
keys <- withGlobalConn $ \c -> do
_ <- J.putIndexed c bt b k [(IndexInt "someindex" 135)] Nothing
(RM (M.fromList [("somekey", "someval")] :: M.Map Text Text))
Default Default
Riak.getByIndex c b (IndexQueryExactInt "someindex" 135)
assertEqual "" ["test"] keys
ping'o'death :: TestTree
ping'o'death = testCase "ping'o'death" $ replicateM_ 23 ping
where ping = withGlobalConn (\c -> replicateM_ 1024 (Riak.ping c))
counter :: TestTree
counter = testCase "increment" $ withGlobalConn $ \conn -> do
Just (C.DTCounter (C.Counter a)) <- act conn
Just (C.DTCounter (C.Counter b)) <- act conn
assertEqual "inc by 1" 1 (b-a)
where
act c = do C.counterSendUpdate c "counters" "xxx" "yyy" [C.CounterInc 1]
C.get c "counters" "xxx" "yyy"
set :: TestTree
set = testCase "set add" $ withGlobalConn $ \conn -> do
C.setSendUpdate conn btype buck key [C.SetRemove val]
C.setSendUpdate conn btype buck key [C.SetAdd val]
Just (C.DTSet (C.Set r)) <- C.get conn btype buck key
assertBool "-foo +foo => contains foo" $ val `S.member` r
where
(btype,buck,key,val) = ("sets","xxx","yyy","foo")
map_ :: TestTree
map_ = testCase "map update" $ withGlobalConn $ \conn -> do
Just (C.DTMap a) <- act conn -- do smth (increment), get
Just (C.DTMap b) <- act conn -- increment, get
assertEqual "map update" (C.modify mapOp a) b -- modify's behaviour should match
assertEqual "mapUpdate sugar" mapOp' mapOp
-- remove top-level field (X)
C.mapSendUpdate conn btype buck key [C.MapRemove fieldX]
Just (C.DTMap c) <- act conn
assertEqual "update after delete" (Just updateCreates) $ C.xlookup "X" C.MapMapTag c
-- remove nested field (X/Y)
C.mapSendUpdate conn btype buck key [C.MapUpdate (C.MapPath $ "X" :| [])
(C.MapMapOp (C.MapRemove fieldY))]
Just (C.DTMap d) <- C.get conn btype buck key
assertEqual "update after nested delete 1" Nothing
$ C.xlookup ("X" C.-/ "Y") C.MapMapTag d
assertEqual "update after nested delete 2" (Just (C.MapMap (C.Map mempty)))
$ C.xlookup "X" C.MapMapTag d
where
act c = do C.mapSendUpdate c btype buck key [mapOp]
C.get c btype buck key
btype = "maps"
fieldX = C.MapField C.MapMapTag "X"
fieldY = C.MapField C.MapMapTag "Y"
(buck,key) = ("xxx","yyy")
updateCreates = C.MapMap (C.Map (M.fromList
[(C.MapField C.MapMapTag "Y",
C.MapMap (C.Map (M.fromList
[(C.MapField C.MapCounterTag "Z",
C.MapCounter (C.Counter 1))])))]))
mapOp = "X" C.-/ "Y" C.-/ "Z" `C.mapUpdate` C.CounterInc 1
mapOp' = C.MapUpdate (C.MapPath ("X" :| "Y" : "Z" : []))
(C.MapCounterOp (C.CounterInc 1))
search1 :: TestTree
search1 = testCase "basic searchRaw" $ withGlobalConn $ \conn -> do
C.sendModify conn btype buck key [C.SetRemove kw]
delay
a <- query conn ("set:" <> kw)
assertEqual "should not found non-existing" (S.SearchResult [] (Just 0.0) (Just 0)) a
C.sendModify conn btype buck key [C.SetAdd kw]
delay
b <- query conn ("set:" <> kw)
assertBool "searches specific" $ not (null (S.docs b))
c <- query conn ("set:*")
assertBool "searches *" $ not (null (S.docs c))
where
query conn q = S.searchRaw conn q "set-ix"
(btype,buck,key) = ("sets","xxx","yyy")
kw = "haskell"
delay = threadDelay (1*5000*1000) -- http://docs.basho.com/riak/2.1.3/dev/using/search/#Indexing-Values
search2 :: TestTree
search2 = testCase "search with fl" $ withGlobalConn $ \conn -> do
let req = (Req.search "set:haskell" "set-ix") & Proto.fl .~ ["_yz_rk"]
resp <- Resp.search <$> exchange conn req
assertEqual "only returns fl"
([[("_yz_rk", Just "yyy")]])
(S.docs resp)
getIndex :: TestTree
getIndex = testCase "getIndex" $ withGlobalConn $ \conn -> do
all' <- S.getIndex conn Nothing
one <- S.getIndex conn (Just "set-ix")
assertBool "all indeces" $ not (null all')
assertEqual "set index" 1 (length one)
putIndex :: TestTree
putIndex = testCase "putIndex" $ withGlobalConn $ \conn -> do
_ <- S.putIndex conn (S.indexInfo "dummy-index" Nothing Nothing) Nothing
threadDelay 5000000
one <- S.getIndex conn (Just "dummy-index")
assertEqual "index was created" 1 (length one)
deleteIndex :: TestTree
deleteIndex = testCase "deleteIndex" $ withGlobalConn $ \conn -> do
S.deleteIndex conn "dummy-index"
threadDelay (5*1000*1000)
_ <- tryJust f (S.getIndex conn (Just "dummy-index"))
pure ()
where
f :: Proto.RpbErrorResp -> Maybe ()
f resp = guard (resp ^. Proto.errmsg == "notfound")
bucketTypes :: TestTree
bucketTypes = testCase "bucketTypes" $ withGlobalConn $ \conn -> do
[p0,p1,p2] <- sequence [ B.put conn bt b k Nothing o Default Default
| bt <- types | o <- [o0,o1,o2] ]
[r0,r1,r2] <- sequence [ B.get conn bt b k Default | bt <- types ]
assertBool "sound get Nothing" (valok r0 o0)
assertBool "sound get untyped-1" (valok r1 o1)
assertBool "sound get untyped-2" (valok r2 o2)
assertEqual "put=get Nothing" (Just p0) r0
assertEqual "put=get untyped-1" (Just p1) r1
assertEqual "put=get untyped-2" (Just p2) r2
where
(b,k) = ("xxx","0") :: (Bucket,Key)
types = [Nothing, Just "untyped-1", Just "untyped-2"] :: [Maybe BucketType]
[o0,o1,o2] = B.binary <$> ["A","B","C"] :: [B.RpbContent]
valok :: Maybe ([B.RpbContent], VClock) -> B.RpbContent -> Bool
valok (Just (rs,_)) o = (o ^. Proto.value) `elem` map (^. Proto.value) rs
valok _ _ = False
exceptions :: TestTree
exceptions = testGroup "exceptions" [
testCase "correct put" . shouldBeOK . withGlobalConn $ put,
testCase "correct put_" . shouldBeOK . withGlobalConn $ put_,
testCase "invalid put" . shouldThrow . withGlobalConn $ putErr,
testCase "invalid put_" . shouldThrow . withGlobalConn $ put_Err
]
where
put = putSome B.put btype
put_ = putSome B.put_ btype
putErr = putSome B.put noBtype
put_Err = putSome B.put_ noBtype
putSome :: (Connection -> Maybe BucketType -> Bucket -> Key
-> Maybe VClock -> B.RpbContent -> Quorum -> Quorum -> IO a)
-> Maybe BucketType -> Connection -> IO a
putSome f bt c = f c bt buck key Nothing val Default Default
shouldBeOK act = act >> assertBool "ok" True
shouldThrow act = catch (act >> assertBool "exception" False) (\(_e::Proto.RpbErrorResp) -> pure ())
btype = Just "untyped-1"
noBtype = Just "no such type"
buck = "xxx"
key = "0"
val = B.binary ""