1{-# LANGUAGE GeneralizedNewtypeDeriving #-} 2{-# LANGUAGE DeriveFunctor #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE TupleSections #-} 5{-# LANGUAGE CPP #-} 6 7module Data.Aeson.BetterErrors.Internal where 8 9#if !MIN_VERSION_base(4,8,0) 10import Control.Applicative (Applicative, pure, (<$>), (<*>)) 11import Data.Foldable (foldMap) 12#endif 13 14import Control.Arrow (left) 15import Control.Monad.Identity 16import Control.Monad.Reader 17import Control.Monad.Trans.Except 18import Control.Monad.Error.Class (MonadError(..)) 19 20import Data.Void 21import Data.Monoid 22import Data.DList (DList) 23import qualified Data.DList as DList 24import Data.Text (Text) 25import qualified Data.Text as T 26import Data.Text.Encoding (decodeUtf8) 27import qualified Data.ByteString.Lazy as BL 28import qualified Data.ByteString as B 29 30import qualified Data.Aeson as A 31import qualified Data.Aeson.Types as A 32import Data.Vector ((!?)) 33import qualified Data.Vector as V 34import Data.Scientific (Scientific) 35import qualified Data.Scientific as S 36import qualified Data.HashMap.Strict as HashMap 37 38import Data.Aeson.BetterErrors.Utils 39 40-- | The type of parsers: things which consume JSON values and produce either 41-- detailed errors or successfully parsed values (of other types). 42-- 43-- The @err@ type parameter is for custom validation errors; for parsers that 44-- don't produce any custom validation errors, I recommend you just stick a 45-- type variable in for full generality: 46-- 47-- @ 48-- asTuple :: Parse e (Int, Int) 49-- asTuple = (,) \<$\> nth 0 asIntegral \<*\> nth 1 asIntegral 50-- @ 51-- 52-- The @m@ parameter allows you to run the parser within an abitrary underlying Monad. 53-- You may want to use 'Parse' in most cases instead, and all functions in this module work on either. 54newtype ParseT err m a 55 = ParseT (ReaderT ParseReader (ExceptT (ParseError err) m) a) 56 deriving (Functor, Applicative, Monad, 57 MonadReader ParseReader, MonadError (ParseError err)) 58-- | This is the standard version of 'ParseT' over the 'Identity' Monad, for running pure parsers. 59type Parse err a = ParseT err Identity a 60 61instance MonadTrans (ParseT err) where 62 lift f = ParseT (lift (lift f)) 63 64runParseT :: ParseT err m a -> A.Value -> m (Either (ParseError err) a) 65runParseT (ParseT p) v = runExceptT (runReaderT p (ParseReader DList.empty v)) 66 67runParse :: Parse err a -> A.Value -> Either (ParseError err) a 68runParse p v = runIdentity (runParseT p v) 69 70mapParseT :: (ReaderT ParseReader (ExceptT (ParseError err) m) a -> ReaderT ParseReader (ExceptT (ParseError err') m') a') -> ParseT err m a -> ParseT err' m' a' 71mapParseT f (ParseT p) = ParseT (f p) 72 73-- | Transform the error of a parser according to the given function. 74mapError :: Functor m => (err -> err') -> ParseT err m a -> ParseT err' m a 75mapError f = mapParseT (mapReaderT (withExceptT (fmap f))) 76 77-- | An infix version of 'mapError'. 78(.!) :: Functor m => ParseT err m a -> (err -> err') -> ParseT err' m a 79(.!) = flip mapError 80 81-- | First try the left parser, if that fails try the right. 82-- | If both fail, the error will come from the right one. 83(<|>) :: Monad m => ParseT err m a -> ParseT err m a -> ParseT err m a 84l <|> r = catchError l (const r) 85 86infixl 3 <|> 87 88-- | The type of parsers which never produce custom validation errors. 89type Parse' a = Parse Void a 90 91runParserT :: Monad m => 92 (s -> Either String A.Value) -> 93 ParseT err m a -> 94 s -> 95 m (Either (ParseError err) a) 96runParserT decode p src = 97 case decode src of 98 Left err -> return $ Left (InvalidJSON err) 99 Right value -> runParseT p value 100 101runParser :: 102 (s -> Either String A.Value) -> 103 Parse err a -> 104 s -> 105 Either (ParseError err) a 106runParser decode p src = 107 runIdentity (runParserT decode p src) 108 109-- | Like 'parse' but runs the parser on an arbitrary underlying Monad. 110parseM :: Monad m => ParseT err m a -> BL.ByteString -> m (Either (ParseError err) a) 111parseM = runParserT A.eitherDecode 112 113-- | Run a parser with a lazy 'BL.ByteString' containing JSON data. Note that 114-- the normal caveat applies: the JSON supplied must contain either an object 115-- or an array for this to work. 116parse :: Parse err a -> BL.ByteString -> Either (ParseError err) a 117parse = runParser A.eitherDecode 118 119-- | Like 'parseStrict' but runs the parser on an arbitrary underlying Monad. 120parseStrictM :: Monad m => ParseT err m a -> B.ByteString -> m (Either (ParseError err) a) 121parseStrictM = runParserT A.eitherDecodeStrict 122 123-- | Run a parser with a strict 'B.ByteString' containing JSON data. Note that 124-- the normal caveat applies: the JSON supplied must contain either an object 125-- or an array for this to work. 126parseStrict :: Parse err a -> B.ByteString -> Either (ParseError err) a 127parseStrict = runParser A.eitherDecodeStrict 128 129-- | Like 'parseValue' but runs the parser on an arbitrary underlying Monad. 130parseValueM :: Monad m => ParseT err m a -> A.Value -> m (Either (ParseError err) a) 131parseValueM = runParserT Right 132 133-- | Run a parser with a pre-parsed JSON 'A.Value'. 134parseValue :: Parse err a -> A.Value -> Either (ParseError err) a 135parseValue = runParser Right 136 137-- | This function is useful when you have a @'Parse' err a@ and you want to 138-- obtain an instance for @'A.FromJSON' a@. Simply define: 139-- 140-- @ 141-- parseJSON = toAesonParser showMyCustomError myParser 142-- @ 143toAesonParser :: (err -> Text) -> Parse err a -> A.Value -> A.Parser a 144toAesonParser showCustom p val = 145 case parseValue p val of 146 Right x -> return x 147 Left err -> fail (unlines (map T.unpack (displayError showCustom err))) 148 149-- | Take a parser which never produces custom validation errors and turn 150-- it into an Aeson parser. Note that in this case, there is no need to provide 151-- a display function. 152toAesonParser' :: Parse' a -> A.Value -> A.Parser a 153toAesonParser' = toAesonParser absurd 154 155-- | Create a parser for any type, using its FromJSON instance. Generally, you 156-- should prefer to write parsers using the other functions in this module; 157-- 'key', 'asString', etc, since they will usually generate better error 158-- messages. However this function is also useful occasionally. 159fromAesonParser :: (Functor m, Monad m) => A.FromJSON a => ParseT e m a 160fromAesonParser = liftParse $ \v -> 161 case A.fromJSON v of 162 A.Success x -> Right x 163 A.Error err -> Left (FromAeson err) 164 165-- | Data used internally by the 'Parse' type. 166data ParseReader = ParseReader 167 { rdrPath :: DList PathPiece 168 , rdrValue :: A.Value 169 } 170 171appendPath :: PathPiece -> ParseReader -> ParseReader 172appendPath p r = r { rdrPath = DList.snoc (rdrPath r) p } 173 174setValue :: A.Value -> ParseReader -> ParseReader 175setValue v r = r { rdrValue = v } 176 177-- | A piece of a path leading to a specific part of the JSON data. 178-- Internally, a list of these is maintained as the parser traverses the JSON 179-- data. This list is included in the error if one occurs. 180data PathPiece 181 = ObjectKey Text 182 | ArrayIndex Int 183 deriving (Show, Eq, Ord) 184 185-- | A value indicating that the JSON could not be decoded successfully. 186data ParseError err 187 = InvalidJSON String 188 -- ^ Indicates a syntax error in the JSON string. Unfortunately, in this 189 -- case, Aeson's errors are not very helpful. 190 | BadSchema [PathPiece] (ErrorSpecifics err) 191 -- ^ Indicates a decoding error; the input was parsed as JSON successfully, 192 -- but a value of the required type could not be constructed, perhaps 193 -- because of a missing key or type mismatch. 194 deriving (Show, Eq, Functor) 195 196-- | The type of parse errors which never involve custom validation 197-- errors. 198type ParseError' = ParseError Void 199 200-- | Detailed information in the case where a value could be parsed as JSON, 201-- but a value of the required type could not be constructed from it, for some 202-- reason. 203data ErrorSpecifics err 204 = KeyMissing Text 205 | OutOfBounds Int 206 | WrongType JSONType A.Value -- ^ Expected type, actual value 207 | ExpectedIntegral Double 208 | FromAeson String -- ^ An error arising inside a 'A.FromJSON' instance. 209 | CustomError err 210 deriving (Show, Eq, Functor) 211 212-- | The type of error specifics which never involve custom validation 213-- errors. 214type ErrorSpecifics' = ErrorSpecifics Void 215 216-- | An enumeration of the different types that JSON values may take. 217data JSONType 218 = TyObject 219 | TyArray 220 | TyString 221 | TyNumber 222 | TyBool 223 | TyNull 224 deriving (Show, Eq, Ord, Enum, Bounded) 225 226displayJSONType :: JSONType -> Text 227displayJSONType t = case t of 228 TyObject -> "object" 229 TyArray -> "array" 230 TyString -> "string" 231 TyNumber -> "number" 232 TyBool -> "boolean" 233 TyNull -> "null" 234 235-- | Turn a 'ParseError' into a human-readable list of 'Text' values. 236-- They will be in a sensible order. For example, you can feed the result to 237-- @mapM putStrLn@, or @unlines@. 238displayError :: (err -> Text) -> ParseError err -> [Text] 239displayError _ (InvalidJSON str) = 240 [ "The input could not be parsed as JSON", "aeson said: " <> T.pack str ] 241displayError f (BadSchema [] specs) = 242 displaySpecifics f specs 243displayError f (BadSchema path specs) = 244 [ "At the path: " <> displayPath path ] <> displaySpecifics f specs 245 246-- | A version of 'displayError' for parsers which do not produce custom 247-- validation errors. 248displayError' :: ParseError' -> [Text] 249displayError' = displayError absurd 250 251displayPath :: [PathPiece] -> Text 252displayPath = foldMap showPiece 253 where 254 showPiece (ObjectKey t) = "[" <> tshow t <> "]" 255 showPiece (ArrayIndex i) = "[" <> tshow i <> "]" 256 257displaySpecifics :: (err -> Text) -> ErrorSpecifics err -> [Text] 258displaySpecifics _ (KeyMissing k) = 259 [ "The required key " <> tshow k <> " is missing" ] 260displaySpecifics _ (OutOfBounds i) = 261 [ "The array index " <> tshow i <> " is out of bounds" ] 262displaySpecifics _ (WrongType t val) = 263 [ "Type mismatch:" 264 , "Expected a value of type " <> displayJSONType t 265 , "Got: " <> decodeUtf8 (B.concat (BL.toChunks (A.encode val))) 266 ] 267displaySpecifics _ (ExpectedIntegral x) = 268 [ "Expected an integral value, got " <> tshow x ] 269displaySpecifics _ (FromAeson str) = 270 [ "Arising from an Aeson FromJSON instance:" 271 , T.pack str 272 ] 273displaySpecifics f (CustomError err) = 274 [ f err ] 275 276-- | A version of `displaySpecifics` for parsers which do not produce 277-- custom validation errors. 278displaySpecifics' :: ErrorSpecifics' -> [Text] 279displaySpecifics' = displaySpecifics absurd 280 281-- | Get the type of a JSON value. 282jsonTypeOf :: A.Value -> JSONType 283jsonTypeOf (A.Object _) = TyObject 284jsonTypeOf (A.Array _) = TyArray 285jsonTypeOf (A.String _) = TyString 286jsonTypeOf (A.Number _) = TyNumber 287jsonTypeOf (A.Bool _) = TyBool 288jsonTypeOf A.Null = TyNull 289 290liftParseT :: (Functor m, Monad m) => (A.Value -> ExceptT (ErrorSpecifics err) m a) -> ParseT err m a 291liftParseT f = ParseT $ ReaderT $ \(ParseReader path value) -> 292 withExceptT (BadSchema (DList.toList path)) (f value) 293 294liftParseM :: (Functor m, Monad m) => (A.Value -> m (Either (ErrorSpecifics err) a)) -> ParseT err m a 295liftParseM f = liftParseT (ExceptT . f) 296 297-- | Lift any parsing function into the 'Parse' type. 298liftParse :: (Functor m, Monad m) => (A.Value -> Either (ErrorSpecifics err) a) -> ParseT err m a 299liftParse f = liftParseM (return . f) 300 301-- | Aborts parsing, due to an error in the structure of the JSON - that is, 302-- any error other than the JSON not actually being parseable into a 'A.Value'. 303badSchema :: (Functor m, Monad m) => ErrorSpecifics err -> ParseT err m a 304badSchema = liftParse . const . Left 305 306as :: (Functor m, Monad m) => (A.Value -> Maybe a) -> JSONType -> ParseT err m a 307as pat ty = liftParse $ \v -> 308 maybe (Left (WrongType ty v)) Right (pat v) 309 310-- | Return the current JSON 'A.Value' as is. This does no error checking and 311-- thus always succeeds. You probably don't want this parser unless the JSON 312-- at the current part of your structure is truly arbitrary. You should prefer 313-- to use more specific parsers, like 'asText' or 'asIntegral', where possible. 314asValue :: (Functor m, Monad m) => ParseT err m A.Value 315asValue = asks rdrValue 316 317-- | Parse a single JSON string as 'Text'. 318asText :: (Functor m, Monad m) => ParseT err m Text 319asText = as patString TyString 320 321-- | Parse a single JSON string as a 'String'. 322asString :: (Functor m, Monad m) => ParseT err m String 323asString = T.unpack <$> asText 324 325-- | Parse a single JSON number as a 'Scientific'. 326asScientific :: (Functor m, Monad m) => ParseT err m Scientific 327asScientific = as patNumber TyNumber 328 329-- | Parse a single JSON number as any 'Integral' type. 330asIntegral :: (Functor m, Monad m, Integral a) => ParseT err m a 331asIntegral = 332 asScientific 333 >>= liftParse . const . left ExpectedIntegral . S.floatingOrInteger 334 335-- | Parse a single JSON number as any 'RealFloat' type. 336asRealFloat :: (Functor m, Monad m, RealFloat a) => ParseT err m a 337asRealFloat = 338 either id fromInteger . S.floatingOrInteger <$> asScientific 339 340-- | Parse a single JSON boolean as a 'Bool'. 341asBool :: (Functor m, Monad m) => ParseT err m Bool 342asBool = as patBool TyBool 343 344-- | Parse a JSON object, as an 'A.Object'. You should prefer functions like 345-- 'eachInObject' where possible, since they will usually generate better 346-- error messages. 347asObject :: (Functor m, Monad m) => ParseT err m A.Object 348asObject = as patObject TyObject 349 350-- | Parse a JSON array, as an 'A.Array'. You should prefer functions like 351-- 'eachInArray' where possible, since they will usually generate better 352-- error messages. 353asArray :: (Functor m, Monad m) => ParseT err m A.Array 354asArray = as patArray TyArray 355 356-- | Parse a single JSON null value. Useful if you want to throw an error in 357-- the case where something is not null. 358asNull :: (Functor m, Monad m) => ParseT err m () 359asNull = as patNull TyNull 360 361-- | Given a parser, transform it into a parser which returns @Nothing@ when 362-- supplied with a JSON @null@, and otherwise, attempts to parse with the 363-- original parser; if this succeeds, the result becomes a @Just@ value. 364perhaps :: (Functor m, Monad m) => ParseT err m a -> ParseT err m (Maybe a) 365perhaps p = do 366 v <- asks rdrValue 367 case v of 368 A.Null -> return Nothing 369 _ -> Just <$> p 370 371-- | Take the value corresponding to a given key in the current object. 372key :: (Functor m, Monad m) => Text -> ParseT err m a -> ParseT err m a 373key k p = key' (badSchema (KeyMissing k)) k p 374 375-- | Take the value corresponding to a given key in the current object, or 376-- if no property exists with that key, use the supplied default. 377keyOrDefault :: (Functor m, Monad m) => Text -> a -> ParseT err m a -> ParseT err m a 378keyOrDefault k def p = key' (pure def) k p 379 380-- | Take the value corresponding to a given key in the current object, or 381-- if no property exists with that key, return Nothing . 382keyMay :: (Functor m, Monad m) => Text -> ParseT err m a -> ParseT err m (Maybe a) 383keyMay k p = keyOrDefault k Nothing (Just <$> p) 384 385key' :: (Functor m, Monad m) => ParseT err m a -> Text -> ParseT err m a -> ParseT err m a 386key' onMissing k p = do 387 v <- asks rdrValue 388 case v of 389 A.Object obj -> 390 case HashMap.lookup k obj of 391 Just v' -> 392 local (appendPath (ObjectKey k) . setValue v') p 393 Nothing -> 394 onMissing 395 _ -> 396 badSchema (WrongType TyObject v) 397 398-- | Take the nth value of the current array. 399nth :: (Functor m, Monad m) => Int -> ParseT err m a -> ParseT err m a 400nth n p = nth' (badSchema (OutOfBounds n)) n p 401 402-- | Take the nth value of the current array, or if no value exists with that 403-- index, use the supplied default. 404nthOrDefault :: (Functor m, Monad m) => Int -> a -> ParseT err m a -> ParseT err m a 405nthOrDefault n def p = 406 nth' (pure def) n p 407 408-- | Take the nth value of the current array, or if no value exists with that 409-- index, return Nothing. 410nthMay :: (Functor m, Monad m) => Int -> ParseT err m a -> ParseT err m (Maybe a) 411nthMay n p = nthOrDefault n Nothing (Just <$> p) 412 413nth' :: (Functor m, Monad m) => ParseT err m a -> Int -> ParseT err m a -> ParseT err m a 414nth' onMissing n p = do 415 v <- asks rdrValue 416 case v of 417 A.Array vect -> 418 case vect !? n of 419 Just v' -> 420 local (appendPath (ArrayIndex n) . setValue v') p 421 Nothing -> 422 onMissing 423 _ -> 424 badSchema (WrongType TyArray v) 425 426-- | Attempt to parse each value in the array with the given parser, and 427-- collect the results. 428eachInArray :: (Functor m, Monad m) => ParseT err m a -> ParseT err m [a] 429eachInArray p = do 430 xs <- zip [0..] . V.toList <$> asArray 431 forM xs $ \(i, x) -> 432 local (appendPath (ArrayIndex i) . setValue x) p 433 434-- | Parse each property in an object with the given parser, given the key as 435-- an argument, and collect the results. 436forEachInObject :: (Functor m, Monad m) => (Text -> ParseT err m a) -> ParseT err m [a] 437forEachInObject p = do 438 xs <- HashMap.toList <$> asObject 439 forM xs $ \(k, x) -> 440 local (appendPath (ObjectKey k) . setValue x) (p k) 441 442-- | Attempt to parse each property value in the object with the given parser, 443-- and collect the results. 444eachInObject :: (Functor m, Monad m) => ParseT err m a -> ParseT err m [(Text, a)] 445eachInObject = eachInObjectWithKey Right 446 447-- | Attempt to parse each property in the object: parse the key with the 448-- given validation function, parse the value with the given parser, and 449-- collect the results. 450eachInObjectWithKey :: (Functor m, Monad m) => (Text -> Either err k) -> ParseT err m a -> ParseT err m [(k, a)] 451eachInObjectWithKey parseKey parseVal = forEachInObject $ \k -> 452 (,) <$> liftEither (parseKey k) <*> parseVal 453 454-- | Lifts a function attempting to validate an arbitrary JSON value into a 455-- parser. You should only use this if absolutely necessary; the other 456-- functions in this module will generally give better error reporting. 457withValue :: (Functor m, Monad m) => (A.Value -> Either err a) -> ParseT err m a 458withValue f = liftParse (left CustomError . f) 459 460withValueM :: (Functor m, Monad m) => (A.Value -> m (Either err a)) -> ParseT err m a 461withValueM f = liftParseM (fmap (left CustomError) . f) 462 463liftEither :: (Functor m, Monad m) => Either err a -> ParseT err m a 464liftEither = withValue . const 465 466withM :: (Functor m, Monad m) => ParseT err m a -> (a -> m (Either err b)) -> ParseT err m b 467withM g f = g >>= lift . f >>= liftEither 468 469with :: (Functor m, Monad m) => ParseT err m a -> (a -> Either err b) -> ParseT err m b 470with g f = withM g (return . f) 471 472withTextM :: (Functor m, Monad m) => (Text -> m (Either err a)) -> ParseT err m a 473withTextM = withM asText 474 475withText :: (Functor m, Monad m) => (Text -> Either err a) -> ParseT err m a 476withText = with asText 477 478withStringM :: (Functor m, Monad m) => (String -> m (Either err a)) -> ParseT err m a 479withStringM = withM asString 480 481withString :: (Functor m, Monad m) => (String -> Either err a) -> ParseT err m a 482withString = with asString 483 484withScientificM :: (Functor m, Monad m) => (Scientific -> m (Either err a)) -> ParseT err m a 485withScientificM = withM asScientific 486 487withScientific :: (Functor m, Monad m) => (Scientific -> Either err a) -> ParseT err m a 488withScientific = with asScientific 489 490withIntegralM :: (Functor m, Monad m, Integral a) => (a -> m (Either err b)) -> ParseT err m b 491withIntegralM = withM asIntegral 492 493withIntegral :: (Functor m, Monad m, Integral a) => (a -> Either err b) -> ParseT err m b 494withIntegral = with asIntegral 495 496withRealFloatM :: (Functor m, Monad m, RealFloat a) => (a -> m (Either err b)) -> ParseT err m b 497withRealFloatM = withM asRealFloat 498 499withRealFloat :: (Functor m, Monad m, RealFloat a) => (a -> Either err b) -> ParseT err m b 500withRealFloat = with asRealFloat 501 502withBoolM :: (Functor m, Monad m) => (Bool -> m (Either err a)) -> ParseT err m a 503withBoolM = withM asBool 504 505withBool :: (Functor m, Monad m) => (Bool -> Either err a) -> ParseT err m a 506withBool = with asBool 507 508-- | Prefer to use functions like 'key' or 'eachInObject' to this one where 509-- possible, as they will generate better error messages. 510withObjectM :: (Functor m, Monad m) => (A.Object -> m (Either err a)) -> ParseT err m a 511withObjectM = withM asObject 512 513-- | Prefer to use functions like 'key' or 'eachInObject' to this one where 514-- possible, as they will generate better error messages. 515withObject :: (Functor m, Monad m) => (A.Object -> Either err a) -> ParseT err m a 516withObject = with asObject 517 518-- | Prefer to use functions like 'nth' or 'eachInArray' to this one where 519-- possible, as they will generate better error messages. 520withArrayM :: (Functor m, Monad m) => (A.Array -> m (Either err a)) -> ParseT err m a 521withArrayM = withM asArray 522 523-- | Prefer to use functions like 'nth' or 'eachInArray' to this one where 524-- possible, as they will generate better error messages. 525withArray :: (Functor m, Monad m) => (A.Array -> Either err a) -> ParseT err m a 526withArray = with asArray 527 528-- | Throw a custom validation error. 529throwCustomError :: (Functor m, Monad m) => err -> ParseT err m a 530throwCustomError = liftEither . Left 531 532liftCustomT :: (Functor m, Monad m) => ExceptT err m a -> ParseT err m a 533liftCustomT f = lift (runExceptT f) >>= liftEither 534