Update docs related to hoistServer
This commit is contained in:
parent
4a6edd7864
commit
15cc4f55dd
11 changed files with 160 additions and 106 deletions
|
@ -1,6 +1,7 @@
|
|||
packages:
|
||||
servant/
|
||||
servant-client/
|
||||
servant-client-core/
|
||||
servant-docs/
|
||||
servant-foreign/
|
||||
servant-server/
|
||||
|
|
|
@ -18,6 +18,7 @@ need to have some language extensions and imports:
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# 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
|
||||
do we have?
|
||||
|
||||
``` haskell ignore
|
||||
newtype m :~> n = NT { ($$) :: forall a. m a -> n a}
|
||||
``` haskell
|
||||
type (~>) m n = forall a. m a -> n a
|
||||
```
|
||||
|
||||
For example:
|
||||
|
||||
``` haskell
|
||||
listToMaybeNT :: [] :~> Maybe
|
||||
listToMaybeNT = NT listToMaybe -- from Data.Maybe
|
||||
listToMaybe' :: [] ~> 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
|
||||
prepare is a function:
|
||||
|
||||
``` haskell ignore
|
||||
readerToHandler :: Reader String :~> Handler
|
||||
readerToHandler :: Reader String a -> Handler a
|
||||
```
|
||||
|
||||
Let's start with `readerToHandler'`. We obviously have to run the `Reader`
|
||||
computation by supplying it with a `String`, like `"hi"`. We get an `a` out
|
||||
from that and can then just `return` it into `Handler`. We can then just wrap
|
||||
that function with the `NT` constructor to make it have the fancier type.
|
||||
We obviously have to run the `Reader` computation by supplying it with a
|
||||
`String`, like `"hi"`. We get an `a` out from that and can then just `return`
|
||||
it into `Handler`.
|
||||
|
||||
``` haskell
|
||||
readerToHandler' :: forall a. Reader String a -> Handler a
|
||||
readerToHandler' r = return (runReader r "hi")
|
||||
|
||||
readerToHandler :: Reader String :~> Handler
|
||||
readerToHandler = NT readerToHandler'
|
||||
readerToHandler :: Reader String a -> Handler a
|
||||
readerToHandler r = return (runReader r "hi")
|
||||
```
|
||||
|
||||
We can write some simple webservice with the handlers running in `Reader String`.
|
||||
|
||||
``` haskell
|
||||
type ReaderAPI = "a" :> Get '[JSON] Int
|
||||
:<|> "b" :> Get '[JSON] String
|
||||
:<|> "b" :> ReqBody '[JSON] Double :> Get '[JSON] Bool
|
||||
|
||||
readerAPI :: Proxy ReaderAPI
|
||||
readerAPI = Proxy
|
||||
|
||||
readerServerT :: ServerT ReaderAPI (Reader String)
|
||||
readerServerT = a :<|> b
|
||||
readerServerT = a :<|> b where
|
||||
a :: Reader String Int
|
||||
a = return 1797
|
||||
|
||||
where a :: Reader String Int
|
||||
a = return 1797
|
||||
|
||||
b :: Reader String String
|
||||
b = ask
|
||||
b :: Double -> Reader String Bool
|
||||
b _ = asks (== "hi")
|
||||
```
|
||||
|
||||
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.
|
||||
|
||||
### Enter `enter`
|
||||
### Welcome `hoistServer`
|
||||
|
||||
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
|
||||
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`.
|
||||
|
||||
In our case, we can wrap up our little webservice by using `enter
|
||||
readerToHandler` on our handlers.
|
||||
In our case, we can wrap up our little webservice by using
|
||||
`hoistServer readerAPI readerToHandler` on our handlers.
|
||||
|
||||
``` haskell
|
||||
readerServer :: Server ReaderAPI
|
||||
readerServer = enter readerToHandler readerServerT
|
||||
readerServer = hoistServer readerAPI readerToHandler readerServerT
|
||||
|
||||
app4 :: Application
|
||||
app4 = serve readerAPI readerServer
|
||||
|
@ -1140,6 +1137,33 @@ $ curl http://localhost:8081/b
|
|||
"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
|
||||
|
||||
You're now equipped to write webservices/web-applications using
|
||||
|
|
|
@ -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 @@ module Servant.Server
|
|||
, layout
|
||||
, layoutWithContext
|
||||
|
||||
-- * Enter
|
||||
-- $enterDoc
|
||||
-- * Enter / hoisting server
|
||||
, hoistServer
|
||||
|
||||
-- ** Basic functions and datatypes
|
||||
, enter
|
||||
, (:~>)(..)
|
||||
-- ** `Nat` utilities
|
||||
, liftNat
|
||||
, runReaderTNat
|
||||
, evalStateTLNat
|
||||
, evalStateTSNat
|
||||
, logWriterTLNat
|
||||
, logWriterTSNat
|
||||
-- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
|
||||
, hoistNat
|
||||
, embedNat
|
||||
, squashNat
|
||||
, generalizeNat
|
||||
, tweakResponse
|
||||
|
||||
-- * Context
|
||||
|
@ -106,12 +93,11 @@ module Servant.Server
|
|||
|
||||
) 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 :: (HasServer api context)
|
|||
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.
|
||||
|
@ -205,28 +215,6 @@ layoutWithContext :: (HasServer api context)
|
|||
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
|
||||
-- >>> :set -XTypeOperators
|
||||
|
|
|
@ -57,7 +57,7 @@ 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
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
|
||||
|
|
|
@ -86,7 +86,7 @@ class HasServer api context where
|
|||
-> Delayed env (Server api)
|
||||
-> Router env
|
||||
|
||||
hoistServer
|
||||
hoistServerWithContext
|
||||
:: Proxy api
|
||||
-> Proxy context
|
||||
-> (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
|
||||
|
||||
-- | This is better than 'enter', as it's tailor made for 'HasServer'.
|
||||
hoistServer _ pc nt (a :<|> b) =
|
||||
hoistServer (Proxy :: Proxy a) pc nt a :<|>
|
||||
hoistServer (Proxy :: Proxy b) pc nt b
|
||||
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
|
||||
|
@ -145,7 +145,7 @@ 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
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context d =
|
||||
CaptureRouter $
|
||||
|
@ -179,7 +179,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
|
|||
type ServerT (CaptureAll capture a :> 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 =
|
||||
CaptureAllRouter $
|
||||
|
@ -258,7 +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
|
||||
hoistServerWithContext _ _ nt s = nt s
|
||||
|
||||
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
@ -270,7 +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
|
||||
hoistServerWithContext _ _ nt s = nt s
|
||||
|
||||
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
|
||||
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 =
|
||||
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 $
|
||||
subserver `addHeaderCheck` withRequest headerCheck
|
||||
|
@ -347,7 +347,7 @@ 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
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context subserver =
|
||||
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 =
|
||||
[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 $
|
||||
subserver `addParameterCheck` withRequest paramsCheck
|
||||
|
@ -436,7 +436,7 @@ 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
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context subserver =
|
||||
let querytext r = parseQueryText $ rawQueryString r
|
||||
|
@ -461,7 +461,7 @@ instance HasServer Raw context where
|
|||
|
||||
type ServerT Raw m = Tagged m Application
|
||||
|
||||
hoistServer _ _ _ = retag
|
||||
hoistServerWithContext _ _ _ = retag
|
||||
|
||||
route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
|
||||
-- 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 =
|
||||
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 $
|
||||
|
@ -538,14 +538,14 @@ 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
|
||||
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)
|
||||
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
|
||||
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)
|
||||
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
|
||||
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
|
||||
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)
|
||||
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.
|
||||
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
|
||||
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)
|
||||
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.
|
||||
data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
|
||||
|
@ -602,7 +602,7 @@ instance HasServer EmptyAPI context where
|
|||
|
||||
route Proxy _ _ = StaticRouter mempty mempty
|
||||
|
||||
hoistServer _ _ _ = retag
|
||||
hoistServerWithContext _ _ _ = retag
|
||||
|
||||
-- | Basic Authentication
|
||||
instance ( KnownSymbol realm
|
||||
|
@ -620,7 +620,7 @@ instance ( KnownSymbol realm
|
|||
basicAuthContext = getContextEntry context
|
||||
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
|
||||
|
||||
|
@ -647,4 +647,4 @@ 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
|
||||
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
|
||||
|
|
|
@ -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 @@ type CombinedAPI = ReaderAPI :<|> IdentityAPI
|
|||
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
|
||||
|
|
38
servant-server/test/Servant/HoistSpec.hs
Normal file
38
servant-server/test/Servant/HoistSpec.hs
Normal 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 ()
|
|
@ -89,7 +89,7 @@ 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
|
||||
hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s
|
||||
|
||||
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
|
||||
addBodyCheck server (return ()) check
|
||||
|
|
|
@ -29,7 +29,7 @@ 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
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s
|
||||
|
||||
route Proxy context delayed =
|
||||
route subProxy context (fmap inject delayed)
|
||||
|
@ -47,8 +47,8 @@ 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
|
||||
hoistServerWithContext _ _ nt s =
|
||||
hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s
|
||||
|
||||
route Proxy context delayed =
|
||||
route subProxy newContext delayed
|
||||
|
@ -66,8 +66,8 @@ 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
|
||||
hoistServerWithContext _ _ nt s =
|
||||
hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
|
||||
|
||||
route Proxy context delayed =
|
||||
route subProxy subContext delayed
|
||||
|
|
|
@ -8,7 +8,7 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Utils.Enter (
|
||||
module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (
|
||||
module Servant.Utils.Enter,
|
||||
-- * natural-transformation re-exports
|
||||
(:~>)(..),
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
module Servant.Utils.EnterSpec where
|
||||
|
||||
import Test.Hspec (Spec)
|
||||
|
|
Loading…
Reference in a new issue