servant/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | These are custom combinators for Servant.Server.UsingContextSpec.
--
-- (For writing your own combinators you need to import Internal modules, for
-- just *using* combinators that require a Context, you don't. This module is
-- separate from Servant.Server.UsingContextSpec to test that the module imports
-- work out this way.)
module Servant.Server.UsingContextSpec.TestCombinators where

import           GHC.TypeLits

import           Servant

data ExtractFromContext

instance (HasContextEntry context String, HasServer subApi context) =>
  HasServer (ExtractFromContext :> subApi) context where

  type ServerT (ExtractFromContext :> subApi) m =
    String -> ServerT subApi m

  route Proxy context delayed =
    route subProxy context (fmap (inject context) delayed)
    where
      subProxy :: Proxy subApi
      subProxy = Proxy

      inject context f = f (getContextEntry context)

data InjectIntoContext

instance (HasServer subApi (String ': context)) =>
  HasServer (InjectIntoContext :> subApi) context where

  type ServerT (InjectIntoContext :> subApi) m =
    ServerT subApi m

  route Proxy context delayed =
    route subProxy newContext delayed
    where
      subProxy :: Proxy subApi
      subProxy = Proxy

      newContext = ("injected" :: String) :. context

data NamedContextWithBirdface (name :: Symbol) (subContext :: [*])

instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) =>
  HasServer (NamedContextWithBirdface name subContext :> subApi) context where

  type ServerT (NamedContextWithBirdface name subContext :> subApi) m =
    ServerT subApi m

  route Proxy context delayed =
    route subProxy subContext delayed
    where
      subProxy :: Proxy subApi
      subProxy = Proxy

      subContext :: Context subContext
      subContext = descendIntoNamedContext (Proxy :: Proxy name) context