diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## v0.7.0 - 2014-09-12 + +* Support for influxdb v0.8 (#15) + * Add shard spaces API + * Add `configureDatabase` +* Add Typeable and Generic instances where missing +* Remove unused `ScheduledDelete` type + ## v0.6.0 - 2014-08-19 * Support for retry-0.5 (#16) diff --git a/influxdb.cabal b/influxdb.cabal --- a/influxdb.cabal +++ b/influxdb.cabal @@ -1,5 +1,5 @@ name: influxdb -version: 0.6.0 +version: 0.7.0 synopsis: Haskell client library for InfluxDB description: Haskell client library for InfluxDB homepage: https://github.com/maoe/influxdb-haskell @@ -102,6 +102,10 @@ build-depends: network < 2.6 + if impl(ghc < 7.6) + build-depends: + ghc-prim + hs-source-dirs: src default-language: Haskell2010 @@ -149,5 +153,5 @@ source-repository this type: git - tag: v0.6.0 + tag: v0.7.0 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 @@ -29,6 +29,7 @@ , User(..) , Admin(..) , Ping(..) + , ShardSpace(..) -- *** Exception , InfluxException(..) @@ -43,12 +44,7 @@ , writePoints -- *** Deleting Points - -- **** One Time Deletes , deleteSeries - -- **** Regularly Scheduled Deletes (not implemented) - -- , getScheduledDeletes - -- , addScheduledDelete - -- , removeScheduledDelete -- ** Querying Data , query @@ -61,7 +57,16 @@ , createDatabase , dropDatabase + , DatabaseRequest(..) + , configureDatabase + -- *** Security + -- **** Shard spaces + , ShardSpaceRequest(..) + , listShardSpaces + , createShardSpace + , dropShardSpace + -- **** Cluster admin , listClusterAdmins , authenticateClusterAdmin 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 @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Database.InfluxDB.Http ( Config(..) , Credentials(..), rootCreds @@ -20,12 +21,7 @@ , writePoints -- ** Deleting Points - -- *** One Time Deletes , deleteSeries - -- *** Regularly Scheduled Deletes (not implemented) - -- , getScheduledDeletes - -- , addScheduledDelete - -- , removeScheduledDelete -- * Querying Data , query @@ -38,7 +34,16 @@ , createDatabase , dropDatabase + , DatabaseRequest(..) + , configureDatabase + -- ** Security + -- *** Shard spaces + , ShardSpaceRequest(..) + , listShardSpaces + , createShardSpace + , dropShardSpace + -- *** Cluster admin , listClusterAdmins , authenticateClusterAdmin @@ -68,16 +73,18 @@ import Data.Proxy import Data.Text (Text) import Data.Vector (Vector) +import Data.Word (Word32) import Network.URI (escapeURIString, isAllowedInURI) -import Text.Printf (printf) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.DList as DL import qualified Data.Text as T +import Text.Printf (printf) import Control.Retry import Data.Aeson ((.=)) +import Data.Aeson.TH (deriveToJSON) import Data.Default.Class (Default(def)) import qualified Data.Aeson as A import qualified Data.Aeson.Encode as AE @@ -90,6 +97,7 @@ import Database.InfluxDB.Decode import Database.InfluxDB.Encode import Database.InfluxDB.Types +import Database.InfluxDB.Types.Internal (stripPrefixOptions) import Database.InfluxDB.Stream (Stream(..)) import qualified Database.InfluxDB.Stream as S @@ -259,30 +267,6 @@ } Credentials {..} = configCreds config --- TODO: Delete API hasn't been implemented in InfluxDB yet --- --- getScheduledDeletes --- :: Config --- -> HC.Manager --- -> IO [ScheduledDelete] --- getScheduledDeletes = do --- error "getScheduledDeletes: not implemented" --- --- addScheduledDelete --- :: Config --- -> HC.Manager --- -> IO ScheduledDelete --- addScheduledDelete = --- error "addScheduledDeletes: not implemented" --- --- removeScheduledDelete --- :: Config --- -> HC.Manager --- -> ScheduledDeletes --- -> IO () --- removeScheduledDelete = --- error "removeScheduledDelete: not implemented" - ----------------------------------------------------------- -- Querying Data @@ -404,6 +388,89 @@ } Credentials {..} = configCreds config + +data DatabaseRequest = DatabaseRequest + { databaseRequestSpaces :: [ShardSpaceRequest] + , databaseRequestContinuousQueries :: [Text] + } deriving Show + +configureDatabase + :: Config + -> Text -- ^ Database name + -> DatabaseRequest + -> IO () +configureDatabase config databaseName databaseRequest = + runRequest_ config request + where + request = def + { HC.method = "POST" + , HC.requestBody = HC.RequestBodyLBS $ AE.encode databaseRequest + , HC.path = escapeString $ printf "/cluster/database_configs/%s" + (T.unpack databaseName) + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds config + +-- | List shard spaces. +listShardSpaces :: Config -> IO [ShardSpace] +listShardSpaces config = runRequest config request + where + request = def + { HC.path = "/cluster/shard_spaces" + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds config + +data ShardSpaceRequest = ShardSpaceRequest + { shardSpaceRequestName :: Text + , shardSpaceRequestRegex :: Text + , shardSpaceRequestRetentionPolicy :: Text + , shardSpaceRequestShardDuration :: Text + , shardSpaceRequestReplicationFactor :: Word32 + , shardSpaceRequestSplit :: Word32 + } deriving Show + +-- | Create a shard space. +createShardSpace + :: Config + -> Text -- ^ Database + -> ShardSpaceRequest + -> IO () +createShardSpace config databaseName shardSpace = runRequest_ config request + where + request = def + { HC.method = "POST" + , HC.requestBody = HC.RequestBodyLBS $ AE.encode shardSpace + , HC.path = escapeString $ printf "/cluster/shard_spaces/%s" + (T.unpack databaseName) + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds config + +dropShardSpace + :: Config + -> Text -- ^ Database name + -> Text -- ^ Shard space name + -> IO () +dropShardSpace config databaseName shardSpaceName = runRequest_ config request + where + request = def + { HC.method = "DELETE" + , HC.path = escapeString $ printf "/cluster/shard_spaces/%s/%s" + (T.unpack databaseName) + (T.unpack shardSpaceName) + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds config + -- | List cluster administrators. listClusterAdmins :: Config -> IO [Admin] listClusterAdmins config = runRequest config request @@ -721,3 +788,9 @@ runRequest_ :: Config -> HC.Request -> IO () runRequest_ Config {..} req = void $ httpLbsWithRetry configServerPool req configHttpManager + +----------------------------------------------------------- +-- Aeson instances + +deriveToJSON (stripPrefixOptions "shardSpaceRequest") ''ShardSpaceRequest +deriveToJSON (stripPrefixOptions "databaseRequest") ''DatabaseRequest 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -17,11 +18,11 @@ , Credentials(..) , Server(..) , Database(..) - , ScheduledDelete(..) , User(..) , Admin(..) , Ping(..) , Interface + , ShardSpace(..) -- * Server pool , ServerPool @@ -42,12 +43,14 @@ import Control.Applicative (empty) import Control.Exception (Exception, throwIO) import Data.Data (Data) -import Data.IORef import Data.Int (Int64) +import Data.IORef import Data.Sequence (Seq, ViewL(..), (|>)) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vector (Vector) +import Data.Word (Word32) +import GHC.Generics (Generic) import qualified Data.Sequence as Seq import Data.Aeson ((.=), (.:)) @@ -92,7 +95,7 @@ -- ^ Series name , seriesData :: {-# UNPACK #-} !SeriesData -- ^ Columns and data points in the series - } + } deriving (Typeable, Generic) -- | Convenient accessor for columns. seriesColumns :: Series -> Vector Column @@ -129,7 +132,7 @@ data SeriesData = SeriesData { seriesDataColumns :: Vector Column , seriesDataPoints :: [Vector Value] - } deriving (Eq, Show) + } deriving (Eq, Show, Typeable, Generic) type Column = Text @@ -140,7 +143,7 @@ | String !Text | Bool !Bool | Null - deriving (Eq, Show, Data, Typeable) + deriving (Eq, Show, Data, Typeable, Generic) instance A.ToJSON Value where toJSON (Int n) = A.toJSON n @@ -188,7 +191,7 @@ data Credentials = Credentials { credsUser :: !Text , credsPassword :: !Text - } deriving Show + } deriving (Show, Typeable, Generic) -- | Server location. data Server = Server @@ -197,7 +200,7 @@ , serverPort :: !Int , serverSsl :: !Bool -- ^ SSL is enabled or not in the server side - } deriving Show + } deriving (Show, Typeable, Generic) -- | Non-empty set of server locations. The active server will always be used -- until any HTTP communications fail. @@ -207,7 +210,7 @@ , serverBackup :: !(Seq Server) -- ^ The rest of the servers in the pool. , serverRetryPolicy :: !RetryPolicy - } + } deriving (Typeable, Generic) {-# DEPRECATED serverRetrySettings "Use serverRetryPolicy instead" #-} serverRetrySettings :: ServerPool -> RetryPolicy @@ -219,29 +222,35 @@ newtype Database = Database { databaseName :: Text - } deriving Show - -newtype ScheduledDelete = ScheduledDelete - { scheduledDeleteId :: Int - } deriving Show + } deriving (Show, Typeable, Generic) -- | User data User = User { userName :: Text , userIsAdmin :: Bool - } deriving Show + } deriving (Show, Typeable, Generic) -- | Administrator newtype Admin = Admin { adminName :: Text - } deriving Show + } deriving (Show, Typeable, Generic) newtype Ping = Ping { pingStatus :: Text - } deriving Show + } deriving (Show, Typeable, Generic) type Interface = Text +data ShardSpace = ShardSpace + { shardSpaceDatabase :: Maybe Text + , shardSpaceName :: Text + , shardSpaceRegex :: Text + , shardSpaceRetentionPolicy :: Text + , shardSpaceShardDuration :: Text + , shardSpaceReplicationFactor :: Word32 + , shardSpaceSplit :: Word32 + } deriving (Show, Typeable, Generic) + ----------------------------------------------------------- -- Server pool manipulation @@ -320,3 +329,4 @@ deriveFromJSON (stripPrefixOptions "admin") ''Admin deriveFromJSON (stripPrefixOptions "user") ''User deriveFromJSON (stripPrefixOptions "ping") ''Ping +deriveFromJSON (stripPrefixOptions "shardSpace") ''ShardSpace diff --git a/tests/test-suite.hs b/tests/test-suite.hs --- a/tests/test-suite.hs +++ b/tests/test-suite.hs @@ -146,8 +146,8 @@ case_query_nonexistent_series = runTest $ \config -> withTestDatabase config $ \database -> do name <- liftIO newName - ss <- query config database $ "select * from " <> name - ss @?= ([] :: [SeriesData]) + assertStatusCodeException + (query config database $ "select * from " <> name :: IO [SeriesData]) case_query_empty_series :: Assertion case_query_empty_series = runTest $ \config -> @@ -198,8 +198,8 @@ [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]) + assertStatusCodeException + (query config database $ "select value from " <> name :: IO [SeriesData]) case_listDatabases :: Assertion case_listDatabases = runTest $ \config -> @@ -208,6 +208,72 @@ assertBool ("No such database: " ++ T.unpack name) $ any ((name ==) . databaseName) databases +case_configureDatabase :: Assertion +case_configureDatabase = runTest $ \config -> do + dbName <- newName + do + configureDatabase config dbName $ DatabaseRequest shardSpaces contQueries + listDatabases config >>= \databases -> + assertBool ("No such database: " ++ T.unpack dbName) $ + any ((dbName ==) . databaseName) databases + listShardSpaces config >>= \spaces -> + assertBool "Missing shard space(s)" $ + any ((`elem` spaceNames) . shardSpaceName) spaces + `finally` + dropDatabase config dbName + where + spaceNames = map shardSpaceRequestName shardSpaces + shardSpaces = + [ ShardSpaceRequest + { shardSpaceRequestName = "everything_30d" + , shardSpaceRequestRetentionPolicy = "30d" + , shardSpaceRequestShardDuration = "7d" + , shardSpaceRequestRegex = "/.*/" + , shardSpaceRequestReplicationFactor = 1 + , shardSpaceRequestSplit = 1 + } + , ShardSpaceRequest + { shardSpaceRequestName = "forever" + , shardSpaceRequestRetentionPolicy = "inf" + , shardSpaceRequestShardDuration = "7d" + , shardSpaceRequestRegex = "/^_.*/" + , shardSpaceRequestReplicationFactor = 1 + , shardSpaceRequestSplit = 1 + } + , ShardSpaceRequest + { shardSpaceRequestName = "rollups" + , shardSpaceRequestRetentionPolicy = "365d" + , shardSpaceRequestShardDuration = "30d" + , shardSpaceRequestRegex = "/^\\d+.*/" + , shardSpaceRequestReplicationFactor = 1 + , shardSpaceRequestSplit = 1 + } + ] + contQueries = + [ "select * from events into events.[id]" + , "select count(value) from events group by time(5m) into 5m.count.events" + ] + +case_shardSpaces :: Assertion +case_shardSpaces = runTest $ \config -> + withTestDatabase config $ \name -> do + spaceName <- newName + createShardSpace config name $ ShardSpaceRequest + { shardSpaceRequestName = spaceName + , shardSpaceRequestRegex = "^[a-z].*" + , shardSpaceRequestRetentionPolicy = "7d" + , shardSpaceRequestShardDuration = "1d" + , shardSpaceRequestReplicationFactor = 1 + , shardSpaceRequestSplit = 1 + } + listShardSpaces config >>= \spaces -> + assertBool ("No such shard space: " ++ T.unpack spaceName) $ + any ((spaceName ==) . shardSpaceName) spaces + dropShardSpace config name spaceName + listShardSpaces config >>= \spaces -> + assertBool ("Found a dropped shard space: " ++ T.unpack spaceName) $ + all ((spaceName /=) . shardSpaceName) spaces + case_create_then_drop_database :: Assertion case_create_then_drop_database = runTest $ \config -> do name <- newName @@ -262,6 +328,7 @@ listDatabases newConfig >>= \databases -> assertBool ("Found a dropped database: " ++ T.unpack name') $ all ((name' /=) . databaseName) databases + deleteClusterAdmin config admin case_add_then_delete_database_users :: Assertion case_add_then_delete_database_users = runTest $ \config -> @@ -398,6 +465,16 @@ catchAll :: IO a -> (SomeException -> IO a) -> IO a catchAll = E.catch + +assertStatusCodeException :: Show a => IO a -> IO () +assertStatusCodeException io = do + r <- try io + case r of + Left e -> case fromException e of + Just HC.StatusCodeException {} -> return () + _ -> + assertFailure $ "Expect a StatusCodeException, but got " ++ show e + Right ss -> assertFailure $ "Expect an exception, but got " ++ show ss -------------------------------------------------