{-# LANGUAGE Arrows #-}

module Hasura.Base.Error
  ( Code (..),
    QErr (..),
    QErrExtra (..),
    overrideQErrStatus,
    prefixQErr,
    showQErr,
    encodeQErr,
    encodeGQLErr,
    noInternalQErrEnc,
    err400,
    err404,
    err405,
    err401,
    err409,
    err429,
    err500,
    internalError,
    QErrM,
    throw400,
    throw404,
    throw405,
    throw409,
    throw429,
    throw500,
    throw500WithDetail,
    throw401,
    iResultToMaybe,
    -- Aeson helpers
    runAesonParser,
    decodeValue,
    -- Modify error messages
    modifyErr,
    modifyErrAndSet500,
    modifyQErr,
    modifyErrA,
    -- Attach context
    withPathK,
    withPathKA,
    withPathI,
    withPathIA,
    indexedFoldlA',
    indexedForM,
    indexedMapM,
    indexedForM_,
    indexedMapM_,
    indexedTraverseA_,
  )
where

import Control.Arrow.Extended
import Data.Aeson
import Data.Aeson.Internal
import Data.Aeson.Key qualified as K
import Data.Aeson.Types
import Data.Parser.JSONPath (encodeJSONPath)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Database.PG.Query qualified as Q
import Hasura.Prelude
import Network.HTTP.Types qualified as HTTP

data Code
  = AccessDenied
  | ActionWebhookCode !Text
  | AlreadyExists
  | AlreadyTracked
  | AlreadyUntracked
  | BadRequest
  | BigQueryError
  | Busy
  | ConcurrentUpdate
  | CoercionError
  | Conflict
  | ConstraintError
  | ConstraintViolation
  | -- | Custom code for extending this sum-type easily
    CustomCode !Text
  | CyclicDependency
  | DataException
  | DataConnectorError
  | DependencyError
  | InvalidConfiguration
  | InvalidHeaders
  | InvalidJSON
  | InvalidParams
  | JWTInvalid
  | JWTInvalidClaims
  | JWTRoleClaimMissing
  | MSSQLError
  | MethodNotAllowed
  | NotExists
  | NotFound
  | NotSupported
  | ParseFailed
  | PermissionDenied
  | PermissionError
  | PostgresError
  | PostgresMaxConnectionsError
  | RemoteSchemaConflicts
  | RemoteSchemaError
  | -- | Websockets
    StartFailed
  | Unexpected
  | UnexpectedPayload
  | ValidationFailed
  deriving (Int -> Code -> ShowS
[Code] -> ShowS
Code -> String
(Int -> Code -> ShowS)
-> (Code -> String) -> ([Code] -> ShowS) -> Show Code
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Code] -> ShowS
$cshowList :: [Code] -> ShowS
show :: Code -> String
$cshow :: Code -> String
showsPrec :: Int -> Code -> ShowS
$cshowsPrec :: Int -> Code -> ShowS
Show, Code -> Code -> Bool
(Code -> Code -> Bool) -> (Code -> Code -> Bool) -> Eq Code
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Code -> Code -> Bool
$c/= :: Code -> Code -> Bool
== :: Code -> Code -> Bool
$c== :: Code -> Code -> Bool
Eq)

instance ToJSON Code where
  toJSON :: Code -> Value
toJSON Code
code = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ case Code
code of
    Code
AccessDenied -> Text
"access-denied"
    ActionWebhookCode Text
t -> Text
t
    Code
AlreadyExists -> Text
"already-exists"
    Code
AlreadyTracked -> Text
"already-tracked"
    Code
AlreadyUntracked -> Text
"already-untracked"
    Code
BadRequest -> Text
"bad-request"
    Code
BigQueryError -> Text
"bigquery-error"
    Code
Busy -> Text
"busy"
    Code
ConcurrentUpdate -> Text
"concurrent-update"
    Code
CoercionError -> Text
"coercion-error"
    Code
Conflict -> Text
"conflict"
    Code
ConstraintError -> Text
"constraint-error"
    Code
ConstraintViolation -> Text
"constraint-violation"
    CustomCode Text
t -> Text
t
    Code
CyclicDependency -> Text
"cyclic-dependency"
    Code
DataException -> Text
"data-exception"
    Code
