Server.hs

module Effectful.Servant.Server
    ( -- * Run a wai application from an API
      serve
    , serveWithContext
    , serveWithContextT
    , ServerContext

      -- * Handlers for all standard combinators
    , HasServer (..)
    , Server
    , EmptyServer
    , emptyServer
    , Handler

      -- * Context
    , Context (..)
    , HasContextEntry (getContextEntry)
    , type (.++)
    , (.++)

      -- ** NamedContext
    , NamedContext (..)
    , descendIntoNamedContext

      -- * Basic Authentication
    , BasicAuthCheck (BasicAuthCheck, unBasicAuthCheck)
    , BasicAuthResult (..)

      -- * Default error type
    , ServerError (..)

      -- ** 3XX
    , err300
    , err301
    , err302
    , err303
    , err304
    , err305
    , err307

      -- ** 4XX
    , err400
    , err401
    , err402
    , err403
    , err404
    , err405
    , err406
    , err407
    , err409
    , err410
    , err411
    , err412
    , err413
    , err414
    , err415
    , err416
    , err417
    , err418
    , err422
    , err429

      -- ** 5XX
    , err500
    , err501
    , err502
    , err503
    , err504
    , err505
    )
where

import Control.Monad.Trans.Except (ExceptT (ExceptT))
import Data.Kind (Type)
import Data.Proxy (Proxy)
import Effectful
import Effectful.Error.Static (Error, runErrorNoCallStack)
import Effectful.Wai (Application, liftApplication)
import Servant.Server hiding
    ( Application
    , Handler
    , Server
    , respond
    , serve
    , serveWithContext
    , serveWithContextT
    )
import Servant.Server qualified as Servant
import Prelude

-- | Lifted 'Servant.Handler'.
type Handler (es :: [Effect]) = Eff (Error ServerError ': es)

-- | Lifted 'Servant.Server'.
type Server (api :: Type) (es :: [Effect]) = ServerT api (Handler es)

-- | Lifted 'Servant.serve'.
serve
    :: ( HasServer api ('[] :: [Type])
       , IOE :> es
       )
    => Proxy api
    -> Server api es
    -> Application es
serve p = serveWithContext p EmptyContext

-- | Lifted 'Servant.serveWithContext'.
serveWithContext
    :: ( HasServer api context
       , ServerContext context
       , IOE :> es
       )
    => Proxy api
    -> Context context
    -> Server api es
    -> Application es
serveWithContext p context = serveWithContextT p context id

-- | Lifted 'Servant.serveWithContextT'.
serveWithContextT
    :: ( HasServer api context
       , ServerContext context
       , IOE :> es
       )
    => Proxy api
    -> Context context
    -> (forall a. m a -> Handler es a)
    -> ServerT api m
    -> Application es
serveWithContextT p context toHandler server req respond =
    withEffToIO SeqUnlift \unlift ->
        unlift $
            liftApplication
                ( Servant.serveWithContextT
                    p
                    context
                    ( Servant.Handler
                        . ExceptT
                        . unlift
                        . runErrorNoCallStack
                        . toHandler
                    )
                    server
                )
                req
                respond