{-# 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 :: forall a.
(Maybe Text
 -> HashMap Text Text -> Vector Text -> Vector Value -> Parser a)
-> Value -> Parser (Vector a)
parseResultsWith = forall a.
Decoder
-> (Maybe Text
    -> HashMap Text Text -> Vector Text -> Vector Value -> Parser a)
-> Value
-> Parser (Vector a)
parseResultsWithDecoder Decoder
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 :: forall a.
Decoder
-> (Maybe Text
    -> HashMap Text Text -> Vector Text -> Vector Value -> Parser a)
-> Value
-> Parser (Vector a)
parseResultsWithDecoder (Decoder SomeDecoder {Parser a -> Parser b
Parser (Vector b) -> Parser (Vector a)
decodeFold :: ()
decodeEach :: ()
decodeFold :: Parser (Vector b) -> Parser (Vector a)
decodeEach :: Parser a -> Parser b
..}) Maybe Text
-> HashMap Text Text -> Vector Text -> Vector Value -> Parser a
row Value
val0 = do
  Either String (Vector a)
r <- forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
    [ forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
parseErrorObject Value
val0
    , forall a b. b -> Either a b
Right 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right Vector a
vec -> forall (m :: * -> *) a. Monad m => a -> m a
return Vector a
vec
  where
    success :: Parser (Vector a)
success = do
      Vector Value
results <- Value -> Parser (Vector Value)
parseResultsObject Value
val0

      (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Vector Value
series) <- forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Vector Value
results forall a b. (a -> b) -> a -> b
$ \Value
val -> do
        Either String (Vector Value)
r <- forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
          [ forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
parseErrorObject Value
val
          , forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Vector Value)
parseSeriesObject Value
val
          ]
        case Either String (Vector Value)
r of
          Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
          Right Vector Value
vec -> forall (m :: * -> *) a. Monad m => a -> m a
return Vector Value
vec
      Vector (Vector a)
values <- forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Vector Value
series forall a b. (a -> b) -> a -> b
$ \Value
val -> do
        (Maybe Text
name, HashMap Text Text
tags, Vector Text
columns, Vector Value
values) <- Value
-> Parser
     (Maybe Text, HashMap Text Text, Vector Text, Vector Value)
parseSeriesBody Value
val
        Parser (Vector b) -> Parser (Vector a)
decodeFold forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Vector Value
values forall a b. (a -> b) -> a -> b
$ forall a. String -> (Vector Value -> Parser a) -> Value -> Parser a
A.withArray String
"values" forall a b. (a -> b) -> a -> b
$ \Vector Value
fields -> do
          forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Vector a -> Int
V.length Vector Text
columns forall a. Eq a => a -> a -> Bool
== forall a. Vector a -> Int
V.length Vector Value
fields) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Parser a -> Parser b
decodeEach forall a b. (a -> b) -> a -> b
$ Maybe Text
-> HashMap Text Text -> Vector Text -> Vector Value -> Parser a
row Maybe Text
name HashMap Text Text
tags Vector Text
columns Vector Value
fields
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Vector (Vector a)
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
strictDecoder = (forall a. SomeDecoder a) -> Decoder
Decoder forall a b. (a -> b) -> a -> b
$ SomeDecoder
  { decodeEach :: Parser a -> Parser a
decodeEach = forall a. a -> a
id
  , decodeFold :: Parser (Vector a) -> Parser (Vector a)
decodeFold = forall a. a -> a
id
  }

