{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Error
  ( at,
    atPositions,
    custom,
    isCustom,
    internal,
    isInternal,
    getCustomErrorType,
    GQLErrors,
    GQLError
      ( message,
        locations,
        path
      ),
    manyMsg,
    Msg (..),
    Message,
    withPath,
    withExtensions,
    PropName (..),
  )
where

import Data.Aeson
  ( FromJSON (..),
    Options (..),
    ToJSON (..),
    Value (Null, Number, String),
    defaultOptions,
    encode,
    genericParseJSON,
    genericToJSON,
  )
import Data.ByteString.Lazy (ByteString)
import Data.Morpheus.Types.Internal.AST.Base
  ( Position (..),
  )
import Data.Scientific (floatingOrInteger)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (decodeUtf8)
import Relude hiding (ByteString, decodeUtf8)

type Message = Text

internal :: GQLError -> GQLError
internal :: GQLError -> GQLError
internal GQLError
x = GQLError
x {errorType :: Maybe ErrorType
errorType = forall a. a -> Maybe a
Just ErrorType
Internal}

isInternal :: GQLError -> Bool
isInternal :: GQLError -> Bool
isInternal GQLError {errorType :: GQLError -> Maybe ErrorType
errorType = Just ErrorType
Internal} = Bool
True
isInternal GQLError
_ = Bool
False

custom :: GQLError -> Text -> GQLError
custom :: GQLError -> Text -> GQLError
custom GQLError
x Text
customError = GQLError
x {errorType :: Maybe ErrorType
errorType = forall a. a -> Maybe a
Just (Text -> ErrorType
Custom Text
customError)}

isCustom :: GQLError -> Bool
isCustom :: GQLError -> Bool
isCustom GQLError {errorType :: GQLError -> Maybe ErrorType
errorType = Just (Custom Text
_)} = Bool
True
isCustom GQLError
_ = Bool
False

getCustomErrorType :: GQLError -> Maybe Text
getCustomErrorType :: GQLError -> Maybe Text
getCustomErrorType GQLError {errorType :: GQLError -> Maybe ErrorType
errorType = Just (Custom Text
customError)} = forall a. a -> Maybe a
Just Text
customError
getCustomErrorType GQLError
_ = forall a. Maybe a
Nothing

at :: GQLError -> Position -> GQLError
at :: GQLError -> Position -> GQLError
at GQLError
err Position
pos = forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
atPositions GQLError
err [Position
pos]
{-# INLINE at #-}

atPositions :: Foldable t => GQLError -> t Position -> GQLError
atPositions :: forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
atPositions GQLError {Maybe [Position]
Maybe [PropName]
Maybe (Map Text Value)
Maybe ErrorType
Text
extensions :: GQLError -> Maybe (Map Text Value)
extensions :: Maybe (Map Text Value)
errorType :: Maybe ErrorType
path :: Maybe [PropName]
locations :: Maybe [Position]
message :: Text
errorType :: GQLError -> Maybe ErrorType
path :: GQLError -> Maybe [PropName]
locations :: GQLError -> Maybe [Position]
message :: GQLError -> Text
..} t Position
pos = case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Position
pos of
  [] -> GQLError {Maybe [Position]
Maybe [PropName]
Maybe (Map Text Value)
Maybe ErrorType
Text
extensions :: Maybe (Map Text Value)
extensions :: Maybe (Map Text Value)
errorType :: Maybe ErrorType
path :: Maybe [PropName]
locations :: Maybe [Position]
message :: Text
errorType :: Maybe ErrorType
path :: Maybe [PropName]
locations :: Maybe [Position]
message :: Text
..}
  [Position]
posList -> GQLError {locations :: Maybe [Position]
locations = Maybe [Position]
locations forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a
Just [Position]
posList, Maybe [PropName]
Maybe (Map Text Value)
Maybe ErrorType
Text
extensions :: Maybe (Map Text Value)
extensions :: Maybe (Map Text Value)
errorType :: Maybe ErrorType
path :: Maybe [PropName]
message :: Text
errorType :: Maybe ErrorType
path :: Maybe [PropName]
message :: Text
..}
{-# INLINE atPositions #-}

withExtensions :: GQLError -> Map Text Value -> GQLError
withExtensions :: GQLError -> Map Text Value -> GQLError
withExtensions GQLError
gqlErr Map Text Value
ext = GQLError
gqlErr {extensions :: Maybe (Map Text Value)
extensions = forall a. a -> Maybe a
Just Map Text Value
ext}

withPath :: GQLError -> [PropName] -> GQLError
withPath :: GQLError -> [PropName] -> GQLError
withPath GQLError
err [] = GQLError
err
withPath GQLError
err [PropName]
path = GQLError
err {path :: Maybe [PropName]
path = forall a. a -> Maybe a
Just [PropName]
path}

manyMsg :: (Foldable t, Msg a) => t a -> GQLError
manyMsg :: forall (t :: * -> *) a. (Foldable t, Msg a) => t a -> GQLError
manyMsg =
  forall a. Msg a => a -> GQLError
msg
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
", "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GQLError -> Text
message forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Msg a => a -> GQLError
msg)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

data ErrorType
  = Internal
  | Custom Text
  deriving
    ( Int -> ErrorType -> ShowS
[ErrorType] -> ShowS
ErrorType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorType] -> ShowS
$cshowList :: [ErrorType] -> ShowS
show :: ErrorType -> String
$cshow :: ErrorType -> String
showsPrec :: Int -> ErrorType -> ShowS
$cshowsPrec :: Int -> ErrorType -> ShowS
Show,
      ErrorType -> ErrorType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorType -> ErrorType -> Bool
$c/= :: ErrorType -> ErrorType -> Bool
== :: ErrorType -> ErrorType -> Bool
$c== :: ErrorType -> ErrorType -> Bool
Eq,
      forall x. Rep ErrorType x -> ErrorType
forall x. ErrorType -> Rep ErrorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrorType x -> ErrorType
$cfrom :: forall x. ErrorType -> Rep ErrorType x
Generic
    )

instance ToJSON ErrorType where
  toJSON :: ErrorType -> Value
toJSON (Custom Text
customError) = Text -> Value
String Text
customError
  toJSON ErrorType
Internal = Value
Null

instance FromJSON ErrorType where
  parseJSON :: Value -> Parser ErrorType
parseJSON (String Text
customError) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ErrorType
Custom Text
customError
  parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected custom error type"

instance Semigroup ErrorType where
  ErrorType
Internal <> :: ErrorType -> ErrorType -> ErrorType
<> ErrorType
_ = ErrorType
Internal
  ErrorType
_ <> ErrorType
Internal = ErrorType
Internal
  Custom Text
customError <> Custom Text
customError' = Text -> ErrorType
Custom forall a b. (a -> b) -> a -> b
$ Text
customError forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> Text
customError'

data GQLError = GQLError
  { GQLError -> Text
message :: Message,
    GQLError -> Maybe [Position]
locations :: Maybe [Position],
    GQLError -> Maybe [PropName]
path :: Maybe [PropName],
    GQLError -> Maybe ErrorType
errorType :: Maybe ErrorType,
    GQLError -> Maybe (Map Text Value)
extensions :: Maybe (Map Text Value)
  }
  deriving
    ( Int -> GQLError -> ShowS
[GQLError] -> ShowS
GQLError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GQLError] -> ShowS
$cshowList :: [GQLError] -> ShowS
show :: GQLError -> String
$cshow :: GQLError -> String
showsPrec :: Int -> GQLError -> ShowS
$cshowsPrec :: Int -> GQLError -> ShowS
Show,
      GQLError -> GQLError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GQLError -> GQLError -> Bool
$c/= :: GQLError -> GQLError -> Bool
== :: GQLError -> GQLError -> Bool
$c== :: GQLError -> GQLError -> Bool
Eq,
      forall x. Rep GQLError x -> GQLError
forall x. GQLError -> Rep GQLError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GQLError x -> GQLError
$cfrom :: forall x. GQLError -> Rep GQLError x
Generic
    )