DataConnectorError -> Text
"data-connector-error"
    Code
DependencyError -> Text
"dependency-error"
    Code
InvalidConfiguration -> Text
"invalid-configuration"
    Code
InvalidHeaders -> Text
"invalid-headers"
    Code
InvalidJSON -> Text
"invalid-json"
    Code
InvalidParams -> Text
"invalid-params"
    Code
JWTInvalid -> Text
"invalid-jwt"
    Code
JWTInvalidClaims -> Text
"jwt-invalid-claims"
    Code
JWTRoleClaimMissing -> Text
"jwt-missing-role-claims"
    Code
MSSQLError -> Text
"mssql-error"
    Code
MethodNotAllowed -> Text
"method-not-allowed"
    Code
NotExists -> Text
"not-exists"
    Code
NotFound -> Text
"not-found"
    Code
NotSupported -> Text
"not-supported"
    Code
ParseFailed -> Text
"parse-failed"
    Code
PermissionDenied -> Text
"permission-denied"
    Code
PermissionError -> Text
"permission-error"
    Code
PostgresError -> Text
"postgres-error"
    Code
PostgresMaxConnectionsError -> Text
"postgres-max-connections-error"
    Code
RemoteSchemaConflicts -> Text
"remote-schema-conflicts"
    Code
RemoteSchemaError -> Text
"remote-schema-error"
    Code
StartFailed -> Text
"start-failed"
    Code
Unexpected -> Text
"unexpected"
    Code
UnexpectedPayload -> Text
"unexpected-payload"
    Code
ValidationFailed -> Text
"validation-failed"

data QErr = QErr
  { QErr -> JSONPath
qePath :: JSONPath,
    QErr -> Status
qeStatus :: HTTP.Status,
    QErr -> Text
qeError :: Text,
    QErr -> Code
qeCode :: Code,
    QErr -> Maybe QErrExtra
qeInternal :: Maybe QErrExtra
  }
  deriving (QErr -> QErr -> Bool
(QErr -> QErr -> Bool) -> (QErr -> QErr -> Bool) -> Eq QErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QErr -> QErr -> Bool
$c/= :: QErr -> QErr -> Bool
== :: QErr -> QErr -> Bool
$c== :: QErr -> QErr -> Bool
Eq)

-- | Extra context for a QErr, which can either be information from an internal
-- error (e.g. from Postgres, or from a network operation timing out), or
-- context provided when an external service or operation fails, for instance, a
-- webhook error response may provide additional context in the `extensions`
-- key.
data QErrExtra
  = ExtraExtensions Value
  | ExtraInternal Value
  deriving (QErrExtra -> QErrExtra -> Bool
(QErrExtra -> QErrExtra -> Bool)
-> (QErrExtra -> QErrExtra -> Bool) -> Eq QErrExtra
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QErrExtra -> QErrExtra -> Bool
$c/= :: QErrExtra -> QErrExtra -> Bool
== :: QErrExtra -> QErrExtra -> Bool
$c== :: QErrExtra -> QErrExtra -> Bool
Eq)

instance ToJSON QErrExtra where
  toJSON :: QErrExtra -> Value
toJSON = \case
    ExtraExtensions Value
v -> Value
v
    ExtraInternal Value
v -> Value
v

instance ToJSON QErr where
  toJSON :: QErr -> Value
toJSON (QErr JSONPath
jPath Status
_ Text
msg Code
code Maybe QErrExtra
Nothing) =
    [Pair] -> Value
object
      [ Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= JSONPath -> Text
encodeJSONPath JSONPath
jPath,
        Key
"error" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg,
        Key
"code" Key -> Code -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Code
code
      ]
  toJSON (QErr JSONPath
jPath Status
_ Text
msg Code
code (Just QErrExtra
extra)) = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
    case QErrExtra
extra of
      ExtraInternal Value
e -> [Pair]
err [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"internal" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
e]
      ExtraExtensions {} -> [Pair]
err
    where
      err :: [Pair]
err =
        [ Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= JSONPath -> Text
encodeJSONPath JSONPath
jPath,
          Key
"error" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg,
          Key
"code" Key -> Code -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Code
code
        ]

