summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMitsutoshiAoe <>2014-04-07 08:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-07 08:47:00 (GMT)
commit9eb7904f1990fc59fa19eeaddc12e191fb1f6d2e (patch)
tree4c1345d3a1dc9920849a6f306224e7671e537d20
parent2a30948e60bc3acf619cec088d81ba02adc791e4 (diff)
version 0.1.00.1.0
-rw-r--r--examples/random-points.hs19
-rw-r--r--influxdb.cabal22
-rw-r--r--src/Database/InfluxDB/Decode.hs7
-rw-r--r--src/Database/InfluxDB/Encode.hs3
-rw-r--r--src/Database/InfluxDB/Http.hs183
-rw-r--r--src/Database/InfluxDB/Types.hs34
-rw-r--r--src/Database/InfluxDB/Types/Internal.hs26
-rw-r--r--tests/test-suite.hs226
8 files changed, 386 insertions, 134 deletions
diff --git a/examples/random-points.hs b/examples/random-points.hs
index 71e3069..63e8b14 100644
--- a/examples/random-points.hs
+++ b/examples/random-points.hs
@@ -28,16 +28,18 @@ main :: IO ()
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 @@ main = do
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 @@ main = do
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
diff --git a/influxdb.cabal b/influxdb.cabal
index 754fa3c..8d7448a 100644
--- a/influxdb.cabal
+++ b/influxdb.cabal
@@ -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 @@ build-type: Simple
cabal-version: >= 1.10
flag examples
+ description: Build examples
default: False
+ manual: True
library
exposed-modules:
@@ -31,7 +33,7 @@ library
ghc-options: -Wall
build-depends:
base >= 4 && < 4.8
- , aeson >= 0.7
+ , aeson >= 0.6.1.0
, attoparsec
, bytestring
, containers
@@ -50,6 +52,22 @@ library
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
if flag(examples)
buildable: True
diff --git a/src/Database/InfluxDB/Decode.hs b/src/Database/InfluxDB/Decode.hs
index 98b8296..0a77b38 100644
--- a/src/Database/InfluxDB/Decode.hs
+++ b/src/Database/InfluxDB/Decode.hs
@@ -12,7 +12,6 @@ import Control.Monad.Reader
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 @@ fromSeries = runParser . parseSeries
-- > data EventType = Login | Logout
-- >
-- > instance FromSeriesData where
--- > parseSeriesData = withValues $ values -> Event
+-- > parseSeriesData = withValues $ \values -> Event
-- > <$> values .: "user"
-- > <*> values .: "type"
-- >
@@ -54,14 +53,14 @@ class FromSeriesData a where
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)
diff --git a/src/Database/InfluxDB/Encode.hs b/src/Database/InfluxDB/Encode.hs
index ffc0ce6..bd61df5 100644
--- a/src/Database/InfluxDB/Encode.hs
+++ b/src/Database/InfluxDB/Encode.hs
@@ -10,7 +10,6 @@ import Data.Int (Int8, Int16, Int32, Int64)
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 @@ class ToSeriesData a where
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.
diff --git a/src/Database/InfluxDB/Http.hs b/src/Database/InfluxDB/Http.hs
index 11d97e5..9e1f424 100644
--- a/src/Database/InfluxDB/Http.hs
+++ b/src/Database/InfluxDB/Http.hs
@@ -86,7 +86,8 @@ import qualified Database.InfluxDB.Stream as S
-- | 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 @@ timePrecChar MicrosecondsPrecision = 'u'
-- | 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 @@ postGeneric Config {..} manager database timePrec write = do
(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 @@ withSeries name (PointT w) = do
{ seriesName = name
, seriesData = SeriesData
{ seriesDataColumns = toSeriesColumns (Proxy :: Proxy a)
- , seriesDataPoints = values
+ , seriesDataPoints = DL.toList values
}
}
@@ -268,12 +267,11 @@ writePoints = tell . DL.singleton . toSeriesPoints
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 @@ query Config {..} manager database q = do
(T.unpack credsPassword)
(T.unpack q)
}
- Database {databaseName} = database
Credentials {..} = configCreds
-- | Construct streaming output
@@ -312,15 +309,14 @@ responseStream body = demandPayload $ \payload ->
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 @@ queryChunked Config {..} manager database q f =
(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 @@ listDatabases Config {..} manager = do
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 @@ createDatabase Config {..} manager name = do
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 @@ dropDatabase Config {..} manager database =
(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 @@ listClusterAdmins Config {..} manager = do
-- | 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 @@ addClusterAdmin Config {..} manager name = do
-- 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 @@ updateClusterAdminPassword Config {..} manager admin password =
-- | 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 @@ deleteClusterAdmin Config {..} manager admin =
-- | 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 @@ listDatabaseUsers Config {..} manager database = do
-- | 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 @@ addDatabaseUser Config {..} manager database name = do
(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 @@ updateDatabaseUserPassword config manager database user password =
-- | 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 @@ grantAdminPrivilegeTo config manager database user =
-- | 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 @@ revokeAdminPrivilegeFrom config manager database user =
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 @@ makeRequestFromDatabaseUser Config {..} database user = def
(T.unpack credsPassword)
}
where
- Database {databaseName} = database
- User {userName} = user
Credentials {..} = configCreds
-----------------------------------------------------------
diff --git a/src/Database/InfluxDB/Types.hs b/src/Database/InfluxDB/Types.hs
index 57b280f..2e99968 100644
--- a/src/Database/InfluxDB/Types.hs
+++ b/src/Database/InfluxDB/Types.hs
@@ -29,7 +29,6 @@ module Database.InfluxDB.Types
) 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.Sequence (Seq, ViewL(..), (|>))
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 :: Series -> Vector Column
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 @@ instance A.FromJSON Series where
{ seriesName = name
, seriesData = SeriesData
{ seriesDataColumns = columns
- , seriesDataPoints = DL.fromList points
+ , seriesDataPoints = points
}
}
parseJSON _ = empty
@@ -105,7 +108,7 @@ instance A.FromJSON Series where
-- | @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 @@ instance A.FromJSON Value where
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 @@ newtype ScheduledDelete = ScheduledDelete
} deriving Show
-- | User
-newtype User = User
+data User = User
{ userName :: Text
+ , userIsAdmin :: Bool
} deriving Show
-- | Administrator
diff --git a/src/Database/InfluxDB/Types/Internal.hs b/src/Database/InfluxDB/Types/Internal.hs
index 2fbfb16..0507cd7 100644
--- a/src/Database/InfluxDB/Types/Internal.hs
+++ b/src/Database/InfluxDB/Types/Internal.hs
@@ -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
diff --git a/tests/test-suite.hs b/tests/test-suite.hs
new file mode 100644
index 0000000..e3de360
--- /dev/null
+++ b/tests/test-suite.hs
@@ -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