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

Merge pull request #824 from phadej/hoist-server-docs

Browse source 
Update docs related to hoistServer
This commit is contained in:
Oleg Grenrus 2017-10-02 09:27:37 +03:00 committed by GitHub
commit 6e431d59f2
11 changed files with 160 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
cabal.project
View file

@ -1,6 +1,7 @@
packages: packages:
servant/ servant/
servant-client/ servant-client/
servant-client-core/
servant-docs/ servant-docs/
servant-foreign/ servant-foreign/
servant-server/ servant-server/

76
doc/tutorial/Server.lhs
View file

@ -18,6 +18,7 @@ need to have some language extensions and imports:
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -1057,75 +1058,71 @@ into something **servant** can understand?
If we have a function that gets us from an `m a` to an `n a`, for any `a`, what If we have a function that gets us from an `m a` to an `n a`, for any `a`, what
do we have? do we have?
``` haskell ignore ``` haskell
newtype m :~> n = NT { ($$) :: forall a. m a -> n a} type (~>) m n = forall a. m a -> n a
``` ```
For example: For example:
``` haskell ``` haskell
listToMaybeNT :: [] :~> Maybe listToMaybe' :: [] ~> Maybe
listToMaybeNT = NT listToMaybe -- from Data.Maybe listToMaybe' = listToMaybe -- from Data.Maybe
``` ```
(`NT` comes from "natural transformation", in case you're wondering.) Note that `servant` doesn't declare the `~>` type-alias, as the unfolded
variant isn't much longer to write, as we'll see shortly.
So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to
prepare is a function: prepare is a function:
``` haskell ignore ``` haskell ignore
readerToHandler :: Reader String :~> Handler readerToHandler :: Reader String a -> Handler a
``` ```
Let's start with `readerToHandler'`. We obviously have to run the `Reader` We obviously have to run the `Reader` computation by supplying it with a
computation by supplying it with a `String`, like `"hi"`. We get an `a` out `String`, like `"hi"`. We get an `a` out from that and can then just `return`
from that and can then just `return` it into `Handler`. We can then just wrap it into `Handler`.
that function with the `NT` constructor to make it have the fancier type.
``` haskell ``` haskell
readerToHandler' :: forall a. Reader String a -> Handler a readerToHandler :: Reader String a -> Handler a
readerToHandler' r = return (runReader r "hi") readerToHandler r = return (runReader r "hi")
readerToHandler :: Reader String :~> Handler
readerToHandler = NT readerToHandler'
``` ```
We can write some simple webservice with the handlers running in `Reader String`. We can write some simple webservice with the handlers running in `Reader String`.
``` haskell ``` haskell
type ReaderAPI = "a" :> Get '[JSON] Int type ReaderAPI = "a" :> Get '[JSON] Int
:<|> "b" :> Get '[JSON] String :<|> "b" :> ReqBody '[JSON] Double :> Get '[JSON] Bool
readerAPI :: Proxy ReaderAPI readerAPI :: Proxy ReaderAPI
readerAPI = Proxy readerAPI = Proxy
readerServerT :: ServerT ReaderAPI (Reader String) readerServerT :: ServerT ReaderAPI (Reader String)
readerServerT = a :<|> b readerServerT = a :<|> b where
a :: Reader String Int
where a :: Reader String Int
a = return 1797 a = return 1797
b :: Reader String String b :: Double -> Reader String Bool
b = ask b _ = asks (== "hi")
``` ```
We unfortunately can't use `readerServerT` as an argument of `serve`, because We unfortunately can't use `readerServerT` as an argument of `serve`, because
`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this. `serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this.
### Enter `enter` ### Welcome `hoistServer`
That's right. We have just written `readerToHandler`, which is exactly what we That's right. We have just written `readerToHandler`, which is exactly what we
would need to apply to all handlers to make the handlers have the would need to apply to all handlers to make the handlers have the
right type for `serve`. Being cumbersome to do by hand, we provide a function right type for `serve`. Being cumbersome to do by hand, we provide a function
`enter` which takes a natural transformation between two parametrized types `m` `hoistServer` which takes a natural transformation between two parametrized types `m`
and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`. and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`.
In our case, we can wrap up our little webservice by using `enter In our case, we can wrap up our little webservice by using
readerToHandler` on our handlers. `hoistServer readerAPI readerToHandler` on our handlers.
``` haskell ``` haskell
readerServer :: Server ReaderAPI readerServer :: Server ReaderAPI
readerServer = enter readerToHandler readerServerT readerServer = hoistServer readerAPI readerToHandler readerServerT
app4 :: Application app4 :: Application
app4 = serve readerAPI readerServer app4 = serve readerAPI readerServer
@ -1140,6 +1137,33 @@ $ curl http://localhost:8081/b
"hi" "hi"
``` ```
### An arrow is a reader too.
In previous versions of `servant` we had an `enter` to do what `hoistServer`
does now. `enter` had a ambitious design goals, but was problematic in practice.
One problematic situation was when the source monad was `(->) r`, yet it's
handy in practice, because `(->) r` is isomorphic to `Reader r`.
We can rewrite the previous example without `Reader`:
```haskell
funServerT :: ServerT ReaderAPI ((->) String)
funServerT = a :<|> b where
a :: String -> Int
a _ = 1797
-- unfortunately, we cannot make `String` the first argument.
b :: Double -> String -> Bool
b _ s = s == "hi"
funToHandler :: (String -> a) -> Handler a
funToHandler f = return (f "hi")
app5 :: Application
app5 = serve readerAPI (hoistServer readerAPI funToHandler funServerT)
```
## Conclusion ## Conclusion
You're now equipped to write webservices/web-applications using You're now equipped to write webservices/web-applications using

68
servant-server/src/Servant/Server.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
-- | This module lets you implement 'Server's for defined APIs. You'll -- | This module lets you implement 'Server's for defined APIs. You'll
@ -26,24 +27,10 @@ module Servant.Server
, layout , layout
, layoutWithContext , layoutWithContext
-- * Enter -- * Enter / hoisting server
-- $enterDoc , hoistServer
-- ** Basic functions and datatypes
, enter
, (:~>)(..)
-- ** `Nat` utilities
, liftNat
, runReaderTNat
, evalStateTLNat
, evalStateTSNat
, logWriterTLNat
, logWriterTSNat
-- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph> -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
, hoistNat
, embedNat
, squashNat
, generalizeNat
, tweakResponse , tweakResponse
-- * Context -- * Context
@ -106,12 +93,11 @@ module Servant.Server
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import Data.Text (Text) import Data.Text (Text)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Utils.Enter
-- * Implementing Servers -- * Implementing Servers
@ -145,6 +131,30 @@ serveWithContext :: (HasServer api context)
serveWithContext p context server = serveWithContext p context server =
toApplication (runRouter (route p context (emptyDelayed (Route 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 -- | The function 'layout' produces a textual description of the internal
-- router layout for debugging purposes. Note that the router layout is -- router layout for debugging purposes. Note that the router layout is
-- determined just by the API, not by the handlers. -- determined just by the API, not by the handlers.
@ -205,28 +215,6 @@ layoutWithContext :: (HasServer api context)
layoutWithContext p context = layoutWithContext p context =
routerLayout (route p context (emptyDelayed (FailFatal err501))) 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 -- $setup
-- >>> :set -XDataKinds -- >>> :set -XDataKinds
-- >>> :set -XTypeOperators -- >>> :set -XTypeOperators

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

@ -57,7 +57,7 @@ instance ( HasServer api context
type ServerT (AuthProtect tag :> api) m = type ServerT (AuthProtect tag :> api) m =
AuthServerData (AuthProtect tag) -> ServerT api m AuthServerData (AuthProtect tag) -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)

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

@ -86,7 +86,7 @@ class HasServer api context where
-> Delayed env (Server api) -> Delayed env (Server api)
-> Router env -> Router env
hoistServer hoistServerWithContext
:: Proxy api :: Proxy api
-> Proxy context -> Proxy context
-> (forall x. m x -> n x) -> (forall x. m x -> n x)
@ -118,9 +118,9 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
pb = Proxy :: Proxy b pb = Proxy :: Proxy b
-- | This is better than 'enter', as it's tailor made for 'HasServer'. -- | This is better than 'enter', as it's tailor made for 'HasServer'.
hoistServer _ pc nt (a :<|> b) = hoistServerWithContext _ pc nt (a :<|> b) =
hoistServer (Proxy :: Proxy a) pc nt a :<|> hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|>
hoistServer (Proxy :: Proxy b) pc nt b hoistServerWithContext (Proxy :: Proxy b) pc nt b
-- | If you use 'Capture' in one of the endpoints for your API, -- | If you use 'Capture' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -145,7 +145,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
type ServerT (Capture capture a :> api) m = type ServerT (Capture capture a :> api) m =
a -> ServerT api m a -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context d = route Proxy context d =
CaptureRouter $ CaptureRouter $
@ -179,7 +179,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
type ServerT (CaptureAll capture a :> api) m = type ServerT (CaptureAll capture a :> api) m =
[a] -> ServerT api m [a] -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context d = route Proxy context d =
CaptureAllRouter $ CaptureAllRouter $
@ -258,7 +258,7 @@ instance OVERLAPPABLE_
) => HasServer (Verb method status ctypes a) context where ) => HasServer (Verb method status ctypes a) context where
type ServerT (Verb method status ctypes a) m = m a type ServerT (Verb method status ctypes a) m = m a
hoistServer _ _ nt s = nt s 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) where method = reflectMethod (Proxy :: Proxy method)
@ -270,7 +270,7 @@ instance OVERLAPPING_
) => HasServer (Verb method status ctypes (Headers h a)) context where ) => HasServer (Verb method status ctypes (Headers h a)) context where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
hoistServer _ _ nt s = nt s hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
@ -302,7 +302,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
type ServerT (Header sym a :> api) m = type ServerT (Header sym a :> api) m =
Maybe a -> ServerT api m Maybe a -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route (Proxy :: Proxy api) context $ route Proxy context subserver = route (Proxy :: Proxy api) context $
subserver `addHeaderCheck` withRequest headerCheck subserver `addHeaderCheck` withRequest headerCheck
@ -347,7 +347,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
type ServerT (QueryParam sym a :> api) m = type ServerT (QueryParam sym a :> api) m =
Maybe a -> ServerT api m Maybe a -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route Proxy context subserver =
let querytext req = parseQueryText $ rawQueryString req let querytext req = parseQueryText $ rawQueryString req
@ -394,7 +394,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
type ServerT (QueryParams sym a :> api) m = type ServerT (QueryParams sym a :> api) m =
[a] -> ServerT api m [a] -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route (Proxy :: Proxy api) context $ route Proxy context subserver = route (Proxy :: Proxy api) context $
subserver `addParameterCheck` withRequest paramsCheck subserver `addParameterCheck` withRequest paramsCheck
@ -436,7 +436,7 @@ instance (KnownSymbol sym, HasServer api context)
type ServerT (QueryFlag sym :> api) m = type ServerT (QueryFlag sym :> api) m =
Bool -> ServerT api m Bool -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r let querytext r = parseQueryText $ rawQueryString r
@ -461,7 +461,7 @@ instance HasServer Raw context where
type ServerT Raw m = Tagged m Application type ServerT Raw m = Tagged m Application
hoistServer _ _ _ = retag hoistServerWithContext _ _ _ = retag
route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
-- note: a Raw application doesn't register any cleanup -- note: a Raw application doesn't register any cleanup
@ -502,7 +502,7 @@ instance ( AllCTUnrender list a, HasServer api context
type ServerT (ReqBody list a :> api) m = type ServerT (ReqBody list a :> api) m =
a -> ServerT api m a -> ServerT api m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver route Proxy context subserver
= route (Proxy :: Proxy api) context $ = route (Proxy :: Proxy api) context $
@ -538,14 +538,14 @@ instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) co
(cs (symbolVal proxyPath)) (cs (symbolVal proxyPath))
(route (Proxy :: Proxy api) context subserver) (route (Proxy :: Proxy api) context subserver)
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
instance HasServer api context => HasServer (RemoteHost :> api) context where instance HasServer api context => HasServer (RemoteHost :> api) context where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy context subserver = route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver remoteHost) route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
instance HasServer api context => HasServer (IsSecure :> api) context where instance HasServer api context => HasServer (IsSecure :> api) context where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
@ -554,35 +554,35 @@ instance HasServer api context => HasServer (IsSecure :> api) context where
route (Proxy :: Proxy api) context (passToServer subserver secure) route (Proxy :: Proxy api) context (passToServer subserver secure)
where secure req = if isSecure req then Secure else NotSecure where secure req = if isSecure req then Secure else NotSecure
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
instance HasServer api context => HasServer (Vault :> api) context where instance HasServer api context => HasServer (Vault :> api) context where
type ServerT (Vault :> api) m = Vault -> ServerT api m type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy context subserver = route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver vault) route (Proxy :: Proxy api) context (passToServer subserver vault)
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
instance HasServer api context => HasServer (HttpVersion :> api) context where instance HasServer api context => HasServer (HttpVersion :> api) context where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy context subserver = route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver httpVersion) route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
-- | Ignore @'Summary'@ in server handlers. -- | Ignore @'Summary'@ in server handlers.
instance HasServer api ctx => HasServer (Summary desc :> api) ctx where instance HasServer api ctx => HasServer (Summary desc :> api) ctx where
type ServerT (Summary desc :> api) m = ServerT api m type ServerT (Summary desc :> api) m = ServerT api m
route _ = route (Proxy :: Proxy api) route _ = route (Proxy :: Proxy api)
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
-- | Ignore @'Description'@ in server handlers. -- | Ignore @'Description'@ in server handlers.
instance HasServer api ctx => HasServer (Description desc :> api) ctx where instance HasServer api ctx => HasServer (Description desc :> api) ctx where
type ServerT (Description desc :> api) m = ServerT api m type ServerT (Description desc :> api) m = ServerT api m
route _ = route (Proxy :: Proxy api) route _ = route (Proxy :: Proxy api)
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
-- | Singleton type representing a server that serves an empty API. -- | Singleton type representing a server that serves an empty API.
data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
@ -602,7 +602,7 @@ instance HasServer EmptyAPI context where
route Proxy _ _ = StaticRouter mempty mempty route Proxy _ _ = StaticRouter mempty mempty
hoistServer _ _ _ = retag hoistServerWithContext _ _ _ = retag
-- | Basic Authentication -- | Basic Authentication
instance ( KnownSymbol realm instance ( KnownSymbol realm
@ -620,7 +620,7 @@ instance ( KnownSymbol realm
basicAuthContext = getContextEntry context basicAuthContext = getContextEntry context
authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
-- * helpers -- * helpers
@ -647,4 +647,4 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
subContext :: Context subContext subContext :: Context subContext
subContext = descendIntoNamedContext (Proxy :: Proxy name) context subContext = descendIntoNamedContext (Proxy :: Proxy name) context
hoistServer _ _ nt s = hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s

14
servant-server/test/Servant/ArbitraryMonadServerSpec.hs
View file

@ -3,7 +3,6 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Servant.ArbitraryMonadServerSpec where module Servant.ArbitraryMonadServerSpec where
import qualified Control.Category as C
import Control.Monad.Reader import Control.Monad.Reader
import Data.Functor.Identity import Data.Functor.Identity
import Data.Proxy import Data.Proxy
@ -28,23 +27,26 @@ type CombinedAPI = ReaderAPI :<|> IdentityAPI
readerAPI :: Proxy ReaderAPI readerAPI :: Proxy ReaderAPI
readerAPI = Proxy readerAPI = Proxy
identityAPI :: Proxy IdentityAPI
identityAPI = Proxy
combinedAPI :: Proxy CombinedAPI combinedAPI :: Proxy CombinedAPI
combinedAPI = Proxy combinedAPI = Proxy
readerServer' :: ServerT ReaderAPI (Reader String) readerServer' :: ServerT ReaderAPI (Reader String)
readerServer' = return 1797 :<|> ask readerServer' = return 1797 :<|> ask
fReader :: Reader String :~> Handler fReader :: Reader String a -> Handler a
fReader = generalizeNat C.. (runReaderTNat "hi") fReader x = return (runReader x "hi")
readerServer :: Server ReaderAPI readerServer :: Server ReaderAPI
readerServer = enter fReader readerServer' readerServer = hoistServer readerAPI fReader readerServer'
combinedReaderServer' :: ServerT CombinedAPI (Reader String) 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 :: Server CombinedAPI
combinedReaderServer = enter fReader combinedReaderServer' combinedReaderServer = hoistServer combinedAPI fReader combinedReaderServer'
enterSpec :: Spec enterSpec :: Spec
enterSpec = describe "Enter" $ do enterSpec = describe "Enter" $ do

38
servant-server/test/Servant/HoistSpec.hs Normal file
View file

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

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

@ -89,7 +89,7 @@ data Res (sym :: Symbol)
instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
hoistServer _ nc nt s = hoistServer (Proxy :: Proxy api) nc nt . s hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s
route Proxy ctx server = route (Proxy :: Proxy api) ctx $ route Proxy ctx server = route (Proxy :: Proxy api) ctx $
addBodyCheck server (return ()) check addBodyCheck server (return ()) check

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

@ -29,7 +29,7 @@ instance (HasContextEntry context String, HasServer subApi context) =>
type ServerT (ExtractFromContext :> subApi) m = type ServerT (ExtractFromContext :> subApi) m =
String -> ServerT subApi m String -> ServerT subApi m
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy subApi) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s
route Proxy context delayed = route Proxy context delayed =
route subProxy context (fmap inject delayed) route subProxy context (fmap inject delayed)
@ -47,8 +47,8 @@ instance (HasServer subApi (String ': context)) =>
type ServerT (InjectIntoContext :> subApi) m = type ServerT (InjectIntoContext :> subApi) m =
ServerT subApi m ServerT subApi m
hoistServer _ _ nt s = hoistServerWithContext _ _ nt s =
hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s
route Proxy context delayed = route Proxy context delayed =
route subProxy newContext delayed route subProxy newContext delayed
@ -66,8 +66,8 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
type ServerT (NamedContextWithBirdface name subContext :> subApi) m = type ServerT (NamedContextWithBirdface name subContext :> subApi) m =
ServerT subApi m ServerT subApi m
hoistServer _ _ nt s = hoistServerWithContext _ _ nt s =
hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
route Proxy context delayed = route Proxy context delayed =
route subProxy subContext delayed route subProxy subContext delayed

2
servant/src/Servant/Utils/Enter.hs
View file

@ -8,7 +8,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Servant.Utils.Enter ( module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (
module Servant.Utils.Enter, module Servant.Utils.Enter,
-- * natural-transformation re-exports -- * natural-transformation re-exports
(:~>)(..), (:~>)(..),

1
servant/test/Servant/Utils/EnterSpec.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Servant.Utils.EnterSpec where module Servant.Utils.EnterSpec where
import Test.Hspec (Spec) import Test.Hspec (Spec)