influxdb 0.4.2 → 0.5.0

raw patch · 7 files changed

+234/−82 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• influxdb.cabal +2/−2
• src/Database/InfluxDB.hs +6/−0
• src/Database/InfluxDB/Decode.hs +4/−0
• src/Database/InfluxDB/Http.hs +105/−67
• src/Database/InfluxDB/Types.hs +44/−1
• tests/test-suite.hs +64/−12

@@ -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`

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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