summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/random-points.hs61
-rw-r--r--influxdb.cabal9
-rw-r--r--src/Database/InfluxDB.hs2
-rw-r--r--src/Database/InfluxDB/Decode.hs96
-rw-r--r--src/Database/InfluxDB/Encode.hs10
-rw-r--r--src/Database/InfluxDB/Http.hs4
-rw-r--r--src/Database/InfluxDB/Stream.hs23
-rw-r--r--src/Database/InfluxDB/TH.hs121
-rw-r--r--src/Database/InfluxDB/Types.hs6
-rw-r--r--src/Database/InfluxDB/Types/Internal.hs9
-rw-r--r--tests/test-suite.hs163
11 files changed, 415 insertions, 89 deletions
diff --git a/examples/random-points.hs b/examples/random-points.hs
index 63e8b14..d87e559 100644
--- a/examples/random-points.hs
+++ b/examples/random-points.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
import Control.Applicative
import Control.Exception as E
import Control.Monad
@@ -13,13 +13,14 @@ import Data.Time.Clock.POSIX
import System.Environment
import System.IO
import qualified Data.Text as T
-import qualified Data.Vector as V
import System.Random.MWC (Variate(..))
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
oneWeekInSeconds :: Int
oneWeekInSeconds = 7*24*60*60
@@ -45,7 +46,7 @@ main = do
<$> getPOSIXTime
<*> (fromIntegral <$> uniformR (0, oneWeekInSeconds) gen)
!value <- liftIO $ uniform gen
- writePoints $ Point value timestamp
+ writePoints $ Point value (Time timestamp)
innerLoop $ n - 1
outerLoop $ m - 1
@@ -56,16 +57,13 @@ main = do
print $ seriesColumns series
print $ seriesPoints series
-- Streaming output
- queryChunked config db "select * from ct1;" $ \stream0 ->
- flip fix stream0 $ \loop stream -> case stream of
- Done -> return ()
- Yield series next -> do
- case fromSeriesData series of
- Left reason -> hPutStrLn stderr reason
- Right points -> mapM_ print (points :: [Point])
- putStrLn "--"
- stream' <- next
- loop stream'
+ 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 "--"
newConfig :: HC.Manager -> IO Config
newConfig manager = do
@@ -81,22 +79,24 @@ managerSettings = HC.defaultManagerSettings
{ HC.managerResponseTimeout = Just $ 60*(10 :: Int)^(6 :: Int)
}
-data Point = Point !Name !POSIXTime deriving Show
+data Point = Point
+ { pointValue :: !Name
+ , pointTime :: !Time
+ } deriving Show
-instance ToSeriesData Point where
- toSeriesColumns _ = V.fromList ["value", "time"]
- toSeriesPoints (Point value time) = V.fromList
- [ toValue value
- , epochInSeconds time
- ]
+newtype Time = Time POSIXTime
+ deriving Show
-instance FromSeriesData Point where
- parseSeriesData = withValues $ \values -> Point
- <$> values .: "value"
- <*> values .: "time"
+instance ToValue Time where
+ toValue (Time epoch) = toValue $ epochInSeconds epoch
+ where
+ epochInSeconds :: POSIXTime -> Value
+ epochInSeconds = Int . floor
-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
data Name
= Foo
@@ -129,7 +129,8 @@ instance Variate Name where
name <- uniformR (fromEnum lower, fromEnum upper) g
return $! toEnum name
-instance FromValue POSIXTime where
- parseValue (Int n) = return $ fromIntegral n
- parseValue (Float d) = return $ realToFrac d
- parseValue v = typeMismatch "Int or Float" v
+-- Instance deriving
+
+deriveSeriesData defaultOptions
+ { fieldLabelModifier = stripPrefixLower "point" }
+ ''Point
diff --git a/influxdb.cabal b/influxdb.cabal
index 58aa352..dead2d7 100644
--- a/influxdb.cabal
+++ b/influxdb.cabal
@@ -1,5 +1,5 @@
name: influxdb
-version: 0.1.0.1
+version: 0.2.0
synopsis: Haskell client library for InfluxDB
description: Haskell client library for InfluxDB
homepage: https://github.com/maoe/influxdb-haskell
@@ -28,6 +28,7 @@ library
-- Database.InfluxDB.Query
Database.InfluxDB.Stream
Database.InfluxDB.Types
+ Database.InfluxDB.TH
other-modules:
Database.InfluxDB.Types.Internal
ghc-options: -Wall
@@ -46,6 +47,7 @@ library
, retry
, scientific
, tagged
+ , template-haskell
, text
, time
, vector
@@ -58,10 +60,12 @@ test-suite test-suite
build-depends:
base
, http-client
+ , HUnit
, influxdb
, mtl
, tasty
, tasty-hunit
+ , tasty-quickcheck
, tasty-th
, text
, vector
@@ -85,7 +89,6 @@ executable influx-random-points
, mwc-random
, text
, time
- , vector
default-language: Haskell2010
source-repository head
@@ -95,5 +98,5 @@ source-repository head
source-repository this
type: git
- tag: v0.1.0.1
+ tag: v0.2.0
location: https://github.com/maoe/influxdb-haskell.git
diff --git a/src/Database/InfluxDB.hs b/src/Database/InfluxDB.hs
index f9ad216..a35baec 100644
--- a/src/Database/InfluxDB.hs
+++ b/src/Database/InfluxDB.hs
@@ -14,7 +14,7 @@ module Database.InfluxDB
, FromSeriesData(..), fromSeriesData
, FromValue(..), fromValue
- , withValues, (.:)
+ , withValues, (.:), (.:?), (.!=)
, typeMismatch
-- * HTTP API
diff --git a/src/Database/InfluxDB/Decode.hs b/src/Database/InfluxDB/Decode.hs
index 0a77b38..f733974 100644
--- a/src/Database/InfluxDB/Decode.hs
+++ b/src/Database/InfluxDB/Decode.hs
@@ -1,24 +1,30 @@
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Database.InfluxDB.Decode
( FromSeries(..), fromSeries
, FromSeriesData(..), fromSeriesData
- , withValues, (.:)
+ , withValues, (.:), (.:?), (.!=)
, FromValue(..), fromValue
, Parser, ValueParser, typeMismatch
) where
import Control.Applicative
import Control.Monad.Reader
+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 Database.InfluxDB.Types
--- | A type that can be converted from a @Series@.
+-- | A type that can be converted from a 'Series'.
class FromSeries a where
parseSeries :: Series -> Parser a
@@ -28,11 +34,11 @@ instance FromSeries Series where
instance FromSeries SeriesData where
parseSeries = return . seriesData
--- | Converte a value from a @Series@, failing if the types do not match.
+-- | 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
+-- | A type that can be converted from a 'SeriesData'. A typical implementation
-- is as follows.
--
-- > import Control.Applicative ((<$>), (<*>))
@@ -56,12 +62,13 @@ instance FromSeriesData SeriesData where
, seriesDataPoints = [values]
}
--- | Converte a value from a @SeriesData@, failing if the types do not match.
+-- | 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
+-- | Helper function to define 'parseSeriesData' from 'ValueParser's.
withValues
:: (Vector Value -> ValueParser a)
-> Vector Column -> Vector Value -> Parser a
@@ -70,6 +77,9 @@ withValues f columns values =
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
@@ -79,11 +89,29 @@ values .: column = do
value <- V.indexM values idx
liftParser $ parseValue value
--- | A type that can be converted from a @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.
+-- | Converte a value from a 'Value', failing if the types do not match.
fromValue :: FromValue a => Value -> Either String a
fromValue = runParser . parseValue
@@ -102,10 +130,64 @@ 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 = fail $ "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 = fail $ "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 = fail $ "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 = fail $ "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 = fail $ "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 = fail $ "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 = fail $ "Larger than the maximum Word32: " ++ show n
+ parseValue v = typeMismatch "Word32" v
+
instance FromValue Double where
parseValue (Float d) = return d
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
diff --git a/src/Database/InfluxDB/Encode.hs b/src/Database/InfluxDB/Encode.hs
index bd61df5..8b5f9b4 100644
--- a/src/Database/InfluxDB/Encode.hs
+++ b/src/Database/InfluxDB/Encode.hs
@@ -15,11 +15,11 @@ import qualified Data.Text.Lazy as TL
import Database.InfluxDB.Types
--- | A type that can be converted to a @Series@.
+-- | 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
+-- | A type that can be converted to a 'SeriesData'. A typical implementation is
-- as follows.
--
-- > import qualified Data.Vector as V
@@ -48,6 +48,9 @@ toSeriesData a = SeriesData
class ToValue a where
toValue :: a -> Value
+instance ToValue Value where
+ toValue = id
+
instance ToValue Bool where
toValue = Bool
@@ -79,9 +82,6 @@ instance ToValue Word16 where
instance ToValue Word32 where
toValue = Int . fromIntegral
-instance ToValue Float where
- toValue = Float . realToFrac
-
instance ToValue Double where
toValue = Float
diff --git a/src/Database/InfluxDB/Http.hs b/src/Database/InfluxDB/Http.hs
index 9e1f424..7773882 100644
--- a/src/Database/InfluxDB/Http.hs
+++ b/src/Database/InfluxDB/Http.hs
@@ -128,7 +128,7 @@ 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.
+-- 'post' but with time precision.
postWithPrecision
:: Config
-> Text -- ^ Database name
@@ -305,7 +305,7 @@ responseStream body = demandPayload $ \payload ->
decode (P.Fail _ _ message) = fail message
parseAsJson = P.parse A.json
--- | Query a specified database like @query@ but in a streaming fashion.
+-- | Query a specified database like 'query' but in a streaming fashion.
queryChunked
:: FromSeries a
=> Config
diff --git a/src/Database/InfluxDB/Stream.hs b/src/Database/InfluxDB/Stream.hs
index e418651..7820616 100644
--- a/src/Database/InfluxDB/Stream.hs
+++ b/src/Database/InfluxDB/Stream.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
module Database.InfluxDB.Stream where
import Prelude hiding (mapM)
@@ -16,3 +17,25 @@ 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'
diff --git a/src/Database/InfluxDB/TH.hs b/src/Database/InfluxDB/TH.hs
new file mode 100644
index 0000000..b3527f0
--- /dev/null
+++ b/src/Database/InfluxDB/TH.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+#if __GLASGOW_HASKELL__ == 704
+{-# LANGUAGE ConstraintKinds #-}
+#endif
+
+module Database.InfluxDB.TH
+ ( Options(..), defaultOptions
+ , deriveSeriesData
+ , deriveToSeriesData
+ , deriveFromSeriesData
+
+ , stripPrefixLower
+ ) where
+import Control.Applicative
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (VarStrictType)
+
+import qualified Data.Vector as V
+
+import Database.InfluxDB.Decode
+import Database.InfluxDB.Encode
+import Database.InfluxDB.Types.Internal (stripPrefixLower)
+
+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
+ DataD _ tyName tyVars [con] _ -> f opts tyName tyVars con
+ NewtypeD _ tyName tyVars con _ -> f opts tyName tyVars con
+ _ -> 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
+ <$> mapM tyVarToPred tyVars
+ <*> [t| ToSeriesData $(conT tyName) |]
+ <*> deriveDecs conName vars
+ _ -> fail $ "Expected a record, but got " ++ show con
+ where
+ tyVarToPred tv = case tv of
+ PlainTV name -> classP ''FromValue [varT name]
+ KindedTV name _ -> classP ''FromValue [varT name]
+ 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
+ PlainTV name -> classP ''FromValue [varT name]
+ KindedTV name _ -> classP ''FromValue [varT name]
+ 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
diff --git a/src/Database/InfluxDB/Types.hs b/src/Database/InfluxDB/Types.hs
index 2e99968..c2e9cdf 100644
--- a/src/Database/InfluxDB/Types.hs
+++ b/src/Database/InfluxDB/Types.hs
@@ -66,7 +66,7 @@ atomicModifyIORef' ref f = do
-----------------------------------------------------------
-- | A series consists of name, columns and points. The columns and points are
--- expressed in a separate type @SeriesData@.
+-- expressed in a separate type 'SeriesData'.
data Series = Series
{ seriesName :: {-# UNPACK #-} !Text
-- ^ Series name
@@ -105,11 +105,11 @@ instance A.FromJSON Series where
}
parseJSON _ = empty
--- | @SeriesData@ consists of columns and points.
+-- | 'SeriesData' consists of columns and points.
data SeriesData = SeriesData
{ seriesDataColumns :: Vector Column
, seriesDataPoints :: [Vector Value]
- }
+ } deriving Show
type Column = Text
diff --git a/src/Database/InfluxDB/Types/Internal.hs b/src/Database/InfluxDB/Types/Internal.hs
index 0507cd7..95d4f5d 100644
--- a/src/Database/InfluxDB/Types/Internal.hs
+++ b/src/Database/InfluxDB/Types/Internal.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
module Database.InfluxDB.Types.Internal
( stripPrefixOptions
+ , stripPrefixLower
) where
import Data.Char (toLower)
@@ -16,14 +17,14 @@ import Data.Aeson.TH (Options(..), defaultOptions)
#if MIN_VERSION_aeson(0, 6, 2)
stripPrefixOptions :: String -> Options
stripPrefixOptions name = defaultOptions
- { fieldLabelModifier = stripPrefix name
+ { fieldLabelModifier = stripPrefixLower name
}
#else
stripPrefixOptions :: String -> String -> String
-stripPrefixOptions = stripPrefix
+stripPrefixOptions = stripPrefixLower
#endif
-stripPrefix :: String -> String -> String
-stripPrefix prefix xs = case drop (length prefix) xs of
+stripPrefixLower :: String -> String -> String
+stripPrefixLower prefix xs = case drop (length prefix) xs of
[] -> error "Insufficient length of field name"
c:cs -> toLower c : cs
diff --git a/tests/test-suite.hs b/tests/test-suite.hs
index e3de360..df5e258 100644
--- a/tests/test-suite.hs
+++ b/tests/test-suite.hs
@@ -5,22 +5,92 @@ import Control.Exception as E
import Control.Monad
import Control.Monad.Trans
import Data.Function
+import Data.Int
import Data.List (find)
import Data.Monoid
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.HUnit.Lang (HUnitFailure(..))
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.TH
+import Test.Tasty.QuickCheck
import qualified Network.HTTP.Client as HC
import Database.InfluxDB
+import qualified Database.InfluxDB.Stream as S
-main :: IO ()
-main = $defaultMainGenerator
+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_post :: Assertion
case_post = runTest $ \config ->
@@ -28,9 +98,10 @@ case_post = runTest $ \config ->
name <- liftIO newName
post config database $
writeSeries name $ Val 42
- [series] <- query config database $
- "select value from " <> name
- fromSeriesData series @=? Right [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 ->
@@ -40,9 +111,10 @@ case_post_multi_series = runTest $ \config ->
writeSeries name $ Val 42
writeSeries name $ Val 42
writeSeries name $ Val 42
- [series] <- query config database $
- "select value from " <> name
- fromSeriesData series @=? Right [Val 42, Val 42, Val 42]
+ 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 ->
@@ -52,9 +124,26 @@ case_post_multi_points = runTest $ \config ->
writePoints $ Val 42
writePoints $ Val 42
writePoints $ Val 42
- [series] <- query config database $
- "select value from " <> name
- fromSeriesData series @=? Right [Val 42, Val 42, Val 42]
+ 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_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 ->
@@ -62,9 +151,10 @@ case_post_with_precision = runTest $ \config ->
name <- liftIO newName
postWithPrecision config database SecondsPrecision $
writeSeries name $ Val 42
- [series] <- query config database $
- "select value from " <> name
- fromSeriesData series @=? Right [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_listDatabases :: Assertion
case_listDatabases = runTest $ \config ->
@@ -78,13 +168,13 @@ case_create_then_drop_database = runTest $ \config -> do
name <- newName
dropDatabaseIfExists config name
createDatabase config name
- databases <- listDatabases config
- assertBool ("No such database: " ++ T.unpack name) $
- any ((name ==) . databaseName) databases
+ listDatabases config >>= \databases ->
+ assertBool ("No such database: " ++ T.unpack name) $
+ any ((name ==) . databaseName) databases
dropDatabase config name
- databases' <- listDatabases config
- assertBool ("Found a dropped database: " ++ T.unpack name) $
- all ((name /=) . databaseName) databases'
+ 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
@@ -96,13 +186,13 @@ case_add_then_delete_cluster_admin :: Assertion
case_add_then_delete_cluster_admin = runTest $ \config -> do
name <- newName
admin <- addClusterAdmin config name "somePassword"
- admins <- listClusterAdmins config
- assertBool ("No such admin: " ++ T.unpack name) $
- any ((name ==) . adminUsername) admins
+ listClusterAdmins config >>= \admins ->
+ assertBool ("No such admin: " ++ T.unpack name) $
+ any ((name ==) . adminUsername) admins
deleteClusterAdmin config admin
- admins' <- listClusterAdmins config
- assertBool ("Found a deleted admin: " ++ T.unpack name) $
- all ((name /=) . adminUsername) admins'
+ listClusterAdmins config >>= \admins ->
+ assertBool ("Found a deleted admin: " ++ T.unpack name) $
+ all ((name /=) . adminUsername) admins
case_update_cluster_admin_password :: Assertion
case_update_cluster_admin_password = runTest $ \config -> do
@@ -117,13 +207,13 @@ case_update_cluster_admin_password = runTest $ \config -> do
name <- newName
dropDatabaseIfExists config name
createDatabase newConfig name
- databases <- listDatabases newConfig
- assertBool ("No such database: " ++ T.unpack name) $
- any ((name ==) . databaseName) databases
+ listDatabases newConfig >>= \databases ->
+ assertBool ("No such database: " ++ T.unpack name) $
+ any ((name ==) . databaseName) databases
dropDatabase newConfig name
- databases' <- listDatabases newConfig
- assertBool ("Found a dropped database: " ++ T.unpack name) $
- all ((name /=) . databaseName) databases'
+ listDatabases newConfig >>= \databases ->
+ assertBool ("Found a dropped database: " ++ T.unpack name) $
+ all ((name /=) . databaseName) databases
case_add_then_delete_database_users :: Assertion
case_add_then_delete_database_users = runTest $ \config ->
@@ -160,14 +250,14 @@ case_grant_revoke_database_user = runTest $ \config ->
assertBool ("No such user: " <> T.unpack newUserName) $
any ((newUserName ==) . userName) users
grantAdminPrivilegeTo config name newUserName
- listDatabaseUsers config name >>= \users -> do
+ 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 -> do
+ listDatabaseUsers config name >>= \users ->
case find ((newUserName ==) . userName) users of
Nothing -> assertFailure $ "No such user: " <> T.unpack newUserName
Just user -> assertBool
@@ -224,3 +314,8 @@ withTestDatabase config = bracket acquire release
catchAll :: IO a -> (SomeException -> IO a) -> IO a
catchAll = E.catch
+
+-------------------------------------------------
+
+main :: IO ()
+main = $defaultMainGenerator