{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | 'HasServer' instances for the 'Throws' api combinator.
module Servant.Exception.Server
  ( Throws
  , ToServantErr(..)
  , ServantException
  , toServantException
  , fromServantException
  , Exception(..)
  , mapException
  ) where

import Servant.Exception (ServantException, Throws, ToServantErr (..), fromServantException,
                          mapException, toServantException)

#if MIN_VERSION_base(4,11,0)
-- (<>) exported by Prelude as of base-4.11.0
#else
import Data.Semigroup ((<>))
#endif
import Control.Monad.Catch       (Exception (..), catch)
import Control.Monad.Error.Class (MonadError (..))
import Data.Kind                 (Type)
import Data.Maybe                (fromMaybe)
import Data.Proxy                (Proxy (..))
import GHC.TypeLits              (Nat)
import Network.HTTP.Media        (mapAccept, matchAccept, renderHeader)
import Network.HTTP.Types        (Status (..), hAccept, hContentType)
import Network.Wai               (requestHeaders)
import Servant                   (HasServer (..), Verb, type (:<|>), type (:>))
import Servant.API.ContentTypes  (AllMimeRender, allMime, allMimeRender)
#if MIN_VERSION_servant_server(0,16,0)
import Servant.Server.Internal.Delayed     (Delayed (..))
import Servant.Server.Internal.ServerError (ServerError (..))
#else
import Servant.Server                             (ServantErr (..))
import Servant.Server.Internal.RoutingApplication (Delayed (..))
#endif

import qualified Data.Text          as Text
import qualified Data.Text.Encoding as Text

-- | Main 'HasServer' instance for 'Throws e'. Catches exceptions of type 'e' in
-- the upstream server and encodes them using 'ToServantErr' and 'MimeRender' to
-- a response with appropriate content-type (uses 'hAccept' header) and body.
instance ( Exception e
         , ToServantErr e
         , AllMimeRender ct e
         , HasServer (Verb mt st ct a) context
         ) => HasServer (Throws e :> Verb (mt :: k) (st :: Nat) (ct :: [Type]) (a :: Type)) context where

  type ServerT (Throws e :> Verb mt st ct a) m =
       ServerT (Verb mt st ct a) m

  route :: Proxy (Throws e :> Verb mt st ct a)
-> Context context
-> Delayed env (Server (Throws e :> Verb mt st ct a))
-> Router env
route Proxy (Throws e :> Verb mt st ct a)
_ Context context
ctx Delayed env (Server (Throws e :> Verb mt st ct a))
del = Proxy (Verb mt st ct a)
-> Context context
-> Delayed env (Server (Verb mt st ct a))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (Verb mt st ct a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Verb mt st ct a)) Context context
ctx (Delayed env (Server (Verb mt st ct a)) -> Router env)
-> Delayed env (Server (Verb mt st ct a)) -> Router env
forall a b. (a -> b) -> a -> b
$ Delayed env (Handler a) -> Delayed env (Handler a)
extendServer Delayed env (Server (Throws e :> Verb mt st ct a))
Delayed env (Handler a)
del
   where
    extendServer :: Delayed env (Handler a) -> Delayed env (Handler a)
