-- | copy of https://github.com/haskell-servant/servant/pull/1551 while we're waiting for this
-- to be released.  this was needed in https://github.com/wireapp/wire-server/pull/2848/, but
-- then in the end it wasn't.  we keep it here in the hope that whoever needs it next will
-- have an easier time putting it to work.
module Servant.API.Extended.RawM where

import Control.Monad.Trans.Resource
import Data.Metrics.Servant
import Data.Proxy
import Imports
import Network.Wai
import Servant.API (Raw)
import Servant.OpenApi
import Servant.Server hiding (respond)
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.Router

type ApplicationM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.
data RawM deriving (Typeable)

-- | Just pass the request to the underlying application and serve its response.
--
-- Example:
--
-- > type MyApi = "images" :> RawM
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer RawM context where
  type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

  route ::
    Proxy RawM ->
    Context context ->
    Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) ->
    Router env
  route :: forall env.
Proxy RawM
-> Context context
-> Delayed
     env
     (Request
      -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
-> Router env
route Proxy RawM
_ Context context
_ Delayed
  env
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
handleDelayed = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
RawRouter ((env -> RoutingApplication) -> Router' env RoutingApplication)
-> (env -> RoutingApplication) -> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$ \env
env Request
request RouteResult Response -> IO ResponseReceived
respond -> ResourceT IO ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO ResponseReceived -> IO ResponseReceived)
-> ResourceT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
    RouteResult
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
routeResult <- Delayed
  env
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
-> env
-> Request
-> ResourceT
     IO
     (RouteResult
        (Request
         -> (Response -> IO ResponseReceived) -> Handler ResponseReceived))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed
  env
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
handleDelayed env
env Request
request
    let respond' :: RouteResult Response -> IO ResponseReceived
respond' = IO ResponseReceived -> IO ResponseReceived
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> IO ResponseReceived)
-> (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult Response -> IO ResponseReceived
respond
    IO ResponseReceived -> ResourceT IO ResponseReceived
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> ResourceT IO ResponseReceived)
-> IO ResponseReceived -> ResourceT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case RouteResult
  (Request
   -> (Response -> IO ResponseReceived) -> Handler ResponseReceived)
routeResult of
      Route Request
-> (Response -> IO ResponseReceived) -> Handler ResponseReceived
handler ->
        Handler ResponseReceived
-> IO (Either ServerError ResponseReceived)
forall a. Handler a -> IO (Either ServerError a)
runHandler (Request
-> (Response -> IO ResponseReceived) -> Handler ResponseReceived
handler Request
request (RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> (Response -> RouteResult Response)
-> Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> RouteResult Response
forall a. a -> RouteResult a
Route))
          IO (Either ServerError ResponseReceived)
-> (Either ServerError ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e
            Right ResponseReceived
a -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
a
      Fail ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail ServerError
e
      FailFatal ServerError
e -> RouteResult Response -> IO ResponseReceived
respond' (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy RawM
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT RawM m
-> ServerT RawM n
hoistServerWithContext Proxy RawM
_ Proxy context
_ forall x. m x -> n x
f ServerT RawM m
srvM Request
req Response -> IO ResponseReceived
respond = m ResponseReceived -> n ResponseReceived
forall x. m x -> n x
f (ServerT RawM m
Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
srvM Request
req Response -> IO ResponseReceived
respond)

instance HasOpenApi RawM where
  toOpenApi :: Proxy RawM -> OpenApi
toOpenApi Proxy RawM
_ = Proxy Raw -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Raw)

instance RoutesToPaths RawM where
  getRoutes :: Forest PathSegment
getRoutes = []