-- | Overrides the status and code of a QErr while retaining all other fields.
overrideQErrStatus :: HTTP.Status -> Code -> QErr -> QErr
overrideQErrStatus :: Status -> Code -> QErr -> QErr
overrideQErrStatus Status
newStatus Code
newCode QErr
err = QErr
err {qeStatus :: Status
qeStatus = Status
newStatus, qeCode :: Code
qeCode = Code
newCode}

-- | Prefixes the message of a QErr while retaining all other fields.
prefixQErr :: Text -> QErr -> QErr
prefixQErr :: Text -> QErr -> QErr
prefixQErr Text
prefix QErr
err = QErr
err {qeError :: Text
qeError = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QErr -> Text
qeError QErr
err}

-- Temporary function until we have a better one in place.
showQErr :: QErr -> Text
showQErr :: QErr -> Text
showQErr = Text -> Text
TL.toStrict (Text -> Text) -> (QErr -> Text) -> QErr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 (ByteString -> Text) -> (QErr -> ByteString) -> QErr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QErr -> ByteString
forall a. ToJSON a => a -> ByteString
encode

noInternalQErrEnc :: QErr -> Value
noInternalQErrEnc :: QErr -> Value
noInternalQErrEnc (QErr JSONPath
jPath Status
_ Text
msg Code
code Maybe QErrExtra
_) =
  [Pair] -> Value
object
    [ Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= JSONPath -> Text
encodeJSONPath JSONPath
jPath,
      Key
"error" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg,
      Key
"code" Key -> Code -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Code
code
    ]

encodeGQLErr :: Bool -> QErr -> Value
encodeGQLErr :: Bool -> QErr -> Value
encodeGQLErr Bool
includeInternal (QErr JSONPath
jPath Status
_ Text
msg Code
code Maybe QErrExtra
maybeExtra) =
  [Pair] -> Value
object
    [ Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg,
      Key
"extensions" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
extnsObj
    ]
  where
    appendIf :: Bool -> [a] -> [a] -> [a]
