{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module      : Servant.Polysemy.Server
Copyright   : (c) 2020 Alex Chapman
License     : BSD3
Maintainer  : alex@farfromthere.net
Stability   : experimental
Portability : GHC
Description : Utilities for running a Servant server in a polysemy stack using Warp.

A simple usage scenario is that you create your API,
then implement a server for it in a 'ServerT api (Sem (Error ServerError ': r))' monad (where 'api' is your API type),
then run it with 'runWarpServer'.
See <example/Server.hs> for a trivial example of this.

If you need to take your Servant-Polysemy server and run it in an ordinary Servant server then you can use 'hoistServerIntoSem'.
This can be used to e.g. add Swagger docs to your server, as in <example/ServerWithSwagger.hs>.
-}
module Servant.Polysemy.Server
  (
  -- * Use ordinary Servant code in a Polysemy 'Sem'
    hoistServerIntoSem
  , liftHandler

  -- * Use Servant-Polysemy code in an ordinary Servant/WAI system
  , serveSem
  , semHandler

  -- * Use Warp to serve a Servant-Polysemy API in a 'Sem' stack.
  , runWarpServer
  , runWarpServerSettings

  -- * Redirect paths in a Servant-Polysemy API
  , Redirect
  , redirect
  ) where

import Control.Monad.Except (ExceptT(..))
import Data.Function ((&))
import Data.Proxy (Proxy(..))
import GHC.TypeLits (Nat)
import qualified Network.Wai.Handler.Warp as Warp
import Polysemy
import Polysemy.Error
import Servant
       ( Application
       , Handler(..)
       , HasServer
       , Header
       , Headers
       , JSON
       , NoContent(..)
       , Server
       , ServerError
       , ServerT
       , StdMethod(GET)
       , ToHttpApiData
       , Verb
       , addHeader
       , hoistServer
       , runHandler
       , serve
       )

-- | Make a Servant 'Handler' run in a Polysemy 'Sem' instead.
liftHandler :: Members '[Error ServerError, Embed IO] r => Handler a -> Sem r a
liftHandler :: Handler a -> Sem r a
liftHandler Handler a
handler =
  IO (Either ServerError a) -> Sem r (Either ServerError a)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Handler a -> IO (Either ServerError a)
forall a. Handler a -> IO (Either ServerError a)
runHandler Handler a
handler) Sem r (Either ServerError a)
-> (Either ServerError a -> Sem r a) -> Sem r a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either ServerError a -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither

-- | Hoist an ordinary Servant 'Server' into a 'ServerT' whose monad is 'Sem',
-- so that it can be used with 'serveSem'.
hoistServerIntoSem
  :: forall api r
   . ( HasServer api '[]
     , Members '[Error ServerError, Embed IO] r
     )
  => Server api -> ServerT api (Sem r)
hoistServerIntoSem :: Server api -> ServerT api (Sem r)
hoistServerIntoSem =
  Proxy api
-> (forall x. Handler x -> Sem r x)
-> Server api
-> ServerT api (Sem r)
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (Proxy api
forall k (t :: k). Proxy t
Proxy @api) (forall (r :: [(* -> *) -> * -> *]) a.
Members '[Error ServerError, Embed IO] r =>
Handler a -> Sem r a
forall a.
Members '[Error ServerError, Embed IO] r =>
Handler a -> Sem r a
liftHandler @r)

-- | Turn a 'Sem' that can throw 'ServerError's into a Servant 'Handler'.
semHandler
  :: (forall x. Sem r x -> IO x)
  -> Sem (Error ServerError ': r) a
  -> Handler a
semHandler :: (forall x. Sem r x -> IO x)
-> Sem (Error ServerError : r) a -> Handler a
semHandler forall x. Sem r x -> IO x
lowerToIO =
  ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO a -> Handler a)
-> (Sem (Error ServerError : r) a -> ExceptT ServerError IO a)
-> Sem (Error ServerError : r) a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ServerError a) -> ExceptT ServerError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ServerError a) -> ExceptT ServerError IO a)
-> (Sem (Error ServerError : r) a -> IO (Either ServerError a))
-> Sem (Error ServerError : r) a
-> ExceptT ServerError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r (Either ServerError a) -> IO (Either ServerError a)
forall x. Sem r x -> IO x
lowerToIO (Sem r (Either ServerError a) -> IO (Either ServerError a))
-> (Sem (Error ServerError : r) a -> Sem r (Either ServerError a))
-> Sem (Error ServerError : r) a
-> IO (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Error ServerError : r) a -> Sem r (Either ServerError a)
forall e (r :: [(* -> *) -> * -> *]) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError

