summaryrefslogtreecommitdiff
path: root/tests/test-suite.hs
blob: df5e258ff3e9f6c6e680a2285fe13d3c4bc6485b (plain)
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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Applicative
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans
import Data.Function
import Data.Int
import Data.List (find)
import Data.Monoid
import Data.Text (Text)
import Data.Unique
import Data.Word
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V

import Test.HUnit.Lang (HUnitFailure(..))
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.TH
import Test.Tasty.QuickCheck
import qualified Network.HTTP.Client as HC

import Database.InfluxDB
import qualified Database.InfluxDB.Stream as S

prop_fromValue_toValue_identity_Value :: Value -> Bool
prop_fromValue_toValue_identity_Value = fromValueToValueIdentity

prop_fromValue_toValue_identity_Bool :: Bool -> Bool
prop_fromValue_toValue_identity_Bool = fromValueToValueIdentity

prop_fromValue_toValue_identity_Int :: Int -> Bool
prop_fromValue_toValue_identity_Int = fromValueToValueIdentity

prop_fromValue_toValue_identity_Int8 :: Int8 -> Bool
prop_fromValue_toValue_identity_Int8 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Int16 :: Int16 -> Bool
prop_fromValue_toValue_identity_Int16 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Int32 :: Int32 -> Bool
prop_fromValue_toValue_identity_Int32 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Int64 :: Int64 -> Bool
prop_fromValue_toValue_identity_Int64 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Word8 :: Word8 -> Bool
prop_fromValue_toValue_identity_Word8 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Word16 :: Word16 -> Bool
prop_fromValue_toValue_identity_Word16 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Word32 :: Word32 -> Bool
prop_fromValue_toValue_identity_Word32 = fromValueToValueIdentity

prop_fromValue_toValue_identity_Double :: Double -> Bool
prop_fromValue_toValue_identity_Double = fromValueToValueIdentity

prop_fromValue_toValue_identity_Text :: T.Text -> Bool
prop_fromValue_toValue_identity_Text = fromValueToValueIdentity

prop_fromValue_toValue_identity_LazyText :: TL.Text -> Bool
prop_fromValue_toValue_identity_LazyText = fromValueToValueIdentity

prop_fromValue_toValue_identity_String :: String -> Bool
prop_fromValue_toValue_identity_String = fromValueToValueIdentity

prop_fromValue_toValue_identity_Maybe_Int :: Maybe Int -> Bool
prop_fromValue_toValue_identity_Maybe_Int = fromValueToValueIdentity

-------------------------------------------------

instance Arbitrary Value where
  arbitrary = oneof
    [ Int <$> arbitrary
    , Float <$> arbitrary
    , String <$> arbitrary
    , Bool <$> arbitrary
    , pure Null
    ]

instance Arbitrary T.Text where
  arbitrary = T.pack <$> arbitrary

instance Arbitrary TL.Text where
  arbitrary = TL.pack <$> arbitrary

fromValueToValueIdentity :: (Eq a, FromValue a, ToValue a) => a -> Bool
fromValueToValueIdentity a = fromValue (toValue a) == Right a

-------------------------------------------------

case_post :: Assertion
case_post = runTest $ \config ->
  withTestDatabase config $ \database -> do
    name <- liftIO newName
    post config database $
      writeSeries name $ Val 42
    ss <- query config database $ "select value from " <> name
    case ss of
      [series] -> fromSeriesData series @=? Right [Val 42]
      _ -> assertFailure $ "Expect one series, but got: " ++ show ss

case_post_multi_series :: Assertion
case_post_multi_series = runTest $ \config ->
  withTestDatabase config $ \database -> do
    name <- liftIO newName
    post config database $ do
      writeSeries name $ Val 42
      writeSeries name $ Val 42
      writeSeries name $ Val 42
    ss <- query config database $ "select value from " <> name
    case ss of
      [series] -> fromSeriesData series @=? Right [Val 42, Val 42, Val 42]
      _ -> assertFailure $ "Expect one series, but got: " ++ show ss

