{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Database.InfluxDB.JSON
(
parseResultsWith
, parseResultsWithDecoder
, Decoder(..)
, SomeDecoder(..)
, strictDecoder
, lenientDecoder
, getField
, getTag
, A.parseJSON
, parseUTCTime
, parsePOSIXTime
, parseRFC3339
, 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
parseResultsWith
:: (Maybe Text -> HashMap Text Text -> Vector Text -> Array -> A.Parser a)
-> Value
-> A.Parser (Vector a)
parseResultsWith :: (Maybe Text
-> HashMap Text Text -> Vector Text -> Array -> Parser a)
-> Value -> Parser (Vector a)
parseResultsWith = Decoder
-> (Maybe Text
-> HashMap Text Text -> Vector Text -> Array -> Parser a)
-> Value
-> Parser (Vector a)
forall a.
Decoder
-> (Maybe Text
-> HashMap Text Text -> Vector Text -> Array -> Parser a)
-> Value
-> Parser (Vector a)
parseResultsWithDecoder Decoder
strictDecoder
parseResultsWithDecoder
:: Decoder
-> (Maybe Text -> HashMap Text Text -> Vector Text -> Array -> A.Parser a)
-> Value
-> A.Parser (Vector a)
parseResultsWithDecoder :: Decoder
-> (Maybe Text
-> HashMap Text Text -> Vector Text -> Array -> Parser a)
-> Value
-> Parser (Vector a)
parseResultsWithDecoder (Decoder SomeDecoder {..}) Maybe Text -> HashMap Text Text -> Vector Text -> Array -> Parser a
row Value
val0 = do
Either String (Vector a)
r <- (Parser (Either String (Vector a))
-> Parser (Either String (Vector a))
-> Parser (Either String (Vector a)))
-> [Parser (Either String (Vector a))]
-> Parser (Either String (Vector a))
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Parser (Either String (Vector a))
-> Parser (Either String (Vector a))
-> Parser (Either String (Vector a))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
[ String -> Either String (Vector a)
forall a b. a -> Either a b
Left (String -> Either String (Vector a))
-> Parser String -> Parser (Either String (Vector a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
parseErrorObject Value
val0
, Vector a -> Either String (Vector a)
forall a b. b -> Either a b
Right (Vector a -> Either String (Vector a))
-> Parser (Vector a) -> Parser (Either String (Vector a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Vector a)
success
]
case Either String (Vector a)
r of
Left String
err -> String -> Parser (Vector a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right Vector a
vec -> Vector a -> Parser (Vector a)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector a
vec
where
success :: Parser (Vector a)
success = do
Array
results <- Value -> Parser Array
parseResultsObject Value
val0
(Vector Array -> Array
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Array
series) <- Array -> (Value -> Parser Array) -> Parser (Vector Array)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Array
results ((Value -> Parser Array) -> Parser (Vector Array))
-> (Value -> Parser Array) -> Parser (Vector Array)
forall a b. (a -> b) -> a -> b
$ \Value
val -> do
Either String Array
r <- (Parser (Either String Array)
-> Parser (Either String Array) -> Parser (Either String Array))
-> [Parser (Either String Array)] -> Parser (Either String Array)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Parser (Either String Array)
-> Parser (Either String Array) -> Parser (Either String Array)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
[ String -> Either String Array
forall a b. a -> Either a b
Left (String -> Either String Array)
-> Parser String -> Parser (Either String Array)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
parseErrorObject Value
val
, Array -> Either String Array
forall a b. b -> Either a b
Right (Array -> Either String Array)
-> Parser Array -> Parser (Either String Array)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Array
parseSeriesObject Value
val
]
case Either String Array
r of
Left String
err -> String -> Parser Array
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right Array
vec -> Array -> Parser Array
forall (m :: * -> *) a. Monad m => a -> m a
return Array
vec
Vector (Vector a)
values <- Array -> (Value -> Parser (Vector a)) -> Parser (Vector (Vector a))
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Array
series ((Value -> Parser (Vector a)) -> Parser (Vector (Vector a)))
-> (Value -> Parser (Vector a)) -> Parser (Vector (Vector a))
forall a b. (a -> b) -> a -> b
$ \Value
val -> do
(Maybe Text
name, HashMap Text Text
tags, Vector Text
columns, Array
values) <- Value -> Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
parseSeriesBody Value
val
Parser (Vector b) -> Parser (Vector a)
decodeFold (Parser (Vector b) -> Parser (Vector a))
-> Parser (Vector b) -> Parser (Vector a)
forall a b. (a -> b) -> a -> b
$ Array -> (Value -> Parser b) -> Parser (Vector b)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Array
values ((Value -> Parser b) -> Parser (Vector b))
-> (Value -> Parser b) -> Parser (Vector b)
forall a b. (a -> b) -> a -> b
$ String -> (Array -> Parser b) -> Value -> Parser b
forall a. String -> (Array -> Parser a) -> Value -> Parser a
A.withArray String
"values" ((Array -> Parser b) -> Value -> Parser b)
-> (Array -> Parser b) -> Value -> Parser b
forall a b. (a -> b) -> a -> b
$ \Array
fields -> do
Bool -> Parser () -> Parser ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Vector Text -> Int
forall a. Vector a -> Int
V.length Vector Text
columns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Array -> Int
forall a. Vector a -> Int
V.length Array
fields) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Parser a -> Parser b
decodeEach (Parser a -> Parser b) -> Parser a -> Parser b
forall a b. (a -> b) -> a -> b
$ Maybe Text -> HashMap Text Text -> Vector Text -> Array -> Parser a
row Maybe Text
name HashMap Text Text
tags Vector Text
columns Array
fields
Vector a -> Parser (Vector a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a -> Parser (Vector a)) -> Vector a -> Parser (Vector a)
forall a b. (a -> b) -> a -> b
$! Vector (Vector a) -> Vector a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Vector (Vector a)
values
newtype Decoder = Decoder (forall a. SomeDecoder a)
data SomeDecoder a = forall b. SomeDecoder
{ ()
decodeEach :: A.Parser a -> A.Parser b
, ()
decodeFold :: A.Parser (Vector b) -> A.Parser (Vector a)
}
strictDecoder :: Decoder
strictDecoder :: Decoder
strictDecoder = (forall a. SomeDecoder a) -> Decoder
Decoder ((forall a. SomeDecoder a) -> Decoder)
-> (forall a. SomeDecoder a) -> Decoder
forall a b. (a -> b) -> a -> b
$ SomeDecoder :: forall a b.
(Parser a -> Parser b)
-> (Parser (Vector b) -> Parser (Vector a)) -> SomeDecoder a
SomeDecoder
{ decodeEach :: Parser a -> Parser a
decodeEach = Parser a -> Parser a
forall a. a -> a
id
, decodeFold :: Parser (Vector a) -> Parser (Vector a)
decodeFold = Parser (Vector a) -> Parser (Vector a)
forall a. a -> a
id
}
lenientDecoder :: Decoder
lenientDecoder :: Decoder
lenientDecoder = (forall a. SomeDecoder a) -> Decoder
Decoder ((forall a. SomeDecoder a) -> Decoder)
-> (forall a. SomeDecoder a) -> Decoder
forall a b. (a -> b) -> a -> b
$ SomeDecoder :: forall a b.
(Parser a -> Parser b)
-> (Parser (Vector b) -> Parser (Vector a)) -> SomeDecoder a
SomeDecoder
{ decodeEach :: Parser a -> Parser (Maybe a)
decodeEach = Parser a -> Parser (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
, decodeFold :: Parser (Vector (Maybe a)) -> Parser (Vector a)
decodeFold = \Parser (Vector (Maybe a))
p -> do
Vector (Maybe a)
bs <- Parser (Vector (Maybe a))
p
Vector a -> Parser (Vector a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a -> Parser (Vector a)) -> Vector a -> Parser (Vector a)
forall a b. (a -> b) -> a -> b
$! (Maybe a -> a) -> Vector (Maybe a) -> Vector a
forall a b. (a -> b) -> Vector a -> Vector b
V.map Maybe a -> a
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Vector (Maybe a) -> Vector a) -> Vector (Maybe a) -> Vector a
forall a b. (a -> b) -> a -> b
$ (Maybe a -> Bool) -> Vector (Maybe a) -> Vector (Maybe a)
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Vector (Maybe a)
bs
}
getField
:: Fail.MonadFail m
=> Text
-> Vector Text
-> Vector Value
-> m Value
getField :: Text -> Vector Text -> Array -> m Value
getField Text
column Vector Text
columns Array
fields =
case Text -> Vector Text -> Maybe Int
forall a. Eq a => a -> Vector a -> Maybe Int
V.elemIndex Text
column Vector Text
columns of
Maybe Int
Nothing -> String -> m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m Value) -> String -> m Value
forall a b. (a -> b) -> a -> b
$ String
"getField: no such column " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
column
Just Int
idx -> case Array -> Int -> Maybe Value
forall (m :: * -> *) a. Monad m => Vector a -> Int -> m a
V.indexM Array
fields Int
idx of
Maybe Value
Nothing -> String -> m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m Value) -> String -> m Value
forall a b. (a -> b) -> a -> b
$ String
"getField: index out of bound for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
column
Just Value
field -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
field
getTag
:: Fail.MonadFail m
=> Text
-> HashMap Text Value
-> m Value
getTag :: Text -> HashMap Text Value -> m Value
getTag Text
tag HashMap Text Value
tags = case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
tag HashMap Text Value
tags of
Maybe Value
Nothing -> String -> m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m Value) -> String -> m Value
forall a b. (a -> b) -> a -> b
$ String
"getTag: no such tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
tag
Just Value
val -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
parseResultsObject :: Value -> A.Parser (Vector A.Value)
parseResultsObject :: Value -> Parser Array
parseResultsObject = String -> (Object -> Parser Array) -> Value -> Parser Array
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"results" ((Object -> Parser Array) -> Value -> Parser Array)
-> (Object -> Parser Array) -> Value -> Parser Array
forall a b. (a -> b) -> a -> b
$ \Object
obj -> Object
obj Object -> Key -> Parser Array
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"results"
parseSeriesObject :: Value -> A.Parser (Vector A.Value)
parseSeriesObject :: Value -> Parser Array
parseSeriesObject = String -> (Object -> Parser Array) -> Value -> Parser Array
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"series" ((Object -> Parser Array) -> Value -> Parser Array)
-> (Object -> Parser Array) -> Value -> Parser Array
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
Array -> Maybe Array -> Array
forall a. a -> Maybe a -> a
fromMaybe Array
forall a. Vector a
V.empty (Maybe Array -> Array) -> Parser (Maybe Array) -> Parser Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser (Maybe Array)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"series"
parseSeriesBody
:: Value
-> A.Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
parseSeriesBody :: Value -> Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
parseSeriesBody = String
-> (Object
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array))
-> Value
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"series" ((Object
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array))
-> Value
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array))
-> (Object
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array))
-> Value
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
!Maybe Text
name <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name"
!Vector Text
columns <- Object
obj Object -> Key -> Parser (Vector Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"columns"
!Array
values <- Object
obj Object -> Key -> Parser (Maybe Array)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"values" Parser (Maybe Array) -> Array -> Parser Array
forall a. Parser (Maybe a) -> a -> Parser a
.!= Array
forall a. Vector a
V.empty
!HashMap Text Text
tags <- Object
obj Object -> Key -> Parser (Maybe (HashMap Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"tags" Parser (Maybe (HashMap Text Text))
-> HashMap Text Text -> Parser (HashMap Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= HashMap Text Text
forall k v. HashMap k v
HashMap.empty
(Maybe Text, HashMap Text Text, Vector Text, Array)
-> Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
name, HashMap Text Text
tags, Vector Text
columns, Array
values)
parseErrorObject :: A.Value -> A.Parser String
parseErrorObject :: Value -> Parser String
parseErrorObject = String -> (Object -> Parser String) -> Value -> Parser String
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"error" ((Object -> Parser String) -> Value -> Parser String)
-> (Object -> Parser String) -> Value -> Parser String
forall a b. (a -> b) -> a -> b
$ \Object
obj -> Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"error"
parseUTCTime :: Precision ty -> A.Value -> A.Parser UTCTime
parseUTCTime :: Precision ty -> Value -> Parser UTCTime
parseUTCTime Precision ty
prec Value
val = case Precision ty
prec of
Precision ty
RFC3339 -> Value -> Parser UTCTime
forall time. ParseTime time => Value -> Parser time
parseRFC3339 Value
val
Precision ty
_ -> POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> Parser POSIXTime -> Parser UTCTime
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Precision ty -> Value -> Parser POSIXTime
forall (ty :: RequestType).
Precision ty -> Value -> Parser POSIXTime
parsePOSIXTime Precision ty
prec Value
val
parsePOSIXTime :: Precision ty -> A.Value -> A.Parser POSIXTime
parsePOSIXTime :: Precision ty -> Value -> Parser POSIXTime
parsePOSIXTime Precision ty
prec Value
val = case Precision ty
prec of
Precision ty
RFC3339 -> UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> POSIXTime) -> Parser UTCTime -> Parser POSIXTime
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Value -> Parser UTCTime
forall time. ParseTime time => Value -> Parser time
parseRFC3339 Value
val
Precision ty
_ -> String
-> (Scientific -> Parser POSIXTime) -> Value -> Parser POSIXTime
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
A.withScientific String
err
(\Scientific
s -> case Scientific -> Maybe POSIXTime
timestampToUTC Scientific
s of
Maybe POSIXTime
Nothing -> String -> Value -> Parser POSIXTime
forall a. String -> Value -> Parser a
A.typeMismatch String
err Value
val
Just !POSIXTime
utc -> POSIXTime -> Parser POSIXTime
forall (m :: * -> *) a. Monad m => a -> m a
return POSIXTime
utc)
Value
val
where
err :: String
err = String
"POSIX timestamp in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Precision ty -> Text
forall (ty :: RequestType). Precision ty -> Text
precisionName Precision ty
prec)
timestampToUTC :: Scientific -> Maybe POSIXTime
timestampToUTC Scientific
s = do
Int
n <- Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Sci.toBoundedInteger Scientific
s
POSIXTime -> Maybe POSIXTime
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime -> Maybe POSIXTime) -> POSIXTime -> Maybe POSIXTime
forall a b. (a -> b) -> a -> b
$! Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* Precision ty -> POSIXTime
forall a (ty :: RequestType). Fractional a => Precision ty -> a
precisionScale Precision ty
prec
parseRFC3339 :: ParseTime time => A.Value -> A.Parser time
parseRFC3339 :: Value -> Parser time
parseRFC3339 Value
val = String -> (Text -> Parser time) -> Value -> Parser time
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
err
(Parser time -> (time -> Parser time) -> Maybe time -> Parser time
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Value -> Parser time
forall a. String -> Value -> Parser a
A.typeMismatch String
err Value
val) (time -> Parser time
forall (m :: * -> *) a. Monad m => a -> m a
return (time -> Parser time) -> time -> Parser time
forall a b. (a -> b) -> a -> b
$!)
(Maybe time -> Parser time)
-> (Text -> Maybe time) -> Text -> Parser time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> TimeLocale -> String -> String -> Maybe time
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt
(String -> Maybe time) -> (Text -> String) -> Text -> Maybe time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
Value
val
where
fmt, err :: String
fmt :: String
fmt = String
"%FT%X%QZ"
err :: String
err = String
"RFC3339-formatted timestamp"