influxdb 0.10.0 → 1.9.3.2
raw patch · 29 files changed
Files
- CHANGELOG.md +280/−10
- LICENSE +1/−1
- README.md +17/−8
- Setup.hs +31/−0
- cabal.project +4/−0
- examples/random-points.hs +60/−91
- examples/write-udp.hs +35/−0
- influxdb.cabal +110/−81
- src/Database/InfluxDB.hs +220/−76
- src/Database/InfluxDB/Decode.hs +0/−232
- src/Database/InfluxDB/Encode.hs +0/−95
- src/Database/InfluxDB/Format.hs +275/−0
- src/Database/InfluxDB/Http.hs +0/−792
- src/Database/InfluxDB/Internal/Text.hs +24/−0
- src/Database/InfluxDB/JSON.hs +251/−0
- src/Database/InfluxDB/Lens.hs +0/−66
- src/Database/InfluxDB/Line.hs +185/−0
- src/Database/InfluxDB/Manage.hs +201/−0
- src/Database/InfluxDB/Ping.hs +151/−0
- src/Database/InfluxDB/Query.hs +621/−0
- src/Database/InfluxDB/Stream.hs +0/−41
- src/Database/InfluxDB/TH.hs +0/−141
- src/Database/InfluxDB/Types.hs +435/−252
- src/Database/InfluxDB/Types/Internal.hs +0/−49
- src/Database/InfluxDB/Write.hs +263/−0
- src/Database/InfluxDB/Write/UDP.hs +111/−0
- tests/doctests.hs +11/−0
- tests/regressions.hs +118/−0
- tests/test-suite.hs +0/−484
CHANGELOG.md view
@@ -1,3 +1,273 @@+# Revision history for influxdb++## v1.9.3.2 - 2024-07-12++* Allow newer dependencies ([101](https://github.com/maoe/influxdb-haskell/pull/101))++## v1.9.3.1 - 2024-03-15++* Support GHC 9.8 ([#98](https://github.com/maoe/influxdb-haskell/pull/98))+* Allow latest time package ([#99](https://github.com/maoe/influxdb-haskell/pull/99))++## v1.9.3 - 2023-06-29++* Mitigate InfluxDB compatibility problems ([#94](https://github.com/maoe/influxdb-haskell/pull/94))+* Support GHC 9.4 and 9.6 ([#95](https://github.com/maoe/influxdb-haskell/pull/95) and [#97](https://github.com/maoe/influxdb-haskell/pull/97))+* Revitalize CI ([#96](https://github.com/maoe/influxdb-haskell/pull/96))++## v1.9.2.2 - 2021-11-21++* Update dependencies++## v1.9.2.1 - 2021-10-20++* Add support for aeson 2.0 ([#89](https://github.com/maoe/influxdb-haskell/pull/89))++## v1.9.2 - 2021-09-08++* Derive Show for Line ([#87](https://github.com/maoe/influxdb-haskell/pull/87))+* Relax upper version bound for time ([#88](https://github.com/maoe/influxdb-haskell/pull/88))++## v1.9.1.2 - 2021-03-25++* Relax upper version bound for attoparsec++## v1.9.1.1 - 2021-03-12++* Support GHC 9.0.1 ([#85](https://github.com/maoe/influxdb-haskell/pull/85))++## v1.9.1 - 2021-02-21++* Show error on the "impossible" path in writeByteString ([#82](https://github.com/maoe/influxdb-haskell/pull/82))+* Relax upper version bounds for lens, time, doctest, and bytestring+* Switch from Travis CI to GitHub Actions ([#84](https://github.com/maoe/influxdb-haskell/pull/84))++## v1.9.0 - 2020-07-18++* Fix `Ignore` and `Empty` to replace the `QueryResults` instance for `Void`. The instance has been deprecated.+* Remove the deprecated `parseResults` method in `QueryResults`.+* Add the `coerceDecoder` method in `QueryResults`.+* Drop support for GHC 8.2 and older because of the use of `EmptyDataDeriving`.+* Update doctest comments with `TypeApplications`.++## v1.8.0 - 2020-06-19++This release reworked the `QueryResuls` type class. There are some breaking changes:++* `parseResults` has been deprecated. `QueryResults` has now `parseMeasurement` method.+* `Decoder` has been monomorphized so that it can be used with lens. The original `Decoder` type has been renamed to `SomeDecoder`.+* `QueryParams` has now `decoder` field.+* `parseResults` and `parseResultsWith` had been using `lenientDecoder` and it caused some unintuitive behavior ([#64](https://github.com/maoe/influxdb-haskell/issues/64), [#66](https://github.com/maoe/influxdb-haskell/issues/66)). Now they use `strictDecoder` instead.+* `parseErrorObject` now doesn't fail. It returns the error message of a response.+* `parseQueryField` which has been deprecated is now deleted.+* `QueryResults` instance for `ShowSeries` was broken. This is fixed.+* The constructor of `Decoder`, `parseResultsWith`, and `parseResultsWithDecoder` have been hidden from the top-level module. They're still available from `Database.InfluxDB.JSON`.++See [#68](https://github.com/maoe/influxdb-haskell/pull/68/files) for how to migrate your code from v1.7.x to v1.8.x.++## v1.7.1.6 - 2020-06-03++* Relax upper version bound for doctest++## v1.7.1.5 - 2020-05-27++* Relax upper version bound for http-client++## v1.7.1.4 - 2020-05-27++* Relax upper version bound for aeson+* Fix a GHC warning++## v1.7.1.3 - 2020-04-03++* Relax upper version bound for base to support GHC 8.10.1++## v1.7.1.2 - 2020-02-08++* Relax upper version bound for lens+* Fix documentation bugs+* Extend doctests+* Test with GHC 8.8.2++## v1.7.1.1 - 2019-09-09++* Relax upper version bound for lens++## v1.7.1 - 2019-07-19++* Escape backslashes when encoding `Line`s (#75)++## v1.7.0 - 2019-05-03++* Support GHC 8.8.1-alpha1+ * The types of `getField` and `getTag` have changed+* Relax upper version bounds for clock and network++## v1.6.1.3 - 2019-03-26++* Drop unused dependency on QuickCheck++## v1.6.1.2 - 2019-01-21++* Relax upper version bound for network++## v1.6.1.1 - 2019-01-10++* Relax upper version bound for http-client++## v1.6.1 - 2018-11-20++* Add secureServer smart constructor for Server+* Test with InfluxDB 1.7.1 and newer GHCs including 8.6.2+* Enhace Haddock comments++## v1.6.0.9 - 2018-09-11++* Relax upper version bound for network++## v1.6.0.8 - 2018-09-04++* Relax upper version bound for QuickCheck++## v1.6.0.7 - 2018-07-23++* Relax upper version bound for base to support GHC 8.6 (#69)++## v1.6.0.6 - 2018-07-07++* Relax upper version bound for lens++## v1.6.0.5 - 2018-06-25++* Relax upper version bound for doctest++## v1.6.0.4 - 2018-06-18++* Relax upper version bound for containers++## v1.6.0.3 - 2018-06-11++* Relax upper version bound for aeson++## v1.6.0.2 - 2018-04-29++* Relax upper version bound for network++## v1.6.0.1 - 2018-04-20++* Relax upper version bound for foldl++## v1.6.0 - 2018-04-14++This release includes a few significant breaking changes.++* Deprecate the confusing parseQueryField and re-export parseJSON instead+* Rewrite the QueryResults instances for tuples+* Add Timestamp instance for TimeSpec (#59)+* Extend haddock comments++## v1.5.2 - 2018-04-11++* Export parseResultsWithDecoder, Decoder, lenientDecoder and strictDecoder from Database.InfluxDB+* Extend haddock comments++## v1.5.1 - 2018-03-29++* Add basic auth support for query (#58)++## v1.5.0 - 2018-03-15++* Change UnexpectedResponse constructor to include the request and throw it in place of UserError in query/write/manage+* Relax upper version bound for doctest+* Extend Haddock comments in Database.InfluxDB.Line++The first item is a breaking change.++## v1.4.0 - 2018-03-13++* Implement proper escaping/quoting for queries ([#54](https://github.com/maoe/influxdb-haskell/pull/54))+* Relax upper version bound for aeson+* Test against InfluxDB 1.5++## v1.3.0.1 - 2018-03-06++* Relax upper version bounds for doctest and QuickCheck++## v1.3.0 - 2018-03-05++* Relax upper version bound for base ([#51](https://github.com/maoe/influxdb-haskell/pull/51))+* Implement proper escaping and quoting for special characters ([#51](https://github.com/maoe/influxdb-haskell/pull/51), [#52](https://github.com/maoe/influxdb-haskell/pull/52))+ * Introduce the Measurement type and accompanying functions+* Fix a bug in the HTTP writer where the precision parameter is ignored when constructing requests+* Some minor doctest fixes++## v1.2.2.3 - 2018-01-30++* Relax upper version bounds for http-types, lens and time++## v1.2.2.2 - 2017-11-30++* Relax upper version bounds for http-types and tasty-hunit++## v1.2.2.1 - 2017-11-30++* Relax upper version bound for http-types++## v1.2.2 - 2017-06-26++* A couple of documentation fixes+* Add `Ord` instance for `Server`++## v1.2.1 - 2017-06-19++* Export `formatDatabase` and `formatKey` from `Database.InfluxDB` for convenience++## v1.2.0 - 2017-06-19++There are a lot of breaking changes in this release. The API has been cleaned up+and a lot of Haddock comments are added extensively.++* The `FieldVal` has been renamed to `Field` which takes `Nullability` as a type parameter.+* `localServer` has been renamed to `defaultServer`+* Some constructors in `InfluxException` have been renamed+ * `BadRequest` to `ClientError`+ * `IllformedJSON` to `UnexpectedResponse`+* Added a smart constructor `credentials` for `Credentials`+* Dropped `parseTimestamp` and added `parseUTCTime`+* `ping` handles timeout proerply and throws `InfluxException` on failure+* `PingResult` has been renamed to `Pong` and is now an abstract data type.+* `PingParams` has been turned into an abstract data type.+* `waitForLeader` has been renamed to `timeout`.+* `parsekey` has been removed. `getField` and `parseQueryField` can be used instead.+* Drop support for `http-client < 0.5`++## v1.1.2.2 - 2017-05-31++* Relax upper version bound for foldl++## v1.1.2.1 - 2017-05-02++* Relax version bounds for base and aeson++## v1.1.2 - 2017-04-10++* Tighten lower version bound for base [#43](https://github.com/maoe/influxdb-haskell/issues/43)+* Add `Database.InfluxDB.Format.{string,byteString8}`++## v1.1.1 - 2017-03-29++* Relax unnecessary Traversable constraints to Foldable++## v1.1.0 - 2017-03-23++* Handle empty "values" in parseSeriesBody++## v1.0.0 - 2017-03-03++The library was completely rewritten and support for older InfluxDB has been dropped.++* Support for InfluxDB 1.2+ ## v0.10.0 - 2016-05-17 * Fix a typo in a Haddock comment (#28)@@ -22,7 +292,7 @@ * Add `writeSeriesData` * Relax upper version bound for exceptions * Drop support for old retry package- * retry < 0.6 had an unexpected behavior wrt exception masking state (https://github.com/Soostone/retry/pull/12)+ * retry < 0.6 had an unexpected behavior wrt exception masking state (https://github.com/Soostone/retry/pull/12) ## v0.9.0.1 - 2015-01-06 @@ -37,7 +307,7 @@ ## v0.8.0 - 2014-11-07 * Retry on connection failure and response timeout in addition to IOException- * Note that this may break existing code silently+ * Note that this may break existing code silently ## v0.7.1.1 - 2014-09-19 @@ -51,15 +321,15 @@ ## v0.7.0 - 2014-09-12 * Support for influxdb v0.8 (#15)- * Add shard spaces API- * Add `configureDatabase`+ * 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)- * `newServerPoolWithRetrySettings` has been renamed to `newServerPoolWithRetryPolicy`+ * `newServerPoolWithRetrySettings` has been renamed to `newServerPoolWithRetryPolicy` * `serverRetrySettings` field in `ServerPool` has been renamed to `serverRetryPolicy` * Support for network-uri (#17) @@ -71,9 +341,9 @@ * Add `InfluxException` type and use it when decoding JSON or SeriesData (#12) * New API- * `ping`- * `listInterfaces`- * `isInSync`+ * `ping`+ * `listInterfaces`+ * `isInSync` * BUGFIX: Fix `when expecting a Float, encountered Int instead` error (#14) ## v0.4.2 - 2014-06-06@@ -95,8 +365,8 @@ ## v0.3.0 - 2014-06-03 * Support for InfluxDB v0.7- * Renamed `username` field for `/cluster_admins` to `user`- * No support for the old field name+ * Renamed `username` field for `/cluster_admins` to `user`+ * No support for the old field name ## v0.2.2 - 2014-05-08
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2015, Mitsutoshi Aoe+Copyright (c) 2014-2020, Mitsutoshi Aoe All rights reserved.
README.md view
@@ -1,13 +1,22 @@-Haskell client library for InfluxDB-==========-[](https://travis-ci.org/maoe/influxdb-haskell?branch=develop)-[](https://coveralls.io/r/maoe/influxdb-haskell?branch=develop)-[](https://gitter.im/maoe/influxdb-haskell)+# InfluxDB client library for Haskell -Support for current version of InfluxDB is under development.+[](https://hackage.haskell.org/package/influxdb)+[](http://packdeps.haskellers.com/feed?needle=influxdb)+[](https://github.com/maoe/influxdb-haskell/actions/workflows/haskell-ci.yml)+[](https://matrix.hackage.haskell.org/package/influxdb)+[](https://gitter.im/maoe/influxdb-haskell?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) -Contact information-----------+Currently this library is tested against InfluxDB 1.8. InfluxDB 2 isn't supported (yet).++## Getting started++There is [a quick start guide](https://hackage.haskell.org/package/influxdb/docs/Database-InfluxDB.html) on Hackage.++## Running tests++Either `cabal new-test` or `stack test` runs the doctests in Haddock comments. Note that they need a local running InfluxDB server.++## Contact information Contributions and bug reports are welcome!
Setup.hs view
@@ -1,2 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+ The doctests test-suite will not work as a result. \+ To fix this, install cabal-doctest before configuring.+#endif+ import Distribution.Simple++main :: IO () main = defaultMain++#endif
+ cabal.project view
@@ -0,0 +1,4 @@+packages: .++package *+ test-show-details: direct
examples/random-points.hs view
@@ -1,26 +1,29 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TemplateHaskell #-}-import Control.Applicative-import Control.Exception as E-import Control.Monad-import Control.Monad.Trans-import Data.Function (fix)-import Data.Time.Clock.POSIX+import Data.Foldable+import Data.Traversable import System.Environment import System.IO-import qualified Data.Text as T+import Text.Printf (printf) +import Control.Lens+import Data.Aeson+import Data.Optional (Optional(Default))+import Data.Time.Clock.POSIX import System.Random.MWC (Variate(..))+import qualified Control.Foldl as L+import qualified Data.Map.Strict as Map+import qualified Data.Text as T import qualified Network.HTTP.Client as HC import qualified System.Random.MWC as MWC import Database.InfluxDB-import Database.InfluxDB.TH-import qualified Database.InfluxDB.Stream as S+import qualified Database.InfluxDB.Format as F+import qualified Database.InfluxDB.Manage as M oneWeekInSeconds :: Int oneWeekInSeconds = 7*24*60*60@@ -29,74 +32,60 @@ main = do [read -> (numPoints :: Int), read -> (batches :: Int)] <- getArgs hSetBuffering stdout NoBuffering- HC.withManager managerSettings $ \manager -> do- config <- newConfig manager+ manager' <- HC.newManager managerSettings - let db = "ctx"- dropDatabase config db- `E.catch`- -- Ignore exceptions here- \(_ :: HC.HttpException) -> return ()- createDatabase config "ctx"- gen <- MWC.create- flip fix batches $ \outerLoop !m -> when (m > 0) $ do- postWithPrecision config db SecondsPrecision $ withSeries "ct1" $- flip fix numPoints $ \innerLoop !n -> when (n > 0) $ do- !timestamp <- liftIO $ (-)- <$> getPOSIXTime- <*> (fromIntegral <$> uniformR (0, oneWeekInSeconds) gen)- !value <- liftIO $ uniform gen- writePoints $ Point value (Time timestamp)- innerLoop $ n - 1- outerLoop $ m - 1+ let+ ctx = "ctx"+ ct1 = "ct1"+ qparams = queryParams ctx+ & manager .~ Right manager'+ & precision .~ RFC3339 - 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 db "select * from ct1;" $ S.fold step ()- where- step _ series = do- case fromSeriesData series of- Left reason -> hPutStrLn stderr reason- Right points -> mapM_ print (points :: [Point])- putStrLn "--"+ M.manage qparams $ F.formatQuery ("DROP DATABASE "%F.database) ctx+ M.manage qparams $ F.formatQuery ("CREATE DATABASE "%F.database) ctx -newConfig :: HC.Manager -> IO Config-newConfig manager = do- pool <- newServerPool localServer []- return Config- { configCreds = rootCreds- , configServerPool = pool- , configHttpManager = manager- }+ let wparams = writeParams ctx & manager .~ Right manager' + gen <- MWC.create+ for_ [1..batches] $ \_ -> do+ batch <- for [1..numPoints] $ \_ -> do+ !time <- (-)+ <$> getPOSIXTime+ <*> (fromIntegral <$> uniformR (0, oneWeekInSeconds) gen)+ !value <- uniform gen+ return (time, value)+ writeBatch wparams $ flip map batch $ \(time, value) ->+ Line ct1+ (Map.fromList [])+ (Map.fromList [("value", nameToFVal value)])+ (Just time)++ queryChunked qparams Default (F.formatQuery ("SELECT * FROM "%F.measurement) ct1) $+ L.mapM_ $ traverse_ $ \Row {..} ->+ printf "%s:\t%s\n"+ (show $ posixSecondsToUTCTime rowTime)+ (show rowValue)+ managerSettings :: HC.ManagerSettings managerSettings = HC.defaultManagerSettings- { HC.managerResponseTimeout = Just $ 60*(10 :: Int)^(6 :: Int)- } -data Point = Point- { pointValue :: !Name- , pointTime :: !Time+data Row = Row+ { rowTime :: POSIXTime+ , rowValue :: Name } deriving Show -newtype Time = Time POSIXTime- deriving Show--instance ToValue Time where- toValue (Time epoch) = toValue $ epochInSeconds epoch- where- epochInSeconds :: POSIXTime -> Value- epochInSeconds = Int . floor--instance FromValue Time where- parseValue (Int n) = return $ Time $ fromIntegral n- parseValue (Float d) = return $ Time $ realToFrac d- parseValue v = typeMismatch "Int or Float" v+instance QueryResults Row where+ parseMeasurement prec _ _ columns fields = do+ rowTime <- getField "time" columns fields >>= parsePOSIXTime prec+ String name <- getField "value" columns fields+ rowValue <- case name of+ "foo" -> return Foo+ "bar" -> return Bar+ "baz" -> return Baz+ "quu" -> return Quu+ "qux" -> return Qux+ _ -> fail $ "unknown name: " ++ show name+ return Row {..} data Name = Foo@@ -106,31 +95,11 @@ | Qux deriving (Enum, Bounded, Show) -instance ToValue Name where- toValue Foo = String "foo"- toValue Bar = String "bar"- toValue Baz = String "baz"- toValue Quu = String "quu"- toValue Qux = String "qux"--instance FromValue Name where- parseValue (String name) = case name of- "foo" -> return Foo- "bar" -> return Bar- "baz" -> return Baz- "quu" -> return Quu- "qux" -> return Qux- _ -> fail $ "Incorrect string: " ++ T.unpack name- parseValue v = typeMismatch "String" v+nameToFVal :: Name -> LineField+nameToFVal = FieldString . T.toLower . T.pack . show instance Variate Name where uniform = uniformR (minBound, maxBound) uniformR (lower, upper) g = do name <- uniformR (fromEnum lower, fromEnum upper) g return $! toEnum name---- Instance deriving--deriveSeriesData defaultOptions- { fieldLabelModifier = stripPrefixLower "point" }- ''Point
+ examples/write-udp.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where+import Control.Exception++import Control.Lens+import Data.Time.Clock+import Network.Socket++import Database.InfluxDB+import qualified Database.InfluxDB.Write.UDP as UDP++main :: IO ()+main = bracket (socket AF_INET Datagram defaultProtocol) close $ \sock -> do+ let localhost = tupleToHostAddress (127, 0, 0, 1)+ let params = UDP.writeParams sock $ SockAddrInet 8089 localhost+ tags1 =+ [ ("tag1", "A")+ , ("tag2", "B")+ ]+ fields1 =+ [ ("val1", FieldInt 10)+ , ("val2", FieldBool True)+ ]+ fields2 =+ [ ("val1", FieldInt 1)+ , ("val2", FieldBool False)+ ]+ UDP.write params $+ Line "measurement1" tags1 fields1 (Nothing :: Maybe UTCTime)+ now <- getCurrentTime+ UDP.write+ (params & UDP.precision .~ Millisecond)+ (Line "measurement1" tags1 fields2 (Just now))
influxdb.cabal view
@@ -1,19 +1,36 @@+cabal-version: 1.24 name: influxdb-version: 0.10.0-synopsis: Haskell client library for InfluxDB-description: Haskell client library for InfluxDB+version: 1.9.3.2+synopsis: InfluxDB client library for Haskell+description:+ @influxdb@ is an InfluxDB client library for Haskell.+ .+ See "Database.InfluxDB" for a quick start guide. homepage: https://github.com/maoe/influxdb-haskell license: BSD3 license-file: LICENSE author: Mitsutoshi Aoe-maintainer: Mitsutoshi Aoe <maoe@foldr.in>-copyright: Copyright (C) 2014-2015 Mitsutoshi Aoe+maintainer: Mitsutoshi Aoe <me@maoe.name>+copyright: Copyright (C) 2014-2024 Mitsutoshi Aoe category: Database-build-type: Simple-cabal-version: >= 1.10+build-type: Custom+tested-with:+ GHC == 8.4.4+ GHC == 8.6.5+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.8+ GHC == 9.4.8+ GHC == 9.6.6+ GHC == 9.8.2+ GHC == 9.10.1 extra-source-files: README.md+ cabal.project++extra-doc-files: CHANGELOG.md flag examples@@ -21,126 +38,138 @@ default: False manual: True -flag aeson-070- description: Use aeson >= 0.7.0- default: True- manual: False--flag network-uri- description: Get Network.URI from the network-uri package- default: True+custom-setup+ setup-depends:+ base >= 4 && < 5+ , Cabal >= 1.24 && < 3.13+ , cabal-doctest >= 1 && < 1.1 library exposed-modules: Database.InfluxDB- Database.InfluxDB.Decode- Database.InfluxDB.Encode- Database.InfluxDB.Http- Database.InfluxDB.Lens- -- Database.InfluxDB.Protobuf- -- Database.InfluxDB.Query- Database.InfluxDB.Stream+ Database.InfluxDB.Format+ Database.InfluxDB.JSON+ Database.InfluxDB.Line+ Database.InfluxDB.Manage+ Database.InfluxDB.Ping+ Database.InfluxDB.Query Database.InfluxDB.Types- Database.InfluxDB.TH+ Database.InfluxDB.Write+ Database.InfluxDB.Write.UDP other-modules:- Database.InfluxDB.Types.Internal+ Database.InfluxDB.Internal.Text other-extensions: BangPatterns CPP- ConstraintKinds+ DataKinds DeriveDataTypeable+ DeriveGeneric+ ExistentialQuantification FlexibleInstances+ FunctionalDependencies+ GADTs GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ MultiParamTypeClasses NamedFieldPuns OverloadedStrings- RankNTypes RecordWildCards ScopedTypeVariables+ StandaloneDeriving TemplateHaskell- TypeSynonymInstances ViewPatterns ghc-options: -Wall build-depends:- base >= 4 && < 5.0- , attoparsec < 0.14- , bytestring- , containers- , data-default-class- , dlist- , exceptions >= 0.5 && < 0.9- , http-client < 0.5- , mtl < 2.3- , retry >= 0.7 && < 0.8- , tagged- , template-haskell- , text < 1.3- , vector-- if flag(aeson-070)- build-depends:- aeson >= 0.7.0 && < 0.12- , scientific >= 0.2- else- build-depends:- aeson >= 0.6.1.0 && < 0.7.0-- if flag(network-uri)- build-depends:- network-uri >= 2.6- else- build-depends:- network < 2.6-- if impl(ghc < 7.6)- build-depends:- ghc-prim-+ base >= 4.11 && < 4.21+ , aeson >= 0.7 && < 2.3+ , attoparsec < 0.15+ , attoparsec-aeson >= 2.1 && < 2.3+ , bytestring >= 0.10 && < 0.13+ , clock >= 0.7 && < 0.9+ , containers >= 0.5 && < 0.8+ , foldl < 1.5+ , http-client >= 0.5 && < 0.8+ , http-types >= 0.8.6 && < 0.13+ , lens >= 4.9 && < 5.4+ , network >= 2.6 && < 3.3+ , optional-args >= 1.0 && < 1.1+ , scientific >= 0.3.3 && < 0.4+ , tagged >= 0.1 && < 0.9+ , text < 2.2+ , time >= 1.5 && < 1.15+ , unordered-containers < 0.3+ , vector >= 0.10 && < 0.14 hs-source-dirs: src default-language: Haskell2010 -test-suite test-suite+test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ build-depends:+ base+ , doctest >= 0.11.3 && < 0.23+ , influxdb+ , template-haskell < 2.23+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ default-language: Haskell2010++test-suite regressions type: exitcode-stdio-1.0- main-is: test-suite.hs+ main-is: regressions.hs build-depends: base- , http-client- , HUnit+ , containers , influxdb- , mtl- , tasty- , tasty-hunit == 0.9.*- , tasty-quickcheck- , tasty-th- , text+ , lens+ , tasty < 1.6+ , tasty-hunit < 1.11+ , time+ , raw-strings-qq >= 1.1 && < 1.2 , vector+ ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010 executable influx-random-points- if flag(examples)- buildable: True- else+ if !flag(examples) buildable: False hs-source-dirs: examples main-is: random-points.hs ghc-options: -Wall build-depends:- base+ aeson+ , base , bytestring+ , containers+ , foldl >= 1.1.3 , http-client , influxdb- , mtl+ , lens , mwc-random+ , optional-args , text , time+ , vector default-language: Haskell2010 +executable influx-write-udp+ if !flag(examples)+ buildable: False+ hs-source-dirs: examples+ main-is: write-udp.hs+ ghc-options: -Wall+ build-depends:+ base+ , containers+ , influxdb+ , lens+ , network+ , time+ default-language: Haskell2010+ source-repository head type: git branch: develop- location: https://github.com/maoe/influxdb-haskell.git--source-repository this- type: git- tag: v0.10.0 location: https://github.com/maoe/influxdb-haskell.git
src/Database/InfluxDB.hs view
@@ -1,94 +1,238 @@+{- |+stability: experimental+portability: GHC+-} module Database.InfluxDB- (- -- * Series data types- Series(..), seriesColumns, seriesPoints- , SeriesData(..)- , Value(..)+ ( -- $intro - -- ** Encoding- , ToSeriesData(..)- , ToValue(..)+ -- * Writing data via HTTP+ -- $write+ write+ , writeBatch+ , writeByteString - -- ** Decoding- , FromSeries(..), fromSeries- , FromSeriesData(..), fromSeriesData- , FromValue(..), fromValue+ -- ** Write parameters+ , WriteParams+ , writeParams+ , retentionPolicy - , withValues, (.:), (.:?), (.!=)- , typeMismatch+ -- ** The Line protocol+ , Line(Line)+ , measurement+ , tagSet+ , fieldSet+ , timestamp - -- * HTTP API- -- ** Data types- , Config(..)- , Credentials(..), rootCreds- , TimePrecision(..)- , Server(..), localServer- , ServerPool, newServerPool- , newServerPoolWithRetryPolicy- , Database(..)- , User(..)- , Admin(..)- , Ping(..)- , ShardSpace(..)+ , Field(..)+ , LineField+ , QueryField+ , Timestamp(..)+ , precisionScale+ , precisionName - -- *** Exception- , InfluxException(..)+ -- * Querying data+ -- $query+ , Query+ , query+ , queryChunked - -- ** Writing Data+ -- ** Query construction+ -- $query-construction+ , F.formatQuery+ , (F.%) - -- *** Updating Points- , post, postWithPrecision- , SeriesT, PointT- , writeSeries- , writeSeriesData- , withSeries- , writePoints+ -- ** Query parameters+ , QueryParams+ , queryParams+ , authentication+ , decoder - -- *** Deleting Points- , deleteSeries+ -- ** Parsing results+ , QueryResults(..)+ , Decoder+ , lenientDecoder+ , strictDecoder - -- ** Querying Data- , query- , Stream(..)- , queryChunked+ -- ** Helper types and functions+ , Ignored+ , Empty+ , Tagged(..)+ , untag - -- ** Administration & Security- -- *** Creating and Dropping Databases- , listDatabases- , createDatabase- , dropDatabase+ , getField+ , getTag+ , parseJSON+ , parseUTCTime+ , parsePOSIXTime - , DatabaseRequest(..)- , configureDatabase - -- *** Security- -- **** Shard spaces- , ShardSpaceRequest(..)- , listShardSpaces- , createShardSpace- , dropShardSpace+ -- * Database management+ , manage - -- **** Cluster admin- , listClusterAdmins- , authenticateClusterAdmin- , addClusterAdmin- , updateClusterAdminPassword- , deleteClusterAdmin- -- **** Database user- , listDatabaseUsers- , authenticateDatabaseUser- , addDatabaseUser- , updateDatabaseUserPassword- , deleteDatabaseUser- , grantAdminPrivilegeTo- , revokeAdminPrivilegeFrom+ -- * Common data types and classes+ , Precision(..)+ , Database+ , F.formatDatabase+ , Measurement+ , F.formatMeasurement+ , Key+ , F.formatKey - -- *** Other API- , ping- , isInSync+ , Server+ , defaultServer+ , secureServer+ , host+ , port+ , ssl++ , Credentials+ , credentials+ , user+ , password++ -- * Exception+ , InfluxException(..)++ , HasServer(..)+ , HasDatabase(..)+ , HasPrecision(..)+ , HasManager(..) ) where -import Database.InfluxDB.Decode-import Database.InfluxDB.Encode-import Database.InfluxDB.Http+import Database.InfluxDB.JSON+import Database.InfluxDB.Line+import Database.InfluxDB.Manage (manage)+import Database.InfluxDB.Query import Database.InfluxDB.Types+import Database.InfluxDB.Write+import qualified Database.InfluxDB.Format as F++{- $intro+= Getting started++This tutorial assumes the following language extensions and imports.++>>> :set -XOverloadedStrings+>>> :set -XRecordWildCards+>>> :set -XTypeApplications+>>> import Database.InfluxDB+>>> import qualified Database.InfluxDB.Format as F+>>> import Control.Lens+>>> import qualified Data.Map as Map+>>> import Data.Time+>>> import qualified Data.Vector as V++The examples below roughly follows the+ [README](https://github.com/influxdata/influxdb/blob/0b4528b26de43d5504ec0623c184540f7c3e1a54/client/README.md)+in the official Go client library.++== Creating a database++This library assumes the [lens](https://hackage.haskell.org/package/lens)+package in some APIs. Here we use 'Control.Lens.?~' to set the authentication+parameters of type @Maybe 'Credentials'@.++Also note that in order to construct a 'Query', we use 'F.formatQuery' with the+'F.database' formatter. There are many other formatters defined in+"Database.InfluxDB.Format".++>>> let db = "square_holes"+>>> let bubba = credentials "bubba" "bumblebeetuna"+>>> let p = queryParams db & authentication ?~ bubba+>>> manage p $ formatQuery ("DROP DATABASE "%F.database) db+>>> manage p $ formatQuery ("CREATE DATABASE "%F.database) db++== Writing data++'write' or 'writeBatch' can be used to write data. In general 'writeBatch'+should be used for efficiency when writing multiple data points.++>>> let wp = writeParams db & authentication ?~ bubba & precision .~ Second+>>> let cpuUsage = "cpu_usage"+>>> :{+writeBatch wp+ [ Line @UTCTime cpuUsage (Map.singleton "cpu" "cpu-total")+ (Map.fromList+ [ ("idle", FieldFloat 10.1)+ , ("system", FieldFloat 53.3)+ , ("user", FieldFloat 46.6)+ ])+ (Just $ parseTimeOrError False defaultTimeLocale+ "%F %T%Q %Z"+ "2017-06-17 15:41:40.42659044 UTC")+ ]+:}++Note that the type signature of the timestamp is necessary. Otherwise it doesn't+type check.++== Querying data++=== Using an one-off tuple++If all the field types are an instance of 'Data.Aeson.FromJSON', we can use a+tuple to store the results.++>>> :set -XDataKinds -XOverloadedStrings -XTypeOperators+>>> type CPUUsage = (Tagged "time" UTCTime, Tagged "idle" Double, Tagged "system" Double, Tagged "user" Double)+>>> v <- query @CPUUsage p $ formatQuery ("SELECT * FROM "%F.measurement) cpuUsage+>>> v+[(Tagged 2017-06-17 15:41:40 UTC,Tagged 10.1,Tagged 53.3,Tagged 46.6)]++Note that the type signature on query here is also necessary to type check.+We can remove the tags using 'untag':++>>> V.map (\(a, b, c, d) -> (untag a, untag b, untag c, untag d)) v :: V.Vector (UTCTime, Double, Double, Double)+[(2017-06-17 15:41:40 UTC,10.1,53.3,46.6)]++Or even using 'Data.Coerce.coerce':++>>> import Data.Coerce+>>> coerce v :: V.Vector (UTCTime, Double, Double, Double)+[(2017-06-17 15:41:40 UTC,10.1,53.3,46.6)]++=== Using a custom data type++We can define our custom data type and write a 'QueryResults' instance+instead. 'getField', 'parseUTCTime' and 'parseJSON' etc are avilable to+make it easier to write a JSON decoder.++>>> :{+data CPUUsage = CPUUsage+ { time :: UTCTime+ , cpuIdle, cpuSystem, cpuUser :: Double+ } deriving Show+instance QueryResults CPUUsage where+ parseMeasurement prec _name _tags columns fields = do+ time <- getField "time" columns fields >>= parseUTCTime prec+ cpuIdle <- getField "idle" columns fields >>= parseJSON+ cpuSystem <- getField "system" columns fields >>= parseJSON+ cpuUser <- getField "user" columns fields >>= parseJSON+ return CPUUsage {..}+:}++>>> query @CPUUsage p $ formatQuery ("SELECT * FROM "%F.measurement) cpuUsage+[CPUUsage {time = 2017-06-17 15:41:40 UTC, cpuIdle = 10.1, cpuSystem = 53.3, cpuUser = 46.6}]+-}++{- $write+InfluxDB has two ways to write data into it, via HTTP and UDP. This module+only exports functions for the HTTP API. For UDP, see+"Database.InfluxDB.Write.UDP".+-}++{- $query+'query' and 'queryChunked' can be used to query data. If your dataset fits your+memory, 'query' is easier to use. If it doesn't, use 'queryChunked' to stream+data.+-}++{- $query-construction+There are various utility functions available in "Database.InfluxDB.Format".+This module is designed to be imported as qualified:++@+import "Database.InfluxDB"+import qualified "Database.InfluxDB.Format" as F+@+-}
− src/Database/InfluxDB/Decode.hs
@@ -1,232 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Database.InfluxDB.Decode- ( FromSeries(..), fromSeries- , FromSeriesData(..), fromSeriesData, fromSeriesData_- , withValues, (.:), (.:?), (.!=)- , FromValue(..), fromValue- , Parser, ValueParser, typeMismatch- ) where-import Control.Applicative-import Control.Monad.Reader-import Data.Either (rights)-import Data.Int-import Data.Word-import Data.Map (Map)-import Data.Maybe (fromMaybe)-import Data.Vector (Vector)-import Data.Tuple (swap)-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as V-import Prelude--import Database.InfluxDB.Types---- | A type that can be converted from a 'Series'.-class FromSeries a where- parseSeries :: Series -> Parser a--instance FromSeries Series where- parseSeries = return--instance FromSeries SeriesData where- parseSeries = return . seriesData---- | Converte a value from a 'Series', failing if the types do not match.-fromSeries :: FromSeries a => Series -> Either String a-fromSeries = runParser . parseSeries---- | A type that can be converted from a 'SeriesData'. A typical implementation--- is as follows.------ > import Control.Applicative ((<$>), (<*>))--- > import qualified Data.Vector as V--- >--- > data Event = Event Text EventType--- > data EventType = Login | Logout--- >--- > instance FromSeriesData Event where--- > parseSeriesData = withValues $ \values -> Event--- > <$> values .: "user"--- > <*> values .: "type"--- >--- > instance FromValue EventType-class FromSeriesData a where- parseSeriesData :: Vector Column -> Vector Value -> Parser a--instance FromSeriesData SeriesData where- parseSeriesData columns values = return SeriesData- { seriesDataColumns = columns- , 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)- seriesDataPoints---- | Same as @fromSeriesData@ but ignores parse errors and returns only--- successful data.-fromSeriesData_ :: FromSeriesData a => SeriesData -> [a]-fromSeriesData_ SeriesData {..} = rights $ map- (runParser . parseSeriesData seriesDataColumns)- seriesDataPoints---- | Helper function to define 'parseSeriesData' from 'ValueParser's.-withValues- :: (Vector Value -> ValueParser a)- -> Vector Column -> Vector Value -> Parser a-withValues f columns values =- runReaderT m $ Map.fromList $ map swap $ V.toList $ V.indexed columns- where- ValueParser m = f values---- | Retrieve the value associated with the given column. The result is 'empty'--- if the column is not present or the value cannot be converted to the desired--- type.-(.:) :: FromValue a => Vector Value -> Column -> ValueParser a-values .: column = do- found <- asks $ Map.lookup column- case found of- Nothing -> liftParser $ parseError $ "No such column: " ++ T.unpack column- Just idx -> do- value <- V.indexM values idx- liftParser $ parseValue value---- | Retrieve the value associated with the given column. The result is--- 'Nothing' if the column is not present or the value cannot be converted to--- the desired type.-(.:?) :: FromValue a => Vector Value -> Column -> ValueParser (Maybe a)-values .:? column = do- found <- asks $ Map.lookup column- case found of- Nothing -> return Nothing- Just idx ->- case values V.!? idx of- Nothing -> return Nothing- Just value -> liftParser $ parseValue value---- | Helper for use in combination with '.:?' to provide default values for--- optional columns.-(.!=) :: Parser (Maybe a) -> a -> Parser a-p .!= def = fromMaybe def <$> p---- | A type that can be converted from a 'Value'.-class FromValue a where- parseValue :: Value -> Parser a---- | Converte a value from a 'Value', failing if the types do not match.-fromValue :: FromValue a => Value -> Either String a-fromValue = runParser . parseValue--instance FromValue Value where- parseValue = return--instance FromValue Bool where- parseValue (Bool b) = return b- parseValue v = typeMismatch "Bool" v--instance FromValue a => FromValue (Maybe a) where- parseValue Null = return Nothing- parseValue v = Just <$> parseValue v--instance FromValue Int where- parseValue (Int n) = return $ fromIntegral n- parseValue v = typeMismatch "Int" v--instance FromValue Int8 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Int8) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Int8: " ++ show n- parseValue v = typeMismatch "Int8" v--instance FromValue Int16 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Int16) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Int16: " ++ show n- parseValue v = typeMismatch "Int16" v--instance FromValue Int32 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Int32) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Int32: " ++ show n- parseValue v = typeMismatch "Int32" v--instance FromValue Int64 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Int64) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Int64: " ++ show n- parseValue v = typeMismatch "Int64" v--instance FromValue Word8 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Word8) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Word8: " ++ show n- parseValue v = typeMismatch "Word8" v--instance FromValue Word16 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Word16) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Word16: " ++ show n- parseValue v = typeMismatch "Word16" v--instance FromValue Word32 where- parseValue (Int n)- | n <= fromIntegral (maxBound :: Word32) = return $ fromIntegral n- | otherwise = parseError $ "Larger than the maximum Word32: " ++ show n- parseValue v = typeMismatch "Word32" v--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- parseValue (String xs) = return xs- parseValue v = typeMismatch "Text" v--instance FromValue TL.Text where- parseValue (String xs) = return $ TL.fromStrict xs- parseValue v = typeMismatch "lazy Text" v--instance FromValue String where- parseValue (String xs) = return $ T.unpack xs- parseValue v = typeMismatch "String" v--typeMismatch- :: String- -> Value- -> Parser a-typeMismatch expected actual = parseError $- "when expecting a " ++ expected ++- ", encountered " ++ name ++ " instead"- where- name = case actual of- Int _ -> "Int"- Float _ -> "Float"- String _ -> "String"- Bool _ -> "Bool"- Null -> "Null"--newtype Parser a = Parser- { runParser :: Either String a- } deriving (Functor, Applicative, Monad)--type ColumnIndex = Map Column Int--newtype ValueParser a = ValueParser (ReaderT ColumnIndex Parser a)- deriving (Functor, Applicative, Monad, MonadReader ColumnIndex)--liftParser :: Parser a -> ValueParser a-liftParser = ValueParser . ReaderT . const--parseError :: String -> Parser a-parseError = Parser . Left
− src/Database/InfluxDB/Encode.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Database.InfluxDB.Encode- ( ToSeries(..)- , ToSeriesData(..), toSeriesData- , ToValue(..)- ) where-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Proxy-import Data.Vector (Vector)-import Data.Word (Word8, Word16, Word32)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import Database.InfluxDB.Types---- | A type that can be converted to a 'Series'.-class ToSeries a where- toSeries :: a -> Series---- | A type that can be converted to a 'SeriesData'. A typical implementation is--- as follows.------ > import qualified Data.Vector as V--- >--- > data Event = Event Text EventType--- > data EventType = Login | Logout--- >--- > instance ToSeriesData Event where--- > toSeriesColumns _ = V.fromList ["user", "type"]--- > toSeriesPoints (Event user ty) = V.fromList [toValue user, toValue ty]--- >--- > instance ToValue EventType-class ToSeriesData a where- -- | Column names. You can safely ignore the proxy agument.- toSeriesColumns :: Proxy a -> Vector Column- -- | Data points.- toSeriesPoints :: a -> Vector Value--toSeriesData :: forall a. ToSeriesData a => a -> SeriesData-toSeriesData a = SeriesData- { seriesDataColumns = toSeriesColumns (Proxy :: Proxy a)- , seriesDataPoints = [toSeriesPoints a]- }---- | A type that can be stored in InfluxDB.-class ToValue a where- toValue :: a -> Value--instance ToValue Value where- toValue = id--instance ToValue Bool where- toValue = Bool--instance ToValue a => ToValue (Maybe a) where- toValue Nothing = Null- toValue (Just a) = toValue a--instance ToValue Int where- toValue = Int . fromIntegral--instance ToValue Int8 where- toValue = Int . fromIntegral--instance ToValue Int16 where- toValue = Int . fromIntegral--instance ToValue Int32 where- toValue = Int . fromIntegral--instance ToValue Int64 where- toValue = Int--instance ToValue Word8 where- toValue = Int . fromIntegral--instance ToValue Word16 where- toValue = Int . fromIntegral--instance ToValue Word32 where- toValue = Int . fromIntegral--instance ToValue Double where- toValue = Float--instance ToValue T.Text where- toValue = String--instance ToValue TL.Text where- toValue = String . TL.toStrict--instance ToValue String where- toValue = String . T.pack
+ src/Database/InfluxDB/Format.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+module Database.InfluxDB.Format+ ( -- $setup++ -- * The 'Format' type and associated functions+ Format+ , makeFormat+ , (%)++ -- * Formatting functions+ , formatQuery+ , formatDatabase+ , formatMeasurement+ , formatKey++ -- * Formatters for various types+ , database+ , key+ , keys+ , measurement+ , measurements+ , field+ , decimal+ , realFloat+ , text+ , string+ , byteString8+ , time++ -- * Utility functions+ , fromQuery+ ) where+import Control.Category+import Data.Monoid+import Data.String+import Prelude hiding ((.), id)++import Data.Time+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TL+import qualified Data.Text.Lazy.Builder.Int as TL+import qualified Data.Text.Lazy.Builder.RealFloat as TL++import Database.InfluxDB.Internal.Text+import Database.InfluxDB.Types hiding (database)++{- $setup+This module is desined to be imported qualified:++>>> :set -XOverloadedStrings+>>> import qualified Data.ByteString as B+>>> import qualified Database.InfluxDB.Format as F+-}++-- | Serialize a 'Query' to a 'B.ByteString'.+fromQuery :: Query -> B.ByteString+fromQuery (Query q) =+ BL.toStrict $ BB.toLazyByteString $ T.encodeUtf8Builder q++-- | A typed format string. @Format a r@ means that @a@ is the type of formatted+-- string, and @r@ is the type of the formatter.+--+-- >>> :t F.formatQuery+-- F.formatQuery :: F.Format Query r -> r+-- >>> :t F.key+-- F.key :: F.Format r (Key -> r)+-- >>> :t "SELECT * FROM "%F.key+-- "SELECT * FROM "%F.key :: F.Format a (Key -> a)+-- >>> :t F.formatQuery ("SELECT * FROM "%F.key)+-- F.formatQuery ("SELECT * FROM "%F.key) :: Key -> Query+-- >>> F.formatQuery ("SELECT * FROM "%F.key) "series"+-- "SELECT * FROM \"series\""+newtype Format a r = Format { runFormat :: (TL.Builder -> a) -> r }++-- | 'Format's can be composed using @('.')@ from "Control.Category".+--+-- >>> import Control.Category ((.))+-- >>> import Prelude hiding ((.))+-- >>> F.formatQuery ("SELECT * FROM " . F.key) "series"+-- "SELECT * FROM \"series\""+instance Category Format where+ id = Format (\k -> k "")+ fmt1 . fmt2 = Format $ \k ->+ runFormat fmt1 $ \a ->+ runFormat fmt2 $ \b ->+ k (a <> b)++-- | With the OverloadedStrings exension, string literals can be used to write+-- queries.+--+-- >>> "SELECT * FROM series" :: Query+-- "SELECT * FROM series"+instance a ~ r => IsString (Format a r) where+ fromString xs = Format $ \k -> k $ fromString xs++-- | 'Format' specific synonym of @('.')@.+--+-- This is typically easier to use than @('.')@ is because it doesn't+-- conflict with @Prelude.(.)@.+(%) :: Format b c -> Format a b -> Format a c+(%) = (.)++runFormatWith :: (T.Text -> a) -> Format a r -> r+runFormatWith f fmt = runFormat fmt (f . TL.toStrict . TL.toLazyText)++-- | Format a 'Query'.+--+-- >>> F.formatQuery "SELECT * FROM series"+-- "SELECT * FROM series"+-- >>> F.formatQuery ("SELECT * FROM "%F.key) "series"+-- "SELECT * FROM \"series\""+formatQuery :: Format Query r -> r+formatQuery = runFormatWith Query++-- | Format a 'Database'.+--+-- >>> F.formatDatabase "test-db"+-- "test-db"+-- >>> F.formatDatabase ("test-db-"%F.decimal) 0+-- "test-db-0"+formatDatabase :: Format Database r -> r+formatDatabase = runFormatWith Database++-- | Format a 'Measurement'.+--+-- >>> F.formatMeasurement "test-series"+-- "test-series"+-- >>> F.formatMeasurement ("test-series-"%F.decimal) 0+-- "test-series-0"+formatMeasurement :: Format Measurement r -> r+formatMeasurement = runFormatWith Measurement++-- | Format a 'Key'.+--+-- >>> F.formatKey "test-key"+-- "test-key"+-- >>> F.formatKey ("test-key-"%F.decimal) 0+-- "test-key-0"+formatKey :: Format Key r -> r+formatKey fmt = runFormat fmt (Key . TL.toStrict . TL.toLazyText)++-- | Convenience function to make a custom formatter.+makeFormat :: (a -> TL.Builder) -> Format r (a -> r)+makeFormat build = Format $ \k a -> k $ build a++doubleQuote :: T.Text -> TL.Builder+doubleQuote name = "\"" <> TL.fromText name <> "\""++singleQuote :: T.Text -> TL.Builder+singleQuote name = "'" <> TL.fromText name <> "'"++identifierBuilder :: T.Text -> TL.Builder+identifierBuilder = doubleQuote . escapeDoubleQuotes++stringBuilder :: T.Text -> TL.Builder+stringBuilder = singleQuote . escapeSingleQuotes++-- | Format a database name.+--+-- >>> F.formatQuery ("CREATE DATABASE "%F.database) "test-db"+-- "CREATE DATABASE \"test-db\""+database :: Format r (Database -> r)+database = makeFormat $ \(Database name) -> identifierBuilder name++-- | Format an identifier (e.g. field names, tag names, etc).+--+-- Identifiers in InfluxDB protocol are surrounded with double quotes.+--+-- >>> F.formatQuery ("SELECT "%F.key%" FROM series") "field"+-- "SELECT \"field\" FROM series"+-- >>> F.formatQuery ("SELECT "%F.key%" FROM series") "foo\"bar"+-- "SELECT \"foo\\\"bar\" FROM series"+key :: Format r (Key -> r)+key = makeFormat $ \(Key name) -> identifierBuilder name++-- | Format multiple keys.+--+-- >>> F.formatQuery ("SELECT "%F.keys%" FROM series") ["field1", "field2"]+-- "SELECT \"field1\",\"field2\" FROM series"+keys :: Format r ([Key] -> r)+keys = makeFormat $+ mconcat . L.intersperse "," . map (\(Key name) -> identifierBuilder name)++-- | Format a measurement.+--+-- >>> F.formatQuery ("SELECT * FROM "%F.measurement) "test-series"+-- "SELECT * FROM \"test-series\""+measurement :: Format r (Measurement -> r)+measurement = makeFormat $ \(Measurement name) -> identifierBuilder name++-- | Format a measurement.+--+-- >>> F.formatQuery ("SELECT * FROM "%F.measurements) ["series1", "series2"]+-- "SELECT * FROM \"series1\",\"series2\""+measurements :: Format r ([Measurement] -> r)+measurements = makeFormat $+ mconcat . L.intersperse ","+ . map (\(Measurement name) -> identifierBuilder name)++-- | Format an InfluxDB value. Good for field and tag values.+--+-- >>> F.formatQuery ("SELECT * FROM series WHERE "%F.key%" = "%F.field) "location" "tokyo"+-- "SELECT * FROM series WHERE \"location\" = 'tokyo'"+field :: Format r (QueryField -> r)+field = makeFormat $ \case+ FieldInt n -> TL.decimal n+ FieldFloat d -> TL.realFloat d+ FieldString s -> stringBuilder s+ FieldBool b -> if b then "true" else "false"+ FieldNull -> "null"++-- | Format a decimal number.+--+-- >>> F.formatQuery ("SELECT * FROM series WHERE time < now() - "%F.decimal%"h") 1+-- "SELECT * FROM series WHERE time < now() - 1h"+decimal :: Integral a => Format r (a -> r)+decimal = makeFormat TL.decimal++-- | Format a floating-point number.+--+-- >>> F.formatQuery ("SELECT * FROM series WHERE value > "%F.realFloat) 0.1+-- "SELECT * FROM series WHERE value > 0.1"+realFloat :: RealFloat a => Format r (a -> r)+realFloat = makeFormat TL.realFloat++-- | Format a text.+--+-- Note that this doesn't escape the string. Use 'formatKey' to format field+-- values in a query.+--+-- >>> :t F.formatKey F.text+-- F.formatKey F.text :: T.Text -> Key+text :: Format r (T.Text -> r)+text = makeFormat TL.fromText++-- | Format a string.+--+-- Note that this doesn't escape the string. Use 'formatKey' to format field+-- values in a query.+--+-- >>> :t F.formatKey F.string+-- F.formatKey F.string :: String -> Key+string :: Format r (String -> r)+string = makeFormat TL.fromString++-- | Format a UTF-8 encoded byte string.+--+-- Note that this doesn't escape the string. Use 'formatKey' to format field+-- values in a query.+--+-- >>> :t F.formatKey F.byteString8+-- F.formatKey F.byteString8 :: B.ByteString -> Key+byteString8 :: Format r (B.ByteString -> r)+byteString8 = makeFormat $ TL.fromText . T.decodeUtf8++-- | Format a time.+--+-- >>> import Data.Time+-- >>> let Just t = parseTimeM False defaultTimeLocale "%s" "0" :: Maybe UTCTime+-- >>> F.formatQuery ("SELECT * FROM series WHERE time >= "%F.time) t+-- "SELECT * FROM series WHERE time >= '1970-01-01 00:00:00'"+time :: FormatTime time => Format r (time -> r)+time = makeFormat $ \t ->+ "'" <> TL.fromString (formatTime defaultTimeLocale fmt t) <> "'"+ where+ fmt = "%F %X%Q" -- YYYY-MM-DD HH:MM:SS.nnnnnnnnn
− src/Database/InfluxDB/Http.hs
@@ -1,792 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-module Database.InfluxDB.Http- ( Config(..)- , Credentials(..), rootCreds- , Server(..), localServer- , TimePrecision(..)-- -- * Writing Data-- -- ** Updating Points- , post, postWithPrecision- , SeriesT, PointT- , writeSeries- , writeSeriesData- , withSeries- , writePoints-- -- ** Deleting Points- , deleteSeries-- -- * Querying Data- , query- , Stream(..)- , queryChunked-- -- * Administration & Security- -- ** Creating and Dropping Databases- , listDatabases- , createDatabase- , dropDatabase-- , DatabaseRequest(..)- , configureDatabase-- -- ** Security- -- *** Shard spaces- , ShardSpaceRequest(..)- , listShardSpaces- , createShardSpace- , dropShardSpace-- -- *** Cluster admin- , listClusterAdmins- , authenticateClusterAdmin- , addClusterAdmin- , updateClusterAdminPassword- , deleteClusterAdmin- -- *** Database user- , listDatabaseUsers- , authenticateDatabaseUser- , addDatabaseUser- , updateDatabaseUserPassword- , deleteDatabaseUser- , grantAdminPrivilegeTo- , revokeAdminPrivilegeFrom-- -- ** Other API- , ping- , isInSync- ) where--import Control.Applicative-import Control.Monad.Identity-import Control.Monad.Writer-import Data.DList (DList)-import Data.IORef-import Data.Proxy-import Data.Text (Text)-import Data.Vector (Vector)-import Data.Word (Word32)-import Network.URI (escapeURIString, isAllowedInURI)-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 Prelude--import Control.Monad.Catch (Handler(..))-import Control.Retry (recovering)-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-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-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---- | Configurations for HTTP API client.-data Config = Config- { configCreds :: !Credentials- , configServerPool :: !(IORef ServerPool)- , configHttpManager :: !HC.Manager- }---- | Default credentials.-rootCreds :: Credentials-rootCreds = Credentials- { credsUser = "root"- , credsPassword = "root"- }---- | Default server location.-localServer :: Server-localServer = Server- { serverHost = "localhost"- , serverPort = 8086- , serverSsl = False- }--data TimePrecision- = SecondsPrecision- | MillisecondsPrecision- | MicrosecondsPrecision--timePrecString :: TimePrecision -> String-timePrecString SecondsPrecision = "s"-timePrecString MillisecondsPrecision = "ms"-timePrecString MicrosecondsPrecision = "u"---------------------------------------------------------------- Writing Data---- | Post a bunch of writes for (possibly multiple) series into a database.-post- :: Config- -> Text- -> SeriesT IO a- -> IO a-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- -> Text -- ^ Database name- -> TimePrecision- -> SeriesT IO a- -> IO a-postWithPrecision config databaseName timePrec =- postGeneric config databaseName (Just timePrec)--postGeneric- :: Config- -> Text -- ^ Database name- -> Maybe TimePrecision- -> SeriesT IO a- -> IO a-postGeneric Config {..} databaseName timePrec write = do- (a, series) <- runSeriesT write- void $ httpLbsWithRetry configServerPool- (makeRequest series)- configHttpManager- return a- where- makeRequest series = def- { HC.method = "POST"- , HC.requestBody = HC.RequestBodyLBS $ AE.encode series- , HC.path = escapeString $ printf "/db/%s/series"- (T.unpack databaseName)- , HC.queryString = escapeString $ printf "u=%s&p=%s%s"- (T.unpack credsUser)- (T.unpack credsPassword)- (maybe- ""- (printf "&time_precision=%s" . timePrecString)- timePrec :: String)- }- Credentials {..} = configCreds---- | Monad transformer to batch up multiple writes of series to speed up--- insertions.-newtype SeriesT m a = SeriesT (WriterT (DList Series) m a)- deriving- ( Functor, Applicative, Monad, MonadIO, MonadTrans- , MonadWriter (DList Series)- )---- | Monad transformer to batch up multiple writes of points to speed up--- insertions.-newtype PointT p m a = PointT (WriterT (DList (Vector Value)) m a)- deriving- ( Functor, Applicative, Monad, MonadIO, MonadTrans- , MonadWriter (DList (Vector Value))- )--runSeriesT :: Monad m => SeriesT m a -> m (a, [Series])-runSeriesT (SeriesT w) = do- (a, series) <- runWriterT w- return (a, DL.toList series)---- | Write a single series data.-writeSeries- :: (Monad m, ToSeriesData a)- => Text- -- ^ Series name- -> a- -- ^ Series data- -> SeriesT m ()-writeSeries name = writeSeriesData name . toSeriesData---- | Write a single series data.-writeSeriesData- :: Monad m- => Text- -- ^ Series name- -> SeriesData- -- ^ Series data- -> SeriesT m ()-writeSeriesData name a = tell . DL.singleton $ Series- { seriesName = name- , seriesData = a- }---- | Write a bunch of data for a single series. Columns for the points don't--- need to be specified because they can be inferred from the type of @a@.-withSeries- :: forall m a. (Monad m, ToSeriesData a)- => Text- -- ^ Series name- -> PointT a m ()- -> SeriesT m ()-withSeries name (PointT w) = do- (_, values) <- lift $ runWriterT w- tell $ DL.singleton Series- { seriesName = name- , seriesData = SeriesData- { seriesDataColumns = toSeriesColumns (Proxy :: Proxy a)- , seriesDataPoints = DL.toList values- }- }---- | Write a data into a series.-writePoints- :: (Monad m, ToSeriesData a)- => a- -> PointT a m ()-writePoints = tell . DL.singleton . toSeriesPoints--deleteSeries- :: Config- -> Text -- ^ Database name- -> Text -- ^ Series name- -> IO ()-deleteSeries config databaseName seriesName = runRequest_ config request- where- request = 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 config---------------------------------------------------------------- Querying Data---- | Query a specified database.------ The query format is specified in the--- <http://influxdb.org/docs/query_language/ InfluxDB Query Language>.-query- :: FromSeries a- => Config- -> Text -- ^ Database name- -> Text -- ^ Query text- -> IO [a]-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"- (T.unpack databaseName)- , HC.queryString = escapeString $ printf "u=%s&p=%s&q=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- (T.unpack q)- }- Credentials {..} = configCreds config---- | Construct streaming output-responseStream :: A.FromJSON a => HC.BodyReader -> IO (Stream IO a)-responseStream body = demandPayload $ \payload ->- if BS.null payload- then return Done- else decode $ parseAsJson payload- where- demandPayload k = HC.brRead body >>= k- decode (P.Done leftover value) = case A.fromJSON value of- A.Success a -> return $ Yield a $ if BS.null leftover- then responseStream body- else decode $ parseAsJson leftover- A.Error message -> jsonDecodeError message- decode (P.Partial k) = demandPayload (decode . k)- decode (P.Fail _ _ message) = jsonDecodeError message- parseAsJson = P.parse A.json---- | Query a specified database like 'query' but in a streaming fashion.-queryChunked- :: FromSeries a- => Config- -> Text -- ^ Database name- -> Text -- ^ Query text- -> (Stream IO a -> IO b)- -- ^ Action to handle the resulting stream of series- -> IO b-queryChunked Config {..} databaseName q f =- withPool configServerPool request $ \request' ->- HC.withResponse request' configHttpManager $- responseStream . HC.responseBody >=> S.mapM parse >=> f- where- parse series = case fromSeries series of- Left reason -> seriesDecodeError reason- Right a -> return a- request = def- { HC.path = escapeString $ printf "/db/%s/series"- (T.unpack databaseName)- , HC.queryString = escapeString $ printf "u=%s&p=%s&q=%s&chunked=true"- (T.unpack credsUser)- (T.unpack credsPassword)- (T.unpack q)- }- Credentials {..} = configCreds---------------------------------------------------------------- Administration & Security---- | List existing databases.-listDatabases :: Config -> IO [Database]-listDatabases config = runRequest config request- where- request = def- { HC.path = "/db"- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Credentials {..} = configCreds config---- | Create a new database. Requires cluster admin privileges.-createDatabase :: Config -> Text -> IO ()-createDatabase config name = runRequest_ config request- where- request = def- { HC.method = "POST"- , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object- [ "name" .= name- ]- , HC.path = "/db"- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Credentials {..} = configCreds config---- | Drop a database. Requires cluster admin privileges.-dropDatabase- :: Config- -> Text -- ^ Database name- -> IO ()-dropDatabase config databaseName = runRequest_ config request- where- request = def- { HC.method = "DELETE"- , HC.path = escapeString $ printf "/db/%s"- (T.unpack databaseName)- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- 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- where- request = def- { HC.path = "/cluster_admins"- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Credentials {..} = configCreds config--authenticateClusterAdmin :: Config -> IO ()-authenticateClusterAdmin config = runRequest_ config request- where- request = def- { HC.path = "/cluster_admins/authenticate"- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Credentials {..} = configCreds config---- | Add a new cluster administrator. Requires cluster admin privilege.-addClusterAdmin- :: Config- -> Text -- ^ Admin name- -> Text -- ^ Password- -> IO Admin-addClusterAdmin config name password = do- runRequest_ config request- return Admin- { adminName = name- }- where- request = def- { 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"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Credentials {..} = configCreds config---- | Update a cluster administrator's password. Requires cluster admin--- privilege.-updateClusterAdminPassword- :: Config- -> Admin- -> Text -- ^ New password- -> IO ()-updateClusterAdminPassword Config {..} admin password =- void $ httpLbsWithRetry configServerPool makeRequest configHttpManager- where- makeRequest = def- { HC.method = "POST"- , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object- [ "password" .= password- ]- , HC.path = escapeString $ printf "/cluster_admins/%s"- (T.unpack adminName)- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Admin {adminName} = admin- Credentials {..} = configCreds---- | Delete a cluster administrator. Requires cluster admin privilege.-deleteClusterAdmin- :: Config- -> Admin- -> IO ()-deleteClusterAdmin Config {..} admin =- void $ httpLbsWithRetry configServerPool makeRequest configHttpManager- where- makeRequest = def- { HC.method = "DELETE"- , HC.path = escapeString $ printf "/cluster_admins/%s"- (T.unpack adminName)- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Admin {adminName} = admin- Credentials {..} = configCreds---- | List database users.-listDatabaseUsers- :: Config- -> Text- -> IO [User]-listDatabaseUsers config@Config {..} database = runRequest config makeRequest- where- makeRequest = def- { HC.path = escapeString $ printf "/db/%s/users"- (T.unpack database)- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- 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- -> Text -- ^ Database name- -> Text -- ^ User name- -> Text -- ^ Password- -> IO ()-addDatabaseUser config databaseName name password = runRequest_ config request- where- request = def- { 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)- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- Credentials {..} = configCreds config---- | Delete an user from the database users.-deleteDatabaseUser- :: Config- -> Text -- ^ Database name- -> Text -- ^ User name- -> IO ()-deleteDatabaseUser config databaseName userName = runRequest_ config request- where- request = (makeRequestFromDatabaseUser config databaseName userName)- { HC.method = "DELETE"- }---- | Update password for the database user.-updateDatabaseUserPassword- :: Config- -> Text -- ^ Database name- -> Text -- ^ User name- -> Text -- ^ New password- -> IO ()-updateDatabaseUserPassword config databaseName userName password =- runRequest_ config request- where- request = (makeRequestFromDatabaseUser config databaseName userName)- { HC.method = "POST"- , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object- [ "password" .= password- ]- }---- | Give admin privilege to the user.-grantAdminPrivilegeTo- :: Config- -> Text -- ^ Database name- -> Text -- ^ User name- -> IO ()-grantAdminPrivilegeTo config databaseName userName = runRequest_ config request- where- request = (makeRequestFromDatabaseUser config databaseName userName)- { HC.method = "POST"- , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object- [ "admin" .= True- ]- }---- | Remove admin privilege from the user.-revokeAdminPrivilegeFrom- :: Config- -> Text -- ^ Database name- -> Text -- ^ User name- -> IO ()-revokeAdminPrivilegeFrom config databaseName userName =- runRequest_ config request- where- request = (makeRequestFromDatabaseUser config databaseName userName)- { HC.method = "POST"- , HC.requestBody = HC.RequestBodyLBS $ AE.encode $ A.object- [ "admin" .= False- ]- }--makeRequestFromDatabaseUser- :: Config- -> Text -- ^ Database name- -> Text -- ^ User name- -> HC.Request-makeRequestFromDatabaseUser Config {..} databaseName userName = def- { HC.path = escapeString $ printf "/db/%s/users/%s"- (T.unpack databaseName)- (T.unpack userName)- , HC.queryString = escapeString $ printf "u=%s&p=%s"- (T.unpack credsUser)- (T.unpack credsPassword)- }- where- Credentials {..} = configCreds--ping :: Config -> IO Ping-ping config = runRequest config request- where- request = def- { HC.path = "/ping"- }--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- :: IORef ServerPool- -> HC.Request- -> HC.Manager- -> IO (HC.Response BL.ByteString)-httpLbsWithRetry pool request manager =- withPool pool request $ \request' ->- HC.httpLbs request' manager--withPool- :: IORef ServerPool- -> HC.Request- -> (HC.Request -> IO a)- -> IO a-withPool pool request f = do- retryPolicy <- serverRetryPolicy <$> readIORef pool- recovering retryPolicy handlers $ \_ -> do- server <- activeServer pool- f $ makeRequest server- where- makeRequest Server {..} = request- { HC.host = escapeText serverHost- , HC.port = serverPort- , HC.secure = serverSsl- }- handlers =- [ const $ Handler $ \e -> case e of- HC.FailedConnectionException {} -> retry- HC.FailedConnectionException2 {} -> retry- HC.InternalIOException {} -> retry- HC.ResponseTimeout {} -> retry- _ -> return False- ]- retry = True <$ failover pool--escapeText :: Text -> BS.ByteString-escapeText = escapeString . T.unpack--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---------------------------------------------------------------- Aeson instances--deriveToJSON (stripPrefixOptions "shardSpaceRequest") ''ShardSpaceRequest-deriveToJSON (stripPrefixOptions "databaseRequest") ''DatabaseRequest
+ src/Database/InfluxDB/Internal/Text.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.InfluxDB.Internal.Text+ ( escapeCommas+ , escapeEqualSigns+ , escapeSpaces+ , escapeDoubleQuotes+ , escapeSingleQuotes+ , escapeBackslashes+ ) where+import Data.Text (Text)+import qualified Data.Text as T++escapeCommas+ , escapeEqualSigns+ , escapeSpaces+ , escapeDoubleQuotes+ , escapeSingleQuotes+ , escapeBackslashes :: Text -> Text+escapeCommas = T.replace "," "\\,"+escapeEqualSigns = T.replace "=" "\\="+escapeSpaces = T.replace " " "\\ "+escapeDoubleQuotes = T.replace "\"" "\\\""+escapeSingleQuotes = T.replace "'" "\\'"+escapeBackslashes = T.replace "\\" "\\\\"
+ src/Database/InfluxDB/JSON.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+module Database.InfluxDB.JSON+ ( -- * Result parsers+ parseResultsWith+ , parseResultsWithDecoder++ -- ** Decoder settings+ , Decoder(..)+ , SomeDecoder(..)+ , strictDecoder+ , lenientDecoder++ -- * Getting fields and tags+ , getField+ , getTag++ -- * Common JSON object parsers+ , A.parseJSON+ , parseUTCTime+ , parsePOSIXTime+ , parseRFC3339+ -- ** Utility functions+ , parseResultsObject+ , parseSeriesObject+ , parseSeriesBody+ , parseErrorObject+ ) where+import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Foldable+import Data.Maybe+import Prelude+import qualified Control.Monad.Fail as Fail++import Data.Aeson+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Time.Format+import Data.Vector (Vector)+import qualified Data.Aeson.Types as A+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Scientific as Sci+import qualified Data.Text as T+import qualified Data.Vector as V++import Database.InfluxDB.Types++-- $setup+-- >>> import Data.Maybe+-- >>> import Data.Aeson (decode)+-- >>> import Database.InfluxDB.JSON+-- >>> import qualified Data.Aeson.Types as A++-- | Parse a JSON response with the 'strictDecoder'.+parseResultsWith+ :: (Maybe Text -> HashMap Text Text -> Vector Text -> Array -> A.Parser a)+ -- ^ A parser that parses a measurement. A measurement consists of+ --+ -- 1. an optional name of the series+ -- 2. a map of tags+ -- 3. an array of field keys+ -- 4. an array of field values+ -> Value -- ^ JSON response+ -> A.Parser (Vector a)+parseResultsWith = parseResultsWithDecoder strictDecoder++-- | Parse a JSON response with the specified decoder settings.+parseResultsWithDecoder+ :: Decoder+ -> (Maybe Text -> HashMap Text Text -> Vector Text -> Array -> A.Parser a)+ -- ^ A parser that parses a measurement. A measurement consists of+ --+ -- 1. an optional name of the series+ -- 2. a map of tags+ -- 3. an array of field keys+ -- 4. an array of field values+ -> Value -- ^ JSON response+ -> A.Parser (Vector a)+parseResultsWithDecoder (Decoder SomeDecoder {..}) row val0 = do+ r <- foldr1 (<|>)+ [ Left <$> parseErrorObject val0+ , Right <$> success+ ]+ case r of+ Left err -> fail err+ Right vec -> return vec+ where+ success = do+ results <- parseResultsObject val0++ (join -> series) <- V.forM results $ \val -> do+ r <- foldr1 (<|>)+ [ Left <$> parseErrorObject val+ , Right <$> parseSeriesObject val+ ]+ case r of+ Left err -> fail err+ Right vec -> return vec+ values <- V.forM series $ \val -> do+ (name, tags, columns, values) <- parseSeriesBody val+ decodeFold $ V.forM values $ A.withArray "values" $ \fields -> do+ assert (V.length columns == V.length fields) $ return ()+ decodeEach $ row name tags columns fields+ return $! join values++-- | A decoder to use when parsing a JSON response.+--+-- Use 'strictDecoder' if you want to fail the entire decoding process if+-- there's any failure. Use 'lenientDecoder' if you want the decoding process+-- to collect only successful results.+newtype Decoder = Decoder (forall a. SomeDecoder a)++-- | @'SomeDecoder' a@ represents how to decode a JSON response given a row+-- parser of type @'A.Parser' a@.+data SomeDecoder a = forall b. SomeDecoder+ { decodeEach :: A.Parser a -> A.Parser b+ -- ^ How to decode each row.+ --+ -- For example 'optional' can be used to turn parse+ -- failrues into 'Nothing's.+ , decodeFold :: A.Parser (Vector b) -> A.Parser (Vector a)+ -- ^ How to aggregate rows into the resulting vector.+ --+ -- For example when @b ~ 'Maybe' a@, one way to aggregate the values is to+ -- return only 'Just's.+ }++-- | A decoder that fails immediately if there's any parse failure.+--+-- 'strictDecoder' is defined as follows:+--+-- @+-- strictDecoder :: Decoder+-- strictDecoder = Decoder $ SomeDecoder+-- { decodeEach = id+-- , decodeFold = id+-- }+-- @+strictDecoder :: Decoder+strictDecoder = Decoder $ SomeDecoder+ { decodeEach = id+ , decodeFold = id+ }++-- | A decoder that ignores parse failures and returns only successful results.+lenientDecoder :: Decoder+lenientDecoder = Decoder $ SomeDecoder+ { decodeEach = optional+ , decodeFold = \p -> do+ bs <- p+ return $! V.map fromJust $ V.filter isJust bs+ }++-- | Get a field value from a column name+getField+ :: Fail.MonadFail m+ => Text -- ^ Column name+ -> Vector Text -- ^ Columns+ -> Vector Value -- ^ Field values+ -> m Value+getField column columns fields =+ case V.elemIndex column columns of+ Nothing -> Fail.fail $ "getField: no such column " ++ show column+ Just idx -> case V.indexM fields idx of+ Nothing -> Fail.fail $ "getField: index out of bound for " ++ show column+ Just field -> return field++-- | Get a tag value from a tag name+getTag+ :: Fail.MonadFail m+ => Text -- ^ Tag name+ -> HashMap Text Value -- ^ Tags+ -> m Value+getTag tag tags = case HashMap.lookup tag tags of+ Nothing -> Fail.fail $ "getTag: no such tag " ++ show tag+ Just val -> return val++-- | Parse a result response.+parseResultsObject :: Value -> A.Parser (Vector A.Value)+parseResultsObject = A.withObject "results" $ \obj -> obj .: "results"++-- | Parse a series response.+parseSeriesObject :: Value -> A.Parser (Vector A.Value)+parseSeriesObject = A.withObject "series" $ \obj ->+ fromMaybe V.empty <$> obj .:? "series"++-- | Parse the common JSON structure used in query responses.+parseSeriesBody+ :: Value+ -> A.Parser (Maybe Text, HashMap Text Text, Vector Text, Array)+parseSeriesBody = A.withObject "series" $ \obj -> do+ !name <- obj .:? "name"+ !columns <- obj .: "columns"+ !values <- obj .:? "values" .!= V.empty+ !tags <- obj .:? "tags" .!= HashMap.empty+ return (name, tags, columns, values)++-- | Parse the common JSON structure used in failure response.+-- >>> A.parse parseErrorObject $ fromJust $ decode "{ \"error\": \"custom error\" }"+-- Success "custom error"+-- >>> A.parse parseErrorObject $ fromJust $ decode "{ \"message\": \"custom error\" }"+-- Success "custom error"+parseErrorObject :: A.Value -> A.Parser String+parseErrorObject = A.withObject "error" $ \obj -> obj .: "error" <|> obj .: "message"++-- | Parse either a POSIX timestamp or RFC3339 formatted timestamp as 'UTCTime'.+parseUTCTime :: Precision ty -> A.Value -> A.Parser UTCTime+parseUTCTime prec val = case prec of+ RFC3339 -> parseRFC3339 val+ _ -> posixSecondsToUTCTime <$!> parsePOSIXTime prec val++-- | Parse either a POSIX timestamp or RFC3339 formatted timestamp as+-- 'POSIXTime'.+parsePOSIXTime :: Precision ty -> A.Value -> A.Parser POSIXTime+parsePOSIXTime prec val = case prec of+ RFC3339 -> utcTimeToPOSIXSeconds <$!> parseRFC3339 val+ _ -> A.withScientific err+ (\s -> case timestampToUTC s of+ Nothing -> A.typeMismatch err val+ Just !utc -> return utc)+ val+ where+ err = "POSIX timestamp in " ++ T.unpack (precisionName prec)+ timestampToUTC s = do+ n <- Sci.toBoundedInteger s+ return $! fromIntegral (n :: Int) * precisionScale prec++-- | Parse a RFC3339-formatted timestamp.+--+-- Note that this parser is slow as it converts a 'T.Text' input to a+-- 'Prelude.String' before parsing.+parseRFC3339 :: ParseTime time => A.Value -> A.Parser time+parseRFC3339 val = A.withText err+ (maybe (A.typeMismatch err val) (return $!)+ . parseTimeM True defaultTimeLocale fmt+ . T.unpack)+ val+ where+ fmt, err :: String+ fmt = "%FT%X%QZ"+ err = "RFC3339-formatted timestamp"
− src/Database/InfluxDB/Lens.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Database.InfluxDB.Lens- ( Lens, Lens'-- -- * Lenses for 'Config'- , credentials- , httpManager-- -- * Lenses for 'Credentials'- , user, password-- -- * Lenses for 'Server'- , host, port, ssl- ) where-import Control.Applicative-import Data.Text (Text)-import Prelude--import Network.HTTP.Client (Manager)--import Database.InfluxDB.Http--type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t-type Lens' s a = Lens s s a a---- | User credentials for authentication-credentials :: Lens' Config Credentials-credentials f r = set <$> f (configCreds r)- where- set c = r { configCreds = c }---- | An instance of 'Manager' from @http-client@ package-httpManager :: Lens' Config Manager-httpManager f c = set <$> f (configHttpManager c)- where- set m = c { configHttpManager = m }---- | User name to be used for authentication-user :: Lens' Credentials Text-user f c = set <$> f (credsUser c)- where- set u = c { credsUser = u }---- | Password to be used for authentication-password :: Lens' Credentials Text-password f s = set <$> f (credsPassword s)- where- set p = s { credsPassword = p }---- | Host name or IP address of an InfluxDB-host :: Lens' Server Text-host f s = set <$> f (serverHost s)- where- set h = s { serverHost = h }---- | Port number to be used to connect to an InfluxDB-port :: Lens' Server Int-port f s = set <$> f (serverPort s)- where- set p = s { serverPort = p }---- | Whether or not to enable SSL connection-ssl :: Lens' Server Bool-ssl f s = set <$> f (serverSsl s)- where- set s' = s { serverSsl = s' }
+ src/Database/InfluxDB/Line.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Database.InfluxDB.Line+ ( -- $setup++ -- * Types and accessors+ Line(Line)+ , measurement+ , tagSet+ , fieldSet+ , timestamp++ -- * Serializers+ , buildLine+ , buildLines+ , encodeLine+ , encodeLines++ -- * Other types+ , LineField+ , Field(..)+ , Precision(..)+ ) where+import Data.List (intersperse)+import Data.Int (Int64)+import Data.Monoid+import Prelude++import Control.Lens+import Data.Map (Map)+import Data.Text (Text)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Map.Strict as Map+import qualified Data.Text.Encoding as TE++import Database.InfluxDB.Internal.Text+import Database.InfluxDB.Types++{- $setup+The Line protocol implementation.++>>> :set -XOverloadedStrings+>>> import Data.Time+>>> import Database.InfluxDB.Line+>>> import System.IO (stdout)+>>> import qualified Data.ByteString as B+>>> import qualified Data.ByteString.Builder as B+>>> import qualified Data.ByteString.Lazy.Char8 as BL8+>>> :{+let l1 = Line "cpu_usage"+ (Map.singleton "cpu" "cpu-total")+ (Map.fromList+ [ ("idle", FieldFloat 10.1)+ , ("system", FieldFloat 53.3)+ , ("user", FieldFloat 46.6)+ ])+ (Just $ parseTimeOrError False defaultTimeLocale+ "%F %T%Q %Z"+ "2017-06-17 15:41:40.42659044 UTC") :: Line UTCTime+:}+-}++-- | Placeholder for the Line Protocol+--+-- See https://docs.influxdata.com/influxdb/v1.7/write_protocols/line_protocol_tutorial/ for the+-- concrete syntax.+data Line time = Line+ { _measurement :: !Measurement+ -- ^ Measurement name+ , _tagSet :: !(Map Key Key)+ -- ^ Set of tags (optional)+ , _fieldSet :: !(Map Key LineField)+ -- ^ Set of fields+ --+ -- It shouldn't be empty.+ , _timestamp :: !(Maybe time)+ -- ^ Timestamp (optional)+ } deriving Show++-- | Serialize a 'Line' to a lazy bytestring+--+-- >>> BL8.putStrLn $ encodeLine (scaleTo Second) l1+-- cpu_usage,cpu=cpu-total idle=10.1,system=53.3,user=46.6 1497714100+encodeLine+ :: (time -> Int64)+ -- ^ Function to convert time to an InfluxDB timestamp+ --+ -- Use 'scaleTo' for HTTP writes and 'roundTo' for UDP writes.+ -> Line time+ -> L.ByteString+encodeLine toTimestamp = B.toLazyByteString . buildLine toTimestamp++-- | Serialize 'Line's to a lazy bytestring+--+-- >>> BL8.putStr $ encodeLines (scaleTo Second) [l1, l1]+-- cpu_usage,cpu=cpu-total idle=10.1,system=53.3,user=46.6 1497714100+-- cpu_usage,cpu=cpu-total idle=10.1,system=53.3,user=46.6 1497714100+--+encodeLines+ :: Foldable f+ => (time -> Int64)+ -- ^ Function to convert time to an InfluxDB timestamp+ --+ -- Use 'scaleTo' for HTTP writes and 'roundTo' for UDP writes.+ -> f (Line time)+ -> L.ByteString+encodeLines toTimestamp = B.toLazyByteString . buildLines toTimestamp++-- | Serialize a 'Line' to a bytestring 'B.Buider'+--+-- >>> B.hPutBuilder stdout $ buildLine (scaleTo Second) l1+-- cpu_usage,cpu=cpu-total idle=10.1,system=53.3,user=46.6 1497714100+buildLine+ :: (time -> Int64)+ -> Line time+ -> B.Builder+buildLine toTimestamp Line {..} =+ key <> " " <> fields <> maybe "" (" " <>) timestamp+ where+ measurement = TE.encodeUtf8Builder $ escapeMeasurement _measurement+ tags = buildMap (TE.encodeUtf8Builder . escapeKey) _tagSet+ key = if Map.null _tagSet+ then measurement+ else measurement <> "," <> tags+ fields = buildMap buildFieldValue _fieldSet+ timestamp = B.int64Dec . toTimestamp <$> _timestamp+ buildMap encodeVal =+ mconcat . intersperse "," . map encodeKeyVal . Map.toList+ where+ encodeKeyVal (name, val) = mconcat+ [ TE.encodeUtf8Builder $ escapeKey name+ , "="+ , encodeVal val+ ]++escapeKey :: Key -> Text+escapeKey (Key text) = escapeCommas $ escapeEqualSigns $ escapeSpaces text++escapeMeasurement :: Measurement -> Text+escapeMeasurement (Measurement text) = escapeCommas $ escapeSpaces text++escapeStringField :: Text -> Text+escapeStringField = escapeDoubleQuotes . escapeBackslashes++buildFieldValue :: LineField -> B.Builder+buildFieldValue = \case+ FieldInt i -> B.int64Dec i <> "i"+ FieldFloat d -> B.doubleDec d+ FieldString t -> "\"" <> TE.encodeUtf8Builder (escapeStringField t) <> "\""+ FieldBool b -> if b then "true" else "false"++-- | Serialize 'Line's to a bytestring 'B.Builder'+--+-- >>> B.hPutBuilder stdout $ buildLines (scaleTo Second) [l1, l1]+-- cpu_usage,cpu=cpu-total idle=10.1,system=53.3,user=46.6 1497714100+-- cpu_usage,cpu=cpu-total idle=10.1,system=53.3,user=46.6 1497714100+--+buildLines+ :: Foldable f+ => (time -> Int64)+ -> f (Line time)+ -> B.Builder+buildLines toTimestamp = foldMap ((<> "\n") . buildLine toTimestamp)++makeLensesWith (lensRules & generateSignatures .~ False) ''Line++-- | Name of the measurement that you want to write your data to.+measurement :: Lens' (Line time) Measurement++-- | Tag(s) that you want to include with your data point. Tags are optional in+-- the Line Protocol, so you can set it 'Control.Applicative.empty'.+tagSet :: Lens' (Line time) (Map Key Key)++-- | Field(s) for your data point. Every data point requires at least one field+-- in the Line Protocol, so it shouldn't be 'Control.Applicative.empty'.+fieldSet :: Lens' (Line time) (Map Key LineField)++-- | Timestamp for your data point. You can put whatever type of timestamp that+-- is an instance of the 'Timestamp' class.+timestamp :: Lens' (Line time) (Maybe time)
+ src/Database/InfluxDB/Manage.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-missing-signatures #-}+#else+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+#endif+module Database.InfluxDB.Manage+ ( -- * Management query interface+ Query+ , manage++ -- * Query parameters+ , QueryParams+ , queryParams+ , server+ , database+ , precision+ , manager++ -- * Management query results+ -- ** SHOW QUERIES+ , ShowQuery+ , qid+ , queryText+ , duration++ -- ** SHOW SERIES+ , ShowSeries+ , key+ ) where+import Control.Exception+import Control.Monad++import Control.Lens+import Data.Aeson (Value(..), eitherDecode', encode, parseJSON)+import Data.Scientific (toBoundedInteger)+import Data.Text (Text)+import Data.Time.Clock+import qualified Data.Aeson.Types as A+import qualified Data.Attoparsec.Combinator as AC+import qualified Data.Attoparsec.Text as AT+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Types as HT++import Database.InfluxDB.JSON (getField)+import Database.InfluxDB.Types as Types+import Database.InfluxDB.Query hiding (query)+import qualified Database.InfluxDB.Format as F++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Database.InfluxDB.Query+-- >>> import Database.InfluxDB.Format ((%))+-- >>> import Database.InfluxDB.Manage++-- | Send a database management query to InfluxDB.+--+-- >>> let db = "manage-test"+-- >>> let p = queryParams db+-- >>> manage p $ F.formatQuery ("CREATE DATABASE "%F.database) db+manage :: QueryParams -> Query -> IO ()+manage params q = do+ manager' <- either HC.newManager return $ params^.manager+ response <- HC.httpLbs request manager' `catch` (throwIO . HTTPException)+ let body = HC.responseBody response+ case eitherDecode' body of+ Left message ->+ throwIO $ UnexpectedResponse message request body+ Right val -> do+ let parser = parseQueryResultsWith+ (params ^. decoder)+ (params ^. precision)+ case A.parse parser val of+ A.Success (_ :: V.Vector Empty) -> return ()+ A.Error message -> do+ let status = HC.responseStatus response+ when (HT.statusIsServerError status) $+ throwIO $ ServerError message+ when (HT.statusIsClientError status) $+ throwIO $ ClientError message request+ throwIO $ UnexpectedResponse+ ("BUG: " ++ message ++ " in Database.InfluxDB.Manage.manage")+ request+ (encode val)+ where+ request = HC.setQueryString qs $ manageRequest params+ qs =+ [ ("q", Just $ F.fromQuery q)+ ]++manageRequest :: QueryParams -> HC.Request+manageRequest params = HC.defaultRequest+ { HC.host = TE.encodeUtf8 _host+ , HC.port = fromIntegral _port+ , HC.secure = _ssl+ , HC.method = "POST"+ , HC.path = "/query"+ }+ where+ Server {..} = params^.server++-- |+-- >>> v <- query @ShowQuery (queryParams "_internal") "SHOW QUERIES"+data ShowQuery = ShowQuery+ { showQueryQid :: !Int+ , showQueryText :: !Query+ , showQueryDatabase :: !Database+ , showQueryDuration :: !NominalDiffTime+ }++instance QueryResults ShowQuery where+ parseMeasurement _ _ _ columns fields =+ maybe (fail "parseResults: parse error") return $ do+ Number (toBoundedInteger -> Just showQueryQid) <-+ getField "qid" columns fields+ String (F.formatQuery F.text -> showQueryText) <-+ getField "query" columns fields+ String (F.formatDatabase F.text -> showQueryDatabase) <-+ getField "database" columns fields+ String (parseDuration -> Right showQueryDuration) <-+ getField "duration" columns fields+ return ShowQuery {..}++parseDuration :: Text -> Either String NominalDiffTime+parseDuration = AT.parseOnly duration+ where+ duration = (*)+ <$> fmap (fromIntegral @Int) AT.decimal+ <*> unit+ unit = AC.choice+ [ 10^^(-6 :: Int) <$ AT.string "µs"+ , 1 <$ AT.char 's'+ , 60 <$ AT.char 'm'+ , 3600 <$ AT.char 'h'+ ]++newtype ShowSeries = ShowSeries+ { _key :: Key+ }++instance QueryResults ShowSeries where+ parseMeasurement _ _ _ columns fields = do+ name <- getField "key" columns fields >>= parseJSON+ return $ ShowSeries $ F.formatKey F.text name++makeLensesWith+ ( lensRules+ & generateSignatures .~ False+ & lensField .~ lookingupNamer+ [ ("showQueryQid", "qid")+ , ("showQueryText", "queryText")+ , ("showQueryDatabase", "_database")+ , ("showQueryDuration", "duration")+ ]+ ) ''ShowQuery++-- | Query ID+--+-- >>> v <- query @ShowQuery (queryParams "_internal") "SHOW QUERIES"+-- >>> v ^.. each.qid+-- ...+qid :: Lens' ShowQuery Int++-- | Query text+--+-- >>> v <- query @ShowQuery (queryParams "_internal") "SHOW QUERIES"+-- >>> v ^.. each.queryText+-- ...+queryText :: Lens' ShowQuery Query++-- |+-- >>> v <- query @ShowQuery (queryParams "_internal") "SHOW QUERIES"+-- >>> v ^.. each.database+-- ...+instance HasDatabase ShowQuery where+ database = _database++-- | Duration of the query+--+-- >>> v <- query @ShowQuery (queryParams "_internal") "SHOW QUERIES"+-- >>> v ^.. each.duration+-- ...+duration :: Lens' ShowQuery NominalDiffTime++makeLensesWith (lensRules & generateSignatures .~ False) ''ShowSeries++-- | Series name+--+-- >>> v <- query @ShowSeries (queryParams "_internal") "SHOW SERIES"+-- >>> length $ v ^.. each.key+-- ...+key :: Lens' ShowSeries Key
+ src/Database/InfluxDB/Ping.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-missing-signatures #-}+#else+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+#endif+module Database.InfluxDB.Ping+ ( -- * Ping interface+ ping++ -- * Ping parameters+ , PingParams+ , pingParams+ , server+ , manager+ , timeout++ -- * Pong+ , Pong+ , roundtripTime+ , influxdbVersion+ ) where+import Control.Exception++import Control.Lens+import Data.Time.Clock (NominalDiffTime)+import System.Clock+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as TE+import qualified Network.HTTP.Client as HC++import Database.InfluxDB.Types as Types++-- $setup+-- >>> import Database.InfluxDB.Ping++-- Ping requests do not require authentication+-- | The full set of parameters for the ping API+--+-- Following lenses are available to access its fields:+--+-- * 'server'+-- * 'manager'+-- * 'timeout'+data PingParams = PingParams+ { pingServer :: !Server+ , pingManager :: !(Either HC.ManagerSettings HC.Manager)+ -- ^ HTTP connection manager+ , pingTimeout :: !(Maybe NominalDiffTime)+ -- ^ Timeout+ }++-- | Smart constructor for 'PingParams'+--+-- Default parameters:+--+-- ['server'] 'defaultServer'+-- ['manager'] @'Left' 'HC.defaultManagerSettings'@+-- ['timeout'] 'Nothing'+pingParams :: PingParams+pingParams = PingParams+ { pingServer = defaultServer+ , pingManager = Left HC.defaultManagerSettings+ , pingTimeout = Nothing+ }++makeLensesWith+ ( lensRules+ & generateSignatures .~ False+ & lensField .~ lookingupNamer+ [ ("pingServer", "_server")+ , ("pingManager", "_manager")+ , ("pingTimeout", "timeout")+ ]+ )+ ''PingParams++-- |+-- >>> pingParams ^. server.host+-- "localhost"+instance HasServer PingParams where+ server = _server++-- |+-- >>> let p = pingParams & manager .~ Left HC.defaultManagerSettings+instance HasManager PingParams where+ manager = _manager++-- | The number of seconds to wait before returning a response+--+-- >>> pingParams ^. timeout+-- Nothing+-- >>> let p = pingParams & timeout ?~ 1+timeout :: Lens' PingParams (Maybe NominalDiffTime)++pingRequest :: PingParams -> HC.Request+pingRequest PingParams {..} = HC.defaultRequest+ { HC.host = TE.encodeUtf8 _host+ , HC.port = fromIntegral _port+ , HC.secure = _ssl+ , HC.method = "GET"+ , HC.path = "/ping"+ }+ where+ Server {..} = pingServer++-- | Response of a ping request+data Pong = Pong+ { _roundtripTime :: !TimeSpec+ -- ^ Round-trip time of the ping+ , _influxdbVersion :: !BS.ByteString+ -- ^ Version string returned by InfluxDB+ } deriving (Show, Eq, Ord)++makeLensesWith (lensRules & generateSignatures .~ False) ''Pong++-- | Round-trip time of the ping+roundtripTime :: Lens' Pong TimeSpec++-- | Version string returned by InfluxDB+influxdbVersion :: Lens' Pong BS.ByteString++-- | Send a ping to InfluxDB.+--+-- It may throw an 'InfluxException'.+ping :: PingParams -> IO Pong+ping params = do+ manager' <- either HC.newManager return $ pingManager params+ startTime <- getTimeMonotonic+ HC.withResponse request manager' $ \response -> do+ endTime <- getTimeMonotonic+ case lookup "X-Influxdb-Version" (HC.responseHeaders response) of+ Just version ->+ return $! Pong (diffTimeSpec endTime startTime) version+ Nothing ->+ throwIO $ UnexpectedResponse+ "The X-Influxdb-Version header was missing in the response."+ request+ ""+ `catch` (throwIO . HTTPException)+ where+ request = (pingRequest params)+ { HC.responseTimeout = case pingTimeout params of+ Nothing -> HC.responseTimeoutNone+ Just sec -> HC.responseTimeoutMicro $+ round $ realToFrac sec / (10**(-6) :: Double)+ }+ getTimeMonotonic = getTime Monotonic
+ src/Database/InfluxDB/Query.hs view
@@ -0,0 +1,621 @@+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+module Database.InfluxDB.Query+ (+ -- * Query interface+ Query+ , query+ , queryChunked++ -- * Query parameters+ , QueryParams+ , queryParams+ , server+ , database+ , precision+ , manager+ , authentication+ , decoder++ -- * Parsing results+ , QueryResults(..)+ , parseQueryResults+ , parseQueryResultsWith++ -- * Low-level functions+ , withQueryResponse++ -- * Helper types+ , Ignored+ , Empty+ , Tagged(..)+ , untag+ ) where+import Control.Exception+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe (fromMaybe)+import Data.Proxy+import GHC.TypeLits++import Control.Lens+import Data.Aeson+import Data.HashMap.Strict (HashMap)+import Data.Optional (Optional(..), optional)+import Data.Tagged+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Void+import qualified Control.Foldl as L+import qualified Data.Aeson.Parser as A+import qualified Data.Aeson.Types as A+import qualified Data.Attoparsec.ByteString as AB+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Types as HT++import Database.InfluxDB.JSON+import Database.InfluxDB.Types as Types+import qualified Database.InfluxDB.Format as F++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XOverloadedStrings+-- >>> :set -XRecordWildCards+-- >>> :set -XTypeApplications+-- >>> import Data.Time (UTCTime)+-- >>> import qualified Data.Vector as V+-- >>> import qualified Data.Text as T++-- | Types that can be converted from an JSON object returned by InfluxDB.+--+-- For example the @h2o_feet@ series in+-- [the official document](https://docs.influxdata.com/influxdb/v1.2/query_language/data_exploration/)+-- can be encoded as follows:+--+-- >>> :{+-- data H2OFeet = H2OFeet+-- { time :: UTCTime+-- , levelDesc :: T.Text+-- , location :: T.Text+-- , waterLevel :: Double+-- }+-- instance QueryResults H2OFeet where+-- parseMeasurement prec _name _tags columns fields = do+-- time <- getField "time" columns fields >>= parseUTCTime prec+-- levelDesc <- getField "level_description" columns fields >>= parseJSON+-- location <- getField "location" columns fields >>= parseJSON+-- waterLevel <- getField "water_level" columns fields >>= parseJSON+-- return H2OFeet {..}+-- :}+class QueryResults a where+ -- | Parse a single measurement in a JSON object.+ parseMeasurement+ :: Precision 'QueryRequest+ -- ^ Timestamp precision+ -> Maybe Text+ -- ^ Optional series name+ -> HashMap Text Text+ -- ^ Tag set+ -> Vector Text+ -- ^ Field keys+ -> Array+ -- ^ Field values+ -> A.Parser a++ -- | Always use this 'Decoder' when decoding this type.+ --+ -- @'Just' dec@ means 'decoder' in 'QueryParams' will be ignored and be+ -- replaced with the @dec@. 'Nothing' means 'decoder' in 'QueryParams' will+ -- be used.+ coerceDecoder :: proxy a -> Maybe Decoder+ coerceDecoder _ = Nothing++-- | Parse a JSON object as an array of values of expected type.+parseQueryResults+ :: forall a. QueryResults a+ => Precision 'QueryRequest+ -> Value+ -> A.Parser (Vector a)+parseQueryResults =+ parseQueryResultsWith $+ fromMaybe strictDecoder (coerceDecoder (Proxy :: Proxy a))++parseQueryResultsWith+ :: forall a. QueryResults a+ => Decoder+ -> Precision 'QueryRequest+ -> Value+ -> A.Parser (Vector a)+parseQueryResultsWith decoder prec =+ parseResultsWithDecoder+ (fromMaybe decoder (coerceDecoder (Proxy :: Proxy a)))+ (parseMeasurement prec)++-- | 'QueryResults' instance for empty results. Used by+-- 'Database.InfluxDB.Manage.manage'.+--+-- NOTE: This instance is deprecated because it's unclear from the name whether+-- it can be used to ignore results. Use 'Empty' when expecting an empty result.+-- Use 'Ignored' if you want to ignore any results.+instance QueryResults Void where+ parseMeasurement _ _ _ _ _ = fail "parseMeasurement for Void"+ coerceDecoder _ = Just $ Decoder $ SomeDecoder+ { decodeEach = id+ , decodeFold = const $ pure V.empty+ }++-- | 'Ignored' can be used in the result type of 'query' when the result values+-- are not needed.+--+-- >>> v <- query @Ignored (queryParams "dummy") "SHOW DATABASES"+-- >>> v+-- []+data Ignored deriving Show++-- | 'QueryResults' instance for ignoring results.+instance QueryResults Ignored where+ parseMeasurement _ _ _ _ _ = fail "parseMeasurement for Ignored"+ coerceDecoder _ = Just $ Decoder $ SomeDecoder+ { decodeEach = id -- doesn't matter+ , decodeFold = const $ pure V.empty -- always succeeds with an empty vector+ }++-- | 'Empty' can be used in the result type of 'query' when the expected results+-- are always empty. Note that if the results are not empty, the decoding+-- process will fail:+--+-- >>> let p = queryParams "empty"+-- >>> Database.InfluxDB.Manage.manage p "CREATE DATABASE empty"+-- >>> v <- query @Empty p "SELECT * FROM empty" -- query an empty series+-- >>> v+-- []+data Empty deriving Show++-- | 'QueryResults' instance for empty results. Used by+-- 'Database.InfluxDB.Manage.manage'.+instance QueryResults Empty where+ parseMeasurement _ _ _ _ _ = fail "parseMeasurement for Empty"+ coerceDecoder _ = Just strictDecoder -- fail when the results are not empty++fieldName :: KnownSymbol k => proxy k -> T.Text+fieldName = T.pack . symbolVal++-- | One-off type for non-timestamped measurements+--+-- >>> let p = queryParams "_internal"+-- >>> dbs <- query @(Tagged "name" T.Text) p "SHOW DATABASES"+-- >>> V.find ((== "_internal") . untag) dbs+-- Just (Tagged "_internal")+instance (KnownSymbol k, FromJSON v) => QueryResults (Tagged k v) where+ parseMeasurement _ _name _ columns fields =+ getField (fieldName (Proxy :: Proxy k)) columns fields >>= parseJSON++-- | One-off tuple for sigle-field measurements+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2 )+ => QueryResults (Tagged k1 v1, Tagged k2 v2) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ return (v1, v2)++-- | One-off tuple for two-field measurements+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2+ , KnownSymbol k3, FromJSON v3 )+ => QueryResults (Tagged k1 v1, Tagged k2 v2, Tagged k3 v3) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ v3 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k3)) columns fields+ return (v1, v2, v3)++-- | One-off tuple for three-field measurements+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2+ , KnownSymbol k3, FromJSON v3+ , KnownSymbol k4, FromJSON v4 )+ => QueryResults (Tagged k1 v1, Tagged k2 v2, Tagged k3 v3, Tagged k4 v4) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ v3 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k3)) columns fields+ v4 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k4)) columns fields+ return (v1, v2, v3, v4)++-- | One-off tuple for four-field measurements+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2+ , KnownSymbol k3, FromJSON v3+ , KnownSymbol k4, FromJSON v4+ , KnownSymbol k5, FromJSON v5 )+ => QueryResults+ ( Tagged k1 v1, Tagged k2 v2, Tagged k3 v3, Tagged k4 v4+ , Tagged k5 v5+ ) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ v3 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k3)) columns fields+ v4 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k4)) columns fields+ v5 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k5)) columns fields+ return (v1, v2, v3, v4, v5)++-- | One-off tuple for five-field measurements+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2+ , KnownSymbol k3, FromJSON v3+ , KnownSymbol k4, FromJSON v4+ , KnownSymbol k5, FromJSON v5+ , KnownSymbol k6, FromJSON v6 )+ => QueryResults+ ( Tagged k1 v1, Tagged k2 v2, Tagged k3 v3, Tagged k4 v4+ , Tagged k5 v5, Tagged k6 v6+ ) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ v3 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k3)) columns fields+ v4 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k4)) columns fields+ v5 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k5)) columns fields+ v6 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k6)) columns fields+ return (v1, v2, v3, v4, v5, v6)++-- | One-off tuple for six-field measurement+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2+ , KnownSymbol k3, FromJSON v3+ , KnownSymbol k4, FromJSON v4+ , KnownSymbol k5, FromJSON v5+ , KnownSymbol k6, FromJSON v6+ , KnownSymbol k7, FromJSON v7 )+ => QueryResults+ ( Tagged k1 v1, Tagged k2 v2, Tagged k3 v3, Tagged k4 v4+ , Tagged k5 v5, Tagged k6 v6, Tagged k7 v7+ ) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ v3 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k3)) columns fields+ v4 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k4)) columns fields+ v5 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k5)) columns fields+ v6 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k6)) columns fields+ v7 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k7)) columns fields+ return (v1, v2, v3, v4, v5, v6, v7)++-- | One-off tuple for seven-field measurements+instance+ ( KnownSymbol k1, FromJSON v1+ , KnownSymbol k2, FromJSON v2+ , KnownSymbol k3, FromJSON v3+ , KnownSymbol k4, FromJSON v4+ , KnownSymbol k5, FromJSON v5+ , KnownSymbol k6, FromJSON v6+ , KnownSymbol k7, FromJSON v7+ , KnownSymbol k8, FromJSON v8 )+ => QueryResults+ ( Tagged k1 v1, Tagged k2 v2, Tagged k3 v3, Tagged k4 v4+ , Tagged k5 v5, Tagged k6 v6, Tagged k7 v7, Tagged k8 v8+ ) where+ parseMeasurement _ _ _ columns fields = do+ v1 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k1)) columns fields+ v2 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k2)) columns fields+ v3 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k3)) columns fields+ v4 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k4)) columns fields+ v5 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k5)) columns fields+ v6 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k6)) columns fields+ v7 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k7)) columns fields+ v8 <- parseJSON+ =<< getField (fieldName (Proxy :: Proxy k8)) columns fields+ return (v1, v2, v3, v4, v5, v6, v7, v8)++-- | The full set of parameters for the query API+--+-- Following lenses are available to access its fields:+--+-- * 'server'+-- * 'database'+-- * 'precision'+-- * 'manager'+-- * 'authentication'+-- * 'decoder'+data QueryParams = QueryParams+ { queryServer :: !Server+ , queryDatabase :: !Database+ , queryPrecision :: !(Precision 'QueryRequest)+ -- ^ Timestamp precision+ --+ -- InfluxDB uses nanosecond precision if nothing is specified.+ , queryAuthentication :: !(Maybe Credentials)+ -- ^ No authentication by default+ , queryManager :: !(Either HC.ManagerSettings HC.Manager)+ -- ^ HTTP connection manager+ , queryDecoder :: Decoder+ -- ^ Decoder settings to configure how to parse a JSON resposne given a row+ -- parser+ }++-- | Smart constructor for 'QueryParams'+--+-- Default parameters:+--+-- ['server'] 'defaultServer'+-- ['precision'] 'RFC3339'+-- ['authentication'] 'Nothing'+-- ['manager'] @'Left' 'HC.defaultManagerSettings'@+-- ['decoder'] @'strictDecoder'@+queryParams :: Database -> QueryParams+queryParams queryDatabase = QueryParams+ { queryServer = defaultServer+ , queryPrecision = RFC3339+ , queryAuthentication = Nothing+ , queryManager = Left HC.defaultManagerSettings+ , queryDecoder = strictDecoder+ , ..+ }++-- | Query data from InfluxDB.+--+-- It may throw 'InfluxException'.+--+-- If you need a lower-level interface (e.g. to bypass the 'QueryResults'+-- constraint etc), see 'withQueryResponse'.+query :: forall a. QueryResults a => QueryParams -> Query -> IO (Vector a)+query params q = withQueryResponse params Nothing q go+ where+ go request response = do+ chunks <- HC.brConsume $ HC.responseBody response+ let body = BL.fromChunks chunks+ case eitherDecode' body of+ Left message -> throwIO $ UnexpectedResponse message request body+ Right val -> do+ let parser = parseQueryResultsWith+ (fromMaybe+ (queryDecoder params)+ (coerceDecoder (Proxy :: Proxy a)))+ (queryPrecision params)+ case A.parse parser val of+ A.Success vec -> return vec+ A.Error message -> errorQuery message request response val++setPrecision+ :: Precision 'QueryRequest+ -> [(B.ByteString, Maybe B.ByteString)]+ -> [(B.ByteString, Maybe B.ByteString)]+setPrecision prec qs = maybe qs (\p -> ("epoch", Just p):qs) $+ precisionParam prec++precisionParam :: Precision 'QueryRequest -> Maybe B.ByteString+precisionParam = \case+ Nanosecond -> return "ns"+ Microsecond -> return "u"+ Millisecond -> return "ms"+ Second -> return "s"+ Minute -> return "m"+ Hour -> return "h"+ RFC3339 -> Nothing++-- | Same as 'query' but it instructs InfluxDB to stream chunked responses+-- rather than returning a huge JSON object. This can be lot more efficient than+-- 'query' if the result is huge.+--+-- It may throw 'InfluxException'.+--+-- If you need a lower-level interface (e.g. to bypass the 'QueryResults'+-- constraint etc), see 'withQueryResponse'.+queryChunked+ :: QueryResults a+ => QueryParams+ -> Optional Int+ -- ^ Chunk size+ --+ -- By 'Default', InfluxDB chunks responses by series or by every 10,000+ -- points, whichever occurs first. If it set to a 'Specific' value, InfluxDB+ -- chunks responses by series or by that number of points.+ -> Query+ -> L.FoldM IO (Vector a) r+ -> IO r+queryChunked params chunkSize q (L.FoldM step initialize extract) =+ withQueryResponse params (Just chunkSize) q go+ where+ go request response = do+ x0 <- initialize+ chunk0 <- HC.responseBody response+ x <- loop x0 k0 chunk0+ extract x+ where+ k0 = AB.parse A.json+ loop x k chunk+ | B.null chunk = return x+ | otherwise = case k chunk of+ AB.Fail unconsumed _contexts message ->+ throwIO $ UnexpectedResponse message request $+ BL.fromStrict unconsumed+ AB.Partial k' -> do+ chunk' <- HC.responseBody response+ loop x k' chunk'+ AB.Done leftover val ->+ case A.parse (parseQueryResults (queryPrecision params)) val of+ A.Success vec -> do+ x' <- step x vec+ loop x' k0 leftover+ A.Error message -> errorQuery message request response val++-- | Lower-level interface to query data.+withQueryResponse+ :: QueryParams+ -> Maybe (Optional Int)+ -- ^ Chunk size+ --+ -- By 'Nothing', InfluxDB returns all matching data points at once.+ -- By @'Just' 'Default'@, InfluxDB chunks responses by series or by every+ -- 10,000 points, whichever occurs first. If it set to a 'Specific' value,+ -- InfluxDB chunks responses by series or by that number of points.+ -> Query+ -> (HC.Request -> HC.Response HC.BodyReader -> IO r)+ -> IO r+withQueryResponse params chunkSize q f = do+ manager' <- either HC.newManager return $ queryManager params+ HC.withResponse request manager' (f request)+ `catch` (throwIO . HTTPException)+ where+ request =+ HC.setQueryString (setPrecision (queryPrecision params) queryString) $+ queryRequest params+ queryString = addChunkedParam+ [ ("q", Just $ F.fromQuery q)+ , ("db", Just db)+ ]+ where+ !db = TE.encodeUtf8 $ databaseName $ queryDatabase params+ addChunkedParam ps = case chunkSize of+ Nothing -> ps+ Just size ->+ let !chunked = optional "true" (decodeChunkSize . max 1) size+ in ("chunked", Just chunked) : ps+ where+ decodeChunkSize = BL.toStrict . BB.toLazyByteString . BB.intDec+++queryRequest :: QueryParams -> HC.Request+queryRequest QueryParams {..} = applyBasicAuth $ HC.defaultRequest+ { HC.host = TE.encodeUtf8 _host+ , HC.port = fromIntegral _port+ , HC.secure = _ssl+ , HC.method = "GET"+ , HC.path = "/query"+ }+ where+ Server {..} = queryServer+ applyBasicAuth =+ case queryAuthentication of+ Nothing -> id+ Just Credentials {..} ->+ HC.applyBasicAuth (TE.encodeUtf8 _user) (TE.encodeUtf8 _password)++errorQuery :: String -> HC.Request -> HC.Response body -> A.Value -> IO a+errorQuery message request response val = do+ let status = HC.responseStatus response+ when (HT.statusIsServerError status) $+ throwIO $ ServerError message+ when (HT.statusIsClientError status) $+ throwIO $ ClientError message request+ throwIO $ UnexpectedResponse+ ("BUG: " ++ message ++ " in Database.InfluxDB.Query.query")+ request+ (encode val)++makeLensesWith+ ( lensRules+ & lensField .~ mappingNamer+ (\name -> case stripPrefix "query" name of+ Just (c:cs) -> ['_':toLower c:cs]+ _ -> [])+ )+ ''QueryParams++-- |+-- >>> let p = queryParams "foo"+-- >>> p ^. server.host+-- "localhost"+instance HasServer QueryParams where+ server = _server++-- |+-- >>> let p = queryParams "foo"+-- >>> p ^. database+-- "foo"+instance HasDatabase QueryParams where+ database = _database++-- | Returning JSON responses contain timestamps in the specified+-- precision/format.+--+-- >>> let p = queryParams "foo"+-- >>> p ^. precision+-- RFC3339+instance HasPrecision 'QueryRequest QueryParams where+ precision = _precision++-- |+-- >>> let p = queryParams "foo" & manager .~ Left HC.defaultManagerSettings+instance HasManager QueryParams where+ manager = _manager++-- | Authentication info for the query+--+-- >>> let p = queryParams "foo"+-- >>> p ^. authentication+-- Nothing+-- >>> let p' = p & authentication ?~ credentials "john" "passw0rd"+-- >>> p' ^. authentication.traverse.user+-- "john"+instance HasCredentials QueryParams where+ authentication = _authentication++-- | Decoder settings+--+-- >>> let p = queryParams "foo"+-- >>> let _ = p & decoder .~ strictDecoder+-- >>> let _ = p & decoder .~ lenientDecoder+decoder :: Lens' QueryParams Decoder+decoder = _decoder
− src/Database/InfluxDB/Stream.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Database.InfluxDB.Stream where-import Prelude hiding (mapM)---- | Effectful stream-data Stream m a- = Yield a (m (Stream m a))- -- ^ Yield a value. The stream will be continued.- | Done- -- ^ The end of the stream.---- | Map each element of a stream to a monadic action, evaluate these actions--- from left to right, and collect the results as a stream.-mapM :: Monad m => (a -> m b) -> Stream m a -> m (Stream m b)-mapM _ Done = return Done-mapM f (Yield a mb) = do- a' <- f a- b <- mb- return $ Yield a' (mapM f b)---- | Monadic left fold for 'Stream'.-fold :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b-fold f = loop- where- loop z stream = case stream of- Done -> return z- Yield a nextStream -> do- b <- f z a- stream' <- nextStream- loop b stream'---- | Strict version of 'fold'.-fold' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b-fold' f = loop- where- loop z stream = case stream of- Done -> return z- Yield a nextStream -> do- !b <- f z a- stream' <- nextStream- loop b stream'
− src/Database/InfluxDB/TH.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--#if __GLASGOW_HASKELL__ == 704-{-# LANGUAGE ConstraintKinds #-}-#endif--module Database.InfluxDB.TH- ( Options(..), defaultOptions- , deriveSeriesData- , deriveToSeriesData- , deriveFromSeriesData-- , stripPrefixLower- , stripPrefixSnake- ) where-import Control.Applicative-import Language.Haskell.TH-import Language.Haskell.TH.Syntax (VarStrictType)-import Prelude--import qualified Data.Vector as V--import Database.InfluxDB.Decode-import Database.InfluxDB.Encode-import Database.InfluxDB.Types.Internal--data Options = Options- { fieldLabelModifier :: String -> String- }--defaultOptions :: Options-defaultOptions = Options- { fieldLabelModifier = id- }--deriveSeriesData :: Options -> Name -> Q [Dec]-deriveSeriesData opts name = (++)- <$> deriveToSeriesData opts name- <*> deriveFromSeriesData opts name--deriveToSeriesData :: Options -> Name -> Q [Dec]-deriveToSeriesData opts name = do- info <- reify name- case info of- TyConI dec -> pure <$> deriveWith toSeriesDataBody opts dec- _ -> fail $ "Expected a type constructor, but got " ++ show info--deriveFromSeriesData :: Options -> Name -> Q [Dec]-deriveFromSeriesData opts name = do- info <- reify name- case info of- TyConI dec -> pure <$> deriveWith fromSeriesDataBody opts dec- _ -> fail $ "Expected a type constructor, but got " ++ show info--deriveWith- :: (Options -> Name -> [TyVarBndr] -> Con -> Q Dec)- -> Options -> Dec -> Q Dec-deriveWith f opts dec = case dec of-#if MIN_VERSION_template_haskell(2, 11, 0)- DataD _ tyName tyVars _ [con] _ -> f opts tyName tyVars con- NewtypeD _ tyName tyVars _ con _ -> f opts tyName tyVars con-#else- DataD _ tyName tyVars [con] _ -> f opts tyName tyVars con- NewtypeD _ tyName tyVars con _ -> f opts tyName tyVars con-#endif- _ -> fail $ "Expected a data or newtype declaration, but got " ++ show dec--toSeriesDataBody :: Options -> Name -> [TyVarBndr] -> Con -> Q Dec-toSeriesDataBody opts tyName tyVars con = do- case con of- RecC conName vars -> InstanceD-#if MIN_VERSION_template_haskell(2, 11, 0)- Nothing-#endif- <$> mapM tyVarToPred tyVars- <*> [t| ToSeriesData $(conT tyName) |]- <*> deriveDecs conName vars- _ -> fail $ "Expected a record, but got " ++ show con- where- tyVarToPred tv = case tv of-#if MIN_VERSION_template_haskell(2, 10, 0)- PlainTV name -> conT ''FromValue `appT` varT name- KindedTV name _ -> conT ''FromValue `appT` varT name-#else- PlainTV name -> classP ''FromValue [varT name]- KindedTV name _ -> classP ''FromValue [varT name]-#endif- deriveDecs _conName vars = do- a <- newName "a"- sequence- [ funD 'toSeriesColumns- [ clause [wildP]- (normalB [| V.fromList $(listE columns) |]) []- ]- , funD 'toSeriesPoints- [ clause [varP a]- (normalB [| V.fromList $(listE $ map (applyToValue a) vars) |]) []- ]- ]- where- applyToValue a (name, _, _) = [| toValue ($(varE name) $(varE a)) |]- columns = map (varStrictTypeToColumn opts) vars--fromSeriesDataBody :: Options -> Name -> [TyVarBndr] -> Con -> Q Dec-fromSeriesDataBody opts tyName tyVars con = do- case con of- RecC conName vars -> instanceD- (mapM tyVarToPred tyVars)- [t| FromSeriesData $(conT tyName) |]- [deriveDec conName vars]- _ -> fail $ "Expected a record, but got " ++ show con- where- tyVarToPred tv = case tv of-#if MIN_VERSION_template_haskell(2, 10, 0)- PlainTV name -> conT ''FromValue `appT` varT name- KindedTV name _ -> conT ''FromValue `appT` varT name-#else- PlainTV name -> classP ''FromValue [varT name]- KindedTV name _ -> classP ''FromValue [varT name]-#endif- deriveDec conName vars = funD 'parseSeriesData- [ clause [] (normalB deriveBody) []- ]- where- deriveBody = do- values <- newName "values"- appE (varE 'withValues) $ lamE [varP values] $- foldl (go values) [| pure $(conE conName) |] columns- where- go :: Name -> Q Exp -> Q Exp -> Q Exp- go values expQ col = [| $expQ <*> $(varE values) .: $col |]- columns = map (varStrictTypeToColumn opts) vars--varStrictTypeToColumn :: Options -> VarStrictType -> Q Exp-varStrictTypeToColumn opts = column opts . f- where- f (var, _, _) = var--column :: Options -> Name -> Q Exp-column opts = litE . stringL . fieldLabelModifier opts . nameBase
src/Database/InfluxDB/Types.hs view
@@ -1,302 +1,485 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}-module Database.InfluxDB.Types- ( -- * Series, columns and data points- Series(..)- , seriesColumns- , seriesPoints- , SeriesData(..)- , Column- , Value(..)+module Database.InfluxDB.Types where+import Control.Exception+import Data.Int (Int64)+import Data.String+import Data.Typeable (Typeable)+import GHC.Generics (Generic) - -- * Data types for HTTP API- , Credentials(..)- , Server(..)- , Database(..)- , User(..)- , Admin(..)- , Ping(..)- , Interface- , ShardSpace(..)+import Control.Lens+import Data.Text (Text)+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Network.HTTP.Client (Manager, ManagerSettings, Request)+import System.Clock (TimeSpec(..))+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Network.HTTP.Client as HC - -- * Server pool- , ServerPool- , serverRetryPolicy- , newServerPool- , newServerPoolWithRetryPolicy- , activeServer- , failover+-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import System.Clock (TimeSpec(..))+-- >>> import Database.InfluxDB+-- >>> import qualified Database.InfluxDB.Format as F - -- * Exceptions- , InfluxException(..)- , jsonDecodeError- , seriesDecodeError- ) where+-- | An InfluxDB query.+--+-- A spec of the format is available at+-- <https://docs.influxdata.com/influxdb/v1.7/query_language/spec/>.+--+-- A 'Query' can be constructed using either+--+-- * the 'IsString' instance with @-XOverloadedStrings@+-- * or 'Database.InfluxDB.Format.formatQuery'.+--+-- >>> :set -XOverloadedStrings+-- >>> "SELECT * FROM series" :: Query+-- "SELECT * FROM series"+-- >>> import qualified Database.InfluxDB.Format as F+-- >>> formatQuery ("SELECT * FROM "%F.key) "series"+-- "SELECT * FROM \"series\""+--+-- NOTE: Currently this library doesn't support type-safe query construction.+newtype Query = Query T.Text deriving IsString -import Control.Applicative (empty)-import Control.Exception (Exception, throwIO)-import Data.Data (Data)-import Data.IORef-import Data.Int (Int64)-import Data.Monoid ((<>))-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+instance Show Query where+ show (Query q) = show q -import Control.Retry (RetryPolicy, limitRetries, exponentialBackoff)-import Data.Aeson ((.=), (.:))-import Data.Aeson.TH-import qualified Data.Aeson as A+-- | InfluxDB server to connect to.+--+-- Following lenses are available to access its fields:+--+-- * 'host': FQDN or IP address of the InfluxDB server+-- * 'port': Port number of the InfluxDB server+-- * 'ssl': Whether or not to use SSL+data Server = Server+ { _host :: !Text+ , _port :: !Int+ , _ssl :: !Bool+ } deriving (Show, Generic, Eq, Ord) -import Database.InfluxDB.Types.Internal (stripPrefixOptions)+makeLensesWith (lensRules & generateSignatures .~ False) ''Server -#if MIN_VERSION_aeson(0, 7, 0)-import Data.Scientific-#else-import Data.Attoparsec.Number-#endif+-- | Host name of the server+host :: Lens' Server Text --------------------------------------------------------------- Compatibility for older GHC+-- | Port number of the server+port :: Lens' Server Int -#if __GLASGOW_HASKELL__ < 706-import Control.Exception (evaluate)+-- | If SSL is enabled+--+-- For secure connections (HTTPS), consider using one of the following packages:+--+-- * [http-client-tls](https://hackage.haskell.org/package/http-client-tls)+-- * [http-client-openssl](https://hackage.haskell.org/package/http-client-openssl)+ssl :: Lens' Server Bool -atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b-atomicModifyIORef' ref f = do- b <- atomicModifyIORef ref $ \x ->- let (a, b) = f x- in (a, a `seq` b)- evaluate b-#endif------------------------------------------------------------+-- | Default InfluxDB server settings+--+-- Default parameters:+--+-- >>> defaultServer ^. host+-- "localhost"+-- >>> defaultServer ^. port+-- 8086+-- >>> defaultServer ^. ssl+-- False+defaultServer :: Server+defaultServer = Server+ { _host = "localhost"+ , _port = 8086+ , _ssl = False+ } --- | A series consists of name, columns and points. The columns and points are--- expressed in a separate type 'SeriesData'.-data Series = Series- { seriesName :: {-# UNPACK #-} !Text- -- ^ Series name- , seriesData :: {-# UNPACK #-} !SeriesData- -- ^ Columns and data points in the series- } deriving (Typeable, Generic)+-- | HTTPS-enabled InfluxDB server settings+secureServer :: Server+secureServer = defaultServer & ssl .~ True --- | Convenient accessor for columns.-seriesColumns :: Series -> Vector Column-seriesColumns = seriesDataColumns . seriesData+-- | User credentials.+--+-- Following lenses are available to access its fields:+--+-- * 'user'+-- * 'password'+data Credentials = Credentials+ { _user :: !Text+ , _password :: !Text+ } deriving Show --- | Convenient accessor for points.-seriesPoints :: Series -> [Vector Value]-seriesPoints = seriesDataPoints . seriesData+-- | Smart constructor for 'Credentials'+credentials+ :: Text -- ^ User name+ -> Text -- ^ Password+ -> Credentials+credentials = Credentials -instance A.ToJSON Series where- toJSON Series {..} = A.object- [ "name" .= seriesName- , "columns" .= seriesDataColumns- , "points" .= seriesDataPoints- ]- where- SeriesData {..} = seriesData+makeLensesWith (lensRules & generateSignatures .~ False) ''Credentials -instance A.FromJSON Series where- parseJSON (A.Object v) = do- name <- v .: "name"- columns <- v .: "columns"- points <- v .: "points"- return Series- { seriesName = name- , seriesData = SeriesData- { seriesDataColumns = columns- , seriesDataPoints = points- }- }- parseJSON _ = empty+-- | User name to access InfluxDB.+--+-- >>> let creds = credentials "john" "passw0rd"+-- >>> creds ^. user+-- "john"+user :: Lens' Credentials Text --- | 'SeriesData' consists of columns and points.-data SeriesData = SeriesData- { seriesDataColumns :: Vector Column- , seriesDataPoints :: [Vector Value]- } deriving (Eq, Show, Typeable, Generic)+-- | Password to access InfluxDB+--+-- >>> let creds = credentials "john" "passw0rd"+-- >>> creds ^. password+-- "passw0rd"+password :: Lens' Credentials Text -type Column = Text+-- | Database name.+--+-- 'Database.InfluxDB.formatDatabase' can be used to construct a+-- 'Database'.+--+-- >>> "test-db" :: Database+-- "test-db"+-- >>> formatDatabase "test-db"+-- "test-db"+-- >>> formatDatabase ("test-db-"%F.decimal) 0+-- "test-db-0"+newtype Database = Database { databaseName :: Text } deriving (Eq, Ord) --- | An InfluxDB value represented as a Haskell value.-data Value- = Int !Int64- | Float !Double- | String !Text- | Bool !Bool- | Null- deriving (Eq, Show, Data, Typeable, Generic)+instance IsString Database where+ fromString xs = Database $ identifier "Database" xs -instance A.ToJSON Value where- toJSON (Int n) = A.toJSON n- toJSON (Float d) = A.toJSON d- toJSON (String xs) = A.toJSON xs- toJSON (Bool b) = A.toJSON b- toJSON Null = A.Null+instance Show Database where+ show (Database name) = show name -instance A.FromJSON Value where- parseJSON (A.Object o) = fail $ "Unexpected object: " ++ show o- parseJSON (A.Array a) = fail $ "Unexpected array: " ++ show a- parseJSON (A.String xs) = return $ String xs- parseJSON (A.Bool b) = return $ Bool b- parseJSON A.Null = return Null- parseJSON (A.Number n) = return $! numberToValue- 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- -- 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)+-- | String name that is used for measurements.+--+-- 'Database.InfluxDB.formatMeasurement' can be used to construct a+-- 'Measurement'.+--+-- >>> "test-series" :: Measurement+-- "test-series"+-- >>> formatMeasurement "test-series"+-- "test-series"+-- >>> formatMeasurement ("test-series-"%F.decimal) 0+-- "test-series-0"+newtype Measurement = Measurement Text deriving (Eq, Ord) ------------------------------------------------------------+instance IsString Measurement where+ fromString xs = Measurement $ identifier "Measurement" xs --- | User credentials.-data Credentials = Credentials- { credsUser :: !Text- , credsPassword :: !Text- } deriving (Show, Typeable, Generic)+instance Show Measurement where+ show (Measurement name) = show name --- | Server location.-data Server = Server- { serverHost :: !Text- -- ^ Hostname or IP address- , serverPort :: !Int- , serverSsl :: !Bool- -- ^ SSL is enabled or not in the server side- } deriving (Show, Typeable, Generic)+-- | String type that is used for tag keys/values and field keys.+--+-- 'Database.InfluxDB.formatKey' can be used to construct a 'Key'.+--+-- >>> "test-key" :: Key+-- "test-key"+-- >>> formatKey "test-key"+-- "test-key"+-- >>> formatKey ("test-key-"%F.decimal) 0+-- "test-key-0"+newtype Key = Key Text deriving (Eq, Ord) --- | Non-empty set of server locations. The active server will always be used--- until any HTTP communications fail.-data ServerPool = ServerPool- { serverActive :: !Server- -- ^ Current active server- , serverBackup :: !(Seq Server)- -- ^ The rest of the servers in the pool.- , serverRetryPolicy :: !RetryPolicy- }+instance IsString Key where+ fromString xs = Key $ identifier "Key" xs -newtype Database = Database- { databaseName :: Text- } deriving (Show, Typeable, Generic)+instance Show Key where+ show (Key name) = show name --- | User-data User = User- { userName :: Text- , userIsAdmin :: Bool- } deriving (Show, Typeable, Generic)+identifier :: String -> String -> Text+identifier ty xs+ | null xs = error $ ty ++ " should never be empty"+ | elem '\n' xs = error $ ty ++ " should not contain a new line"+ | otherwise = fromString xs --- | Administrator-newtype Admin = Admin- { adminName :: Text- } deriving (Show, Typeable, Generic)+-- | Nullability of fields.+--+-- Queries can contain nulls but the line protocol cannot.+data Nullability = Nullable | NonNullable deriving Typeable -newtype Ping = Ping- { pingStatus :: Text- } deriving (Show, Typeable, Generic)+-- | Field type for queries. Queries can contain null values.+type QueryField = Field 'Nullable -type Interface = Text+-- | Field type for the line protocol. The line protocol doesn't accept null+-- values.+type LineField = Field 'NonNullable -data ShardSpace = ShardSpace- { shardSpaceDatabase :: Maybe Text- , shardSpaceName :: Text- , shardSpaceRegex :: Text- , shardSpaceRetentionPolicy :: Text- , shardSpaceShardDuration :: Text- , shardSpaceReplicationFactor :: Word32- , shardSpaceSplit :: Word32- } deriving (Show, Typeable, Generic)+data Field (n :: Nullability) where+ -- | Signed 64-bit integers (@-9,223,372,036,854,775,808@ to+ -- @9,223,372,036,854,775,807@).+ FieldInt :: !Int64 -> Field n+ -- | IEEE-754 64-bit floating-point numbers. This is the default numerical+ -- type.+ FieldFloat :: !Double -> Field n+ -- | String field. Its length is limited to 64KB, which is not enforced by+ -- this library.+ FieldString :: !Text -> Field n+ -- | Boolean field.+ FieldBool :: !Bool -> Field n+ -- | Null field.+ --+ -- Note that a field can be null only in queries. The line protocol doesn't+ -- allow null values.+ FieldNull :: Field 'Nullable+ deriving Typeable --------------------------------------------------------------- Server pool manipulation+deriving instance Eq (Field n)+deriving instance Show (Field n) --- | Create a non-empty server pool. You must specify at least one server--- location to create a pool.-newServerPool :: Server -> [Server] -> IO (IORef ServerPool)-newServerPool = newServerPoolWithRetryPolicy defaultRetryPolicy- where- defaultRetryPolicy :: RetryPolicy- defaultRetryPolicy = limitRetries 5 <> exponentialBackoff 50+instance IsString (Field n) where+ fromString = FieldString . T.pack -newServerPoolWithRetryPolicy- :: RetryPolicy -> Server -> [Server] -> IO (IORef ServerPool)-newServerPoolWithRetryPolicy retryPolicy active backups =- newIORef ServerPool- { serverActive = active- , serverBackup = Seq.fromList backups- , serverRetryPolicy = retryPolicy- }+-- | Type of a request+data RequestType+ = QueryRequest+ -- ^ Request for @/query@+ | WriteRequest+ -- ^ Request for @/write@+ deriving Show --- | Get a server from the pool.-activeServer :: IORef ServerPool -> IO Server-activeServer ref = do- ServerPool { serverActive } <- readIORef ref- return serverActive+-- | Predefined set of time precision.+--+-- 'RFC3339' is only available for 'QueryRequest's.+data Precision (ty :: RequestType) where+ -- | POSIX time in ns+ Nanosecond :: Precision ty+ -- | POSIX time in μs+ Microsecond :: Precision ty+ -- | POSIX time in ms+ Millisecond :: Precision ty+ -- | POSIX time in s+ Second :: Precision ty+ -- | POSIX time in minutes+ Minute :: Precision ty+ -- | POSIX time in hours+ Hour :: Precision ty+ -- | Nanosecond precision time in a human readable format, like+ -- @2016-01-04T00:00:23.135623Z@. This is the default format for @/query@.+ RFC3339 :: Precision 'QueryRequest --- | Move the current server to the backup pool and pick one of the backup--- server as the new active server. Currently the scheduler works in--- round-robin fashion.-failover :: IORef ServerPool -> IO ()-failover ref = atomicModifyIORef' ref $ \pool@ServerPool {..} ->- case Seq.viewl serverBackup of- EmptyL -> (pool, ())- active :< rest -> (newPool, ())- where- newPool = pool- { serverActive = active- , serverBackup = rest |> serverActive- }+deriving instance Show (Precision a)+deriving instance Eq (Precision a) --------------------------------------------------------------- Exceptions+-- | Name of the time precision.+--+-- >>> precisionName Nanosecond+-- "n"+-- >>> precisionName Microsecond+-- "u"+-- >>> precisionName Millisecond+-- "ms"+-- >>> precisionName Second+-- "s"+-- >>> precisionName Minute+-- "m"+-- >>> precisionName Hour+-- "h"+-- >>> precisionName RFC3339+-- "rfc3339"+precisionName :: Precision ty -> Text+precisionName = \case+ Nanosecond -> "n"+ Microsecond -> "u"+ Millisecond -> "ms"+ Second -> "s"+ Minute -> "m"+ Hour -> "h"+ RFC3339 -> "rfc3339" +-- | A 'Timestamp' is something that can be converted to a valid+-- InfluxDB timestamp, which is represented as a 64-bit integer.+class Timestamp time where+ -- | Round a time to the given precision and scale it to nanoseconds+ roundTo :: Precision 'WriteRequest -> time -> Int64+ -- | Scale a time to the given precision+ scaleTo :: Precision 'WriteRequest -> time -> Int64++roundAt :: RealFrac a => a -> a -> a+roundAt scale x = fromIntegral (round (x / scale) :: Int64) * scale++-- | Scale of the type precision.+--+-- >>> precisionScale RFC3339+-- 1.0e-9+-- >>> precisionScale Microsecond+-- 1.0e-6+precisionScale :: Fractional a => Precision ty -> a+precisionScale = \case+ RFC3339 -> 10^^(-9 :: Int)+ Nanosecond -> 10^^(-9 :: Int)+ Microsecond -> 10^^(-6 :: Int)+ Millisecond -> 10^^(-3 :: Int)+ Second -> 1+ Minute -> 60+ Hour -> 60 * 60++-- |+-- >>> import Data.Time.Calendar+-- >>> let t = UTCTime (fromGregorian 2018 04 14) 123.123456789+-- >>> t+-- 2018-04-14 00:02:03.123456789 UTC+-- >>> roundTo Nanosecond t+-- 1523664123123456789+-- >>> roundTo Microsecond t+-- 1523664123123457000+-- >>> roundTo Millisecond t+-- 1523664123123000000+-- >>> roundTo Second t+-- 1523664123000000000+-- >>> roundTo Minute t+-- 1523664120000000000+-- >>> roundTo Hour t+-- 1523664000000000000+-- >>> scaleTo Nanosecond t+-- 1523664123123456789+-- >>> scaleTo Microsecond t+-- 1523664123123457+-- >>> scaleTo Millisecond t+-- 1523664123123+-- >>> scaleTo Second t+-- 1523664123+-- >>> scaleTo Minute t+-- 25394402+-- >>> scaleTo Hour t+-- 423240+instance Timestamp UTCTime where+ roundTo prec = roundTo prec . utcTimeToPOSIXSeconds+ scaleTo prec = scaleTo prec . utcTimeToPOSIXSeconds++-- |+-- >>> let dt = 123.123456789 :: NominalDiffTime+-- >>> roundTo Nanosecond dt+-- 123123456789+-- >>> roundTo Microsecond dt+-- 123123457000+-- >>> roundTo Millisecond dt+-- 123123000000+-- >>> roundTo Second dt+-- 123000000000+-- >>> roundTo Minute dt+-- 120000000000+-- >>> roundTo Hour dt+-- 0+-- >>> scaleTo Nanosecond dt+-- 123123456789+-- >>> scaleTo Microsecond dt+-- 123123457+-- >>> scaleTo Millisecond dt+-- 123123+-- >>> scaleTo Second dt+-- 123+-- >>> scaleTo Minute dt+-- 2+-- >>> scaleTo Hour dt+-- 0+instance Timestamp NominalDiffTime where+ roundTo prec time =+ round $ 10^(9 :: Int) * roundAt (precisionScale prec) time+ scaleTo prec time = round $ time / precisionScale prec++-- |+-- >>> let timespec = TimeSpec 123 123456789+-- >>> roundTo Nanosecond timespec+-- 123123456789+-- >>> roundTo Microsecond timespec+-- 123123457000+-- >>> roundTo Millisecond timespec+-- 123123000000+-- >>> roundTo Second timespec+-- 123000000000+-- >>> roundTo Minute timespec+-- 120000000000+-- >>> roundTo Hour timespec+-- 0+-- >>> scaleTo Nanosecond timespec+-- 123123456789+-- >>> scaleTo Microsecond timespec+-- 123123457+-- >>> scaleTo Millisecond timespec+-- 123123+-- >>> scaleTo Second timespec+-- 123+-- >>> scaleTo Minute timespec+-- 2+-- >>> scaleTo Hour timespec+-- 0+instance Timestamp TimeSpec where+ roundTo prec t =+ round $ 10^(9 :: Int) * roundAt (precisionScale prec) (timeSpecToSeconds t)+ scaleTo prec t = round $ timeSpecToSeconds t / precisionScale prec++timeSpecToSeconds :: TimeSpec -> Double+timeSpecToSeconds TimeSpec { sec, nsec } =+ fromIntegral sec + fromIntegral nsec * 10^^(-9 :: Int)++-- | Exceptions used in this library.+--+-- In general, the library tries to convert exceptions from the dependent+-- libraries to the following types of errors. data InfluxException- = JsonDecodeError String- | SeriesDecodeError String+ = ServerError String+ -- ^ Server side error.+ --+ -- You can expect to get a successful response once the issue is resolved on+ -- the server side.+ | ClientError String Request+ -- ^ Client side error.+ --+ -- You need to fix your query to get a successful response.+ | UnexpectedResponse String Request BL.ByteString+ -- ^ Received an unexpected response. The 'String' field is a message and the+ -- 'BL.ByteString' field is a possibly-empty relevant payload of the response.+ --+ -- This can happen e.g. when the response from InfluxDB is incompatible with+ -- what this library expects due to an upstream format change or when the JSON+ -- response doesn't have expected fields etc.+ | HTTPException HC.HttpException+ -- ^ HTTP communication error.+ --+ -- Typical HTTP errors (4xx and 5xx) are covered by 'ClientError' and+ -- 'ServerError'. So this exception means something unusual happened. Note+ -- that if 'HC.checkResponse' is overridden to throw an 'HC.HttpException' on+ -- an unsuccessful HTTP code, this exception is thrown instead of+ -- 'ClientError' or 'ServerError'. deriving (Show, Typeable) instance Exception InfluxException -jsonDecodeError :: String -> IO a-jsonDecodeError = throwIO . JsonDecodeError+-- | Class of data types that have a server field+class HasServer a where+ -- | InfluxDB server address and port that to interact with.+ server :: Lens' a Server -seriesDecodeError :: String -> IO a-seriesDecodeError = throwIO . SeriesDecodeError+-- | Class of data types that have a database field+class HasDatabase a where+ -- | Database name to work on.+ database :: Lens' a Database --------------------------------------------------------------- Aeson instances+-- | Class of data types that have a precision field+class HasPrecision (ty :: RequestType) a | a -> ty where+ -- | Time precision parameter.+ precision :: Lens' a (Precision ty) -deriveFromJSON (stripPrefixOptions "database") ''Database-deriveFromJSON (stripPrefixOptions "admin") ''Admin-deriveFromJSON (stripPrefixOptions "user") ''User-deriveFromJSON (stripPrefixOptions "ping") ''Ping-deriveFromJSON (stripPrefixOptions "shardSpace") ''ShardSpace+-- | Class of data types that have a manager field+class HasManager a where+ -- | HTTP manager settings or a manager itself.+ --+ -- If it's set to 'ManagerSettings', the library will create a 'Manager' from+ -- the settings for you.+ manager :: Lens' a (Either ManagerSettings Manager)++-- | Class of data types that has an authentication field+class HasCredentials a where+ -- | User name and password to be used when sending requests to InfluxDB.+ authentication :: Lens' a (Maybe Credentials)
− src/Database/InfluxDB/Types/Internal.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE CPP #-}-module Database.InfluxDB.Types.Internal- ( stripPrefixOptions- , stripPrefixLower- , stripPrefixSnake- ) where-import Data.Char (isUpper, toLower)------------------------------------------------------ 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 = stripPrefixLower name- }-#else-stripPrefixOptions :: String -> String -> String-stripPrefixOptions = stripPrefixLower-#endif---- | Strip the prefix then convert to 'lowerCamelCase'.-stripPrefixLower- :: String -- ^ Prefix to be stripped- -> String -- ^ Input string- -> String-stripPrefixLower prefix xs = case drop (length prefix) xs of- [] -> error "Insufficient length of field name"- c:cs -> toLower c : cs---- | Strip the prefix then convert to 'snake_case'.-stripPrefixSnake- :: String -- ^ Prefix to be stripped- -> String -- ^ Input string- -> String-stripPrefixSnake prefix xs = case drop (length prefix) xs of- [] -> error "Insufficient length of field name"- cs -> toSnake cs- where- toSnake = dropWhile (== '_') . foldr f []- f c cs- | isUpper c = '_':toLower c:cs- | otherwise = c:cs
+ src/Database/InfluxDB/Write.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-missing-signatures #-}+#else+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+#endif+module Database.InfluxDB.Write+ ( -- * Writers+ -- $intro+ write+ , writeBatch+ , writeByteString++ -- * Writer parameters+ , WriteParams+ , writeParams+ , Types.server+ , Types.database+ , retentionPolicy+ , Types.precision+ , Types.manager+) where+import Control.Exception+import Control.Monad+import Data.Maybe++import Control.Lens+import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Encoding as TE+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Types as HT++import Database.InfluxDB.Line+import Database.InfluxDB.Types as Types+import Database.InfluxDB.JSON++-- $setup+-- >>> :set -XOverloadedStrings -XNoOverloadedLists -XTypeApplications+-- >>> import qualified Data.Map as Map+-- >>> import Data.Time+-- >>> import Database.InfluxDB+-- >>> import qualified Network.HTTP.Client as HC+-- >>> Database.InfluxDB.manage (queryParams "test-db") "CREATE DATABASE \"test-db\""++{- $intro+The code snippets in this module assume the following imports.++@+import qualified Data.Map as Map+import Data.Time+@+-}++-- | The full set of parameters for the HTTP writer.+--+-- Following lenses are available to access its fields:+--+-- * 'server'+-- * 'database'+-- * 'retentionPolicy'+-- * 'precision'+-- * 'authentication'+-- * 'manager'+data WriteParams = WriteParams+ { writeServer :: !Server+ , writeDatabase :: !Database+ -- ^ Database to be written+ , writeRetentionPolicy :: !(Maybe Key)+ -- ^ 'Nothing' means the default retention policy for the database.+ , writePrecision :: !(Precision 'WriteRequest)+ -- ^ Timestamp precision+ --+ -- In the HTTP API, timestamps are scaled by the given precision.+ , writeAuthentication :: !(Maybe Credentials)+ -- ^ No authentication by default+ , writeManager :: !(Either HC.ManagerSettings HC.Manager)+ -- ^ HTTP connection manager+ }++-- | Smart constructor for 'WriteParams'+--+-- Default parameters:+--+-- ['server'] 'defaultServer'+-- ['retentionPolicy'] 'Nothing'+-- ['precision'] 'Nanosecond'+-- ['authentication'] 'Nothing'+-- ['manager'] @'Left' 'HC.defaultManagerSettings'@+writeParams :: Database -> WriteParams+writeParams writeDatabase = WriteParams+ { writeServer = defaultServer+ , writePrecision = Nanosecond+ , writeRetentionPolicy = Nothing+ , writeAuthentication = Nothing+ , writeManager = Left HC.defaultManagerSettings+ , ..+ }++-- | Write a 'Line'.+--+-- >>> let p = writeParams "test-db"+-- >>> write p $ Line @UTCTime "room_temp" Map.empty (Map.fromList [("temp", FieldFloat 25.0)]) Nothing+write+ :: Timestamp time+ => WriteParams+ -> Line time+ -> IO ()+write p@WriteParams {writePrecision} =+ writeByteString p . encodeLine (scaleTo writePrecision)++-- | Write multiple 'Line's in a batch.+--+-- This is more efficient than calling 'write' multiple times.+--+-- >>> let p = writeParams "test-db"+-- >>> :{+-- writeBatch p+-- [ Line @UTCTime "temp" (Map.singleton "city" "tokyo") (Map.fromList [("temp", FieldFloat 25.0)]) Nothing+-- , Line @UTCTime "temp" (Map.singleton "city" "osaka") (Map.fromList [("temp", FieldFloat 25.2)]) Nothing+-- ]+-- :}+writeBatch+ :: (Timestamp time, Foldable f)+ => WriteParams+ -> f (Line time)+ -> IO ()+writeBatch p@WriteParams {writePrecision} =+ writeByteString p . encodeLines (scaleTo writePrecision)++-- | Write a raw 'BL.ByteString'+writeByteString :: WriteParams -> BL.ByteString -> IO ()+writeByteString params payload = do+ manager' <- either HC.newManager return $ writeManager params+ response <- HC.httpLbs request manager' `catch` (throwIO . HTTPException)+ let body = HC.responseBody response+ status = HC.responseStatus response+ if BL.null body+ then do+ let message = B8.unpack $ HT.statusMessage status+ when (HT.statusIsServerError status) $+ throwIO $ ServerError message+ when (HT.statusIsClientError status) $+ throwIO $ ClientError message request+ else case A.eitherDecode' body of+ Left message ->+ throwIO $ UnexpectedResponse message request body+ Right val -> case A.parse parseErrorObject val of+ A.Success err ->+ fail $ "BUG: impossible code path in "+ ++ "Database.InfluxDB.Write.writeByteString: "+ ++ err+ A.Error message -> do+ when (HT.statusIsServerError status) $+ throwIO $ ServerError message+ when (HT.statusIsClientError status) $+ throwIO $ ClientError message request+ throwIO $ UnexpectedResponse+ ("BUG: " ++ message+ ++ " in Database.InfluxDB.Write.writeByteString")+ request+ (A.encode val)+ where+ request = (writeRequest params)+ { HC.requestBody = HC.RequestBodyLBS payload+ }++writeRequest :: WriteParams -> HC.Request+writeRequest WriteParams {..} =+ HC.setQueryString qs HC.defaultRequest+ { HC.host = TE.encodeUtf8 _host+ , HC.port = fromIntegral _port+ , HC.secure = _ssl+ , HC.method = "POST"+ , HC.path = "/write"+ }+ where+ Server {..} = writeServer+ qs = concat+ [ [ ("db", Just $ TE.encodeUtf8 $ databaseName writeDatabase)+ , ("precision", Just $ TE.encodeUtf8 $ precisionName writePrecision)+ ]+ , fromMaybe [] $ do+ Key name <- writeRetentionPolicy+ return [("rp", Just (TE.encodeUtf8 name))]+ , fromMaybe [] $ do+ Credentials { _user = u, _password = p } <- writeAuthentication+ return+ [ ("u", Just (TE.encodeUtf8 u))+ , ("p", Just (TE.encodeUtf8 p))+ ]+ ]++makeLensesWith+ ( lensRules+ & generateSignatures .~ False+ & lensField .~ lookingupNamer+ [ ("writeServer", "_server")+ , ("writeDatabase", "_database")+ , ("writeRetentionPolicy", "retentionPolicy")+ , ("writePrecision", "_precision")+ , ("writeManager", "_manager")+ , ("writeAuthentication", "_authentication")+ ]+ )+ ''WriteParams++-- |+-- >>> let p = writeParams "foo"+-- >>> p ^. server.host+-- "localhost"+instance HasServer WriteParams where+ server = _server++-- |+-- >>> let p = writeParams "foo"+-- >>> p ^. database+-- "foo"+instance HasDatabase WriteParams where+ database = _database++-- | Target retention policy for the write.+--+-- InfluxDB writes to the @default@ retention policy if this parameter is set+-- to 'Nothing'.+--+-- >>> let p = writeParams "foo" & retentionPolicy .~ Just "two_hours"+-- >>> p ^. retentionPolicy+-- Just "two_hours"+retentionPolicy :: Lens' WriteParams (Maybe Key)++-- |+-- >>> let p = writeParams "foo"+-- >>> p ^. precision+-- Nanosecond+instance HasPrecision 'WriteRequest WriteParams where+ precision = _precision++-- |+-- >>> let p = writeParams "foo" & manager .~ Left HC.defaultManagerSettings+instance HasManager WriteParams where+ manager = _manager++-- | Authentication info for the write+--+-- >>> let p = writeParams "foo"+-- >>> p ^. authentication+-- Nothing+-- >>> let p' = p & authentication ?~ credentials "john" "passw0rd"+-- >>> p' ^. authentication . traverse . user+-- "john"+instance HasCredentials WriteParams where+ authentication = _authentication
+ src/Database/InfluxDB/Write/UDP.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Database.InfluxDB.Write.UDP+ ( -- $intro++ -- * Writers+ write+ , writeBatch+ , writeByteString++ -- * Writer parameters+ , WriteParams+ , writeParams+ , socket+ , sockAddr+ , Types.precision+ ) where++import Control.Lens+import Network.Socket (SockAddr, Socket)+import Network.Socket.ByteString (sendManyTo)+import qualified Data.ByteString.Lazy as BL++import Database.InfluxDB.Line+import Database.InfluxDB.Types as Types++{- $intro+This module is desined to be used with the [network]+(https://hackage.haskell.org/package/network) package and be imported qualified.++>>> :set -XOverloadedStrings -XNoOverloadedLists+>>> import qualified Data.Map as Map+>>> import Data.Time+>>> import Network.Socket+>>> import Database.InfluxDB+>>> import qualified Database.InfluxDB.Write.UDP as UDP+>>> sock <- Network.Socket.socket AF_INET Datagram defaultProtocol+>>> let localhost = tupleToHostAddress (127, 0, 0, 1)+>>> let params = UDP.writeParams sock $ SockAddrInet 8089 localhost+>>> UDP.write params $ Line "measurement1" Map.empty (Map.fromList [("value", FieldInt 42)]) (Nothing :: Maybe UTCTime)+>>> close sock++Make sure that the UDP service is enabled in the InfluxDB config. This API+doesn't tell you if any error occurs. See [the official doc]+(https://docs.influxdata.com/influxdb/v1.6/supported_protocols/udp/) for+details.+-}++-- | The full set of parameters for the UDP writer.+data WriteParams = WriteParams+ { _socket :: !Socket+ , _sockAddr :: !SockAddr+ , _precision :: !(Precision 'WriteRequest)+ }++-- | Smart constructor for 'WriteParams'+--+-- Default parameters:+--+-- ['L.precision'] 'Nanosecond'+writeParams :: Socket -> SockAddr -> WriteParams+writeParams _socket _sockAddr = WriteParams+ { _precision = Nanosecond+ , ..+ }++-- | Write a 'Line'+write+ :: Timestamp time+ => WriteParams+ -> Line time+ -> IO ()+write p@WriteParams {_precision} =+ writeByteString p . encodeLine (roundTo _precision)++-- | Write 'Line's in a batch+--+-- This is more efficient than 'write'.+writeBatch+ :: (Timestamp time, Foldable f)+ => WriteParams+ -> f (Line time)+ -> IO ()+writeBatch p@WriteParams {_precision} =+ writeByteString p . encodeLines (roundTo _precision)++-- | Write a lazy 'L.ByteString'+writeByteString :: WriteParams -> BL.ByteString -> IO ()+writeByteString WriteParams {..} payload =+ sendManyTo _socket (BL.toChunks payload) _sockAddr++makeLensesWith (lensRules & generateSignatures .~ False) ''WriteParams++-- | Open UDP socket+socket :: Lens' WriteParams Socket++-- | UDP endopoint of the database+sockAddr :: Lens' WriteParams SockAddr++precision :: Lens' WriteParams (Precision 'WriteRequest)++-- | Timestamp precision.+--+-- In the UDP API, all timestamps are sent in nanosecond but you can specify+-- lower precision. The writer just rounds timestamps to the specified+-- precision.+instance HasPrecision 'WriteRequest WriteParams where+ precision = Database.InfluxDB.Write.UDP.precision
+ tests/doctests.hs view
@@ -0,0 +1,11 @@+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Test.DocTest (doctest)++main :: IO ()+main = doctest+ $ "-fobject-code"+ --- ^ Use object code to work around https://gitlab.haskell.org/ghc/ghc/-/issues/19460+ -- in GHC 9.0.1.+ : flags ++ pkgs ++ module_sources
+ tests/regressions.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+import Control.Exception (bracket_, try)++import Control.Lens+import Data.Time+import Test.Tasty+import Test.Tasty.HUnit+import qualified Data.Map as M+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import qualified Text.RawString.QQ as Raw (r)++import Database.InfluxDB+import Database.InfluxDB.Line+import qualified Database.InfluxDB.Format as F++main :: IO ()+main = defaultMain $ testGroup "regression tests"+ [ testCase "issue #64" case_issue64+ , testCase "issue #66" case_issue66+ , testCaseSteps "issue #75" case_issue75+ , testCaseSteps "issue #79" case_issue79+ ]++-- https://github.com/maoe/influxdb-haskell/issues/64+case_issue64 :: Assertion+case_issue64 = withDatabase dbName $ do+ write wp $ Line @UTCTime "count" Map.empty+ (Map.fromList [("value", FieldInt 1)])+ Nothing+ r <- try $ query qp "SELECT value FROM count"+ case r of+ Left err -> case err of+ UnexpectedResponse message _ _ ->+ message `elem` [+ "BUG: parsing Int failed, expected Number, but encountered String in Database.InfluxDB.Query.query",+ "BUG: expected Int, encountered String in Database.InfluxDB.Query.query"+ ] @? "Correct error message."+ _ ->+ assertFailure $ got ++ show err+ Right (v :: (V.Vector (Tagged "time" Int, Tagged "value" Int))) ->+ -- NOTE: The time columns should be UTCTime, Text, or String+ assertFailure $ got ++ "no errors: " ++ show v+ where+ dbName = "case_issue64"+ qp = queryParams dbName & precision .~ RFC3339+ wp = writeParams dbName+ got = "expeted an UnexpectedResponse but got "++-- https://github.com/maoe/influxdb-haskell/issues/66+case_issue66 :: Assertion+case_issue66 = do+ r <- try $ query (queryParams "_internal") "SELECT time FROM dummy"+ case r of+ Left err -> case err of+ UnexpectedResponse message _ _ ->+ message @?=+ "BUG: at least 1 non-time field must be queried in Database.InfluxDB.Query.query"+ _ ->+ assertFailure $ got ++ show err+ Right (v :: V.Vector (Tagged "time" Int)) ->+ assertFailure $ got ++ "no errors: " ++ show v+ where+ got = "expected an UnexpectedResponse but got "++-- https://github.com/maoe/influxdb-haskell/issues/75+case_issue75 :: (String -> IO ()) -> Assertion+case_issue75 step = do+ step "Checking encoded value"+ let string = [Raw.r|bl\"a|]+ let encoded = encodeLine (scaleTo Nanosecond)+ $ Line @UTCTime "testing" mempty+ (M.singleton "test" $ FieldString string)+ Nothing+ encoded @?= [Raw.r|testing test="bl\\\"a"|]++ step "Preparing a test database"+ let db = "issue75"+ let p = queryParams db+ manage p $ formatQuery ("DROP DATABASE "%F.database) db+ manage p $ formatQuery ("CREATE DATABASE "%F.database) db++ step "Checking server response"+ let wp = writeParams db+ writeByteString wp encoded++case_issue79 :: (String -> IO ()) -> Assertion+case_issue79 step = withDatabase db $ do+ let w = writeParams db+ let q = queryParams db+ step "Querying an empty series with two fields expected"+ _ <- query @(Tagged "time" UTCTime, Tagged "value" Int) q "SELECT * FROM foo"+ step "Querying an empty series with the results ignored"+ _ <- query @Ignored q "SELECT * FROM foo"+ step "Querying an empty series expecting an empty result"+ _ <- query @Empty q "SELECT * FROM foo"+ step "Writing a data point"+ write w $ Line @UTCTime "foo" mempty (Map.fromList [("value", FieldInt 42)]) Nothing+ step "Querying a non-empty series with two fields expected"+ _ <- query @(Tagged "time" UTCTime, Tagged "value" Int) q "SELECT * FROM foo"+ step "Querying a non-empty series with the results ignored"+ _ <- query @Ignored q "SELECT * FROM foo"+ return ()+ where+ db = "case_issue79"++withDatabase :: Database -> IO a -> IO a+withDatabase dbName f = bracket_+ (manage q (formatQuery ("CREATE DATABASE "%F.database) dbName))+ (manage q (formatQuery ("DROP DATABASE "%F.database) dbName))+ f+ where+ q = queryParams dbName
− tests/test-suite.hs
@@ -1,484 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-import Control.Applicative-import Control.Exception as E-import Control.Monad.Trans-import Data.Int-import Data.List (find)-import Data.Monoid-import Data.Text (Text)-import Data.Unique-import Data.Word-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as V--import Test.Tasty.HUnit-import Test.Tasty.TH-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-prop_fromValue_toValue_identity_Value = fromValueToValueIdentity--prop_fromValue_toValue_identity_Bool :: Bool -> Bool-prop_fromValue_toValue_identity_Bool = fromValueToValueIdentity--prop_fromValue_toValue_identity_Int :: Int -> Bool-prop_fromValue_toValue_identity_Int = fromValueToValueIdentity--prop_fromValue_toValue_identity_Int8 :: Int8 -> Bool-prop_fromValue_toValue_identity_Int8 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Int16 :: Int16 -> Bool-prop_fromValue_toValue_identity_Int16 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Int32 :: Int32 -> Bool-prop_fromValue_toValue_identity_Int32 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Int64 :: Int64 -> Bool-prop_fromValue_toValue_identity_Int64 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Word8 :: Word8 -> Bool-prop_fromValue_toValue_identity_Word8 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Word16 :: Word16 -> Bool-prop_fromValue_toValue_identity_Word16 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Word32 :: Word32 -> Bool-prop_fromValue_toValue_identity_Word32 = fromValueToValueIdentity--prop_fromValue_toValue_identity_Double :: Double -> Bool-prop_fromValue_toValue_identity_Double = fromValueToValueIdentity--prop_fromValue_toValue_identity_Text :: T.Text -> Bool-prop_fromValue_toValue_identity_Text = fromValueToValueIdentity--prop_fromValue_toValue_identity_LazyText :: TL.Text -> Bool-prop_fromValue_toValue_identity_LazyText = fromValueToValueIdentity--prop_fromValue_toValue_identity_String :: String -> Bool-prop_fromValue_toValue_identity_String = fromValueToValueIdentity--prop_fromValue_toValue_identity_Maybe_Int :: Maybe Int -> Bool-prop_fromValue_toValue_identity_Maybe_Int = fromValueToValueIdentity-----------------------------------------------------instance Arbitrary Value where- arbitrary = oneof- [ Int <$> arbitrary- , Float <$> arbitrary- , String <$> arbitrary- , Bool <$> arbitrary- , pure Null- ]--instance Arbitrary T.Text where- arbitrary = T.pack <$> arbitrary--instance Arbitrary TL.Text where- arbitrary = TL.pack <$> arbitrary--fromValueToValueIdentity :: (Eq a, FromValue a, ToValue a) => a -> Bool-fromValueToValueIdentity a = fromValue (toValue a) == Right a-----------------------------------------------------case_ping :: Assertion-case_ping = runTest $ \config -> do- Ping status <- ping config- status @?= "ok"--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- 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--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- ss <- query config database $ "select value from " <> name- case ss of- [series] -> fromSeriesData series @?= Right [Val 42, Val 42, Val 42]- _ -> assertFailure $ "Expect one series, but got: " ++ show ss--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- ss <- query config database $ "select value from " <> name- case ss of- [series] -> fromSeriesData series @?= Right [Val 42, Val 42, Val 42]- _ -> assertFailure $ "Expect one series, but got: " ++ show ss--case_query_nonexistent_series :: Assertion-case_query_nonexistent_series = runTest $ \config ->- withTestDatabase config $ \database -> do- name <- liftIO newName- assertStatusCodeException- (query config database $ "select * from " <> name :: IO [SeriesData])--case_query_empty_series :: Assertion-case_query_empty_series = runTest $ \config ->- withTestDatabase config $ \database -> do- name <- liftIO newName- post config database $- writeSeries name $ Val 42- ss1 <- query config database $ "delete from " <> name- ss1 @?= ([] :: [SeriesData])- ss2 <- query config database $ "select * from " <> name- ss2 @?= ([] :: [SeriesData])--case_queryChunked :: Assertion-case_queryChunked = runTest $ \config ->- withTestDatabase config $ \database -> do- name <- liftIO newName- post config database $ withSeries name $ do- writePoints $ Val 42- writePoints $ Val 42- writePoints $ Val 42- ss <- queryChunked config database ("select value from " <> name) $- S.fold step []- mapM fromSeriesData ss @?= Right [[Val 42], [Val 42], [Val 42]]- where- step xs series = case fromSeriesData series of- Left reason -> throwIO $ HUnitFailure reason- Right values -> return $ xs ++ values--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- 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--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- assertStatusCodeException- (query config database $ "select value from " <> name :: IO [SeriesData])--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_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- dropDatabaseIfExists config name- createDatabase config name- listDatabases config >>= \databases ->- assertBool ("No such database: " ++ T.unpack name) $- any ((name ==) . databaseName) databases- dropDatabase config name- listDatabases config >>= \databases ->- 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" ==) . adminName) 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- admin <- addClusterAdmin config name "somePassword"- listClusterAdmins config >>= \admins ->- assertBool ("No such admin: " ++ T.unpack name) $- any ((name ==) . adminName) admins- deleteClusterAdmin config admin- listClusterAdmins config >>= \admins ->- assertBool ("Found a deleted admin: " ++ T.unpack name) $- all ((name /=) . adminName) 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'- listDatabases newConfig >>= \databases ->- 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- deleteClusterAdmin config admin--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"- 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- 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 ->- 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 ->- 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------------------------------------------------------ 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- 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--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-----------------------------------------------------main :: IO ()-main = $defaultMainGenerator------------------------------------------------------ Instance deriving--deriveSeriesData defaultOptions- { fieldLabelModifier = stripPrefixLower "wholeFloat" }- ''WholeFloat