extendServer Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (Handler a)
contentType -> DelayedIO body
capturesD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
contentD :: ()
paramsD :: ()
headersD :: ()
bodyD :: ()
serverD :: ()
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (Handler a)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..} =
      Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed { serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (Handler a)
serverD = \captures
c params
p headers
h auth
a body
b Request
req -> do
                  let accH :: ByteString
accH = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (ByteString
"*" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"*") (Maybe ByteString -> ByteString)
-> ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept ([(HeaderName, ByteString)] -> ByteString)
-> [(HeaderName, ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
                  Proxy ct -> ByteString -> Handler a -> Handler a
handleException (Proxy ct
forall k (t :: k). Proxy t
Proxy :: Proxy ct) ByteString
accH (Handler a -> Handler a)
-> RouteResult (Handler a) -> RouteResult (Handler a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (Handler a)
serverD captures
c params
p headers
h auth
a body
b Request
req
              , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
contentType -> DelayedIO body
capturesD :: env -> DelayedIO captures
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
              }

    handleException :: Proxy ct -> ByteString -> Handler a -> Handler a
handleException Proxy ct
ct ByteString
h Handler a
a = Handler a
a Handler a -> (e -> Handler a) -> Handler a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(e
e :: e) -> do
      -- AllMime and AllMimeRender should prevent 'Nothing'
      let contentType :: MediaType
contentType = MediaType -> Maybe MediaType -> MediaType
forall a. a -> Maybe a -> a
fromMaybe MediaType
"" (Maybe MediaType -> MediaType) -> Maybe MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$ [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept (Proxy ct -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime Proxy ct
ct) ByteString
h
          body :: ByteString
body = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [(MediaType, ByteString)] -> ByteString -> Maybe ByteString
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept (Proxy ct -> e -> [(MediaType, ByteString)]
forall (list :: [*]) a.
AllMimeRender list a =>
Proxy list -> a -> [(MediaType, ByteString)]
allMimeRender Proxy ct
ct e
e) ByteString
h
      ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
#if MIN_VERSION_servant_server(0,16,0)
        ServerError :: Int
-> String
-> ByteString
-> [(HeaderName, ByteString)]
-> ServerError
ServerError
#else
        ServantErr
#endif
          { errHTTPCode :: Int
errHTTPCode = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ e -> Status
forall e. ToServantErr e => e -> Status
status e
e
          , errReasonPhrase :: String
errReasonPhrase = Text -> String
Text.unpack (Text -> String) -> (Status -> Text) -> Status -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (Status -> ByteString) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ByteString
statusMessage (Status -> String) -> Status -> String
forall a b. (a -> b) -> a -> b
$ e -> Status
forall e. ToServantErr e => e -> Status
status e
e
          , errBody :: ByteString
errBody = ByteString
body
          , errHeaders :: [(HeaderName, ByteString)]
errHeaders = (HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
contentType) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: e -> [(HeaderName, ByteString)]
forall e. ToServantErr e => e -> [(HeaderName, ByteString)]
headers e
e
          }


#if MIN_VERSION_servant_server(0,12,0)
  hoistServerWithContext :: Proxy (Throws e :> Verb mt st ct a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throws e :> Verb mt st ct a) m
-> ServerT (Throws e :> Verb mt st ct a) n
hoistServerWithContext Proxy (Throws e :> Verb mt st ct a)
_ = Proxy (Verb mt st ct a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Verb mt st ct a) m
-> ServerT (Verb mt st ct a) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (Verb mt st ct a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Verb mt st ct a))
#endif

-- | Push 'Throws' further "upstream".
instance HasServer (api :> Throws e :> upstream) context =>
         HasServer (Throws e :> api :> upstream) context where

  type ServerT (Throws e :> api :> upstream) m =
       ServerT (api :> Throws e :> upstream) m

  route :: Proxy (Throws e :> (api :> upstream))
-> Context context
-> Delayed env (Server (Throws e :> (api :> upstream)))
-> Router env
route Proxy (Throws e :> (api :> upstream))
_ = Proxy (api :> (Throws e :> upstream))
-> Context context
-> Delayed env (Server (api :> (Throws e :> upstream)))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (api :> (Throws e :> upstream))
forall k (t :: k). Proxy t
Proxy :: Proxy (api :> Throws e :> upstream))

#if MIN_VERSION_servant_server(0,12,0)
  hoistServerWithContext :: Proxy (Throws e :> (api :> upstream))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throws e :> (api :> upstream)) m
-> ServerT (Throws e :> (api :> upstream)) n
hoistServerWithContext Proxy (Throws e :> (api :> upstream))
_ = Proxy (api :> (Throws e :> upstream))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (api :> (Throws e :> upstream)) m
-> ServerT (api :> (Throws e :> upstream)) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (api :> (Throws e :> upstream))
forall k (t :: k). Proxy t
Proxy :: Proxy (api :> Throws e :> upstream))
#endif

-- | Transitive application of 'Throws' on '(:<|>)'.
instance HasServer (Throws e :> api1 :<|> Throws e :> api2) context =>
         HasServer (Throws e :> (api1 :<|> api2)) context where

  type ServerT (Throws e :> (api1 :<|> api2)) m =
       ServerT (Throws e :> api1 :<|> Throws e :> api2) m

  route :: Proxy (Throws e :> (api1 :<|> api2))
-> Context context
-> Delayed env (Server (Throws e :> (api1 :<|> api2)))
-> Router env
route Proxy (Throws e :> (api1 :<|> api2))
_ = Proxy ((Throws e :> api1) :<|> (Throws e :> api2))
-> Context context
-> Delayed
     env (Server ((Throws e :> api1) :<|> (Throws e :> api2)))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy ((Throws e :> api1) :<|> (Throws e :> api2))
forall k (t :: k). Proxy t
Proxy :: Proxy (Throws e :> api1 :<|> Throws e :> api2))

#if MIN_VERSION_servant_server(0,12,0)
  hoistServerWithContext :: Proxy (Throws e :> (api1 :<|> api2))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throws e :> (api1 :<|> api2)) m
-> ServerT (Throws e :> (api1 :<|> api2)) n
hoistServerWithContext Proxy (Throws e :> (api1 :<|> api2))
_ = Proxy ((Throws e :> api1) :<|> (Throws e :> api2))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ((Throws e :> api1) :<|> (Throws e :> api2)) m
-> ServerT ((Throws e :> api1) :<|> (Throws e :> api2)) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy ((Throws e :> api1) :<|> (Throws e :> api2))
forall k (t :: k). Proxy t
Proxy :: Proxy (Throws e :> api1 :<|> Throws e :> api2))
#endif