Improve error handling

examples/random-points.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 import Data.Foldable
@@ -76,7 +75,7 @@ data Row = Row
   } deriving Show
 
 instance QueryResults Row where
-  parseResults prec = parseResultsWith $ \_ _ columns fields -> do
+  parseMeasurement prec _ _ columns fields = do
     rowTime <- getField "time" columns fields >>= parsePOSIXTime prec
     String name <- getField "value" columns fields
     rowValue <- case name of

influxdb.cabal

@@ -115,10 +115,12 @@ test-suite regressions
       base
     , containers
     , influxdb
+    , lens
     , tasty
     , tasty-hunit
     , time
     , raw-strings-qq >= 1.1 && < 1.2
+    , vector
   ghc-options: -Wall -threaded
   hs-source-dirs: tests
   default-language: Haskell2010

src/Database/InfluxDB.hs

@@ -45,20 +45,18 @@ module Database.InfluxDB
   , QueryParams
   , queryParams
   , authentication
+  , decoder
 
   -- ** Parsing results
   , QueryResults(..)
-  , parseResultsWith
-  , parseResultsWithDecoder
-  , Decoder(..)
+  , Decoder
   , lenientDecoder
   , strictDecoder
   , getField
   , getTag
   , parseJSON
   , parseUTCTime
   , parsePOSIXTime
-  , parseQueryField
 
   -- *** Re-exports from tagged
   , Tagged(..)
@@ -200,7 +198,7 @@ data CPUUsage = CPUUsage
   , cpuIdle, cpuSystem, cpuUser :: Double
   } deriving Show
 instance QueryResults CPUUsage where
-  parseResults prec = parseResultsWithDecoder strictDecoder $ \_ _ columns fields -> do
+  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

src/Database/InfluxDB/JSON.hs