data PropName
  = PropIndex Int
  | PropName Text
  deriving (Int -> PropName -> ShowS
[PropName] -> ShowS
PropName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropName] -> ShowS
$cshowList :: [PropName] -> ShowS
show :: PropName -> String
$cshow :: PropName -> String
showsPrec :: Int -> PropName -> ShowS
$cshowsPrec :: Int -> PropName -> ShowS
Show, PropName -> PropName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PropName -> PropName -> Bool
$c/= :: PropName -> PropName -> Bool
== :: PropName -> PropName -> Bool
$c== :: PropName -> PropName -> Bool
Eq, forall x. Rep PropName x -> PropName
forall x. PropName -> Rep PropName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PropName x -> PropName
$cfrom :: forall x. PropName -> Rep PropName x
Generic)

instance IsString PropName where
  fromString :: String -> PropName
fromString = Text -> PropName
PropName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance FromJSON PropName where
  parseJSON :: Value -> Parser PropName
parseJSON (String Text
name) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> PropName
PropName Text
name)
  parseJSON (Number Scientific
v) = case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
v of
    Left Double
fl -> forall (m :: * -> *) a. MonadFail m => Double -> m a
invalidIndex Double
fl
    Right Int
index -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> PropName
PropIndex Int
index)
  parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Property Name must be a either Name or Index"

