diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## v0.5.0 - 2014-07-18 + +* Add `InfluxException` type and use it when decoding JSON or SeriesData (#12) +* New API + * `ping` + * `listInterfaces` + * `isInSync` +* BUGFIX: Fix `when expecting a Float, encountered Int instead` error (#14) + ## v0.4.2 - 2014-06-06 * Export `newServerPoolWithRetrySettings` from `Database.InfluxDB` diff --git a/influxdb.cabal b/influxdb.cabal --- a/influxdb.cabal +++ b/influxdb.cabal @@ -1,5 +1,5 @@ name: influxdb -version: 0.4.2 +version: 0.5.0 synopsis: Haskell client library for InfluxDB description: Haskell client library for InfluxDB homepage: https://github.com/maoe/influxdb-haskell @@ -141,5 +141,5 @@ source-repository this type: git - tag: v0.4.2 + tag: v0.5.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 @@ -27,6 +27,7 @@ , Database(..) , User(..) , Admin(..) + , Ping(..) -- ** Writing Data @@ -71,6 +72,11 @@ , deleteDatabaseUser , grantAdminPrivilegeTo , revokeAdminPrivilegeFrom + + -- *** Other API + , ping + , listInterfaces + , isInSync ) where import Database.InfluxDB.Decode diff --git a/src/Database/InfluxDB/Decode.hs b/src/Database/InfluxDB/Decode.hs --- a/src/Database/InfluxDB/Decode.hs +++ b/src/Database/InfluxDB/Decode.hs @@ -174,6 +174,10 @@ instance FromValue Double where parseValue (Float d) = return d + -- If the floating number happens to be a whole number, it must + -- have encoded as an integer. We should decode it back as a floating + -- number here. + parseValue (Int n) = return $ fromIntegral n parseValue v = typeMismatch "Float" v instance FromValue T.Text where 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 @@ -53,6 +53,11 @@ , deleteDatabaseUser , grantAdminPrivilegeTo , revokeAdminPrivilegeFrom + + -- ** Other API + , ping + , listInterfaces + , isInSync ) where import Control.Applicative @@ -76,7 +81,10 @@ import Data.Default.Class (Default(def)) import qualified Data.Aeson as A import qualified Data.Aeson.Encode as AE +import qualified Data.Aeson.Parser as AP +import qualified Data.Aeson.Types as AT import qualified Data.Attoparsec.ByteString as P +import qualified Data.Attoparsec.ByteString.Lazy as PL import qualified Network.HTTP.Client as HC import Database.InfluxDB.Decode @@ -118,10 +126,10 @@ | MillisecondsPrecision | MicrosecondsPrecision -timePrecChar :: TimePrecision -> Char -timePrecChar SecondsPrecision = 's' -timePrecChar MillisecondsPrecision = 'm' -timePrecChar MicrosecondsPrecision = 'u' +timePrecString :: TimePrecision -> String +timePrecString SecondsPrecision = "s" +timePrecString MillisecondsPrecision = "ms" +timePrecString MicrosecondsPrecision = "u" ----------------------------------------------------------- -- Writing Data @@ -169,7 +177,7 @@ (T.unpack credsPassword) (maybe "" - (printf "&time_precision=%c" . timePrecChar) + (printf "&time_precision=%s" . timePrecString) timePrec :: String) } Credentials {..} = configCreds @@ -238,10 +246,9 @@ -> Text -- ^ Database name -> Text -- ^ Series name -> IO () -deleteSeries Config {..} databaseName seriesName = - void $ httpLbsWithRetry configServerPool makeRequest configHttpManager +deleteSeries config databaseName seriesName = runRequest_ config request where - makeRequest = def + request = def { HC.method = "DELETE" , HC.path = escapeString $ printf "/db/%s/series/%s" (T.unpack databaseName) @@ -250,7 +257,7 @@ (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- TODO: Delete API hasn't been implemented in InfluxDB yet -- @@ -289,13 +296,11 @@ -> Text -- ^ Database name -> Text -- ^ Query text -> IO [a] -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 - Left reason -> fail reason - Right ys -> return ys +query config databaseName q = do + xs <- runRequest config request + case mapM fromSeries xs of + Left reason -> seriesDecodeError reason + Right ys -> return ys where request = def { HC.path = escapeString $ printf "/db/%s/series" @@ -305,7 +310,7 @@ (T.unpack credsPassword) (T.unpack q) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | Construct streaming output responseStream :: A.FromJSON a => HC.BodyReader -> IO (Stream IO a) @@ -319,9 +324,9 @@ A.Success a -> return $ Yield a $ if BS.null leftover then responseStream body else decode $ parseAsJson leftover - A.Error message -> fail message + A.Error message -> jsonDecodeError message decode (P.Partial k) = demandPayload (decode . k) - decode (P.Fail _ _ message) = fail message + decode (P.Fail _ _ message) = jsonDecodeError message parseAsJson = P.parse A.json -- | Query a specified database like 'query' but in a streaming fashion. @@ -339,7 +344,7 @@ responseStream . HC.responseBody >=> S.mapM parse >=> f where parse series = case fromSeries series of - Left reason -> fail reason + Left reason -> seriesDecodeError reason Right a -> return a request = def { HC.path = escapeString $ printf "/db/%s/series" @@ -356,26 +361,21 @@ -- | List existing databases. 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 +listDatabases config = runRequest config request where - makeRequest = def + request = def { HC.path = "/db" , HC.queryString = escapeString $ printf "u=%s&p=%s" (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | Create a new database. Requires cluster admin privileges. createDatabase :: Config -> Text -> IO () -createDatabase Config {..} name = - void $ httpLbsWithRetry configServerPool makeRequest configHttpManager +createDatabase config name = runRequest_ config request where - makeRequest = def + request = def { HC.method = "POST" , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "name" .= name @@ -385,17 +385,16 @@ (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | Drop a database. Requires cluster admin privileges. dropDatabase :: Config -> Text -- ^ Database name -> IO () -dropDatabase Config {..} databaseName = - void $ httpLbsWithRetry configServerPool makeRequest configHttpManager +dropDatabase config databaseName = runRequest_ config request where - makeRequest = def + request = def { HC.method = "DELETE" , HC.path = escapeString $ printf "/db/%s" (T.unpack databaseName) @@ -403,35 +402,30 @@ (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | List cluster administrators. 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 +listClusterAdmins config = runRequest config request where - makeRequest = def + request = def { HC.path = "/cluster_admins" , HC.queryString = escapeString $ printf "u=%s&p=%s" (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config authenticateClusterAdmin :: Config -> IO () -authenticateClusterAdmin Config {..} = - void $ httpLbsWithRetry configServerPool makeRequest configHttpManager +authenticateClusterAdmin config = runRequest_ config request where - makeRequest = def + request = def { HC.path = "/cluster_admins/authenticate" , HC.queryString = escapeString $ printf "u=%s&p=%s" (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | Add a new cluster administrator. Requires cluster admin privilege. addClusterAdmin @@ -439,13 +433,13 @@ -> Text -- ^ Admin name -> Text -- ^ Password -> IO Admin -addClusterAdmin Config {..} name password = do - void $ httpLbsWithRetry configServerPool makeRequest configHttpManager +addClusterAdmin config name password = do + runRequest_ config request return Admin { adminName = name } where - makeRequest = def + request = def { HC.method = "POST" , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "name" .= name @@ -456,7 +450,7 @@ (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | Update a cluster administrator's password. Requires cluster admin -- privilege. @@ -506,11 +500,7 @@ :: Config -> Text -> IO [User] -listDatabaseUsers Config {..} database = do - response <- httpLbsWithRetry configServerPool makeRequest configHttpManager - case A.decode (HC.responseBody response) of - Nothing -> fail $ show response - Just xs -> return xs +listDatabaseUsers config@Config {..} database = runRequest config makeRequest where makeRequest = def { HC.path = escapeString $ printf "/db/%s/users" @@ -544,10 +534,9 @@ -> Text -- ^ User name -> Text -- ^ Password -> IO () -addDatabaseUser Config {..} databaseName name password = - void $ httpLbsWithRetry configServerPool makeRequest configHttpManager +addDatabaseUser config databaseName name password = runRequest_ config request where - makeRequest = def + request = def { HC.method = "POST" , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object [ "name" .= name @@ -559,7 +548,7 @@ (T.unpack credsUser) (T.unpack credsPassword) } - Credentials {..} = configCreds + Credentials {..} = configCreds config -- | Delete an user from the database users. deleteDatabaseUser @@ -567,8 +556,7 @@ -> Text -- ^ Database name -> Text -- ^ User name -> IO () -deleteDatabaseUser config@Config {..} databaseName userName = - void $ httpLbsWithRetry configServerPool request configHttpManager +deleteDatabaseUser config databaseName userName = runRequest_ config request where request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "DELETE" @@ -581,8 +569,8 @@ -> Text -- ^ User name -> Text -- ^ New password -> IO () -updateDatabaseUserPassword config@Config {..} databaseName userName password = - void $ httpLbsWithRetry configServerPool request configHttpManager +updateDatabaseUserPassword config databaseName userName password = + runRequest_ config request where request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "POST" @@ -597,8 +585,7 @@ -> Text -- ^ Database name -> Text -- ^ User name -> IO () -grantAdminPrivilegeTo config@Config {..} databaseName userName = - void $ httpLbsWithRetry configServerPool request configHttpManager +grantAdminPrivilegeTo config databaseName userName = runRequest_ config request where request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "POST" @@ -613,8 +600,8 @@ -> Text -- ^ Database name -> Text -- ^ User name -> IO () -revokeAdminPrivilegeFrom config@Config {..} databaseName userName = - void $ httpLbsWithRetry configServerPool request configHttpManager +revokeAdminPrivilegeFrom config databaseName userName = + runRequest_ config request where request = (makeRequestFromDatabaseUser config databaseName userName) { HC.method = "POST" @@ -639,6 +626,39 @@ where Credentials {..} = configCreds +ping :: Config -> IO Ping +ping config = runRequest config request + where + request = def + { HC.path = "/ping" + } + +-- | Fetch current list of available interfaces +listInterfaces :: Config -> IO [Text] +listInterfaces config = runRequest config request + where + request = def + { HC.path = "/interfaces" + } + +isInSync :: Config -> IO Bool +isInSync Config {..} = do + response <- httpLbsWithRetry configServerPool makeRequest configHttpManager + case eitherDecodeBool (HC.responseBody response) of + Left reason -> jsonDecodeError reason + Right status -> return status + where + makeRequest = def + { HC.path = "/sync" + , HC.queryString = escapeString $ printf "u=%s&p=%s" + (T.unpack credsUser) + (T.unpack credsPassword) + } + Credentials {..} = configCreds + eitherDecodeBool lbs = do + val <- PL.eitherResult $ PL.parse AP.value lbs + AT.parseEither A.parseJSON val + ----------------------------------------------------------- httpLbsWithRetry @@ -679,3 +699,21 @@ escapeString :: String -> BS.ByteString escapeString = BS8.pack . escapeURIString isAllowedInURI + +decodeJsonResponse + :: A.FromJSON a + => HC.Response BL.ByteString + -> IO a +decodeJsonResponse response = + case A.eitherDecode (HC.responseBody response) of + Left reason -> jsonDecodeError reason + Right a -> return a + +runRequest :: A.FromJSON a => Config -> HC.Request -> IO a +runRequest Config {..} req = do + response <- httpLbsWithRetry configServerPool req configHttpManager + decodeJsonResponse response + +runRequest_ :: Config -> HC.Request -> IO () +runRequest_ Config {..} req = + void $ httpLbsWithRetry configServerPool req configHttpManager 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 @@ -20,6 +20,8 @@ , ScheduledDelete(..) , User(..) , Admin(..) + , Ping(..) + , Interface -- * Server pool , ServerPool @@ -28,9 +30,15 @@ , newServerPoolWithRetrySettings , activeServer , failover + + -- * Exceptions + , InfluxException(..) + , jsonDecodeError + , seriesDecodeError ) where import Control.Applicative (empty) +import Control.Exception (Exception, throwIO) import Data.Data (Data) import Data.IORef import Data.Int (Int64) @@ -142,15 +150,28 @@ where #if MIN_VERSION_aeson(0, 7, 0) numberToValue + -- If the number is larger than Int64, it must be + -- a float64 (Double in Haskell). + | n > maxInt = Float $ toRealFloat n | e < 0 = Float $ realToFrac n | otherwise = Int $ fromIntegral $ coefficient n * 10 ^ e where e = base10Exponent n +#if !MIN_VERSION_scientific(0, 3, 0) + toRealFloat = realToFrac +-- scientific +#endif #else numberToValue = case n of - I i -> Int $ fromIntegral i + I i + -- If the number is larger than Int64, it must be + -- a float64 (Double in Haskell). + | i > maxInt -> Float $ fromIntegral i + | otherwise -> Int $ fromIntegral i D d -> Float d +-- aeson #endif + maxInt = fromIntegral (maxBound :: Int64) ----------------------------------------------------------- @@ -198,7 +219,12 @@ { adminName :: Text } deriving Show +newtype Ping = Ping + { pingStatus :: Text + } deriving Show +type Interface = Text + ----------------------------------------------------------- -- Server pool manipulation @@ -243,8 +269,25 @@ } ----------------------------------------------------------- +-- Exceptions + +data InfluxException + = JsonDecodeError String + | SeriesDecodeError String + deriving (Show, Typeable) + +instance Exception InfluxException + +jsonDecodeError :: String -> IO a +jsonDecodeError = throwIO . JsonDecodeError + +seriesDecodeError :: String -> IO a +seriesDecodeError = throwIO . SeriesDecodeError + +----------------------------------------------------------- -- Aeson instances deriveFromJSON (stripPrefixOptions "database") ''Database deriveFromJSON (stripPrefixOptions "admin") ''Admin deriveFromJSON (stripPrefixOptions "user") ''User +deriveFromJSON (stripPrefixOptions "ping") ''Ping diff --git a/tests/test-suite.hs b/tests/test-suite.hs --- a/tests/test-suite.hs +++ b/tests/test-suite.hs @@ -1,10 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Applicative import Control.Exception as E -import Control.Monad import Control.Monad.Trans -import Data.Function import Data.Int import Data.List (find) import Data.Monoid @@ -16,13 +15,13 @@ import qualified Data.Vector as V import Test.HUnit.Lang (HUnitFailure(..)) -import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.TH -import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck hiding (reason) import qualified Network.HTTP.Client as HC import Database.InfluxDB +import Database.InfluxDB.TH import qualified Database.InfluxDB.Stream as S prop_fromValue_toValue_identity_Value :: Value -> Bool @@ -92,6 +91,21 @@ ------------------------------------------------- +case_ping :: Assertion +case_ping = runTest $ \config -> do + Ping status <- ping config + status @?= "ok" + +case_listInterfaces :: Assertion +case_listInterfaces = runTest $ \config -> do + ifaces <- listInterfaces config + ifaces @?= ["default"] + +case_isInSync :: Assertion +case_isInSync = runTest $ \config -> do + inSync <- isInSync config + assertBool "The database is not in sync." inSync + case_post :: Assertion case_post = runTest $ \config -> withTestDatabase config $ \database -> do @@ -239,16 +253,16 @@ updateClusterAdminPassword config admin newPassword let newCreds = Credentials name newPassword newConfig = config { configCreds = newCreds } - name <- newName - dropDatabaseIfExists config name - createDatabase newConfig name + name' <- newName + dropDatabaseIfExists config name' + createDatabase newConfig name' listDatabases newConfig >>= \databases -> - assertBool ("No such database: " ++ T.unpack name) $ - any ((name ==) . databaseName) databases - dropDatabase newConfig name + assertBool ("No such database: " ++ T.unpack name') $ + any ((name' ==) . databaseName) databases + dropDatabase newConfig name' listDatabases newConfig >>= \databases -> - assertBool ("Found a dropped database: " ++ T.unpack name) $ - all ((name /=) . databaseName) databases + 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 -> @@ -306,7 +320,38 @@ deleteDatabaseUser config name newUserName ------------------------------------------------- +-- Regressions +newtype WholeFloat = WholeFloat + { wholeFloatValue :: Double + } deriving (Eq, Show) + +-- #14: InfluxDB may return Int instead of Float when +-- the WholeFloat value happens to be a whole number. +case_regression_whole_Float_number :: Assertion +case_regression_whole_Float_number = runTest $ \config -> + withTestDatabase config $ \database -> do + series <- newName + post config database $ + writeSeries series $ WholeFloat 42.0 + ss <- query config database $ "select value from " <> series + case ss of + [sd] -> fromSeriesData sd @?= Right [WholeFloat 42] + _ -> assertFailure $ "Expect one series, but got: " ++ show ss + +case_regression_really_big_Float_number :: Assertion +case_regression_really_big_Float_number = runTest $ \config -> + withTestDatabase config $ \database -> do + series <- newName + post config database $ + writeSeries series $ WholeFloat 42e100 + ss <- query config database $ "select value from " <> series + case ss of + [sd] -> fromSeriesData sd @?= Right [WholeFloat 42e100] + _ -> assertFailure $ "Expect one series, but got: " ++ show ss + +------------------------------------------------- + data Val = Val Int deriving (Eq, Show) instance ToSeriesData Val where @@ -359,3 +404,10 @@ main :: IO () main = $defaultMainGenerator + +------------------------------------------------- +-- Instance deriving + +deriveSeriesData defaultOptions + { fieldLabelModifier = stripPrefixLower "wholeFloat" } + ''WholeFloat