@@ -3,7 +3,9 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
 module Database.InfluxDB.JSON
   ( -- * Result parsers
@@ -12,6 +14,7 @@ module Database.InfluxDB.JSON
 
   -- ** Decoder settings
   , Decoder(..)
+  , SomeDecoder(..)
   , strictDecoder
   , lenientDecoder
 
@@ -24,7 +27,6 @@ module Database.InfluxDB.JSON
   , parseUTCTime
   , parsePOSIXTime
   , parseRFC3339
-  , parseQueryField
   -- ** Utility functions
   , parseResultsObject
   , parseSeriesObject
@@ -34,8 +36,10 @@ module Database.InfluxDB.JSON
 import Control.Applicative
 import Control.Exception
 import Control.Monad
-import qualified Control.Monad.Fail as Fail
+import Data.Foldable
 import Data.Maybe
+import Prelude
+import qualified Control.Monad.Fail as Fail
 
 import Data.Aeson
 import Data.HashMap.Strict (HashMap)
@@ -52,69 +56,100 @@ import qualified Data.Vector as V
 
 import Database.InfluxDB.Types
 
--- | Parse a JSON response with the 'lenientDecoder'. This can be useful to
--- implement the 'Database.InfluxDB.Query.parseResults' method.
+-- | Parse a JSON response with the 'strictDecoder'.
 parseResultsWith
   :: (Maybe Text -> HashMap Text Text -> Vector Text -> Array -> A.Parser a)
-  -- ^ A parser that takes
+  -- ^ 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 names
-  -- 4. an array of values
-  --
-  -- to construct a value.
-  -> Value
+  -- 3. an array of field keys
+  -- 4. an array of field values
+  -> Value -- ^ JSON response
   -> A.Parser (Vector a)
-parseResultsWith = parseResultsWithDecoder lenientDecoder
+parseResultsWith = parseResultsWithDecoder strictDecoder
 
 -- | Parse a JSON response with the specified decoder settings.
 parseResultsWithDecoder
-  :: Decoder a
+  :: Decoder
   -> (Maybe Text -> HashMap Text Text -> Vector Text -> Array -> A.Parser a)
-  -- ^ A parser that takes
+  -- ^ 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 names
-  -- 4. an array of values
-  --
-  -- to construct a value.
-  -> Value
+  -- 3. an array of field keys
+  -- 4. an array of field values
+  -> Value -- ^ JSON response
   -> A.Parser (Vector a)
-parseResultsWithDecoder Decoder {..} row val0 = success
+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 ->
-        parseSeriesObject val <|> parseErrorObject val
+      (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
 
--- | Decoder settings
-data Decoder a = forall b. Decoder
+-- | 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
+  -- ^ 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 :: Decoder a
-strictDecoder = Decoder
+--
+-- '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 a
-lenientDecoder = Decoder
+lenientDecoder :: Decoder
+lenientDecoder = Decoder $ SomeDecoder
   { decodeEach = optional
   , decodeFold = \p -> do
     bs <- p
@@ -166,10 +201,8 @@ parseSeriesBody = A.withObject "series" $ \obj -> do
   return (name, tags, columns, values)
 
 -- | Parse the common JSON structure used in failure response.
-parseErrorObject :: A.Value -> A.Parser a
-parseErrorObject = A.withObject "error" $ \obj -> do
-  message <- obj .: "error"
-  fail $ T.unpack message
+parseErrorObject :: A.Value -> A.Parser String
+parseErrorObject = A.withObject "error" $ \obj -> obj .: "error"
 
 -- | Parse either a POSIX timestamp or RFC3339 formatted timestamp as 'UTCTime'.
 parseUTCTime :: Precision ty -> A.Value -> A.Parser UTCTime
@@ -207,20 +240,3 @@ parseRFC3339 val = A.withText err
     fmt, err :: String
     fmt = "%FT%X%QZ"
     err = "RFC3339-formatted timestamp"
-
--- | Parse a 'QueryField'.
-parseQueryField :: A.Value -> A.Parser QueryField
-parseQueryField val = case val of
-  A.Number sci ->
-    return $! either FieldFloat FieldInt $ Sci.floatingOrInteger sci
-  A.String txt ->
-    return $! FieldString txt
-  A.Bool b ->
-    return $! FieldBool b
-  A.Null ->
-    return FieldNull
-  _ -> fail $ "parseQueryField: expected a flat data structure, but got "
-    ++ show val
-{-# DEPRECATED parseQueryField
-  "This function parses numbers in a misleading way. Use 'parseJSON' instead."
-  #-}

src/Database/InfluxDB/Manage.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -33,7 +35,6 @@ module Database.InfluxDB.Manage
   , ShowSeries
   , key
   ) where
-import Control.Applicative
 import Control.Exception
 import Control.Monad
 
@@ -74,19 +75,20 @@ manage params q = do
   case eitherDecode' body of
     Left message ->
       throwIO $ UnexpectedResponse message request body
-    Right val -> case A.parse (parseResults (params^.precision)) val of
-      A.Success (_ :: V.Vector Void) -> 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)
-
+    Right val -> do
+      let parser = parseQueryResultsWith (params^.decoder) (params^.precision)
+      case A.parse parser val of
+        A.Success (_ :: V.Vector Void) -> 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 =
@@ -114,29 +116,26 @@ data ShowQuery = ShowQuery
   }
 
 instance QueryResults ShowQuery where
-  parseResults _ = parseResultsWith $ \_ _ columns fields ->
+  parseMeasurement _ _ _ columns fields =
     maybe (fail "parseResults: parse error") return $ do
       Number (toBoundedInteger -> Just showQueryQid) <-
-        V.elemIndex "qid" columns >>= V.indexM fields
+        getField "qid" columns fields
       String (F.formatQuery F.text -> showQueryText) <-
-        V.elemIndex "query" columns >>= V.indexM fields
+        getField "query" columns fields
       String (F.formatDatabase F.text -> showQueryDatabase) <-
-        V.elemIndex "database" columns >>= V.indexM fields
+        getField "database" columns fields
       String (parseDuration -> Right showQueryDuration) <-
-        V.elemIndex "duration" columns >>= V.indexM fields
+        getField "duration" columns fields
       return ShowQuery {..}
 
 parseDuration :: Text -> Either String NominalDiffTime
-parseDuration = AT.parseOnly $ sum <$!> durations
+parseDuration = AT.parseOnly duration
   where
-    durations = some $ (*)
-      <$> fmap fromIntegral int
+    duration = (*)
+      <$> fmap (fromIntegral @Int) AT.decimal
       <*> unit
-      where
-        int :: AT.Parser Int
-        int = AT.decimal
     unit = AC.choice
-      [ 10^^(-6 :: Int) <$ AT.char 'u'
+      [ 10^^(-6 :: Int) <$ AT.string "µs"
       , 1 <$ AT.char 's'
       , 60 <$ AT.char 'm'
       , 3600 <$ AT.char 'h'
@@ -147,7 +146,7 @@ newtype ShowSeries = ShowSeries
   }
 
 instance QueryResults ShowSeries where
-  parseResults _ = parseResultsWith $ \_ _ columns fields -> do
+  parseMeasurement _ _ _ columns fields = do
     name <- getField "key" columns fields >>= parseJSON
     return $ ShowSeries $ F.formatKey F.text name