appendIf Bool
cond [a]
a [a]
b = if Bool
cond then [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
b else [a]
a

    extnsObj :: Value
extnsObj = case Maybe QErrExtra
maybeExtra of
      Maybe QErrExtra
Nothing -> [Pair] -> Value
object [Pair]
codeAndPath
      -- if an `extensions` key is given in the error response from the webhook,
      -- we ignore the `code` key regardless of whether the `extensions` object
      -- contains a `code` field:
      Just (ExtraExtensions Value
v) -> Value
v
      Just (ExtraInternal Value
v) ->
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> [Pair] -> [Pair] -> [Pair]
forall a. Bool -> [a] -> [a] -> [a]
appendIf Bool
includeInternal [Pair]
codeAndPath [Key
"internal" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v]
    codeAndPath :: [Pair]
codeAndPath =
      [ Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= JSONPath -> Text
encodeJSONPath JSONPath
jPath,
        Key
"code" Key -> Code -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Code
code
      ]

-- whether internal should be included or not
encodeQErr :: Bool -> QErr -> Value
encodeQErr :: Bool -> QErr -> Value
encodeQErr Bool
True = QErr -> Value
forall a. ToJSON a => a -> Value
toJSON
encodeQErr Bool
_ = QErr -> Value
noInternalQErrEnc

-- Postgres Connection Errors
instance Q.FromPGConnErr QErr where
  fromPGConnErr :: PGConnErr -> QErr
fromPGConnErr PGConnErr
c
    | Text
"too many clients" Text -> Text -> Bool
`T.isInfixOf` (PGConnErr -> Text
Q.getConnErr PGConnErr
c) =
      let e :: QErr
e = Code -> Text -> QErr
err500 Code
PostgresMaxConnectionsError Text
"max connections reached on postgres"
       in QErr
e {qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ PGConnErr -> Value
forall a. ToJSON a => a -> Value
toJSON PGConnErr
c}
    | Text
"root certificate file" Text -> Text -> Bool
`T.isInfixOf` (PGConnErr -> Text
Q.getConnErr PGConnErr
c) =
      Code -> Text -> QErr
err500 Code
PostgresError Text
"root certificate error"
    | Text
"certificate file" Text -> Text -> Bool
`T.isInfixOf` (PGConnErr -> Text
Q.getConnErr PGConnErr
c) =
      Code -> Text -> QErr
err500 Code
PostgresError Text
"certificate error"
    | Text
"private key file" Text -> Text -> Bool
`T.isInfixOf` (PGConnErr -> Text
Q.getConnErr PGConnErr
c) =
      Code -> Text -> QErr
err500 Code
PostgresError Text
"private-key error"
  fromPGConnErr PGConnErr
c =
    (Code -> Text -> QErr
err500 Code
PostgresError Text
"connection error")
      { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ PGConnErr -> Value
forall a. ToJSON a => a -> Value
toJSON PGConnErr
c
      }

-- Postgres Transaction error
instance Q.FromPGTxErr QErr where
  fromPGTxErr :: PGTxErr -> QErr
fromPGTxErr PGTxErr
txe =
    (Code -> Text -> QErr
err500 Code
PostgresError Text
"postgres tx error")
      { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ PGTxErr -> Value
forall a. ToJSON a => a -> Value
toJSON PGTxErr
txe
      }

err400 :: Code -> Text -> QErr
err400 :: Code -> Text -> QErr
err400 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status400 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

err404 :: Code -> Text -> QErr
err404 :: Code -> Text -> QErr
err404 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status404 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

err405 :: Code -> Text -> QErr
err405 :: Code -> Text -> QErr
err405 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status405 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

err401 :: Code -> Text -> QErr
err401 :: Code -> Text -> QErr
err401 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status401 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

err409 :: Code -> Text -> QErr
err409 :: Code -> Text -> QErr
err409 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status409 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

err429 :: Code -> Text -> QErr
err429 :: Code -> Text -> QErr
err429 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status429 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

err500 :: Code -> Text -> QErr
err500 :: Code -> Text -> QErr
err500 Code
c Text
t = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
HTTP.status500 Text
t Code
c Maybe QErrExtra
forall a. Maybe a
Nothing

type QErrM m = (MonadError QErr m)

throw400 :: (QErrM m) => Code -> Text -> m a
throw400 :: Code -> Text -> m a
throw400 Code
c Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err400 Code
c Text
t

throw404 :: (QErrM m) => Text -> m a
throw404 :: Text -> m a
throw404 Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err404 Code
NotFound Text
t

-- | MethodNotAllowed
throw405 :: (QErrM m) => Text -> m a
throw405 :: Text -> m a
throw405 Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err405 Code
MethodNotAllowed Text
t

-- | AccessDenied
throw401 :: (QErrM m) => Text -> m a
throw401 :: Text -> m a
throw401 Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err401 Code
AccessDenied Text
t

-- | Conflict
throw409 :: (QErrM m) => Text -> m a
throw409 :: Text -> m a
throw409 Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err409 Code
Conflict Text
t

throw429 :: (QErrM m) => Code -> Text -> m a
throw429 :: Code -> Text -> m a
throw429 Code
c Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err429 Code
c Text
t

throw500 :: (QErrM m) => Text -> m a
throw500 :: Text -> m a
throw500 Text
t = QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ Text -> QErr
internalError Text
t

internalError :: Text -> QErr
internalError :: Text -> QErr
internalError = Code -> Text -> QErr
err500 Code
Unexpected

throw500WithDetail :: (QErrM m) => Text -> Value -> m a
throw500WithDetail :: Text -> Value -> m a
throw500WithDetail Text
t Value
detail =
  QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ (Code -> Text -> QErr
err500 Code
Unexpected Text
t) {qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal Value
detail}

modifyQErr ::
  (QErrM m) =>
  (QErr -> QErr) ->
  m a ->
  m a
modifyQErr :: (QErr -> QErr) -> m a -> m a
modifyQErr QErr -> QErr
f m a
a = m a -> (QErr -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
a (QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> (QErr -> QErr) -> QErr -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QErr -> QErr
f)

modifyErr ::
  (QErrM m) =>
  (Text -> Text) ->
  m a ->
  m a
modifyErr :: (Text -> Text) -> m a -> m a
modifyErr Text -> Text
f = (QErr -> QErr) -> m a -> m a
forall (m :: * -> *) a. QErrM m => (QErr -> QErr) -> m a -> m a
modifyQErr ((Text -> Text) -> QErr -> QErr
liftTxtMod Text -> Text
f)

modifyErrA :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (Text -> Text, s)) a
modifyErrA :: arr (e, s) a -> arr (e, (Text -> Text, s)) a
modifyErrA arr (e, s) a
f = proc (e
e, (Text -> Text
g, s
s)) -> (| forall a. arr (a, ()) a -> arr (a, (QErr -> QErr, ())) a
forall e (arr :: * -> * -> *) a s b.
ArrowError e arr =>
arr (a, s) b -> arr (a, (e -> e, s)) b
mapErrorA (arr (e, s) a
f -< (e
e, s
s)) |) ((Text -> Text) -> QErr -> QErr
liftTxtMod Text -> Text
g)

liftTxtMod :: (Text -> Text) -> QErr -> QErr
liftTxtMod :: (Text -> Text) -> QErr -> QErr
liftTxtMod Text -> Text
f (QErr JSONPath
path Status
st Text
s Code
c Maybe QErrExtra
i) = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr JSONPath
path Status
st (Text -> Text
f Text
s) Code
c Maybe QErrExtra
i

modifyErrAndSet500 ::
  (QErrM m) =>
  (Text -> Text) ->
  m a ->
  m a
modifyErrAndSet500 :: (Text -> Text) -> m a -> m a
modifyErrAndSet500 Text -> Text
f = (QErr -> QErr) -> m a -> m a
forall (m :: * -> *) a. QErrM m => (QErr -> QErr) -> m a -> m a
modifyQErr ((Text -> Text) -> QErr -> QErr
liftTxtMod500 Text -> Text
f)

liftTxtMod500 :: (Text -> Text) -> QErr -> QErr
liftTxtMod500 :: (Text -> Text) -> QErr -> QErr
liftTxtMod500 Text -> Text
f (QErr JSONPath
path Status
_ Text
s Code
c Maybe QErrExtra
i) = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr JSONPath
path Status
HTTP.status500 (Text -> Text
f Text
s) Code
c Maybe QErrExtra
i

withPathE :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (JSONPathElement, s)) a
withPathE :: arr (e, s) a -> arr (e, (JSONPathElement, s)) a
withPathE arr (e, s) a
f = proc (e
e, (JSONPathElement
pe, s
s)) -> (| forall a. arr (a, ()) a -> arr (a, (QErr -> QErr, ())) a
forall e (arr :: * -> * -> *) a s b.
ArrowError e arr =>
arr (a, s) b -> arr (a, (e -> e, s)) b
mapErrorA ((e
e, s
s) >- arr (e, s) a
f) |) (JSONPathElement -> QErr -> QErr
injectPrefix JSONPathElement
pe)
  where
    injectPrefix :: JSONPathElement -> QErr -> QErr
