summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMitsutoshiAoe <>2014-05-08 05:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-05-08 05:30:00 (GMT)
commit154186f50b8b9be27ad7af7e792ff7edf84a1c32 (patch)
tree8272322ea0cfe84b291f4c2ae3df66e2d4ed1e9b
parente3e306073d3cf9af6683ccc7c7a12d663de42d8d (diff)
version 0.2.20.2.2
-rw-r--r--CHANGELOG.md6
-rw-r--r--influxdb.cabal42
-rw-r--r--src/Database/InfluxDB.hs6
-rw-r--r--src/Database/InfluxDB/Http.hs69
-rw-r--r--src/Database/InfluxDB/Types.hs2
-rw-r--r--tests/test-suite.hs32
6 files changed, 131 insertions, 26 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 36d71ca..75d0097 100644
--- 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
index 43899e8..8d58530 100644
--- 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,8 +21,14 @@ flag examples
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
@@ -39,6 +45,21 @@ library
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 @@ library
, 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 @@ library
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 head
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
index a35baec..359c950 100644
--- a/src/Database/InfluxDB.hs
+++ b/src/Database/InfluxDB.hs
@@ -38,8 +38,8 @@ module Database.InfluxDB
, writePoints
-- *** Deleting Points
- -- **** One Time Deletes (not implemented)
- -- , deleteSeries
+ -- **** One Time Deletes
+ , deleteSeries
-- **** Regularly Scheduled Deletes (not implemented)
-- , getScheduledDeletes
-- , addScheduledDelete
@@ -59,11 +59,13 @@ module Database.InfluxDB
-- *** 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
index 7773882..1768f1c 100644
--- 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 @@ module Database.InfluxDB.Http
, writePoints
-- ** Deleting Points
- -- *** One Time Deletes (not implemented)
- -- , deleteSeries
+ -- *** One Time Deletes
+ , deleteSeries
-- *** Regularly Scheduled Deletes (not implemented)
-- , getScheduledDeletes
-- , addScheduledDelete
@@ -40,11 +41,13 @@ module Database.InfluxDB.Http
-- ** Security
-- *** Cluster admin
, listClusterAdmins
+ , authenticateClusterAdmin
, addClusterAdmin
, updateClusterAdminPassword
, deleteClusterAdmin
-- *** Database user
, listDatabaseUsers
+ , authenticateDatabaseUser
, addDatabaseUser
, updateDatabaseUserPassword
, deleteDatabaseUser
@@ -68,7 +71,6 @@ import qualified Data.ByteString.Lazy as BL
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.Types
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 @@ writePoints
-> 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 @@ listClusterAdmins Config {..} = do
}
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
@@ -490,6 +521,22 @@ listDatabaseUsers Config {..} database = do
}
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)
+ (T.unpack credsPassword)
+ }
+ Credentials {..} = configCreds
+
-- | Add an user to the database users.
addDatabaseUser
:: Config
diff --git a/src/Database/InfluxDB/Types.hs b/src/Database/InfluxDB/Types.hs
index bf12e1f..13d2d19 100644
--- a/src/Database/InfluxDB/Types.hs
+++ b/src/Database/InfluxDB/Types.hs
@@ -109,7 +109,7 @@ instance A.FromJSON Series where
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
index df5e258..6510197 100644
--- a/tests/test-suite.hs
+++ b/tests/test-suite.hs
@@ -100,7 +100,7 @@ case_post = runTest $ \config ->
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 @@ case_post_multi_series = runTest $ \config ->
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 @@ case_post_multi_points = runTest $ \config ->
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 @@ case_queryChunked = runTest $ \config ->
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 @@ case_post_with_precision = runTest $ \config ->
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 @@ case_list_cluster_admins = runTest $ \config -> do
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 @@ case_add_then_delete_database_users = runTest $ \config ->
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