diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) +[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) + +0.12 +---- + +### Breaking changes + +* Added `hoistServer` member to the `HasServer` class, which is `HasServer` + specific `enter`. + ([#804](https://github.com/haskell-servant/servant/pull/804)) + 0.11 ---- diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.11.0.1 +version: 0.12 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -18,7 +18,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Servant Web +category: Servant, Web build-type: Custom cabal-version: >=1.10 tested-with: @@ -70,7 +70,7 @@ , mtl >= 2 && < 2.3 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.11.* + , servant == 0.12.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 @@ -122,6 +122,7 @@ Servant.Server.StreamingSpec Servant.Server.UsingContextSpec Servant.Server.UsingContextSpec.TestCombinators + Servant.HoistSpec Servant.ServerSpec Servant.Utils.StaticFilesSpec build-tool-depends: diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | This module lets you implement 'Server's for defined APIs. You'll @@ -26,24 +27,10 @@ , layout , layoutWithContext - -- * Enter - -- $enterDoc + -- * Enter / hoisting server + , hoistServer - -- ** Basic functions and datatypes - , enter - , (:~>)(..) - -- ** `Nat` utilities - , liftNat - , runReaderTNat - , evalStateTLNat - , evalStateTSNat - , logWriterTLNat - , logWriterTSNat -- ** Functions based on - , hoistNat - , embedNat - , squashNat - , generalizeNat , tweakResponse -- * Context @@ -106,12 +93,11 @@ ) where -import Data.Proxy (Proxy) +import Data.Proxy (Proxy (..)) import Data.Tagged (Tagged (..)) import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Utils.Enter -- * Implementing Servers @@ -145,6 +131,30 @@ serveWithContext p context server = toApplication (runRouter (route p context (emptyDelayed (Route server)))) +-- | Hoist server implementation. +-- +-- Sometimes our cherished `Handler` monad isn't quite the type you'd like for +-- your handlers. Maybe you want to thread some configuration in a @Reader@ +-- monad. Or have your types ensure that your handlers don't do any IO. Use +-- `hoistServer` (a successor of now deprecated @enter@). +-- +-- With `hoistServer`, you can provide a function, +-- to convert any number of endpoints from one type constructor to +-- another. For example +-- +-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged. +-- +-- >>> import Control.Monad.Reader +-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI +-- >>> let readerApi = Proxy :: Proxy ReaderAPI +-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String) +-- >>> let nt x = return (runReader x "hi") +-- >>> let mainServer = hoistServer readerApi nt readerServer :: Server ReaderAPI +-- +hoistServer :: (HasServer api '[]) => Proxy api + -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n +hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[]) + -- | The function 'layout' produces a textual description of the internal -- router layout for debugging purposes. Note that the router layout is -- determined just by the API, not by the handlers. @@ -204,28 +214,6 @@ => Proxy api -> Context context -> Text layoutWithContext p context = routerLayout (route p context (emptyDelayed (FailFatal err501))) - --- Documentation - --- $enterDoc --- Sometimes our cherished `ExceptT` monad isn't quite the type you'd like for --- your handlers. Maybe you want to thread some configuration in a @Reader@ --- monad. Or have your types ensure that your handlers don't do any IO. Enter --- `enter`. --- --- With `enter`, you can provide a function, wrapped in the `(:~>)` / `NT` --- newtype, to convert any number of endpoints from one type constructor to --- another. For example --- --- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged. --- --- >>> import Control.Monad.Reader --- >>> import qualified Control.Category as C --- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI --- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String) --- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler --- >>> let mainServer = enter nt readerServer :: Server ReaderAPI --- -- $setup -- >>> :set -XDataKinds diff --git a/src/Servant/Server/Experimental/Auth.hs b/src/Servant/Server/Experimental/Auth.hs --- a/src/Servant/Server/Experimental/Auth.hs +++ b/src/Servant/Server/Experimental/Auth.hs @@ -21,9 +21,8 @@ import Servant ((:>)) import Servant.API.Experimental.Auth import Servant.Server.Internal (HasContextEntry, - HasServer, ServerT, - getContextEntry, - route) + HasServer (..), + getContextEntry) import Servant.Server.Internal.RoutingApplication (addAuthCheck, delayedFailFatal, DelayedIO, @@ -57,6 +56,8 @@ type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -8,7 +8,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -33,14 +35,14 @@ import Data.Either (partitionEithers) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) -import Data.Tagged (Tagged(..), untag) +import Data.Tagged (Tagged(..), retag, untag) import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) -import Network.Wai (Application, Request, Response, +import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, rawQueryString, remoteHost, @@ -58,7 +60,8 @@ IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault, - WithNamedContext) + WithNamedContext, + Description, Summary) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -84,6 +87,13 @@ -> Delayed env (Server api) -> Router env + hoistServerWithContext + :: Proxy api + -> Proxy context + -> (forall x. m x -> n x) + -> ServerT api m + -> ServerT api n + type Server api = ServerT api Handler -- * Instances @@ -108,6 +118,11 @@ where pa = Proxy :: Proxy a pb = Proxy :: Proxy b + -- | This is better than 'enter', as it's tailor made for 'HasServer'. + hoistServerWithContext _ pc nt (a :<|> b) = + hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|> + hoistServerWithContext (Proxy :: Proxy b) pc nt b + -- | If you use 'Capture' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by the 'Capture'. @@ -131,6 +146,8 @@ type ServerT (Capture capture a :> api) m = a -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context d = CaptureRouter $ route (Proxy :: Proxy api) @@ -157,15 +174,17 @@ -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) - => HasServer (CaptureAll capture a :> sublayout) context where +instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) + => HasServer (CaptureAll capture a :> api) context where - type ServerT (CaptureAll capture a :> sublayout) m = - [a] -> ServerT sublayout m + type ServerT (CaptureAll capture a :> api) m = + [a] -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context d = CaptureAllRouter $ - route (Proxy :: Proxy sublayout) + route (Proxy :: Proxy api) context (addCapture d $ \ txts -> case parseUrlPieces txts of Left _ -> delayedFail err400 @@ -179,16 +198,6 @@ allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method -processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method - -> Maybe [(HeaderName, B.ByteString)] - -> Request -> RouteResult Response -processMethodRouter handleA status method headers request = case handleA of - Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does - Just (contentT, body) -> Route $ responseLBS status hdrs bdy - where - bdy = if allowedMethodHead method request then "" else body - hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) - methodCheck :: Method -> Request -> DelayedIO () methodCheck method request | allowedMethod method request = return () @@ -207,41 +216,32 @@ | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) - => Method -> Proxy ctypes -> Status - -> Delayed env (Handler a) + => (b -> ([(HeaderName, B.ByteString)], a)) + -> Method -> Proxy ctypes -> Status + -> Delayed env (Handler b) -> Router env -methodRouter method proxy status action = leafRouter route' +methodRouter splitHeaders method proxy status action = leafRouter route' where route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do - let handleA = handleAcceptH proxy (AcceptHeader accH) output - processMethodRouter handleA status method Nothing request - -methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) - => Method -> Proxy ctypes -> Status - -> Delayed env (Handler (Headers h v)) - -> Router env -methodRouterHeaders method proxy status action = leafRouter route' - where - route' env request respond = - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH - ) env request respond $ \ output -> do - let headers = getHeaders output - handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) - processMethodRouter handleA status method (Just headers) request + let (headers, b) = splitHeaders output + case handleAcceptH proxy (AcceptHeader accH) b of + Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does + Just (contentT, body) -> + let bdy = if allowedMethodHead method request then "" else body + in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a + hoistServerWithContext _ _ nt s = nt s - route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status + route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -251,8 +251,9 @@ ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) + hoistServerWithContext _ _ nt s = nt s - route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status + route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -282,6 +283,8 @@ type ServerT (Header sym a :> api) m = Maybe a -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where @@ -325,6 +328,8 @@ type ServerT (QueryParam sym a :> api) m = Maybe a -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = let querytext req = parseQueryText $ rawQueryString req parseParam req = @@ -370,6 +375,8 @@ type ServerT (QueryParams sym a :> api) m = [a] -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where @@ -410,6 +417,8 @@ type ServerT (QueryFlag sym :> api) m = Bool -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = let querytext r = parseQueryText $ rawQueryString r param r = case lookup paramname (querytext r) of @@ -433,6 +442,8 @@ type ServerT Raw m = Tagged m Application + hoistServerWithContext _ _ _ = retag + route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do -- note: a Raw application doesn't register any cleanup -- but for the sake of consistency, we nonetheless run @@ -472,6 +483,8 @@ type ServerT (ReqBody list a :> api) m = a -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck @@ -506,33 +519,52 @@ (cs (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver remoteHost) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver secure) - where secure req = if isSecure req then Secure else NotSecure + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver vault) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver httpVersion) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s +-- | Ignore @'Summary'@ in server handlers. +instance HasServer api ctx => HasServer (Summary desc :> api) ctx where + type ServerT (Summary desc :> api) m = ServerT api m + + route _ = route (Proxy :: Proxy api) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s + +-- | Ignore @'Description'@ in server handlers. +instance HasServer api ctx => HasServer (Description desc :> api) ctx where + type ServerT (Description desc :> api) m = ServerT api m + + route _ = route (Proxy :: Proxy api) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s + -- | Singleton type representing a server that serves an empty API. data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) @@ -551,6 +583,8 @@ route Proxy _ _ = StaticRouter mempty mempty + hoistServerWithContext _ _ _ = retag + -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context @@ -567,6 +601,8 @@ basicAuthContext = getContextEntry context authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + -- * helpers ct_wildcard :: B.ByteString @@ -591,3 +627,5 @@ subContext :: Context subContext subContext = descendIntoNamedContext (Proxy :: Proxy name) context + + hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s diff --git a/test/Servant/ArbitraryMonadServerSpec.hs b/test/Servant/ArbitraryMonadServerSpec.hs --- a/test/Servant/ArbitraryMonadServerSpec.hs +++ b/test/Servant/ArbitraryMonadServerSpec.hs @@ -3,9 +3,8 @@ {-# LANGUAGE TypeOperators #-} module Servant.ArbitraryMonadServerSpec where -import qualified Control.Category as C import Control.Monad.Reader -import Data.Functor.Identity +import Data.Functor.Identity import Data.Proxy import Servant.API import Servant.Server @@ -28,23 +27,26 @@ readerAPI :: Proxy ReaderAPI readerAPI = Proxy +identityAPI :: Proxy IdentityAPI +identityAPI = Proxy + combinedAPI :: Proxy CombinedAPI combinedAPI = Proxy readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask -fReader :: Reader String :~> Handler -fReader = generalizeNat C.. (runReaderTNat "hi") +fReader :: Reader String a -> Handler a +fReader x = return (runReader x "hi") readerServer :: Server ReaderAPI -readerServer = enter fReader readerServer' +readerServer = hoistServer readerAPI fReader readerServer' combinedReaderServer' :: ServerT CombinedAPI (Reader String) -combinedReaderServer' = readerServer' :<|> enter (generalizeNat :: Identity :~> Reader String) (return True) +combinedReaderServer' = readerServer' :<|> hoistServer identityAPI (return . runIdentity) (return True) combinedReaderServer :: Server CombinedAPI -combinedReaderServer = enter fReader combinedReaderServer' +combinedReaderServer = hoistServer combinedAPI fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do diff --git a/test/Servant/HoistSpec.hs b/test/Servant/HoistSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/HoistSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module Servant.HoistSpec where + +import Test.Hspec (Spec) + +import Servant + +------------------------------------------------------------------------------- +-- https://github.com/haskell-servant/servant/issues/734 +------------------------------------------------------------------------------- + +-- This didn't fail if executed in GHCi; cannot have as a doctest. + +newtype App a = App a + +type API = Get '[JSON] Int + :<|> ReqBody '[JSON] String :> Get '[JSON] Bool + +api :: Proxy API +api = Proxy + +server :: App Int :<|> (String -> App Bool) +server = undefined + +-- Natural transformation still seems to need an explicit type. +f :: App a -> App a +f = id + +server' :: App Int :<|> (String -> App Bool) +server' = hoistServer api f server + +------------------------------------------------------------------------------- +-- Spec +------------------------------------------------------------------------------- + +spec :: Spec +spec = return () diff --git a/test/Servant/Server/Internal/ContextSpec.hs b/test/Servant/Server/Internal/ContextSpec.hs --- a/test/Servant/Server/Internal/ContextSpec.hs +++ b/test/Servant/Server/Internal/ContextSpec.hs @@ -36,8 +36,8 @@ show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" it "works with operators" $ do - let cxt = ((1 :: Integer) :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) - show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)" + let cxt = (1 :: Integer) :. 'a' :. EmptyContext :<|> 'b' :. True :. EmptyContext + show cxt `shouldBe` "1 :. 'a' :. EmptyContext :<|> 'b' :. True :. EmptyContext" describe "descendIntoNamedContext" $ do let cxt :: Context [Char, NamedContext "sub" '[Char]] diff --git a/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/test/Servant/Server/Internal/RoutingApplicationSpec.hs --- a/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -88,6 +88,9 @@ instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m + + hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s + route Proxy ctx server = route (Proxy :: Proxy api) ctx $ addBodyCheck server (return ()) check where diff --git a/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/test/Servant/Server/UsingContextSpec/TestCombinators.hs --- a/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -29,6 +29,8 @@ type ServerT (ExtractFromContext :> subApi) m = String -> ServerT subApi m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s + route Proxy context delayed = route subProxy context (fmap inject delayed) where @@ -45,6 +47,9 @@ type ServerT (InjectIntoContext :> subApi) m = ServerT subApi m + hoistServerWithContext _ _ nt s = + hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s + route Proxy context delayed = route subProxy newContext delayed where @@ -60,6 +65,9 @@ type ServerT (NamedContextWithBirdface name subContext :> subApi) m = ServerT subApi m + + hoistServerWithContext _ _ nt s = + hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s route Proxy context delayed = route subProxy subContext delayed diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -10,6 +10,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif module Servant.ServerSpec where