injectPrefix JSONPathElement
pe (QErr JSONPath
path Status
st Text
msg Code
code Maybe QErrExtra
i) = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr (JSONPathElement
pe JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
path) Status
st Text
msg Code
code Maybe QErrExtra
i

withPathKA :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (Text, s)) a
withPathKA :: arr (e, s) a -> arr (e, (Text, s)) a
withPathKA arr (e, s) a
f = arr (Text, s) (JSONPathElement, s)
-> arr (e, (Text, s)) (e, (JSONPathElement, s))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (arr Text JSONPathElement -> arr (Text, s) (JSONPathElement, s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (arr Text JSONPathElement -> arr (Text, s) (JSONPathElement, s))
-> arr Text JSONPathElement -> arr (Text, s) (JSONPathElement, s)
forall a b. (a -> b) -> a -> b
$ (Text -> JSONPathElement) -> arr Text JSONPathElement
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Key -> JSONPathElement
Key (Key -> JSONPathElement)
-> (Text -> Key) -> Text -> JSONPathElement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
K.fromText)) arr (e, (Text, s)) (e, (JSONPathElement, s))
-> arr (e, (JSONPathElement, s)) a -> arr (e, (Text, s)) a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> arr (e, s) a -> arr (e, (JSONPathElement, s)) a
forall (arr :: * -> * -> *) e s a.
ArrowError QErr arr =>
arr (e, s) a -> arr (e, (JSONPathElement, s)) a
withPathE arr (e, s) a
f

