{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Error handling.
module Language.GraphQL.Error
    ( CollectErrsT
    , Error(..)
    , Path(..)
    , Resolution(..)
    , ResolverException(..)
    , Response(..)
    , ResponseEventStream
    , addErr
    , addErrMsg
    , parseError
    , runCollectErrs
    , singleError
    ) where

import Conduit
import Control.Exception (Exception(..))
import Control.Monad.Trans.State (StateT, modify, runStateT)
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST (Location(..), Name)
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Type.Schema as Schema
import Prelude hiding (null)
import Text.Megaparsec
    ( ParseErrorBundle(..)
    , PosState(..)
    , SourcePos(..)
    , errorOffset
    , parseErrorTextPretty
    , reachOffset
    , unPos
    )

-- | Executor context.
data Resolution m = Resolution
    { Resolution m -> Seq Error
errors :: Seq Error
    , Resolution m -> HashMap Name (Type m)
types :: HashMap Name (Schema.Type m)
    }

-- | Wraps a parse error into a list of errors.
parseError :: (Applicative f, Serialize a)
    => ParseErrorBundle Text Void
    -> f (Response a)
parseError :: ParseErrorBundle Name Void -> f (Response a)
parseError ParseErrorBundle{NonEmpty (ParseError Name Void)
PosState Name
bundleErrors :: forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundlePosState :: forall s e. ParseErrorBundle s e -> PosState s
bundlePosState :: PosState Name
bundleErrors :: NonEmpty (ParseError Name Void)
..}  =
    Response a -> f (Response a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response a -> f (Response a)) -> Response a -> f (Response a)
forall a b. (a -> b) -> a -> b
$ a -> Seq Error -> Response a
forall a. a -> Seq Error -> Response a
Response a
forall a. Serialize a => a
null (Seq Error -> Response a) -> Seq Error -> Response a
forall a b. (a -> b) -> a -> b
$ (Seq Error, PosState Name) -> Seq Error
forall a b. (a, b) -> a
fst
        ((Seq Error, PosState Name) -> Seq Error)
-> (Seq Error, PosState Name) -> Seq Error
forall a b. (a -> b) -> a -> b
$ ((Seq Error, PosState Name)
 -> ParseError Name Void -> (Seq Error, PosState Name))
-> (Seq Error, PosState Name)
-> NonEmpty (ParseError Name Void)
-> (Seq Error, PosState Name)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Seq Error, PosState Name)
-> ParseError Name Void -> (Seq Error, PosState Name)
forall s e s.
(VisualStream s, ShowErrorComponent e, TraversableStream s) =>
(Seq Error, PosState s)
-> ParseError s e -> (Seq Error, PosState s)
go (Seq Error
forall a. Seq a
Seq.empty, PosState Name
bundlePosState) NonEmpty (ParseError Name Void)
bundleErrors
  where
    errorObject :: ParseError s e -> SourcePos -> Error
