1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
-- ------------------------------------------------------ --
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module: Main
-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.
-- License: BSD3
-- Maintainer: Lars Kuhtz <lars@alephcloud.com>
-- Stability: experimental
--
-- Tests for Haskell AWS DynamoDb bindings
--
module Main
( main
) where
import Aws
import qualified Aws.DynamoDb as DY
import Control.Arrow (second)
import Control.Error
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import qualified Data.List as L
import qualified Data.Text as T
import qualified Network.HTTP.Client as HTTP
import Test.Tasty
import Test.QuickCheck.Instances ()
import System.Environment
import System.Exit
import Utils
import DynamoDb.Utils
-- -------------------------------------------------------------------------- --
-- Main
main :: IO ()
main = do
args <- getArgs
runMain args $ map (second tail . span (/= '=')) args
where
runMain :: [String] -> [(String,String)] -> IO ()
runMain args _argsMap
| any (`elem` helpArgs) args = defaultMain tests
| "--run-with-aws-credentials" `elem` args =
withArgs (tastyArgs args) . defaultMain $ tests
| otherwise = putStrLn help >> exitFailure
helpArgs = ["--help", "-h"]
mainArgs =
[ "--run-with-aws-credentials"
]
tastyArgs args = flip filter args $ \x -> not
$ any (`L.isPrefixOf` x) mainArgs
help :: String
help = L.intercalate "\n"
[ ""
, "NOTE"
, ""
, "This test suite accesses the AWS account that is associated with"
, "the default credentials from the credential file ~/.aws-keys."
, ""
, "By running the tests in this test-suite costs for usage of AWS"
, "services may incur."
, ""
, "In order to actually execute the tests in this test-suite you must"
, "provide the command line options:"
, ""
, " --run-with-aws-credentials"
, ""
, "When running this test-suite through cabal you may use the following"
, "command:"
, ""
, " cabal test --test-option=--run-with-aws-credentials dynamodb-tests"
, ""
]
tests :: TestTree
tests = testGroup "DynamoDb Tests"
[ test_table
-- , test_message
, test_core
]
-- -------------------------------------------------------------------------- --
-- Table Tests
test_table :: TestTree
test_table = testGroup "Table Tests"
[ eitherTOnceTest1 "CreateDescribeDeleteTable" (prop_createDescribeDeleteTable 10 10)
]
-- |
--
prop_createDescribeDeleteTable
:: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)
-> Int -- ^ write capacity (#writes * itemsize/1KB)
-> T.Text -- ^ table name
-> ExceptT T.Text IO ()
prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do
tTableName <- testData tableName
tryT $ createTestTable tTableName readCapacity writeCapacity
let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName)
flip catchE (\e -> deleteTable >> throwE e) $ do
retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName
deleteTable
-- -------------------------------------------------------------------------- --
-- Test core functionality
test_core :: TestTree
test_core = testGroup "Core Tests"
[ eitherTOnceTest0 "connectionReuse" prop_connectionReuse
]
prop_connectionReuse
:: ExceptT T.Text IO ()
prop_connectionReuse = do
c <- liftIO $ do
cfg <- baseConfiguration
-- counts the number of TCP connections
ref <- newIORef (0 :: Int)
manager <- HTTP.newManager (managerSettings ref)
void $ runExceptT $
flip catchE (error . T.unpack) . replicateM_ 3 $ do
void $ dyT cfg manager DY.ListTables
mustFail . dyT cfg manager $ DY.DescribeTable "____"
readIORef ref
unless (c == 1) $
throwE "The TCP connection has not been reused"
where
managerSettings ref = HTTP.defaultManagerSettings
{ HTTP.managerRawConnection = do
mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings
return $ \a b c -> do
atomicModifyIORef ref $ \i -> (succ i, ())
mkConn a b c
}
|