-- | Turn a 'ServerT' that contains a 'Sem' (as returned by 'hoistServerIntoSem') into a WAI 'Application'.
serveSem
  :: forall api r
   . HasServer api '[]
  => (forall x. Sem r x -> IO x)
  -> ServerT api (Sem (Error ServerError ': r))
  -> Application
serveSem :: (forall x. Sem r x -> IO x)
-> ServerT api (Sem (Error ServerError : r)) -> Application
serveSem forall x. Sem r x -> IO x
lowerToIO ServerT api (Sem (Error ServerError : r))
m = let api :: Proxy api
api = Proxy api
forall k (t :: k). Proxy t
Proxy @api
  in Proxy api -> Server api -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy api
api (Proxy api
-> (forall x. Sem (Error ServerError : r) x -> Handler x)
-> ServerT api (Sem (Error ServerError : r))
-> Server api
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer Proxy api
api ((forall x. Sem r x -> IO x)
-> Sem (Error ServerError : r) x -> Handler x
forall (r :: [(* -> *) -> * -> *]) a.
(forall x. Sem r x -> IO x)
-> Sem (Error ServerError : r) a -> Handler a
semHandler forall x. Sem r x -> IO x
lowerToIO) ServerT api (Sem (Error ServerError : r))
m)

-- | Run the given server on the given port, possibly showing exceptions in the responses.
runWarpServer
  :: forall api r
   . ( HasServer api '[]
     , Member (Embed IO) r
     )
  => Warp.Port -- ^ The port to listen on, e.g. '8080'
  -> Bool -- ^ Whether to show exceptions in the http response (good for debugging but potentially a security risk)
  -> ServerT api (Sem (Error ServerError ': r)) -- ^ The server to run. You can create one of these with 'hoistServerIntoSem'.
  -> Sem r ()
runWarpServer :: Port
-> Bool -> ServerT api (Sem (Error ServerError : r)) -> Sem r ()
runWarpServer Port
port Bool
showExceptionResponse ServerT api (Sem (Error ServerError : r))
server =
  let warpSettings :: Settings
warpSettings = Settings
Warp.defaultSettings
        Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Port -> Settings -> Settings
Warp.setPort Port
port
        Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& if Bool
showExceptionResponse
            then (SomeException -> Response) -> Settings -> Settings
Warp.setOnExceptionResponse SomeException -> Response
Warp.exceptionResponseForDebug
            else Settings -> Settings
forall a. a -> a
id
  in
    Settings -> ServerT api (Sem (Error ServerError : r)) -> Sem r ()
forall api (r :: [(* -> *) -> * -> *]).
(HasServer api '[], Member (Embed IO) r) =>
Settings -> ServerT api (Sem (Error ServerError : r)) -> Sem r ()
runWarpServerSettings @api Settings
warpSettings ServerT api (Sem (Error ServerError : r))
server

-- | Run the given server with these Warp settings.
runWarpServerSettings
  :: forall api r
   . ( HasServer api '[]
     , Member (Embed IO) r
     )
  => Warp.Settings
  -> ServerT api (Sem (Error ServerError ': r))
  -> Sem r ()
runWarpServerSettings :: Settings -> ServerT api (Sem (Error ServerError : r)) -> Sem r ()
runWarpServerSettings Settings
settings ServerT api (Sem (Error ServerError : r))
server = ((forall x. Sem r x -> IO x) -> IO () -> IO ()) -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
withLowerToIO (((forall x. Sem r x -> IO x) -> IO () -> IO ()) -> Sem r ())
-> ((forall x. Sem r x -> IO x) -> IO () -> IO ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \forall x. Sem r x -> IO x
lowerToIO IO ()
finished -> do
  Settings -> Application -> IO ()
Warp.runSettings Settings
settings ((forall x. Sem r x -> IO x)
-> ServerT api (Sem (Error ServerError : r)) -> Application
forall api (r :: [(* -> *) -> * -> *]).
HasServer api '[] =>
(forall x. Sem r x -> IO x)
-> ServerT api (Sem (Error ServerError : r)) -> Application
serveSem @api forall x. Sem r x -> IO x
lowerToIO ServerT api (Sem (Error ServerError : r))
server)
  IO ()
finished

-- | A redirect response with the given code, the new location given in the given type, e.g:
-- > Redirect 302 Text
-- This will return a '302 Found' response, and we will use 'Text' in the server to say where it will redirect to.
type Redirect (code :: Nat) loc
  = Verb 'GET code '[JSON] (Headers '[Header "Location" loc] NoContent)

-- | Serve a redirect response to the given location, e.g:
-- > redirect "/api/v1"
redirect :: ToHttpApiData a => a -> Sem r (Headers '[Header "Location" a] NoContent)
redirect :: a -> Sem r (Headers '[Header "Location" a] NoContent)
redirect a
a = Headers '[Header "Location" a] NoContent
-> Sem r (Headers '[Header "Location" a] NoContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers '[Header "Location" a] NoContent
 -> Sem r (Headers '[Header "Location" a] NoContent))
-> Headers '[Header "Location" a] NoContent
-> Sem r (Headers '[Header "Location" a] NoContent)
forall a b. (a -> b) -> a -> b
$ a -> NoContent -> Headers '[Header "Location" a] NoContent
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader a
a NoContent
NoContent