case_post_multi_points :: Assertion
case_post_multi_points = runTest $ \config ->
  withTestDatabase config $ \database -> do
    name <- liftIO newName
    post config database $ withSeries name $ do
      writePoints $ Val 42
      writePoints $ Val 42
      writePoints $ Val 42
    ss <- query config database $ "select value from " <> name
    case ss of
      [series] -> fromSeriesData series @=? Right [Val 42, Val 42, Val 42]
      _ -> assertFailure $ "Expect one series, but got: " ++ show ss

case_queryChunked :: Assertion
case_queryChunked = runTest $ \config ->
  withTestDatabase config $ \database -> do
    name <- liftIO newName
    post config database $ withSeries name $ do
      writePoints $ Val 42
      writePoints $ Val 42
      writePoints $ Val 42
    ss <- queryChunked config database ("select value from " <> name) $
      S.fold step []
    mapM fromSeriesData ss @=? Right [[Val 42], [Val 42], [Val 42]]
  where
    step xs series = case fromSeriesData series of
      Left reason -> throwIO $ HUnitFailure reason
      Right values -> return $ xs ++ values

case_post_with_precision :: Assertion
case_post_with_precision = runTest $ \config ->
  withTestDatabase config $ \database -> do
    name <- liftIO newName
    postWithPrecision config database SecondsPrecision $
      writeSeries name $ Val 42
    ss <- query config database $ "select value from " <> name
    case ss of
      [series] -> fromSeriesData series @=? Right [Val 42]
      _ -> assertFailure $ "Expect one series, but got: " ++ show ss

case_listDatabases :: Assertion
case_listDatabases = runTest $ \config ->
  withTestDatabase config $ \name -> do
    databases <- listDatabases config
    assertBool ("No such database: " ++ T.unpack name) $
      any ((name ==) . databaseName) databases

case_create_then_drop_database :: Assertion
case_create_then_drop_database = runTest $ \config -> do
  name <- newName
  dropDatabaseIfExists config name
  createDatabase config name
  listDatabases config >>= \databases ->
    assertBool ("No such database: " ++ T.unpack name) $
      any ((name ==) . databaseName) databases
  dropDatabase config name
  listDatabases config >>= \databases ->
    assertBool ("Found a dropped database: " ++ T.unpack name) $
      all ((name /=) . databaseName) databases

case_list_cluster_admins :: Assertion
case_list_cluster_admins = runTest $ \config -> do
  admins <- listClusterAdmins config
  assertBool "No root admin" $
    any (("root" ==) . adminUsername) admins

case_add_then_delete_cluster_admin :: Assertion
case_add_then_delete_cluster_admin = runTest $ \config -> do
  name <- newName
  admin <- addClusterAdmin config name "somePassword"
  listClusterAdmins config >>= \admins ->
    assertBool ("No such admin: " ++ T.unpack name) $
      any ((name ==) . adminUsername) admins
  deleteClusterAdmin config admin
  listClusterAdmins config >>= \admins ->
    assertBool ("Found a deleted admin: " ++ T.unpack name) $
      all ((name /=) . adminUsername) admins

case_update_cluster_admin_password :: Assertion
case_update_cluster_admin_password = runTest $ \config -> do
  let curPassword = "somePassword"
      newPassword = "otherPassword"
  name <- newName
  deleteClusterAdminIfExists config name
  admin <- addClusterAdmin config name curPassword
  updateClusterAdminPassword config admin newPassword
  let newCreds = Credentials name newPassword
      newConfig = config { configCreds = newCreds }
  name <- newName
  dropDatabaseIfExists config name
  createDatabase newConfig name
  listDatabases newConfig >>= \databases ->
    assertBool ("No such database: " ++ T.unpack name) $
      any ((name ==) . databaseName) databases
  dropDatabase newConfig name
  listDatabases newConfig >>= \databases ->
    assertBool ("Found a dropped database: " ++ T.unpack name) $
      all ((name /=) . databaseName) databases