withPathK :: (QErrM m) => Text -> m a -> m a
withPathK :: Text -> m a -> m a
withPathK Text
a = Kleisli m (m a) a -> m a -> m a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli proc m a
m -> (| forall a. Kleisli m (a, ()) a -> Kleisli m (a, (Text, ())) a
forall (arr :: * -> * -> *) e s a.
ArrowError QErr arr =>
arr (e, s) a -> arr (e, (Text, s)) a
withPathKA (m a
m >- Kleisli m (m a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA) |) Text
a

withPathIA :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (Int, s)) a
withPathIA :: arr (e, s) a -> arr (e, (Int, s)) a
withPathIA arr (e, s) a
f = arr (Int, s) (JSONPathElement, s)
-> arr (e, (Int, s)) (e, (JSONPathElement, s))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (arr Int JSONPathElement -> arr (Int, s) (JSONPathElement, s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (arr Int JSONPathElement -> arr (Int, s) (JSONPathElement, s))
-> arr Int JSONPathElement -> arr (Int, s) (JSONPathElement, s)
forall a b. (a -> b) -> a -> b
$ (Int -> JSONPathElement) -> arr Int JSONPathElement
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Int -> JSONPathElement
Index) arr (e, (Int, s)) (e, (JSONPathElement, s))
-> arr (e, (JSONPathElement, s)) a -> arr (e, (Int, s)) a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> arr (e, s) a -> arr (e, (JSONPathElement, s)) a
forall (arr :: * -> * -> *) e s a.
ArrowError QErr arr =>
arr (e, s) a -> arr (e, (JSONPathElement, s)) a
withPathE arr (e, s) a
f

withPathI :: (QErrM m) => Int -> m a -> m a
withPathI :: Int -> m a -> m a
withPathI Int
a = Kleisli m (m a) a -> m a -> m a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli proc m a
m -> (| forall a. Kleisli m (a, ()) a -> Kleisli m (a, (Int, ())) a
forall (arr :: * -> * -> *) e s a.
ArrowError QErr arr =>
arr (e, s) a -> arr (e, (Int, s)) a
withPathIA (m a
m >- Kleisli m (m a) a
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA) |) Int
a

indexedFoldlA' ::
  (ArrowChoice arr, ArrowError QErr arr, Foldable t) =>
  arr (e, (b, (a, s))) b ->
  arr (e, (b, (t a, s))) b
indexedFoldlA' :: arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
indexedFoldlA' arr (e, (b, (a, s))) b
f = proc (e
e, (b
acc0, (t a
xs, s
s))) ->
  (|
    forall a.
arr (a, (b, ((Int, a), ()))) b -> arr (a, (b, ([(Int, a)], ()))) b
forall (arr :: * -> * -> *) (t :: * -> *) e b a s.
(ArrowChoice arr, Foldable t) =>
arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
foldlA'
      (\b
acc (Int
i, a
v) -> (| forall a. arr (a, ()) b -> arr (a, (Int, ())) b
forall (arr :: * -> * -> *) e s a.
ArrowError QErr arr =>
arr (e, s) a -> arr (e, (Int, s)) a
withPathIA ((e
e, (b
acc, (a
v, s
s))) >- arr (e, (b, (a, s))) b
f) |) Int
i)
  |) b
acc0 ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs))

indexedTraverseA_ ::
  (ArrowChoice arr, ArrowError QErr arr, Foldable t) =>
  arr (e, (a, s)) b ->
  arr (e, (t a, s)) ()
indexedTraverseA_ :: arr (e, (a, s)) b -> arr (e, (t a, s)) ()
indexedTraverseA_ arr (e, (a, s)) b
f = proc (e
e, (t a
xs, s
s)) ->
  (| forall a. arr (a, ((), (a, ()))) () -> arr (a, ((), (t a, ()))) ()
forall (arr :: * -> * -> *) (t :: * -> *) e b a s.
(ArrowChoice arr, ArrowError QErr arr, Foldable t) =>
arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
indexedFoldlA' (\() a
x -> do (e
e, (a
x, s
s)) >- arr (e, (a, s)) b
f; () >- arr () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA) |) () t a
xs

