From 24af338dea8b5230888ead8115bf7373baacb0fb Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 8 Sep 2017 19:21:16 +0300 Subject: [PATCH 1/2] Add hoistServer to HasServer --- .gitignore | 1 + servant-server/CHANGELOG.md | 9 + .../src/Servant/Server/Experimental/Auth.hs | 7 +- servant-server/src/Servant/Server/Internal.hs | 58 +++++- .../Server/Internal/RoutingApplicationSpec.hs | 3 + .../UsingContextSpec/TestCombinators.hs | 8 + stack-ghc-8.2.1.yaml | 187 +----------------- 7 files changed, 77 insertions(+), 196 deletions(-) diff --git a/.gitignore b/.gitignore index a66f2a0e..16abfc41 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ **/*/dist dist-newstyle +.ghc.environment.* /bin /lib /share diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 5b55cb7e..a2a9a750 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,12 @@ +Next +---- + +### 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/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index a6dfd52f..10713e35 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -21,9 +21,8 @@ import Network.Wai (Request) 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, @@ -58,6 +57,8 @@ instance ( HasServer api context type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) where diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index b6656fb8..cc81e711 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -8,6 +8,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -33,7 +34,7 @@ import Data.Maybe (fromMaybe, mapMaybe) 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, @@ -85,6 +86,13 @@ class HasServer api context where -> Delayed env (Server api) -> Router env + hoistServer + :: Proxy api + -> Proxy context + -> (forall x. m x -> n x) + -> ServerT api m + -> ServerT api n + type Server api = ServerT api Handler -- * Instances @@ -109,6 +117,11 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont where pa = Proxy :: Proxy a pb = Proxy :: Proxy b + -- | This is better than 'enter', as it's taylor made for 'HasServer'. + hoistServer _ pc nt (a :<|> b) = + hoistServer (Proxy :: Proxy a) pc nt a :<|> + hoistServer (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'. @@ -132,6 +145,8 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) type ServerT (Capture capture a :> api) m = a -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context d = CaptureRouter $ route (Proxy :: Proxy api) @@ -158,15 +173,17 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) -- > 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 + + hoistServer _ pc nt s = hoistServer (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 @@ -241,6 +258,7 @@ instance OVERLAPPABLE_ ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a + hoistServer _ _ nt s = nt s route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -252,6 +270,7 @@ instance OVERLAPPING_ ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) + hoistServer _ _ nt s = nt s route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -283,6 +302,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) type ServerT (Header sym a :> api) m = Maybe a -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where @@ -326,6 +347,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) type ServerT (QueryParam sym a :> api) m = Maybe a -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = let querytext req = parseQueryText $ rawQueryString req parseParam req = @@ -371,6 +394,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) type ServerT (QueryParams sym a :> api) m = [a] -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where @@ -411,6 +436,8 @@ instance (KnownSymbol sym, HasServer api context) type ServerT (QueryFlag sym :> api) m = Bool -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = let querytext r = parseQueryText $ rawQueryString r param r = case lookup paramname (querytext r) of @@ -434,6 +461,8 @@ instance HasServer Raw context where type ServerT Raw m = Tagged m Application + hoistServer _ _ _ = 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 @@ -473,6 +502,8 @@ instance ( AllCTUnrender list a, HasServer api context type ServerT (ReqBody list a :> api) m = a -> ServerT api m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck @@ -507,44 +538,51 @@ instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) co (cs (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path + hoistServer _ pc nt s = hoistServer (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) + hoistServer _ pc nt s = hoistServer (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 + hoistServer _ pc nt s = hoistServer (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) + hoistServer _ pc nt s = hoistServer (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) + hoistServer _ pc nt s = hoistServer (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) + hoistServer _ pc nt s = hoistServer (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) + hoistServer _ pc nt s = hoistServer (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) @@ -564,6 +602,8 @@ instance HasServer EmptyAPI context where route Proxy _ _ = StaticRouter mempty mempty + hoistServer _ _ _ = retag + -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context @@ -580,6 +620,8 @@ instance ( KnownSymbol realm basicAuthContext = getContextEntry context authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s + -- * helpers ct_wildcard :: B.ByteString @@ -604,3 +646,5 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA subContext :: Context subContext subContext = descendIntoNamedContext (Proxy :: Proxy name) context + + hoistServer _ _ nt s = hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 30710db0..aad08b30 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -88,6 +88,9 @@ data Res (sym :: Symbol) instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m + + hoistServer _ nc nt s = hoistServer (Proxy :: Proxy api) nc nt . s + route Proxy ctx server = route (Proxy :: Proxy api) ctx $ addBodyCheck server (return ()) check where diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs index 0a718788..65fb4577 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -29,6 +29,8 @@ instance (HasContextEntry context String, HasServer subApi context) => type ServerT (ExtractFromContext :> subApi) m = String -> ServerT subApi m + hoistServer _ pc nt s = hoistServer (Proxy :: Proxy subApi) pc nt . s + route Proxy context delayed = route subProxy context (fmap inject delayed) where @@ -45,6 +47,9 @@ instance (HasServer subApi (String ': context)) => type ServerT (InjectIntoContext :> subApi) m = ServerT subApi m + hoistServer _ _ nt s = + hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s + route Proxy context delayed = route subProxy newContext delayed where @@ -61,6 +66,9 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA type ServerT (NamedContextWithBirdface name subContext :> subApi) m = ServerT subApi m + hoistServer _ _ nt s = + hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s + route Proxy context delayed = route subProxy subContext delayed where diff --git a/stack-ghc-8.2.1.yaml b/stack-ghc-8.2.1.yaml index 78d7d383..c1a64f37 100644 --- a/stack-ghc-8.2.1.yaml +++ b/stack-ghc-8.2.1.yaml @@ -1,192 +1,7 @@ -resolver: ghc-8.2.0.20170507 +resolver: nightly-2017-09-01 packages: - servant-client/ - servant-docs/ - servant-foreign/ - servant-server/ - servant/ -extra-deps: -- abstract-deque-0.3 -- abstract-par-0.3.3 -- adjunctions-4.3 -- aeson-1.2.0.0 -- aeson-compat-0.3.7 -- aeson-pretty-0.8.4 -- ansi-terminal-0.6.3.1 -- ansi-wl-pprint-0.6.7.3 -- appar-0.1.4 -- asn1-encoding-0.9.5 -- asn1-parse-0.9.4 -- asn1-types-0.3.2 -- async-2.1.1.1 -- attoparsec-0.13.1.0 -- attoparsec-iso8601-1.0.0.0 -- auto-update-0.1.4 -- base-compat-0.9.3 -- base-orphans-0.6 -- base64-bytestring-1.0.0.1 -- bifunctors-5.4.2 -- blaze-builder-0.4.0.2 -- blaze-html-0.9.0.1 -- blaze-markup-0.8.0.0 -- byteable-0.1.1 -- byteorder-1.0.4 -- bytestring-builder-0.10.8.1.0 -- cabal-doctest-1.0.2 -- call-stack-0.1.0 -- case-insensitive-1.2.0.10 -- cassava-0.4.5.1 -- cereal-0.5.4.0 -- clock-0.7.2 -- cmdargs-0.10.17 -- code-page-0.1.3 -- comonad-5.0.1 -- connection-0.2.8 -- contravariant-1.4 -- control-monad-omega-0.3.1 -- cookie-0.4.2.1 -- criterion-1.2.0.0 -- cryptonite-0.23 -- data-default-class-0.1.2.0 -- deepseq-generics-0.2.0.0 -- distributive-0.5.2 -- dlist-0.8.0.2 -- doctest-0.11.2 -- easy-file-0.2.1 -- erf-2.0.0.0 -- exceptions-0.8.3 -- fail-4.9.0.0 -- fast-logger-2.4.10 -- file-embed-0.0.10 -- filemanip-0.3.6.3 -- foundation-0.0.9 -- free-4.12.4 -- generics-sop-0.3.0.0 -- ghc-paths-0.1.0.9 -- Glob-0.8.0 -- hashable-1.2.6.0 -- hex-0.1.2 -- hourglass-0.2.10 -- hspec-2.4.3 -- hspec-core-2.4.3 -- hspec-discover-2.4.3 -- hspec-expectations-0.8.2 -- hspec-wai-0.8.0 -- http-api-data-0.3.7.1 -- http-client-0.5.7.0 -- http-client-tls-0.3.5 -- http-date-0.0.6.1 -- http-media-0.6.4 -- http-types-0.9.1 -- http2-1.6.3 -- HUnit-1.6.0.0 -- integer-logarithms-1.0.1 -- iproute-1.7.1 -- js-flot-0.8.3 -- js-jquery-3.2.1 -- kan-extensions-5.0.2 -- lens-4.15.2 -- lifted-base-0.2.3.11 -- math-functions-0.2.1.0 -- memory-0.14.5 -- microstache-1 -- mime-types-0.1.0.7 -- mmorph-1.1.0 -- monad-control-1.0.1.0 -- monad-par-0.3.4.8 -- monad-par-extras-0.3.3 -- mtl-2.2.1 -- mwc-random-0.13.6.0 -- nats-1.1.1 -- natural-transformation-0.4 -- network-2.6.3.2 -- network-uri-2.6.1.0 -- old-locale-1.0.0.7 -- old-time-1.1.0.3 -- optparse-applicative-0.13.2.0 -- parallel-3.2.1.1 -- parsec-3.1.11 -- pem-0.2.2 -- prelude-extras-0.4.0.3 -- primitive-0.6.2.0 -- profunctors-5.2 -- psqueues-0.2.2.3 -- QuickCheck-2.9.2 -- quickcheck-instances-0.3.13 -- quickcheck-io-0.1.4 -- random-1.1 -- reflection-2.1.2 -- regex-base-0.93.2 -- regex-tdfa-1.2.2 -- resourcet-1.1.9 -- safe-0.3.14 -- scientific-0.3.4.13 -- semigroupoids-5.2 -- semigroups-0.18.3 -- setenv-0.1.1.3 -- should-not-typecheck-2.1.0 -- simple-sendfile-0.2.25 -- socks-0.5.5 -- split-0.2.3.2 -- StateVar-1.1.0.4 -- statistics-0.14.0.2 -- stm-2.4.4.1 -- streaming-commons-0.1.18 -- string-conversions-0.4.0.1 -- stringsearch-0.3.6.6 -- syb-0.7 -- system-filepath-0.4.13.4 -- tagged-0.8.5 -- tasty-0.11.2.1 -- tasty-hunit-0.9.2 -- tasty-quickcheck-0.8.4 -- temporary-1.2.0.4 -- text-1.2.2.2 -- tf-random-0.5 -- th-lift-0.7.7 -- th-lift-instances-0.1.11 -- time-locale-compat-0.1.1.3 -- tls-1.3.10 -- transformers-base-0.4.4 -- transformers-compat-0.5.1.4 -- unbounded-delays-0.1.1.0 -- unix-compat-0.4.3.1 -- unix-time-0.3.7 -- unordered-containers-0.2.8.0 -- uri-bytestring-0.2.3.3 -- url-2.1.3 -- utf8-string-1.0.1.1 -- uuid-types-1.0.3 -- vault-0.3.0.7 -- vector-0.12.0.1 -- vector-algorithms-0.7.0.1 -- vector-binary-instances-0.2.3.5 -- vector-th-unbox-0.2.1.6 -- void-0.7.2 -- wai-3.2.1.1 -- wai-app-static-3.1.6.1 -- wai-extra-3.0.19.1 -- wai-logger-2.3.0 -- warp-3.2.12 -- word8-0.1.2 -- x509-1.6.5 -- x509-store-1.6.2 -- x509-system-1.6.4 -- x509-validation-1.6.5 -- zlib-0.6.1.2 -flags: - time-locale-compat: - old-locale: false -compiler: ghc-8.2.0.20170507 -compiler-check: match-exact -setup-info: - ghc: - linux64: - 8.2.0.20170507: - url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-deb8-linux.tar.xz - macosx: - 8.2.0.20170507: - url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-apple-darwin.tar.xz - windows64: - 8.2.0.20170507: - url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-unknown-mingw32.tar.xz From 822b853590974a8812d45dead7f06699f96d2d5f Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 14 Sep 2017 13:57:57 +0300 Subject: [PATCH 2/2] Ignore -Wno-missing-home-modules in travis --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 32c4b6ce..7ee29bef 100644 --- a/.travis.yml +++ b/.travis.yml @@ -23,7 +23,8 @@ install: - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) script: - - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi + - if [ "$STACK_YAML" = "stack-ghc-8.2.1.yaml" ]; then HOMEMODULES="--ghc-options=-Wno-missing-home-modules"; fi + - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test $HOMEMODULES --ghc-options=-Werror --no-terminal ; fi cache: directories: