summaryrefslogtreecommitdiff
path: root/src/Database
diff options
context:
space:
mode:
Diffstat (limited to 'src/Database')
-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
8 files changed, 249 insertions, 22 deletions
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