influxdb 0.0.0 → 0.1.0
raw patch · 8 files changed
+386/−134 lines, 8 filesdep +tastydep +tasty-hunitdep +tasty-thdep ~aesondep ~base
Dependencies added: tasty, tasty-hunit, tasty-th
Dependency ranges changed: aeson, base
Files
- examples/random-points.hs +11/−8
- influxdb.cabal +20/−2
- src/Database/InfluxDB/Decode.hs +3/−4
- src/Database/InfluxDB/Encode.hs +1/−2
- src/Database/InfluxDB/Http.hs +82/−101
- src/Database/InfluxDB/Types.hs +23/−11
- src/Database/InfluxDB/Types/Internal.hs +20/−6
- tests/test-suite.hs +226/−0
examples/random-points.hs view
@@ -28,16 +28,18 @@ main = do [read -> (numPoints :: Int), read -> (batches :: Int)] <- getArgs hSetBuffering stdout NoBuffering- config <- newConfig HC.withManager managerSettings $ \manager -> do- dropDatabase config manager (Database "ctx" Nothing)+ config <- newConfig manager++ let db = "ctx"+ dropDatabase config db `E.catch` -- Ignore exceptions here \(_ :: HC.HttpException) -> return ()- db <- createDatabase config manager "ctx"+ createDatabase config "ctx" gen <- MWC.create flip fix batches $ \outerLoop !m -> when (m > 0) $ do- postWithPrecision config manager db SecondsPrecision $ withSeries "ct1" $+ postWithPrecision config db SecondsPrecision $ withSeries "ct1" $ flip fix numPoints $ \innerLoop !n -> when (n > 0) $ do !timestamp <- liftIO $ (-) <$> getPOSIXTime@@ -47,14 +49,14 @@ innerLoop $ n - 1 outerLoop $ m - 1 - result <- query config manager db "select count(value) from ct1;"+ result <- query config db "select count(value) from ct1;" case result of [] -> putStrLn "Empty series" series:_ -> do print $ seriesColumns series print $ seriesPoints series -- Streaming output- queryChunked config manager db "select * from ct1;" $ \stream0 ->+ queryChunked config db "select * from ct1;" $ \stream0 -> flip fix stream0 $ \loop stream -> case stream of Done -> return () Yield series next -> do@@ -65,12 +67,13 @@ stream' <- next loop stream' -newConfig :: IO Config-newConfig = do+newConfig :: HC.Manager -> IO Config+newConfig manager = do pool <- newServerPool localServer [] -- no backup servers return Config { configCreds = rootCreds , configServerPool = pool+ , configHttpManager = manager } managerSettings :: HC.ManagerSettings
influxdb.cabal view
@@ -1,5 +1,5 @@ name: influxdb-version: 0.0.0+version: 0.1.0 synopsis: Haskell client library for InfluxDB description: Haskell client library for InfluxDB homepage: https://github.com/maoe/influxdb-haskell@@ -13,7 +13,9 @@ cabal-version: >= 1.10 flag examples+ description: Build examples default: False+ manual: True library exposed-modules:@@ -31,7 +33,7 @@ ghc-options: -Wall build-depends: base >= 4 && < 4.8- , aeson >= 0.7+ , aeson >= 0.6.1.0 , attoparsec , bytestring , containers@@ -48,6 +50,22 @@ , time , vector hs-source-dirs: src+ default-language: Haskell2010++test-suite test-suite+ type: exitcode-stdio-1.0+ main-is: test-suite.hs+ build-depends:+ base+ , http-client+ , influxdb+ , mtl+ , tasty+ , tasty-hunit+ , tasty-th+ , text+ , vector+ hs-source-dirs: tests default-language: Haskell2010 executable influx-random-points
src/Database/InfluxDB/Decode.hs view
@@ -12,7 +12,6 @@ import Data.Map (Map) import Data.Vector (Vector) import Data.Tuple (swap)-import qualified Data.DList as DL import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Vector as V@@ -43,7 +42,7 @@ -- > data EventType = Login | Logout -- > -- > instance FromSeriesData where--- > parseSeriesData = withValues $ values -> Event+-- > parseSeriesData = withValues $ \values -> Event -- > <$> values .: "user" -- > <*> values .: "type" -- >@@ -54,14 +53,14 @@ instance FromSeriesData SeriesData where parseSeriesData columns values = return SeriesData { seriesDataColumns = columns- , seriesDataPoints = DL.singleton values+ , seriesDataPoints = [values] } -- | Converte a value from a @SeriesData@, failing if the types do not match. fromSeriesData :: FromSeriesData a => SeriesData -> Either String [a] fromSeriesData SeriesData {..} = mapM (runParser . parseSeriesData seriesDataColumns)- (DL.toList seriesDataPoints)+ seriesDataPoints withValues :: (Vector Value -> ValueParser a)
src/Database/InfluxDB/Encode.hs view
@@ -10,7 +10,6 @@ import Data.Proxy import Data.Vector (Vector) import Data.Word (Word8, Word16, Word32)-import qualified Data.DList as DL import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -42,7 +41,7 @@ toSeriesData :: forall a. ToSeriesData a => a -> SeriesData toSeriesData a = SeriesData { seriesDataColumns = toSeriesColumns (Proxy :: Proxy a)- , seriesDataPoints = DL.singleton (toSeriesPoints a)+ , seriesDataPoints = [toSeriesPoints a] } -- | A type that can be stored in InfluxDB.
src/Database/InfluxDB/Http.hs view
@@ -86,7 +86,8 @@ -- | Configurations for HTTP API client. data Config = Config { configCreds :: !Credentials- , configServerPool :: IORef ServerPool+ , configServerPool :: !(IORef ServerPool)+ , configHttpManager :: !HC.Manager } -- | Default credentials.@@ -120,35 +121,34 @@ -- | Post a bunch of writes for (possibly multiple) series into a database. post :: Config- -> HC.Manager- -> Database+ -> Text -> SeriesT IO a -> IO a-post config manager database =- postGeneric config manager database Nothing+post config databaseName =+ postGeneric config databaseName Nothing -- | Post a bunch of writes for (possibly multiple) series into a database like -- @post@ but with time precision. postWithPrecision :: Config- -> HC.Manager- -> Database+ -> Text -- ^ Database name -> TimePrecision -> SeriesT IO a -> IO a-postWithPrecision config manager database timePrec =- postGeneric config manager database (Just timePrec)+postWithPrecision config databaseName timePrec =+ postGeneric config databaseName (Just timePrec) postGeneric :: Config- -> HC.Manager- -> Database+ -> Text -- ^ Database name -> Maybe TimePrecision -> SeriesT IO a -> IO a-postGeneric Config {..} manager database timePrec write = do+postGeneric Config {..} databaseName timePrec write = do (a, series) <- runSeriesT write- void $ httpLbsWithRetry configServerPool (makeRequest series) manager+ void $ httpLbsWithRetry configServerPool+ (makeRequest series)+ configHttpManager return a where makeRequest series = def@@ -164,7 +164,6 @@ (printf "&time_precision=%c" . timePrecChar) timePrec :: String) }- Database {databaseName} = database Credentials {..} = configCreds -- | Monad transformer to batch up multiple writes of series to speed up@@ -215,7 +214,7 @@ { seriesName = name , seriesData = SeriesData { seriesDataColumns = toSeriesColumns (Proxy :: Proxy a)- , seriesDataPoints = values+ , seriesDataPoints = DL.toList values } } @@ -268,12 +267,11 @@ query :: FromSeries a => Config- -> HC.Manager- -> Database+ -> Text -- ^ Database name -> Text -- ^ Query text -> IO [a]-query Config {..} manager database q = do- response <- httpLbsWithRetry configServerPool request manager+query Config {..} databaseName q = do+ response <- httpLbsWithRetry configServerPool request configHttpManager case A.decode (HC.responseBody response) of Nothing -> fail $ show response Just xs -> case mapM fromSeries xs of@@ -288,7 +286,6 @@ (T.unpack credsPassword) (T.unpack q) }- Database {databaseName} = database Credentials {..} = configCreds -- | Construct streaming output@@ -312,15 +309,14 @@ queryChunked :: FromSeries a => Config- -> HC.Manager- -> Database+ -> Text -- ^ Database name -> Text -- ^ Query text -> (Stream IO a -> IO b) -- ^ Action to handle the resulting stream of series -> IO b-queryChunked Config {..} manager database q f =+queryChunked Config {..} databaseName q f = withPool configServerPool request $ \request' ->- HC.withResponse request' manager $+ HC.withResponse request' configHttpManager $ responseStream . HC.responseBody >=> S.mapM parse >=> f where parse series = case fromSeries series of@@ -334,16 +330,15 @@ (T.unpack credsPassword) (T.unpack q) }- Database {databaseName} = database Credentials {..} = configCreds ----------------------------------------------------------- -- Administration & Security -- | List existing databases.-listDatabases :: Config -> HC.Manager -> IO [Database]-listDatabases Config {..} manager = do- response <- httpLbsWithRetry configServerPool makeRequest manager+listDatabases :: Config -> IO [Database]+listDatabases Config {..} = do+ response <- httpLbsWithRetry configServerPool makeRequest configHttpManager case A.decode (HC.responseBody response) of Nothing -> fail $ show response Just xs -> return xs@@ -357,13 +352,9 @@ Credentials {..} = configCreds -- | Create a new database. Requires cluster admin privileges.-createDatabase :: Config -> HC.Manager -> Text -> IO Database-createDatabase Config {..} manager name = do- void $ httpLbsWithRetry configServerPool makeRequest manager- return Database- { databaseName = name- , databaseReplicationFactor = Nothing- }+createDatabase :: Config -> Text -> IO ()+createDatabase Config {..} name =+ void $ httpLbsWithRetry configServerPool makeRequest configHttpManager where makeRequest = def { HC.method = "POST"@@ -378,9 +369,12 @@ Credentials {..} = configCreds -- | Drop a database. Requires cluster admin privileges.-dropDatabase :: Config -> HC.Manager -> Database -> IO ()-dropDatabase Config {..} manager database =- void $ httpLbsWithRetry configServerPool makeRequest manager+dropDatabase+ :: Config+ -> Text -- ^ Database name+ -> IO ()+dropDatabase Config {..} databaseName =+ void $ httpLbsWithRetry configServerPool makeRequest configHttpManager where makeRequest = def { HC.method = "DELETE"@@ -390,16 +384,12 @@ (T.unpack credsUser) (T.unpack credsPassword) }- Database {databaseName} = database Credentials {..} = configCreds -- | List cluster administrators.-listClusterAdmins- :: Config- -> HC.Manager- -> IO [Admin]-listClusterAdmins Config {..} manager = do- response <- httpLbsWithRetry configServerPool makeRequest manager+listClusterAdmins :: Config -> IO [Admin]+listClusterAdmins Config {..} = do+ response <- httpLbsWithRetry configServerPool makeRequest configHttpManager case A.decode (HC.responseBody response) of Nothing -> fail $ show response Just xs -> return xs@@ -415,18 +405,20 @@ -- | Add a new cluster administrator. Requires cluster admin privilege. addClusterAdmin :: Config- -> HC.Manager- -> Text+ -> Text -- ^ Admin name+ -> Text -- ^ Password -> IO Admin-addClusterAdmin Config {..} manager name = do- void $ httpLbsWithRetry configServerPool makeRequest manager+addClusterAdmin Config {..} name password = do+ void $ httpLbsWithRetry configServerPool makeRequest configHttpManager return Admin { adminUsername = name } where makeRequest = def- { HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object+ { HC.method = "POST"+ , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "name" .= name+ , "password" .= password ] , HC.path = "/cluster_admins" , HC.queryString = escapeString $ printf "u=%s&p=%s"@@ -439,12 +431,11 @@ -- privilege. updateClusterAdminPassword :: Config- -> HC.Manager -> Admin- -> Text+ -> Text -- ^ New password -> IO ()-updateClusterAdminPassword Config {..} manager admin password =- void $ httpLbsWithRetry configServerPool makeRequest manager+updateClusterAdminPassword Config {..} admin password =+ void $ httpLbsWithRetry configServerPool makeRequest configHttpManager where makeRequest = def { HC.method = "POST"@@ -463,11 +454,10 @@ -- | Delete a cluster administrator. Requires cluster admin privilege. deleteClusterAdmin :: Config- -> HC.Manager -> Admin -> IO ()-deleteClusterAdmin Config {..} manager admin =- void $ httpLbsWithRetry configServerPool makeRequest manager+deleteClusterAdmin Config {..} admin =+ void $ httpLbsWithRetry configServerPool makeRequest configHttpManager where makeRequest = def { HC.method = "DELETE"@@ -483,11 +473,10 @@ -- | List database users. listDatabaseUsers :: Config- -> HC.Manager -> Text -> IO [User]-listDatabaseUsers Config {..} manager database = do- response <- httpLbsWithRetry configServerPool makeRequest manager+listDatabaseUsers Config {..} database = do+ response <- httpLbsWithRetry configServerPool makeRequest configHttpManager case A.decode (HC.responseBody response) of Nothing -> fail $ show response Just xs -> return xs@@ -504,19 +493,18 @@ -- | Add an user to the database users. addDatabaseUser :: Config- -> HC.Manager- -> Database- -> Text- -> IO User-addDatabaseUser Config {..} manager database name = do- void $ httpLbsWithRetry configServerPool makeRequest manager- return User- { userName = name- }+ -> Text -- ^ Database name+ -> Text -- ^ User name+ -> Text -- ^ Password+ -> IO ()+addDatabaseUser Config {..} databaseName name password =+ void $ httpLbsWithRetry configServerPool makeRequest configHttpManager where makeRequest = def- { HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object+ { HC.method = "POST"+ , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "name" .= name+ , "password" .= password ] , HC.path = escapeString $ printf "/db/%s/users" (T.unpack databaseName)@@ -524,35 +512,32 @@ (T.unpack credsUser) (T.unpack credsPassword) }- Database {databaseName} = database Credentials {..} = configCreds -- | Delete an user from the database users. deleteDatabaseUser :: Config- -> HC.Manager- -> Database- -> User+ -> Text -- ^ Database name+ -> Text -- ^ User name -> IO ()-deleteDatabaseUser config manager database user =- void $ httpLbsWithRetry (configServerPool config) request manager+deleteDatabaseUser config@Config {..} databaseName userName =+ void $ httpLbsWithRetry configServerPool request configHttpManager where- request = (makeRequestFromDatabaseUser config database user)+ request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "DELETE" } -- | Update password for the database user. updateDatabaseUserPassword :: Config- -> HC.Manager- -> Database- -> User- -> Text+ -> Text -- ^ Database name+ -> Text -- ^ User name+ -> Text -- ^ New password -> IO ()-updateDatabaseUserPassword config manager database user password =- void $ httpLbsWithRetry (configServerPool config) request manager+updateDatabaseUserPassword config@Config {..} databaseName userName password =+ void $ httpLbsWithRetry configServerPool request configHttpManager where- request = (makeRequestFromDatabaseUser config database user)+ request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "POST" , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "password" .= password@@ -562,14 +547,13 @@ -- | Give admin privilege to the user. grantAdminPrivilegeTo :: Config- -> HC.Manager- -> Database- -> User+ -> Text -- ^ Database name+ -> Text -- ^ User name -> IO ()-grantAdminPrivilegeTo config manager database user =- void $ httpLbsWithRetry (configServerPool config) request manager+grantAdminPrivilegeTo config@Config {..} databaseName userName =+ void $ httpLbsWithRetry configServerPool request configHttpManager where- request = (makeRequestFromDatabaseUser config database user)+ request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "POST" , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "admin" .= True@@ -579,14 +563,13 @@ -- | Remove admin privilege from the user. revokeAdminPrivilegeFrom :: Config- -> HC.Manager- -> Database- -> User+ -> Text -- ^ Database name+ -> Text -- ^ User name -> IO ()-revokeAdminPrivilegeFrom config manager database user =- void $ httpLbsWithRetry (configServerPool config) request manager+revokeAdminPrivilegeFrom config@Config {..} databaseName userName =+ void $ httpLbsWithRetry configServerPool request configHttpManager where- request = (makeRequestFromDatabaseUser config database user)+ request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "POST" , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "admin" .= False@@ -595,10 +578,10 @@ makeRequestFromDatabaseUser :: Config- -> Database- -> User+ -> Text -- ^ Database name+ -> Text -- ^ User name -> HC.Request-makeRequestFromDatabaseUser Config {..} database user = def+makeRequestFromDatabaseUser Config {..} databaseName userName = def { HC.path = escapeString $ printf "/db/%s/users/%s" (T.unpack databaseName) (T.unpack userName)@@ -607,8 +590,6 @@ (T.unpack credsPassword) } where- Database {databaseName} = database- User {userName} = user Credentials {..} = configCreds -----------------------------------------------------------
src/Database/InfluxDB/Types.hs view
@@ -29,7 +29,6 @@ ) where import Control.Applicative (empty)-import Data.DList (DList) import Data.Data (Data) import Data.IORef import Data.Int (Int64)@@ -37,16 +36,20 @@ import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vector (Vector)-import qualified Data.DList as DL import qualified Data.Sequence as Seq import Data.Aeson ((.=), (.:)) import Data.Aeson.TH-import Data.Scientific import qualified Data.Aeson as A import Database.InfluxDB.Types.Internal (stripPrefixOptions) +#if MIN_VERSION_aeson(0, 7, 0)+import Data.Scientific+#else+import Data.Attoparsec.Number+#endif+ ----------------------------------------------------------- -- Compatibility for older GHC @@ -76,14 +79,14 @@ seriesColumns = seriesDataColumns . seriesData -- | Convenient accessor for points.-seriesPoints :: Series -> DList (Vector Value)+seriesPoints :: Series -> [Vector Value] seriesPoints = seriesDataPoints . seriesData instance A.ToJSON Series where toJSON Series {..} = A.object [ "name" .= seriesName , "columns" .= seriesDataColumns- , "points" .= DL.toList seriesDataPoints+ , "points" .= seriesDataPoints ] where SeriesData {..} = seriesData@@ -97,7 +100,7 @@ { seriesName = name , seriesData = SeriesData { seriesDataColumns = columns- , seriesDataPoints = DL.fromList points+ , seriesDataPoints = points } } parseJSON _ = empty@@ -105,7 +108,7 @@ -- | @SeriesData@ consists of columns and points. data SeriesData = SeriesData { seriesDataColumns :: Vector Column- , seriesDataPoints :: DList (Vector Value)+ , seriesDataPoints :: [Vector Value] } type Column = Text@@ -132,9 +135,17 @@ parseJSON (A.String xs) = return $ String xs parseJSON (A.Bool b) = return $ Bool b parseJSON A.Null = return Null- parseJSON (A.Number n) = return $! if base10Exponent n == 0- then Int $ fromIntegral $ coefficient n- else Float $ realToFrac n+ parseJSON (A.Number n) = return $! numberToValue+ where+#if MIN_VERSION_aeson(0, 7, 0)+ numberToValue+ | base10Exponent n == 0 = Int $ fromIntegral $ coefficient n+ | otherwise = Float $ realToFrac n+#else+ numberToValue = case n of+ I i -> Int $ fromIntegral i+ D d -> Float d+#endif ----------------------------------------------------------- @@ -173,8 +184,9 @@ } deriving Show -- | User-newtype User = User+data User = User { userName :: Text+ , userIsAdmin :: Bool } deriving Show -- | Administrator
src/Database/InfluxDB/Types/Internal.hs view
@@ -1,15 +1,29 @@+{-# LANGUAGE CPP #-} module Database.InfluxDB.Types.Internal ( stripPrefixOptions ) where import Data.Char (toLower) -import Data.Aeson.TH+-------------------------------------------------+-- Conditional imports +#if MIN_VERSION_aeson(0, 6, 2)+import Data.Aeson.TH (Options(..), defaultOptions)+#endif++-------------------------------------------------++#if MIN_VERSION_aeson(0, 6, 2) stripPrefixOptions :: String -> Options stripPrefixOptions name = defaultOptions- { fieldLabelModifier = modifier+ { fieldLabelModifier = stripPrefix name }- where- modifier xs = case drop (length name) xs of- [] -> error "Insufficient length of field name"- c:cs -> toLower c:cs+#else+stripPrefixOptions :: String -> String -> String+stripPrefixOptions = stripPrefix+#endif++stripPrefix :: String -> String -> String+stripPrefix prefix xs = case drop (length prefix) xs of+ [] -> error "Insufficient length of field name"+ c:cs -> toLower c : cs
+ tests/test-suite.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+import Control.Applicative+import Control.Exception as E+import Control.Monad+import Control.Monad.Trans+import Data.Function+import Data.List (find)+import Data.Monoid+import Data.Text (Text)+import Data.Unique+import qualified Data.Text as T+import qualified Data.Vector as V++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Network.HTTP.Client as HC++import Database.InfluxDB++main :: IO ()+main = $defaultMainGenerator++case_post :: Assertion+case_post = runTest $ \config ->+ withTestDatabase config $ \database -> do+ name <- liftIO newName+ post config database $+ writeSeries name $ Val 42+ [series] <- query config database $+ "select value from " <> name+ fromSeriesData series @=? Right [Val 42]++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+ [series] <- query config database $+ "select value from " <> name+ fromSeriesData series @=? Right [Val 42, Val 42, Val 42]++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+ [series] <- query config database $+ "select value from " <> name+ fromSeriesData series @=? Right [Val 42, Val 42, Val 42]++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+ [series] <- query config database $+ "select value from " <> name+ fromSeriesData series @=? Right [Val 42]++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+ databases <- listDatabases config+ assertBool ("No such database: " ++ T.unpack name) $+ any ((name ==) . databaseName) databases+ dropDatabase config name+ databases' <- listDatabases config+ 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"+ admins <- listClusterAdmins config+ assertBool ("No such admin: " ++ T.unpack name) $+ any ((name ==) . adminUsername) admins+ deleteClusterAdmin config admin+ admins' <- listClusterAdmins config+ 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+ databases <- listDatabases newConfig+ assertBool ("No such database: " ++ T.unpack name) $+ any ((name ==) . databaseName) databases+ dropDatabase newConfig name+ databases' <- listDatabases newConfig+ 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 -> do+ 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 -> do+ 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