-- | A decoder that ignores parse failures and returns only successful results.
lenientDecoder :: Decoder
lenientDecoder :: Decoder
lenientDecoder = (forall a. SomeDecoder a) -> Decoder
Decoder forall a b. (a -> b) -> a -> b
$ SomeDecoder
  { decodeEach :: Parser a -> Parser (Maybe a)
decodeEach = 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (a -> b) -> Vector a -> Vector b
V.map forall a. (?callStack::CallStack) => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Vector a -> Vector a
V.filter forall a. Maybe a -> Bool
isJust Vector (Maybe a)
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 :: forall (m :: * -> *).
MonadFail m =>
Text -> Vector Text -> Vector Value -> m Value
getField Text
column Vector Text
columns Vector Value
fields =
  case forall a. Eq a => a -> Vector a -> Maybe Int
V.elemIndex Text
column Vector Text
columns of
    Maybe Int
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"getField: no such column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
column
    Just Int
idx -> case forall (m :: * -> *) a. Monad m => Vector a -> Int -> m a
V.indexM Vector Value
fields Int
idx of
      Maybe Value
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"getField: index out of bound for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
column
      Just Value
field -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
field

-- | Get a tag value from a tag name
getTag
  :: Fail.MonadFail m
  => Text -- ^ Tag name
  -> HashMap Text Value -- ^ Tags
  -> m Value
getTag :: forall (m :: * -> *).
MonadFail m =>
Text -> HashMap Text Value -> m Value
getTag Text
tag HashMap Text Value
tags = case 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"getTag: no such tag " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
tag
  Just Value
val -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
val

-- | Parse a result response.
parseResultsObject :: Value -> A.Parser (Vector A.Value)
parseResultsObject :: Value -> Parser (Vector Value)
parseResultsObject = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"results" forall a b. (a -> b) -> a -> b
$ \Object
obj -> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"results"

-- | Parse a series response.
parseSeriesObject :: Value -> A.Parser (Vector A.Value)
parseSeriesObject :: Value -> Parser (Vector Value)
parseSeriesObject = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"series" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
  forall a. a -> Maybe a -> a
fromMaybe forall a. Vector a
V.empty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"series"

-- | Parse the common JSON structure used in query responses.
parseSeriesBody
  :: Value
  -> A.Parser (Maybe Text, HashMap Text Text, Vector Text, Array)
parseSeriesBody :: Value
-> Parser
     (Maybe Text, HashMap Text Text, Vector Text, Vector Value)
parseSeriesBody = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"series" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
  !Maybe Text
name <- Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name"
  !Vector Text
columns <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"columns"
  !Vector Value
values <- Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"values" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Vector a
V.empty
  !HashMap Text Text
tags <- Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"tags" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall k v. HashMap k v
HashMap.empty
  forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
name, HashMap Text Text
tags, Vector Text
columns, Vector Value
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 :: Value -> Parser String
parseErrorObject = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"error" forall a b. (a -> b) -> a -> b
$ \Object
obj -> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"error" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"

-- | Parse either a POSIX timestamp or RFC3339 formatted timestamp as 'UTCTime'.
parseUTCTime :: Precision ty -> A.Value -> A.Parser UTCTime
parseUTCTime :: forall (ty :: RequestType). Precision ty -> Value -> Parser UTCTime
parseUTCTime Precision ty
prec Value
val = case Precision ty
prec of
  Precision ty
RFC3339 -> forall time. ParseTime time => Value -> Parser time
parseRFC3339 Value
val
  Precision ty
_ -> POSIXTime -> UTCTime
posixSecondsToUTCTime forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall (ty :: RequestType).
Precision ty -> Value -> Parser POSIXTime
parsePOSIXTime Precision ty
prec Value
val

-- | Parse either a POSIX timestamp or RFC3339 formatted timestamp as
-- 'POSIXTime'.
parsePOSIXTime :: Precision ty -> A.Value -> A.Parser POSIXTime
parsePOSIXTime :: forall (ty :: RequestType).
Precision ty -> Value -> Parser POSIXTime
parsePOSIXTime Precision ty
prec Value
val = case Precision ty
prec of
  Precision ty
RFC3339 -> UTCTime -> POSIXTime
utcTimeToPOSIXSeconds forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall time. ParseTime time => Value -> Parser time
parseRFC3339 Value
val
  Precision ty
_ -> 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 -> forall a. String -> Value -> Parser a
A.typeMismatch String
err Value
val
      Just !POSIXTime
utc -> forall (m :: * -> *) a. Monad m => a -> m a
return POSIXTime
utc)
    Value
val
  where
    err :: String
err = String
"POSIX timestamp in " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (forall (ty :: RequestType). Precision ty -> Text
precisionName Precision ty
prec)
    timestampToUTC :: Scientific -> Maybe POSIXTime
timestampToUTC Scientific
s = do
      Int
n <- forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Sci.toBoundedInteger Scientific
s
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int) forall a. Num a => a -> a -> a
* forall a (ty :: RequestType). Fractional a => Precision ty -> a
precisionScale Precision ty
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 :: forall time. ParseTime time => Value -> Parser time
parseRFC3339 Value
val = forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
err
  (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> Value -> Parser a
A.typeMismatch String
err Value
val) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt
    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"