case_add_then_delete_database_users :: Assertion
case_add_then_delete_database_users = runTest $ \config ->
  withTestDatabase config $ \name -> do
    listDatabaseUsers config name >>= \users ->
      assertBool "There shouldn't be any users" $ null users
    newUserName <- newName
    addDatabaseUser config name newUserName "somePassword"
    listDatabaseUsers config name >>= \users ->
      assertBool ("No such user: " <> T.unpack newUserName) $
        any ((newUserName ==) . userName) users
    deleteDatabaseUser config name newUserName
    listDatabaseUsers config name >>= \users ->
      assertBool ("Found a deleted user: " <> T.unpack newUserName) $
        all ((newUserName /=) . userName) users

case_update_database_user_password :: Assertion
case_update_database_user_password = runTest $ \config ->
  withTestDatabase config $ \name -> do
    newUserName <- newName
    addDatabaseUser config name newUserName "somePassword"
    listDatabaseUsers config name >>= \users ->
      assertBool ("No such user: " <> T.unpack newUserName) $
        any ((newUserName ==) . userName) users
    updateDatabaseUserPassword config name newUserName "otherPassword"
    deleteDatabaseUser config name newUserName

case_grant_revoke_database_user :: Assertion
case_grant_revoke_database_user = runTest $ \config ->
  withTestDatabase config $ \name -> do
    newUserName <- newName
    addDatabaseUser config name newUserName "somePassword"
    listDatabaseUsers config name >>= \users ->
      assertBool ("No such user: " <> T.unpack newUserName) $
        any ((newUserName ==) . userName) users
    grantAdminPrivilegeTo config name newUserName
    listDatabaseUsers config name >>= \users ->
      case find ((newUserName ==) . userName) users of
        Nothing -> assertFailure $ "No such user: " <> T.unpack newUserName
        Just user -> assertBool
          ("User is not privileged: " <> T.unpack newUserName)
          (userIsAdmin user)
    revokeAdminPrivilegeFrom config name newUserName
    listDatabaseUsers config name >>= \users ->
      case find ((newUserName ==) . userName) users of
        Nothing -> assertFailure $ "No such user: " <> T.unpack newUserName
        Just user -> assertBool
          ("User is still privileged: " <> T.unpack newUserName)
          (not $ userIsAdmin user)
    deleteDatabaseUser config name newUserName

-------------------------------------------------

data Val = Val Int deriving (Eq, Show)

instance ToSeriesData Val where
  toSeriesColumns _ = V.fromList ["value"]
  toSeriesPoints (Val n) = V.fromList [toValue n]

instance FromSeriesData Val where
  parseSeriesData = withValues $ \values -> Val <$> values .: "value"

-------------------------------------------------

dropDatabaseIfExists :: Config -> Text -> IO ()
dropDatabaseIfExists config name =
  dropDatabase config name
    `catchAll` \_ -> return ()

deleteClusterAdminIfExists :: Config -> Text -> IO ()
deleteClusterAdminIfExists config name =
  deleteClusterAdmin config (Admin name)
    `catchAll` \_ -> return ()

-------------------------------------------------

runTest :: (Config -> IO a) -> IO a
runTest f = do
  pool <- newServerPool localServer []
  HC.withManager settings (f . Config rootCreds pool)
  where
    settings = HC.defaultManagerSettings

newName :: IO Text
newName = do
  uniq <- newUnique
  return $ T.pack $ "test_" ++ show (hashUnique uniq)

withTestDatabase :: Config -> (Text -> IO a) -> IO a
withTestDatabase config = bracket acquire release
  where
    acquire = do
      name <- newName
      dropDatabaseIfExists config name
      createDatabase config name
      return name
    release = dropDatabase config

catchAll :: IO a -> (SomeException -> IO a) -> IO a
catchAll = E.catch

-------------------------------------------------

main :: IO ()
main = $defaultMainGenerator