module Data.API.JSON
(
JSONError(..)
, JSONWarning
, Expected(..)
, FormatExpected(..)
, Position
, Step(..)
, prettyJSONErrorPositions
, prettyJSONError
, prettyStep
, ParserWithErrs
, ParseFlags(useDefaults, enforceReadOnlyFields, enforceFilters)
, defaultParseFlags
, runParserWithErrsTop
, FromJSONWithErrs(..)
, fromJSONWithErrs
, fromJSONWithErrs'
, fromJSONWithErrs''
, decodeWithErrs
, decodeWithErrs'
, parseJSONDefault
, withParseFlags
, failWith
, expectedArray
, expectedBool
, expectedInt
, expectedObject
, expectedString
, badFormat
, withInt
, withIntRange
, withBinary
, withBool
, withText
, withRegEx
, withUTC
, withUTCRange
, withVersion
, withField
, withDefaultField
, (.:.)
, (.::)
, withUnion
) where
import Data.API.Types
import Data.API.Utils
import Control.Applicative
import qualified Data.Aeson as JS
import qualified Data.Aeson.Parser as JS
import qualified Data.Aeson.Types as JS
import Data.Aeson.TH
import Data.Attoparsec.ByteString
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HMap
import Data.List
import Data.Maybe
import qualified Data.SafeCopy as SC
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import Data.Traversable
import qualified Data.Vector as V
import Data.Version
import Distribution.Text
import Text.Regex
data JSONError = Expected Expected String JS.Value
| BadFormat FormatExpected String T.Text
| MissingField
| MissingAlt [String]
| UnexpectedField
| UnexpectedEnumVal [T.Text] T.Text
| IntRangeError String Int IntRange
| UTCRangeError String UTCTime UTCRange
| RegexError String T.Text RegEx
| SyntaxError String
deriving (Eq, Show)
type JSONWarning = JSONError
data Expected = ExpArray
| ExpBool
| ExpInt
| ExpObject
| ExpString
deriving (Eq, Show)
data FormatExpected = FmtBinary
| FmtUTC
| FmtOther
deriving (Eq, Show)
expectedArray, expectedBool, expectedInt, expectedObject, expectedString
:: JS.Value -> JSONError
expectedArray = Expected ExpArray "Array"
expectedBool = Expected ExpBool "Bool"
expectedInt = Expected ExpInt "Int"
expectedObject = Expected ExpObject "Object"
expectedString = Expected ExpString "String"
badFormat :: String -> T.Text -> JSONError
badFormat = BadFormat FmtOther
prettyJSONError :: JSONError -> String
prettyJSONError (Expected _ s v) = "When expecting " ++ s ++ ", encountered "
++ x ++ " instead"
where
x = case v of
JS.Object _ -> "Object"
JS.Array _ -> "Array"
JS.String _ -> "String"
JS.Number _ -> "Number"
JS.Bool _ -> "Boolean"
JS.Null -> "Null"
prettyJSONError (BadFormat _ s t) = "Could not parse as " ++ s ++ " the string " ++ show t
prettyJSONError MissingField = "Field missing from Object"
prettyJSONError (MissingAlt xs) = "Missing alternative, expecting one of: "
++ intercalate ", " xs
prettyJSONError UnexpectedField = "Unexpected field in Object"
prettyJSONError (UnexpectedEnumVal xs t) = "Unexpected enum value " ++ show t
++ ", expecting one of: "
++ T.unpack (T.intercalate ", " xs)
prettyJSONError (IntRangeError s i r) = s ++ ": " ++ show i ++ " not in range " ++ show r
prettyJSONError (UTCRangeError s u r) = s ++ ": " ++ show u ++ " not in range " ++ show r
prettyJSONError (RegexError s _ t) = s ++ ": failed to match RE: " ++ show t
prettyJSONError (SyntaxError e) = "JSON syntax error: " ++ e
type Position = [Step]
data Step = InField T.Text | InElem Int
deriving (Eq, Show)
prettyStep :: Step -> String
prettyStep (InField f) = " in the field " ++ show f
prettyStep (InElem i) = " in array index " ++ show i
prettyJSONErrorPositions :: [(JSONError, Position)] -> String
prettyJSONErrorPositions xs = unlines $ concatMap help xs
where
help (e, pos) = prettyJSONError e : map prettyStep pos
newtype ParserWithErrs a = ParserWithErrs {
runParserWithErrs :: ParseFlags -> Position -> ([(JSONError, Position)], Maybe a) }
deriving Functor
instance Applicative ParserWithErrs where
pure x = ParserWithErrs $ \ _ _ -> ([], Just x)
pf <*> ps = ParserWithErrs $ \ q z ->
let (es_f, mb_f) = runParserWithErrs pf q z
(es_s, mb_s) = runParserWithErrs ps q z
in (es_f ++ es_s, mb_f <*> mb_s)
instance Alternative ParserWithErrs where
empty = failWith $ SyntaxError "No alternative"
px <|> py = ParserWithErrs $ \ q z -> case runParserWithErrs px q z of
r@(_, Just _) -> r
(_, Nothing) -> runParserWithErrs py q z
instance Monad ParserWithErrs where
return = pure
px >>= f = ParserWithErrs $ \ q z ->
case runParserWithErrs px q z of
(es, Just x ) -> let (es', r) = runParserWithErrs (f x) q z
in (es ++ es', r)
(es, Nothing) -> (es, Nothing)
fail = failWith . SyntaxError
data ParseFlags = ParseFlags
{ useDefaults :: Bool
, enforceReadOnlyFields :: Bool
, enforceFilters :: Bool
}
defaultParseFlags :: ParseFlags
defaultParseFlags = ParseFlags { useDefaults = False
, enforceReadOnlyFields = False
, enforceFilters = True
}
runParserWithErrsTop :: ParseFlags -> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONWarning, Position)])
runParserWithErrsTop q p = case runParserWithErrs p q [] of
(es, Nothing) -> Left es
(es, Just v) -> Right (v, es)
class FromJSONWithErrs a where
parseJSONWithErrs :: JS.Value -> ParserWithErrs a
default parseJSONWithErrs :: JS.FromJSON a => JS.Value -> ParserWithErrs a
parseJSONWithErrs v = case JS.fromJSON v of
JS.Error e -> failWith $ SyntaxError e
JS.Success a -> pure a
instance FromJSONWithErrs JS.Value where
parseJSONWithErrs = pure
instance FromJSONWithErrs () where
parseJSONWithErrs (JS.Array a) | V.null a = pure ()
parseJSONWithErrs _ = failWith $ SyntaxError "Expected empty array"
instance FromJSONWithErrs a => FromJSONWithErrs (Maybe a) where
parseJSONWithErrs JS.Null = pure Nothing
parseJSONWithErrs v = Just <$> parseJSONWithErrs v
instance FromJSONWithErrs a => FromJSONWithErrs [a] where
parseJSONWithErrs (JS.Array a) = traverse help $ zip (V.toList a) [0..]
where
help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x
parseJSONWithErrs JS.Null = pure []
parseJSONWithErrs v = failWith $ expectedArray v
instance FromJSONWithErrs Int where
parseJSONWithErrs = withInt "Int" pure
instance FromJSONWithErrs Integer where
parseJSONWithErrs = withNum "Integer" pure
instance FromJSONWithErrs Bool where
parseJSONWithErrs = withBool "Bool" pure
instance FromJSONWithErrs Binary where
parseJSONWithErrs = withBinary "Binary" pure
instance FromJSONWithErrs T.Text where
parseJSONWithErrs = withText "Text" pure
instance FromJSONWithErrs UTCTime where
parseJSONWithErrs = withUTC "UTC" pure
instance FromJSONWithErrs Version where
parseJSONWithErrs = withVersion "Version" pure
fromJSONWithErrs :: FromJSONWithErrs a => JS.Value -> Either [(JSONError, Position)] a
fromJSONWithErrs = fromJSONWithErrs' defaultParseFlags
fromJSONWithErrs' :: FromJSONWithErrs a => ParseFlags -> JS.Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' q = fmap fst . fromJSONWithErrs'' q
fromJSONWithErrs'' :: FromJSONWithErrs a => ParseFlags -> JS.Value
-> Either [(JSONError, Position)] (a, [(JSONWarning, Position)])
fromJSONWithErrs'' q = runParserWithErrsTop q . parseJSONWithErrs
decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a
decodeWithErrs = decodeWithErrs' defaultParseFlags
decodeWithErrs' :: FromJSONWithErrs a => ParseFlags -> BL.ByteString -> Either [(JSONError, Position)] a
decodeWithErrs' q x = case JS.eitherDecode x of
Left e -> Left [(SyntaxError e, [])]
Right v -> fromJSONWithErrs' q v
parseJSONDefault :: FromJSONWithErrs a => JS.Value -> JS.Parser a
parseJSONDefault v = case fromJSONWithErrs v of
Right x -> return x
Left es -> fail $ prettyJSONErrorPositions es
withParseFlags :: (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
withParseFlags k = ParserWithErrs $ \ q -> runParserWithErrs (k q) q
failWith :: JSONError -> ParserWithErrs a
failWith e = ParserWithErrs $ \ _ z -> ([(e, z)], Nothing)
warning :: JSONError -> ParserWithErrs ()
warning e = ParserWithErrs $ \ _ z -> ([(e, z)], Just ())
stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a
stepInside s p = ParserWithErrs $ \ q z -> runParserWithErrs p q (s:z)
modifyTopError :: (JSONError -> JSONError)
-> ParserWithErrs a -> ParserWithErrs a
modifyTopError f p = ParserWithErrs $ \ q z -> case runParserWithErrs p q z of
(es, r) -> (map (modifyIfAt z) es, r)
where
modifyIfAt z x@(e, z') | z == z' = (f e, z')
| otherwise = x
withFilter :: Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter p err m | p = m
| otherwise = withParseFlags $ \ pf -> if enforceFilters pf then failWith err
else warning err >> m
withInt :: String -> (Int -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withInt = withNum
withNum :: JS.FromJSON n => String -> (n -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withNum s f v = case JS.fromJSON v of
JS.Success i -> f i
JS.Error _ | JS.String t <- v
, Right v' <- parseOnly (JS.value <* endOfInput) (T.encodeUtf8 t)
, JS.Success i <- JS.fromJSON v' -> f i
| otherwise -> failWith $ Expected ExpInt s v
withIntRange :: IntRange -> String -> (Int -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withIntRange ir dg f = withInt dg $ \ i -> withFilter (i `inIntRange` ir) (IntRangeError dg i ir) (f i)
withBinary :: String -> (Binary -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withBinary lab f = withText lab g
where
g t =
case B64.decode $ B.pack $ T.unpack t of
Left _ -> failWith $ BadFormat FmtBinary lab t
Right bs -> f $ Binary bs
withBool :: String -> (Bool -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withBool _ f (JS.Bool b) = f b
withBool _ f (JS.Number x) | x == 0 = f False
| x == 1 = f True
withBool s _ v = failWith $ Expected ExpBool s v
withText :: String -> (T.Text -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withText _ f (JS.String t) = f t
withText s _ v = failWith $ Expected ExpString s v
withRegEx :: RegEx -> String -> (T.Text -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withRegEx re dg f = withText dg $ \ txt -> withFilter (ok txt) (RegexError dg txt re) (f txt)
where
ok txt = isJust $ matchRegex (re_regex re) $ T.unpack txt
withUTC :: String -> (UTCTime -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withUTC lab f = withText lab g
where
g t = maybe (failWith $ BadFormat FmtUTC lab t) f $ parseUTC' t
withUTCRange :: UTCRange -> String -> (UTCTime -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withUTCRange ur dg f = withUTC dg $ \ u -> withFilter (u `inUTCRange` ur) (UTCRangeError dg u ur) (f u)
withVersion :: String -> (Version -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withVersion lab f (JS.String s) = case simpleParse $ T.unpack s of
Just ver -> f ver
Nothing -> failWith $ badFormat lab s
withVersion lab _ v = failWith $ Expected ExpString lab v
withField :: T.Text -> (JS.Value -> ParserWithErrs a)
-> JS.Object -> ParserWithErrs a
withField k f m = stepInside (InField k) $ modifyTopError treatAsMissing $ f v
where
v = fromMaybe JS.Null $ HMap.lookup k m
treatAsMissing :: JSONError -> JSONError
treatAsMissing (Expected _ _ JS.Null) = MissingField
treatAsMissing e = e
withDefaultField :: Bool -> Maybe JS.Value -> T.Text -> (JS.Value -> ParserWithErrs a)
-> JS.Object -> ParserWithErrs a
withDefaultField readOnly mb_defVal k f m =
stepInside (InField k) $ modifyTopError treatAsMissing $ withParseFlags foo
where
foo q | readOnly && enforceReadOnlyFields q = f defVal
| useDefaults q = f $ fromMaybe defVal $ HMap.lookup k m
| otherwise = f $ fromMaybe JS.Null $ HMap.lookup k m
defVal = fromMaybe JS.Null mb_defVal
withStrictField :: T.Text -> (JS.Value -> ParserWithErrs a)
-> JS.Object -> ParserWithErrs a
withStrictField k f m = stepInside (InField k) $ case HMap.lookup k m of
Nothing -> failWith MissingField
Just r -> f r
(.:.) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a
m .:. k = withField k parseJSONWithErrs m
(.::) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a
m .:: k = withStrictField k parseJSONWithErrs m
withUnion :: [(T.Text, JS.Value -> ParserWithErrs a)] -> JS.Value -> ParserWithErrs a
withUnion xs (JS.Object hs) =
case HMap.toList hs of
[(k, v)] -> case lookup k xs of
Just c -> stepInside (InField k) $ c v
Nothing -> failWith $ MissingAlt $ map (T.unpack . fst) xs
[] -> failWith $ MissingAlt $ map (T.unpack . fst) xs
_:_:_ -> failWith UnexpectedField
withUnion _ val = failWith $ Expected ExpObject "Union" val
deriveJSON defaultOptions ''JSONError
deriveJSON defaultOptions ''Expected
deriveJSON defaultOptions ''FormatExpected
deriveJSON defaultOptions ''Step
$(SC.deriveSafeCopy 1 'SC.base ''Step)