indexedMapM_ :: (QErrM m, Foldable t) => (a -> m b) -> t a -> m ()
indexedMapM_ :: (a -> m b) -> t a -> m ()
indexedMapM_ a -> m b
f = Kleisli m (t a) () -> t a -> m ()
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli proc t a
xs -> (| forall a. Kleisli m (a, (a, ())) b -> Kleisli m (a, (t a, ())) ()
forall (arr :: * -> * -> *) (t :: * -> *) e a s b.
(ArrowChoice arr, ArrowError QErr arr, Foldable t) =>
arr (e, (a, s)) b -> arr (e, (t a, s)) ()
indexedTraverseA_ (\a
x -> a -> m b
f a
x >- Kleisli m (m b) b
forall (m :: * -> *) (arr :: * -> * -> *) a.
ArrowKleisli m arr =>
arr (m a) a
bindA) |) t a
xs

indexedForM_ :: (QErrM m, Foldable t) => t a -> (a -> m b) -> m ()
indexedForM_ :: t a -> (a -> m b) -> m ()
indexedForM_ = ((a -> m b) -> t a -> m ()) -> t a -> (a -> m b) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> t a -> m ()
forall (m :: * -> *) (t :: * -> *) a b.
(QErrM m, Foldable t) =>
(a -> m b) -> t a -> m ()
indexedMapM_

indexedMapM :: (QErrM m) => (a -> m b) -> [a] -> m [b]
indexedMapM :: (a -> m b) -> [a] -> m [b]
indexedMapM a -> m b
f = ((Int, a) -> m b) -> [(Int, a)] -> m [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Int
i, a
x) -> Int -> m b -> m b
forall (m :: * -> *) a. QErrM m => Int -> m a -> m a
withPathI Int
i (a -> m b
f a
x)) ([(Int, a)] -> m [b]) -> ([a] -> [(Int, a)]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..]

indexedForM :: (QErrM m) => [a] -> (a -> m b) -> m [b]
indexedForM :: [a] -> (a -> m b) -> m [b]
indexedForM = ((a -> m b) -> [a] -> m [b]) -> [a] -> (a -> m b) -> m [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> [a] -> m [b]
forall (m :: * -> *) a b. QErrM m => (a -> m b) -> [a] -> m [b]
indexedMapM

liftIResult :: (QErrM m) => IResult a -> m a
liftIResult :: IResult a -> m a
liftIResult (IError JSONPath
path String
msg) =
  QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr JSONPath
path Status
HTTP.status400 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
formatMsg String
msg) Code
ParseFailed Maybe QErrExtra
forall a. Maybe a
Nothing
liftIResult (ISuccess a
a) =
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

iResultToMaybe :: IResult a -> Maybe a
iResultToMaybe :: IResult a -> Maybe a
iResultToMaybe (IError JSONPath
_ String
_) = Maybe a
forall a. Maybe a
Nothing
iResultToMaybe (ISuccess a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

formatMsg :: String -> String
formatMsg :: ShowS
formatMsg String
str = case Text -> Text -> [Text]
T.splitOn Text
"the key " Text
txt of
  [Text
_, Text
txt2] -> case Text -> Text -> [Text]
T.splitOn Text
" was not present" Text
txt2 of
    [Text
key, Text
_] -> String
"the key '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' was not present"
    [Text]
_ -> String
str
  [Text]
_ -> String
str
  where
    txt :: Text
txt = String -> Text
T.pack String
str

runAesonParser :: (QErrM m) => (v -> Parser a) -> v -> m a
runAesonParser :: (v -> Parser a) -> v -> m a
runAesonParser v -> Parser a
p =
  IResult a -> m a
forall (m :: * -> *) a. QErrM m => IResult a -> m a
liftIResult (IResult a -> m a) -> (v -> IResult a) -> v -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Parser a) -> v -> IResult a
forall a b. (a -> Parser b) -> a -> IResult b
iparse v -> Parser a
p

decodeValue :: (FromJSON a, QErrM m) => Value -> m a
decodeValue :: Value -> m a
decodeValue = IResult a -> m a
forall (m :: * -> *) a. QErrM m => IResult a -> m a
liftIResult (IResult a -> m a) -> (Value -> IResult a) -> Value -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> IResult a
forall a. FromJSON a => Value -> IResult a
ifromJSON