eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add hoistServer to HasServer

Browse source
This commit is contained in:
Oleg Grenrus 2017-09-08 19:21:16 +03:00
parent 50be3a263b
commit 24af338dea
7 changed files with 77 additions and 196 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -1,5 +1,6 @@
**/*/dist
dist-newstyle
.ghc.environment.*
/bin
/lib
/share

9
servant-server/CHANGELOG.md
View file

@ -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
----

7
servant-server/src/Servant/Server/Experimental/Auth.hs
View file

@ -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

58
servant-server/src/Servant/Server/Internal.hs
View file

@ -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

3
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
View file

@ -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

8
servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs
View file

@ -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

187
stack-ghc-8.2.1.yaml
View file

@ -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