diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## v0.2.2 - 2014-05-08 + +* Support for retry-0.4 +* Add deleteSeries +* Add authenticateClusterAdmin and authenticateDatabaseUser + ## v0.2.1.1 - 2014-04-22 * Bug fix: Treat as integer if base10Exponent is positive diff --git a/influxdb.cabal b/influxdb.cabal --- a/influxdb.cabal +++ b/influxdb.cabal @@ -1,5 +1,5 @@ name: influxdb -version: 0.2.1.1 +version: 0.2.2 synopsis: Haskell client library for InfluxDB description: Haskell client library for InfluxDB homepage: https://github.com/maoe/influxdb-haskell @@ -21,10 +21,16 @@ default: False manual: True -flag aeson070 - default: False +flag aeson-070 + description: Use aeson >= 0.7.0 + default: True manual: False +flag retry-040 + description: Use retry >= 0.4, which depends on exceptions + default: True + manual: False + library exposed-modules: Database.InfluxDB @@ -39,6 +45,21 @@ Database.InfluxDB.TH other-modules: Database.InfluxDB.Types.Internal + other-extensions: + BangPatterns + CPP + ConstraintKinds + DeriveDataTypeable + FlexibleInstances + GeneralizedNewtypeDeriving + NamedFieldPuns + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TypeSynonymInstances + ViewPatterns ghc-options: -Wall build-depends: base >= 4 && < 4.8 @@ -48,17 +69,15 @@ , data-default-class , dlist , http-client - , lifted-base , mtl , network - , retry , tagged , template-haskell , text , time , vector - if flag(aeson070) + if flag(aeson-070) build-depends: aeson >= 0.7.0 , scientific >= 0.2 @@ -66,6 +85,15 @@ build-depends: aeson >= 0.6.1.0 && < 0.7.0 + if flag(retry-040) + build-depends: + exceptions == 0.5.* + , retry >= 0.4 + else + build-depends: + lifted-base + , retry < 0.4 + hs-source-dirs: src default-language: Haskell2010 @@ -113,5 +141,5 @@ source-repository this type: git - tag: v0.2.1.1 + tag: v0.2.2 location: https://github.com/maoe/influxdb-haskell.git diff --git a/src/Database/InfluxDB.hs b/src/Database/InfluxDB.hs --- a/src/Database/InfluxDB.hs +++ b/src/Database/InfluxDB.hs @@ -38,8 +38,8 @@ , writePoints -- *** Deleting Points - -- **** One Time Deletes (not implemented) - -- , deleteSeries + -- **** One Time Deletes + , deleteSeries -- **** Regularly Scheduled Deletes (not implemented) -- , getScheduledDeletes -- , addScheduledDelete @@ -59,11 +59,13 @@ -- *** Security -- **** Cluster admin , listClusterAdmins + , authenticateClusterAdmin , addClusterAdmin , updateClusterAdminPassword , deleteClusterAdmin -- **** Database user , listDatabaseUsers + , authenticateDatabaseUser , addDatabaseUser , updateDatabaseUserPassword , deleteDatabaseUser diff --git a/src/Database/InfluxDB/Http.hs b/src/Database/InfluxDB/Http.hs --- a/src/Database/InfluxDB/Http.hs +++ b/src/Database/InfluxDB/Http.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,8 +20,8 @@ , writePoints -- ** Deleting Points - -- *** One Time Deletes (not implemented) - -- , deleteSeries + -- *** One Time Deletes + , deleteSeries -- *** Regularly Scheduled Deletes (not implemented) -- , getScheduledDeletes -- , addScheduledDelete @@ -40,11 +41,13 @@ -- ** Security -- *** Cluster admin , listClusterAdmins + , authenticateClusterAdmin , addClusterAdmin , updateClusterAdminPassword , deleteClusterAdmin -- *** Database user , listDatabaseUsers + , authenticateDatabaseUser , addDatabaseUser , updateDatabaseUserPassword , deleteDatabaseUser @@ -68,7 +71,6 @@ import qualified Data.DList as DL import qualified Data.Text as T -import Control.Exception.Lifted (Handler(..)) import Control.Retry import Data.Aeson ((.=)) import Data.Default.Class (Default(def)) @@ -83,6 +85,12 @@ import Database.InfluxDB.Stream (Stream(..)) import qualified Database.InfluxDB.Stream as S +#if MIN_VERSION_retry(0, 4, 0) +import Control.Monad.Catch (Handler(..)) +#else +import Control.Exception.Lifted (Handler(..)) +#endif + -- | Configurations for HTTP API client. data Config = Config { configCreds :: !Credentials @@ -225,16 +233,27 @@ -> PointT a m () writePoints = tell . DL.singleton . toSeriesPoints +deleteSeries + :: Config + -> Text -- ^ Database name + -> Text -- ^ Series name + -> IO () +deleteSeries Config {..} databaseName seriesName = + void $ httpLbsWithRetry configServerPool makeRequest configHttpManager + where + makeRequest = def + { HC.method = "DELETE" + , HC.path = escapeString $ printf "/db/%s/series/%s" + (T.unpack databaseName) + (T.unpack seriesName) + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds + -- TODO: Delete API hasn't been implemented in InfluxDB yet -- --- deleteSeries --- :: Config --- -> HC.Manager --- -> Series --- -> IO () --- deleteSeries Config {..} manager = --- error "deleteSeries: not implemented" --- -- getScheduledDeletes -- :: Config -- -> HC.Manager @@ -402,6 +421,18 @@ } Credentials {..} = configCreds +authenticateClusterAdmin :: Config -> IO () +authenticateClusterAdmin Config {..} = + void $ httpLbsWithRetry configServerPool makeRequest configHttpManager + where + makeRequest = def + { HC.path = "/cluster_admins/authenticate" + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds + -- | Add a new cluster administrator. Requires cluster admin privilege. addClusterAdmin :: Config @@ -483,6 +514,22 @@ where makeRequest = def { HC.path = escapeString $ printf "/db/%s/users" + (T.unpack database) + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds + +authenticateDatabaseUser + :: Config + -> Text -- ^ Database name + -> IO () +authenticateDatabaseUser Config {..} database = + void $ httpLbsWithRetry configServerPool makeRequest configHttpManager + where + makeRequest = def + { HC.path = escapeString $ printf "/db/%s/authenticate" (T.unpack database) , HC.queryString = escapeString $ printf "u=%s&p=%s" (T.unpack credsUser) diff --git a/src/Database/InfluxDB/Types.hs b/src/Database/InfluxDB/Types.hs --- a/src/Database/InfluxDB/Types.hs +++ b/src/Database/InfluxDB/Types.hs @@ -109,7 +109,7 @@ data SeriesData = SeriesData { seriesDataColumns :: Vector Column , seriesDataPoints :: [Vector Value] - } deriving Show + } deriving (Eq, Show) type Column = Text diff --git a/tests/test-suite.hs b/tests/test-suite.hs --- a/tests/test-suite.hs +++ b/tests/test-suite.hs @@ -100,7 +100,7 @@ writeSeries name $ Val 42 ss <- query config database $ "select value from " <> name case ss of - [series] -> fromSeriesData series @=? Right [Val 42] + [series] -> fromSeriesData series @?= Right [Val 42] _ -> assertFailure $ "Expect one series, but got: " ++ show ss case_post_multi_series :: Assertion @@ -113,7 +113,7 @@ 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] + [series] -> fromSeriesData series @?= Right [Val 42, Val 42, Val 42] _ -> assertFailure $ "Expect one series, but got: " ++ show ss case_post_multi_points :: Assertion @@ -126,7 +126,7 @@ writePoints $ Val 42 ss <- query config database $ "select value from " <> name case ss of - [series] -> fromSeriesData series @=? Right [Val 42, Val 42, Val 42] + [series] -> fromSeriesData series @?= Right [Val 42, Val 42, Val 42] _ -> assertFailure $ "Expect one series, but got: " ++ show ss case_queryChunked :: Assertion @@ -139,7 +139,7 @@ writePoints $ Val 42 ss <- queryChunked config database ("select value from " <> name) $ S.fold step [] - mapM fromSeriesData ss @=? Right [[Val 42], [Val 42], [Val 42]] + mapM fromSeriesData ss @?= Right [[Val 42], [Val 42], [Val 42]] where step xs series = case fromSeriesData series of Left reason -> throwIO $ HUnitFailure reason @@ -153,9 +153,23 @@ writeSeries name $ Val 42 ss <- query config database $ "select value from " <> name case ss of - [series] -> fromSeriesData series @=? Right [Val 42] + [series] -> fromSeriesData series @?= Right [Val 42] _ -> assertFailure $ "Expect one series, but got: " ++ show ss +case_delete_series :: Assertion +case_delete_series = 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 + deleteSeries config database name + ss' <- query config database $ "select value from " <> name + ss' @=? ([] :: [SeriesData]) + case_listDatabases :: Assertion case_listDatabases = runTest $ \config -> withTestDatabase config $ \name -> do @@ -182,6 +196,9 @@ assertBool "No root admin" $ any (("root" ==) . adminUsername) admins +case_authenticate_cluster_admin :: Assertion +case_authenticate_cluster_admin = runTest authenticateClusterAdmin + case_add_then_delete_cluster_admin :: Assertion case_add_then_delete_cluster_admin = runTest $ \config -> do name <- newName @@ -222,6 +239,11 @@ assertBool "There shouldn't be any users" $ null users newUserName <- newName addDatabaseUser config name newUserName "somePassword" + let newCreds = rootCreds + { credsUser = newUserName + , credsPassword = "somePassword" } + newConfig = config { configCreds = newCreds } + authenticateDatabaseUser newConfig name listDatabaseUsers config name >>= \users -> assertBool ("No such user: " <> T.unpack newUserName) $ any ((newUserName ==) . userName) users