module Data.API.JSON
(
JSONError(..)
, Expected(..)
, FormatExpected(..)
, Position
, Step(..)
, prettyJSONErrorPositions
, prettyJSONError
, prettyStep
, ParserWithErrs
, runParserWithErrsTop
, FromJSONWithErrs(..)
, fromJSONWithErrs
, decodeWithErrs
, failWith
, expectedArray
, expectedBool
, expectedInt
, expectedObject
, expectedString
, badFormat
, withInt
, withNum
, withIntRange
, withBinary
, withBool
, withText
, withRegEx
, withUTC
, withUTCRange
, withVersion
, withField
, (.:.)
, (.::)
) where
import Data.API.Types
import Data.API.Utils
import Control.Applicative
import qualified Data.Aeson as JS
import Data.Aeson.TH
import Data.Attoparsec.Number
import Data.Attoparsec.Text
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 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)
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 :: Position -> Either [(JSONError, Position)] a }
deriving Functor
instance Applicative ParserWithErrs where
pure x = ParserWithErrs $ const $ Right x
pf <*> ps = ParserWithErrs $ \ z ->
case (runParserWithErrs pf z, runParserWithErrs ps z) of
(Right f, Right s) -> Right $ f s
(Left es, Right _) -> Left es
(Right _, Left es) -> Left es
(Left es, Left es') -> Left $ es ++ es'
instance Alternative ParserWithErrs where
empty = failWith $ SyntaxError "No alternative"
px <|> py = ParserWithErrs $ \ z -> case runParserWithErrs px z of
Right v -> Right v
Left _ -> runParserWithErrs py z
instance Monad ParserWithErrs where
return = pure
px >>= f = ParserWithErrs $ \ z ->
case runParserWithErrs px z of
Right x -> runParserWithErrs (f x) z
Left es -> Left es
fail = failWith . SyntaxError
runParserWithErrsTop :: ParserWithErrs a -> Either [(JSONError, Position)] a
runParserWithErrsTop p = runParserWithErrs p []
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 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 = runParserWithErrsTop . parseJSONWithErrs
decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a
decodeWithErrs x = case JS.eitherDecode x of
Left e -> Left [(SyntaxError e, [])]
Right v -> fromJSONWithErrs v
failWith :: JSONError -> ParserWithErrs a
failWith e = ParserWithErrs $ \ z -> Left [(e, z)]
stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a
stepInside s p = ParserWithErrs $ \ z -> runParserWithErrs p (s:z)
modifyTopError :: (JSONError -> JSONError)
-> ParserWithErrs a -> ParserWithErrs a
modifyTopError f p = ParserWithErrs $ \ z -> case runParserWithErrs p z of
Left es -> Left $ map (modifyIfAt z) es
r -> r
where
modifyIfAt z x@(e, z') | z == z' = (f e, z')
| otherwise = x
withInt :: String -> (Int -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withInt = withNum
withNum :: Num n => String -> (n -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withNum _ f (JS.Number (I n)) = f (fromInteger n)
withNum _ f (JS.String s)
| Right (I n) <- parseOnly (number <* endOfInput) s = f (fromInteger n)
withNum s _ v = failWith $ Expected ExpInt s v
withIntRange :: IntRange -> String -> (Int -> ParserWithErrs a)
-> JS.Value -> ParserWithErrs a
withIntRange ir dg f = withInt dg g
where
g i | i `inIntRange` ir = f i
| otherwise = failWith $ IntRangeError dg i ir
_ `inIntRange` IntRange Nothing Nothing = True
i `inIntRange` IntRange (Just lo) Nothing = lo <= i
i `inIntRange` IntRange Nothing (Just hi) = i <= hi
i `inIntRange` IntRange (Just lo) (Just hi) = lo <= i && i <= hi
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 (I i)) | i == 0 = f False
| i == 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 g
where
g txt = case matchRegex (re_regex re) $ T.unpack txt of
Just _ -> f txt
Nothing -> failWith $ RegexError dg txt re
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 g
where
g u | u `inUTCRange` ur = f u
| otherwise = failWith $ UTCRangeError dg u ur
_ `inUTCRange` UTCRange Nothing Nothing = True
u `inUTCRange` UTCRange (Just lo) Nothing = lo <= u
u `inUTCRange` UTCRange Nothing (Just hi) = u <= hi
u `inUTCRange` UTCRange (Just lo) (Just hi) = lo <= u && u <= hi
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 (Expected _ _ JS.Null) = MissingField
treatAsMissing e = e
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
deriveJSON defaultOptions ''JSONError
deriveJSON defaultOptions ''Expected
deriveJSON defaultOptions ''FormatExpected
deriveJSON defaultOptions ''Step
$(SC.deriveSafeCopy 1 'SC.base ''Step)