errorObject ParseError s e
s SourcePos{FilePath
Pos
sourceName :: SourcePos -> FilePath
sourceLine :: SourcePos -> Pos
sourceColumn :: SourcePos -> Pos
sourceColumn :: Pos
sourceLine :: Pos
sourceName :: FilePath
..} = Error :: Name -> [Location] -> [Path] -> Error
Error
        { $sel:message:Error :: Name
message = FilePath -> Name
Text.pack (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
init (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ParseError s e -> FilePath
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> FilePath
parseErrorTextPretty ParseError s e
s
        , $sel:locations:Error :: [Location]
locations = [Word -> Word -> Location
Location (Pos -> Word
unPos' Pos
sourceLine) (Pos -> Word
unPos' Pos
sourceColumn)]
        , $sel:path:Error :: [Path]
path = []
        }
    unPos' :: Pos -> Word
unPos' = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Pos -> Int) -> Pos -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Int
unPos
    go :: (Seq Error, PosState s)
-> ParseError s e -> (Seq Error, PosState s)
go (Seq Error
result, PosState s
state) ParseError s e
x =
        let (Maybe FilePath
_, PosState s
newState) = Int -> PosState s -> (Maybe FilePath, PosState s)
forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe FilePath, PosState s)
reachOffset (ParseError s e -> Int
forall s e. ParseError s e -> Int
errorOffset ParseError s e
x) PosState s
state
            sourcePosition :: SourcePos
sourcePosition = PosState s -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos PosState s
newState
         in (Seq Error
result Seq Error -> Error -> Seq Error
forall a. Seq a -> a -> Seq a
|> ParseError s e -> SourcePos -> Error
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> SourcePos -> Error
errorObject ParseError s e
x SourcePos
sourcePosition, PosState s
newState)

-- | A wrapper to pass error messages around.
type CollectErrsT m = StateT (Resolution m) m

-- | Adds an error to the list of errors.
addErr :: Monad m => Error -> CollectErrsT m ()
addErr :: Error -> CollectErrsT m ()
addErr Error
v = (Resolution m -> Resolution m) -> CollectErrsT m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify Resolution m -> Resolution m
forall (m :: * -> *). Monad m => Resolution m -> Resolution m
appender
  where
    appender :: Monad m => Resolution m -> Resolution m
    appender :: Resolution m -> Resolution m
appender resolution :: Resolution m
resolution@Resolution{HashMap Name (Type m)
Seq Error
types :: HashMap Name (Type m)
errors :: Seq Error
$sel:types:Resolution :: forall (m :: * -> *). Resolution m -> HashMap Name (Type m)
$sel:errors:Resolution :: forall (m :: * -> *). Resolution m -> Seq Error
..} = Resolution m
resolution{ $sel:errors:Resolution :: Seq Error
errors = Seq Error
errors Seq Error -> Error -> Seq Error
forall a. Seq a -> a -> Seq a
|> Error
v }

makeErrorMessage :: Text -> Error
makeErrorMessage :: Name -> Error
makeErrorMessage Name
s = Name -> [Location] -> [Path] -> Error
Error Name
s [] []

-- | Constructs a response object containing only the error with the given
-- message.
singleError :: Serialize a => Text -> Response a
singleError :: Name -> Response a
singleError Name
message = a -> Seq Error -> Response a
forall a. a -> Seq Error -> Response a
Response a
forall a. Serialize a => a
null (Seq Error -> Response a) -> Seq Error -> Response a
forall a b. (a -> b) -> a -> b
$ Error -> Seq Error
forall a. a -> Seq a
Seq.singleton (Error -> Seq Error) -> Error -> Seq Error
forall a b. (a -> b) -> a -> b
$ Name -> Error
makeErrorMessage Name
message

-- | Convenience function for just wrapping an error message.
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
addErrMsg :: Name -> CollectErrsT m a
addErrMsg Name
errorMessage = (Error -> CollectErrsT m ()
forall (m :: * -> *). Monad m => Error -> CollectErrsT m ()
addErr (Error -> CollectErrsT m ())
-> (Name -> Error) -> Name -> CollectErrsT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Error
makeErrorMessage) Name
errorMessage CollectErrsT m () -> CollectErrsT m a -> CollectErrsT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> CollectErrsT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Serialize a => a
null

-- | If an error can be associated to a particular field in the GraphQL result,
-- it must contain an entry with the key path that details the path of the
-- response field which experienced the error. This allows clients to identify
-- whether a null result is intentional or caused by a runtime error.
data Path
    = Segment Text -- ^ Field name.
    | Index Int -- ^ List index if a field returned a list.
    deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Int -> Path -> FilePath -> FilePath
[Path] -> FilePath -> FilePath
Path -> FilePath
(Int -> Path -> FilePath -> FilePath)
-> (Path -> FilePath)
-> ([Path] -> FilePath -> FilePath)
-> Show Path
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Path] -> FilePath -> FilePath
$cshowList :: [Path] -> FilePath -> FilePath
show :: Path -> FilePath
$cshow :: Path -> FilePath
showsPrec :: Int -> Path -> FilePath -> FilePath
$cshowsPrec :: Int -> Path -> FilePath -> FilePath
Show)

-- | @GraphQL@ error.
data Error = Error
    { Error -> Name
message :: Text
    , Error -> [Location]
locations :: [Location]
    , Error -> [Path]
path :: [Path]
    } deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> FilePath -> FilePath
[Error] -> FilePath -> FilePath
Error -> FilePath
(Int -> Error -> FilePath -> FilePath)
-> (Error -> FilePath)
-> ([Error] -> FilePath -> FilePath)
-> Show Error
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Error] -> FilePath -> FilePath
$cshowList :: [Error] -> FilePath -> FilePath
show :: Error -> FilePath
$cshow :: Error -> FilePath
showsPrec :: Int -> Error -> FilePath -> FilePath
$cshowsPrec :: Int -> Error -> FilePath -> FilePath
Show)

-- | The server\'s response describes the result of executing the requested
-- operation if successful, and describes any errors encountered during the
-- request.
data Response a = Response
    { Response a -> a
data' :: a
    , Response a -> Seq Error
errors :: Seq Error
    } deriving (Response a -> Response a -> Bool
(Response a -> Response a -> Bool)
-> (Response a -> Response a -> Bool) -> Eq (Response a)
forall a. Eq a => Response a -> Response a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response a -> Response a -> Bool
$c/= :: forall a. Eq a => Response a -> Response a -> Bool
== :: Response a -> Response a -> Bool
$c== :: forall a. Eq a => Response a -> Response a -> Bool
Eq, Int -> Response a -> FilePath -> FilePath
[Response a] -> FilePath -> FilePath
Response a -> FilePath
(Int -> Response a -> FilePath -> FilePath)
-> (Response a -> FilePath)
-> ([Response a] -> FilePath -> FilePath)
-> Show (Response a)
forall a. Show a => Int -> Response a -> FilePath -> FilePath
forall a. Show a => [Response a] -> FilePath -> FilePath
forall a. Show a => Response a -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Response a] -> FilePath -> FilePath
$cshowList :: forall a. Show a => [Response a] -> FilePath -> FilePath
show :: Response a -> FilePath
$cshow :: forall a. Show a => Response a -> FilePath
showsPrec :: Int -> Response a -> FilePath -> FilePath
$cshowsPrec :: forall a. Show a => Int -> Response a -> FilePath -> FilePath
Show)

-- | Each event in the underlying Source Stream triggers execution of the
-- subscription selection set. The results of the execution generate a Response
-- Stream.
type ResponseEventStream m a = ConduitT () (Response a) m ()

-- | Only exceptions that inherit from 'ResolverException' a cought by the
-- executor.
data ResolverException = forall e. Exception e => ResolverException e

instance Show ResolverException where
    show :: ResolverException -> FilePath
show (ResolverException e
e) = e -> FilePath
forall a. Show a => a -> FilePath
show e
e

instance Exception ResolverException

-- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data.
runCollectErrs :: (Monad m, Serialize a)
    => HashMap Name (Schema.Type m)
    -> CollectErrsT m a
    -> m (Response a)
runCollectErrs :: HashMap Name (Type m) -> CollectErrsT m a -> m (Response a)
runCollectErrs HashMap Name (Type m)
types' CollectErrsT m a
res = do
    (a
dat, Resolution{HashMap Name (Type m)
Seq Error
types :: HashMap Name (Type m)
errors :: Seq Error
$sel:types:Resolution :: forall (m :: * -> *). Resolution m -> HashMap Name (Type m)
$sel:errors:Resolution :: forall (m :: * -> *). Resolution m -> Seq Error
..}) <- CollectErrsT m a -> Resolution m -> m (a, Resolution m)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT CollectErrsT m a
res
        (Resolution m -> m (a, Resolution m))
-> Resolution m -> m (a, Resolution m)
forall a b. (a -> b) -> a -> b
$ Resolution :: forall (m :: * -> *).
Seq Error -> HashMap Name (Type m) -> Resolution m
Resolution{ $sel:errors:Resolution :: Seq Error
errors = Seq Error
forall a. Seq a
Seq.empty, $sel:types:Resolution :: HashMap Name (Type m)
types = HashMap Name (Type m)
types' }
    Response a -> m (Response a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response a -> m (Response a)) -> Response a -> m (Response a)
forall a b. (a -> b) -> a -> b
$ a -> Seq Error -> Response a
forall a. a -> Seq Error -> Response a
Response a
dat Seq Error
errors