{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.Rpc.Server.Internal.Error
  ( throwEither
  , throwExceptT
  , throwGrpcErrorWithMessage
  , RpcException (..)
  )
where

import Cardano.Api

import RIO

import GHC.Stack
import Network.GRPC.Spec (GrpcError, GrpcException (..))

throwEither :: (Error e, HasCallStack, MonadIO m, Show e, Typeable e) => Either e a -> m a
throwEither :: forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither = (HasCallStack => Either e a -> m a) -> Either e a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Either e a -> m a) -> Either e a -> m a)
-> (HasCallStack => Either e a -> m a) -> Either e a -> m a
forall a b. (a -> b) -> a -> b
$ (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (RpcException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (RpcException -> m a) -> (e -> RpcException) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> RpcException
forall err.
(Error err, HasCallStack, Show err, Typeable err) =>
err -> RpcException
RpcException) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

throwExceptT :: (Error e, HasCallStack, MonadIO m, Show e, Typeable e) => ExceptT e m a -> m a
throwExceptT :: forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
ExceptT e m a -> m a
throwExceptT = (HasCallStack => ExceptT e m a -> m a) -> ExceptT e m a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => ExceptT e m a -> m a) -> ExceptT e m a -> m a)
-> (HasCallStack => ExceptT e m a -> m a) -> ExceptT e m a -> m a
forall a b. (a -> b) -> a -> b
$ Either e a -> m a
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither (Either e a -> m a)
-> (ExceptT e m a -> m (Either e a)) -> ExceptT e m a -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

data RpcException where
  RpcException :: (Error err, HasCallStack, Show err, Typeable err) => err -> RpcException

deriving instance Show RpcException

instance Exception RpcException where
  displayException :: RpcException -> String
displayException (RpcException err
e) =
    [String] -> String
unlines
      [ Doc (ZonkAny 0) -> String
forall a. Show a => a -> String
show (err -> Doc (ZonkAny 0)
forall ann. err -> Doc ann
forall e ann. Error e => e -> Doc ann
prettyError err
e)
      , CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
      ]

-- | Throw a 'GrpcException' with the given error code and message.
-- grapesy converts this to proper gRPC trailers before it reaches 'serverTopLevel'.
throwGrpcErrorWithMessage :: MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage :: forall (m :: * -> *) a. MonadIO m => GrpcError -> Text -> m a
throwGrpcErrorWithMessage GrpcError
err Text
message =
  GrpcException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
    GrpcException
      { grpcError :: GrpcError
grpcError = GrpcError
err
      , grpcErrorMessage :: Maybe Text
grpcErrorMessage = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
message
      , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails = Maybe ByteString
forall a. Maybe a
Nothing
      , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata = []
      }