invalidIndex :: MonadFail m => Double -> m a
invalidIndex :: forall (m :: * -> *) a. MonadFail m => Double -> m a
invalidIndex Double
i = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Property Name must be a either Name or Index. it can't be " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Double
i forall a. Semigroup a => a -> a -> a
<> String
"."

instance ToJSON PropName where
  toJSON :: PropName -> Value
toJSON (PropName Text
name) = forall a. ToJSON a => a -> Value
toJSON Text
name
  toJSON (PropIndex Int
index) = forall a. ToJSON a => a -> Value
toJSON Int
index

instance Ord GQLError where
  compare :: GQLError -> GQLError -> Ordering
compare GQLError
x GQLError
y = forall a. Ord a => a -> a -> Ordering
compare (GQLError -> Maybe [Position]
locations GQLError
x) (GQLError -> Maybe [Position]
locations GQLError
y) forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare (GQLError -> Text
message GQLError
x) (GQLError -> Text
message GQLError
y)

instance IsString GQLError where
  fromString :: String -> GQLError
fromString = forall a. Msg a => a -> GQLError
msg

-- cannot have 'type' as the record name, this is less painful than
-- manually writing to/from JSON instances
stripErrorPrefix :: String -> String
stripErrorPrefix :: ShowS
stripErrorPrefix String
"errorType" = String
"type"
stripErrorPrefix String
other = String
other

aesonOptions :: Options
aesonOptions :: Options
aesonOptions = Options
defaultOptions {omitNothingFields :: Bool
omitNothingFields = Bool
True, fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
stripErrorPrefix}

instance ToJSON GQLError where
  toJSON :: GQLError -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
aesonOptions

instance FromJSON GQLError where
  parseJSON :: Value -> Parser GQLError
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonOptions

instance Semigroup GQLError where
  GQLError Text
m1 Maybe [Position]
l1 Maybe [PropName]
p1 Maybe ErrorType
t1 Maybe (Map Text Value)
e1 <> :: GQLError -> GQLError -> GQLError
<> GQLError Text
m2 Maybe [Position]
l2 Maybe [PropName]
p2 Maybe ErrorType
t2 Maybe (Map Text Value)
e2 = Text
-> Maybe [Position]
-> Maybe [PropName]
-> Maybe ErrorType
-> Maybe (Map Text Value)
-> GQLError
GQLError (Text
m1 forall a. Semigroup a => a -> a -> a
<> Text
m2) (Maybe [Position]
l1 forall a. Semigroup a => a -> a -> a
<> Maybe [Position]
l2) (Maybe [PropName]
p1 forall a. Semigroup a => a -> a -> a
<> Maybe [PropName]
p2) (Maybe ErrorType
t1 forall a. Semigroup a => a -> a -> a
<> Maybe ErrorType
t2) (Maybe (Map Text Value)
e1 forall a. Semigroup a => a -> a -> a
<> Maybe (Map Text Value)
e2)

type GQLErrors = NonEmpty GQLError

class Msg a where
  msg :: a -> GQLError

instance Msg GQLError where
  msg :: GQLError -> GQLError
msg = forall a. a -> a
id

instance Msg String where
  msg :: String -> GQLError
msg = forall a. Msg a => a -> GQLError
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Msg Int where
  msg :: Int -> GQLError
msg = forall a. Msg a => a -> GQLError
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show

instance Msg Text where
  msg :: Text -> GQLError
msg Text
message =
    GQLError
      { Text
message :: Text
message :: Text
message,
        locations :: Maybe [Position]
locations = forall a. Maybe a
Nothing,
        errorType :: Maybe ErrorType
errorType = forall a. Maybe a
Nothing,
        extensions :: Maybe (Map Text Value)
extensions = forall a. Maybe a
Nothing,
        path :: Maybe [PropName]
path = forall a. Maybe a
Nothing
      }

instance Msg ByteString where
  msg :: ByteString -> GQLError
msg = forall a. Msg a => a -> GQLError
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8

instance Msg Value where
  msg :: Value -> GQLError
msg = forall a. Msg a => a -> GQLError
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode