union verbs (#1314)
This commit is contained in:
fisx
GitHub
parent
64f3543034
commit
c1105899f4
24 changed files with 892 additions and 49 deletions
|
|
@ -34,6 +34,7 @@ packages:
|
|||
doc/cookbook/pagination
|
||||
-- doc/cookbook/sentry
|
||||
doc/cookbook/testing
|
||||
doc/cookbook/uverb
|
||||
doc/cookbook/structuring-apis
|
||||
doc/cookbook/using-custom-monad
|
||||
doc/cookbook/using-free-client
|
||||
|
|
|
|||
217
doc/cookbook/uverb/UVerb.lhs
Normal file
217
doc/cookbook/uverb/UVerb.lhs
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
# Listing alternative responses and exceptions in your API types
|
||||
|
||||
Servant allows you to talk about the exceptions you throw in your API
|
||||
types. This is not limited to actual exceptions, you can write
|
||||
handlers that respond with arbitrary open unions of types.
|
||||
|
||||
## Preliminaries
|
||||
|
||||
```haskell
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wall -Wno-orphans #-}
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (async)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import Data.Aeson.Encode.Pretty (encodePretty)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Swagger (ToSchema)
|
||||
import Data.Typeable (Proxy (Proxy))
|
||||
import qualified GHC.Generics as GHC
|
||||
import qualified Network.HTTP.Client as Client
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Servant.Server
|
||||
import Servant.Swagger
|
||||
```
|
||||
|
||||
## The API
|
||||
|
||||
This looks like a `Verb`-based routing table, except that `UVerb` has
|
||||
no status, and carries a list of response types rather than a single
|
||||
one. Each entry in the list carries its own response code.
|
||||
|
||||
```haskell
|
||||
type API =
|
||||
"fisx" :> Capture "bool" Bool
|
||||
:> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]
|
||||
:<|> "arian"
|
||||
:> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]
|
||||
```
|
||||
|
||||
Here are the details:
|
||||
|
||||
```haskell
|
||||
data FisxUser = FisxUser {name :: String}
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance ToJSON FisxUser
|
||||
instance FromJSON FisxUser
|
||||
instance ToSchema FisxUser
|
||||
|
||||
-- | 'HasStatus' allows us to can get around 'WithStatus' if we want
|
||||
-- to, and associate the status code with our resource types directly.
|
||||
--
|
||||
-- (To avoid orphan instances and make it more explicit what's in the
|
||||
-- API and what isn't, we could even introduce a newtype 'Resource'
|
||||
-- that wraps all the types we're using in our routing table, and then
|
||||
-- define lots of 'HasStatus' instances for @Resource This@ and
|
||||
-- @Resource That@.)
|
||||
instance HasStatus FisxUser where
|
||||
type StatusOf FisxUser = 203
|
||||
|
||||
data ArianUser = ArianUser
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance ToJSON ArianUser
|
||||
instance FromJSON ArianUser
|
||||
instance ToSchema ArianUser
|
||||
```
|
||||
|
||||
## Server, Client, Swagger
|
||||
|
||||
You can just respond with any of the elements of the union in handlers.
|
||||
|
||||
```haskell
|
||||
fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])
|
||||
fisx True = respond (FisxUser "fisx")
|
||||
fisx False = respond (WithStatus @303 ("still fisx" :: String))
|
||||
|
||||
arian :: Handler (Union '[WithStatus 201 ArianUser])
|
||||
arian = respond (WithStatus @201 ArianUser)
|
||||
```
|
||||
|
||||
You can create client functions like you're used to:
|
||||
|
||||
```
|
||||
fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])
|
||||
arianClient :: ClientM (Union '[WithStatus 201 ArianUser])
|
||||
(fisxClient :<|> arianClient) = client (Proxy @API)
|
||||
```
|
||||
|
||||
... and that's basically it! Here are a few sample commands that
|
||||
show you how the swagger docs look like and how you can handle the
|
||||
result unions in clients:
|
||||
|
||||
```
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn . cs . encodePretty $ toSwagger (Proxy @API)
|
||||
_ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)
|
||||
threadDelay 50000
|
||||
mgr <- Client.newManager Client.defaultManagerSettings
|
||||
let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")
|
||||
result <- runClientM (fisxClient True) cenv
|
||||
print $ foldMapUnion (Proxy @Show) show <$> result
|
||||
print $ matchUnion @FisxUser <$> result
|
||||
print $ matchUnion @(WithStatus 303 String) <$> result
|
||||
pure ()
|
||||
```
|
||||
|
||||
## Idiomatic exceptions
|
||||
|
||||
Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.
|
||||
|
||||
```haskell
|
||||
newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }
|
||||
deriving newtype (Functor, Applicative, Monad, MonadTrans)
|
||||
|
||||
-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use
|
||||
-- underlying monad's instance.
|
||||
instance MonadError e m => MonadError e (UVerbT xs m) where
|
||||
throwError = lift . throwError
|
||||
catchError (UVerbT act) h = UVerbT $ ExceptT $
|
||||
runExceptT act `catchError` (runExceptT . unUVerbT . h)
|
||||
|
||||
-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler
|
||||
-- may use the usual 'return'.
|
||||
runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)
|
||||
runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)
|
||||
|
||||
-- | Short-circuit 'UVerbT' computation returning one of the response types.
|
||||
throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a
|
||||
throwUVerb = UVerbT . ExceptT . fmap Left . respond
|
||||
```
|
||||
|
||||
Example usage:
|
||||
|
||||
```haskell
|
||||
data Foo = Foo Int Int Int
|
||||
deriving (Show, Eq, GHC.Generic, ToJSON)
|
||||
deriving HasStatus via WithStatus 200 Foo
|
||||
|
||||
data Bar = Bar
|
||||
deriving (Show, Eq, GHC.Generic, ToJSON)
|
||||
|
||||
h :: Handler (Union '[Foo, WithStatus 400 Bar])
|
||||
h = runUVerbT $ do
|
||||
when ({- something bad -} True) $
|
||||
throwUVerb $ WithStatus @400 Bar
|
||||
|
||||
when ({- really bad -} False) $
|
||||
throwError $ err500
|
||||
|
||||
-- a lot of code here...
|
||||
|
||||
return $ Foo 1 2 3
|
||||
```
|
||||
|
||||
## Related Work
|
||||
|
||||
There is the [issue from
|
||||
2017](https://github.com/haskell-servant/servant/issues/841) that was
|
||||
resolved by the introduction of `UVerb`, with a long discussion on
|
||||
alternative designs.
|
||||
|
||||
[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)
|
||||
is a good solution to the problem, but it restricts the user to JSON
|
||||
and a very specific envelop encoding for the union type, which is
|
||||
often not acceptable. (One good reason for this design choice is that
|
||||
it makes writing clients easier, where you need to get to the union
|
||||
type from one representative, and you don't want to run several
|
||||
parsers in the hope that the ones that should will always error out so
|
||||
you can try until the right one returns a value.)
|
||||
|
||||
[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
|
||||
another shot at at the problem. It is inspired by
|
||||
servant-checked-exceptions, so it may be worth taking a closer look.
|
||||
The README claims that
|
||||
[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
|
||||
some code for generalized error handling.
|
||||
|
||||
In an earier version of the `UVerb` implementation, we have used some
|
||||
code from
|
||||
[world-peace](https://hackage.haskell.org/package/world-peace), but
|
||||
that package itself wasn't flexible enough, and we had to use
|
||||
[sop-core](https://hackage.haskell.org/package/sop-core) to implement
|
||||
the `HasServer` instance.
|
||||
|
||||
Here is a blog post we found on the subject:
|
||||
https://lukwagoallan.com/posts/unifying-servant-server-error-responses
|
||||
|
||||
(If you have anything else, please add it here or let us know.)
|
||||
|
||||
```haskell
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
```
|
||||
33
doc/cookbook/uverb/uverb.cabal
Normal file
33
doc/cookbook/uverb/uverb.cabal
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
name: cookbook-uverb
|
||||
version: 0.0.1
|
||||
synopsis: How to use the 'UVerb' type.
|
||||
description: Listing alternative responses and exceptions in your API types.
|
||||
homepage: http://docs.servant.dev/
|
||||
license: BSD3
|
||||
license-file: ../../../servant/LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
category: Servant
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2
|
||||
|
||||
executable cookbook-uverb
|
||||
main-is: UVerb.lhs
|
||||
build-depends: base == 4.*
|
||||
, aeson >= 1.2
|
||||
, aeson-pretty >= 0.8.8
|
||||
, async
|
||||
, http-client
|
||||
, mtl
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-server
|
||||
, servant-swagger
|
||||
, string-conversions
|
||||
, swagger2
|
||||
, wai
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
||||
|
|
@ -78,6 +78,7 @@ library
|
|||
, http-types >= 0.12.2 && < 0.13
|
||||
, network-uri >= 2.6.1.0 && < 2.7
|
||||
, safe >= 0.3.17 && < 0.4
|
||||
, sop-core >= 0.4.0.0 && < 0.6
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -18,6 +18,8 @@ module Servant.Client.Core
|
|||
-- * Client generation
|
||||
clientIn
|
||||
, HasClient(..)
|
||||
, foldMapUnion
|
||||
, matchUnion
|
||||
|
||||
-- * Request
|
||||
, Request
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
|
@ -7,6 +8,7 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
|
@ -15,31 +17,48 @@ module Servant.Client.Core.HasClient (
|
|||
clientIn,
|
||||
HasClient (..),
|
||||
EmptyClient (..),
|
||||
foldMapUnion,
|
||||
matchUnion,
|
||||
) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Arrow
|
||||
(left, (+++))
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either
|
||||
(partitionEithers)
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
import Data.List
|
||||
(foldl')
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.Sequence
|
||||
(fromList)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Media
|
||||
(MediaType, matches, parseAccept, (//))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.SOP.BasicFunctors
|
||||
(I (I), (:.:) (Comp))
|
||||
import Data.SOP.Constraint
|
||||
(All)
|
||||
import Data.SOP.NP
|
||||
(NP (..), cpure_NP)
|
||||
import Data.SOP.NS
|
||||
(NS (S))
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Data.Text
|
||||
(Text, pack)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import GHC.TypeLits
|
||||
(KnownSymbol, symbolVal)
|
||||
import Network.HTTP.Types
|
||||
(Status)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Servant.API
|
||||
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
|
||||
|
|
@ -54,9 +73,11 @@ import Servant.API
|
|||
contentType, getHeadersHList, getResponse, toQueryParam,
|
||||
toUrlPiece)
|
||||
import Servant.API.ContentTypes
|
||||
(contentTypes)
|
||||
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
|
||||
import Servant.API.Modifiers
|
||||
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
||||
import Servant.API.UVerb
|
||||
(HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
|
||||
|
||||
import Servant.Client.Core.Auth
|
||||
import Servant.Client.Core.BasicAuth
|
||||
|
|
@ -288,6 +309,71 @@ instance {-# OVERLAPPING #-}
|
|||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( RunClient m,
|
||||
contentTypes ~ (contentType ': otherContentTypes),
|
||||
-- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
|
||||
-- allow this in instance types as of 8.8.3.)
|
||||
as ~ (a ': as'),
|
||||
AllMime contentTypes,
|
||||
ReflectMethod method,
|
||||
All (AllMimeUnrender contentTypes) as,
|
||||
All HasStatus as, HasStatuses as',
|
||||
Unique (Statuses as)
|
||||
) =>
|
||||
HasClient m (UVerb method contentTypes as)
|
||||
where
|
||||
type Client m (UVerb method contentTypes as) = m (Union as)
|
||||
|
||||
clientWithRoute _ _ request = do
|
||||
let accept = Seq.fromList . allMime $ Proxy @contentTypes
|
||||
-- offering to accept all mime types listed in the api gives best compatibility. eg.,
|
||||
-- we might not own the server implementation, and the server may choose to support
|
||||
-- only part of the api.
|
||||
|
||||
method = reflectMethod $ Proxy @method
|
||||
acceptStatus = statuses (Proxy @as)
|
||||
response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
|
||||
responseContentType <- checkContentTypeHeader response
|
||||
unless (any (matches responseContentType) accept) $ do
|
||||
throwClientError $ UnsupportedContentType responseContentType response
|
||||
|
||||
let status = responseStatusCode response
|
||||
body = responseBody response
|
||||
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body
|
||||
case res of
|
||||
Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
|
||||
Right x -> return x
|
||||
where
|
||||
-- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
|
||||
-- failures it encountered along the way
|
||||
-- TODO; better name, rewrite haddocs.
|
||||
tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
|
||||
tryParsers _ Nil = Left [ClientNoMatchingStatus]
|
||||
tryParsers status (Comp x :* xs)
|
||||
| status == statusOf (Comp x) =
|
||||
case partitionEithers x of
|
||||
(err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
|
||||
(_, (res : _)) -> Right . inject . I $ res
|
||||
| otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
|
||||
(ClientStatusMismatch :) +++ S $ tryParsers status xs
|
||||
|
||||
-- | Given a list of types, parses the given response body as each type
|
||||
mimeUnrenders ::
|
||||
forall cts xs.
|
||||
All (AllMimeUnrender cts) xs =>
|
||||
Proxy cts ->
|
||||
BL.ByteString ->
|
||||
NP ([] :.: Either (MediaType, String)) xs
|
||||
mimeUnrenders ctp body = cpure_NP
|
||||
(Proxy @(AllMimeUnrender cts))
|
||||
(Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)
|
||||
|
||||
hoistClientMonad _ _ nt s = nt s
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
|
||||
FramingUnrender framing, FromSourceIO chunk a
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ module Servant.Client.Core.Reexport
|
|||
(
|
||||
-- * HasClient
|
||||
HasClient(..)
|
||||
, foldMapUnion
|
||||
, matchUnion
|
||||
|
||||
-- * Response (for @Raw@)
|
||||
, Response
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
-- | Types for possible backends to run client-side `Request` queries
|
||||
module Servant.Client.Core.RunClient (
|
||||
RunClient (..),
|
||||
runRequest,
|
||||
RunStreamingClient (..),
|
||||
ClientF (..),
|
||||
) where
|
||||
|
|
@ -14,6 +15,8 @@ module Servant.Client.Core.RunClient (
|
|||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Network.HTTP.Types.Status
|
||||
(Status)
|
||||
import Control.Monad.Free
|
||||
(Free (..), liftF)
|
||||
|
||||
|
|
@ -22,10 +25,15 @@ import Servant.Client.Core.Request
|
|||
import Servant.Client.Core.Response
|
||||
|
||||
class Monad m => RunClient m where
|
||||
-- | How to make a request.
|
||||
runRequest :: Request -> m Response
|
||||
-- | How to make a request, with an optional list of status codes to not throw exceptions
|
||||
-- for (default: [200..299]).
|
||||
runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response
|
||||
throwClientError :: ClientError -> m a
|
||||
|
||||
-- | How to make a request.
|
||||
runRequest :: RunClient m => Request -> m Response
|
||||
runRequest = runRequestAcceptStatus Nothing
|
||||
|
||||
class RunClient m => RunStreamingClient m where
|
||||
withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
|
||||
|
||||
|
|
@ -41,6 +49,7 @@ data ClientF a
|
|||
| Throw ClientError
|
||||
deriving (Functor)
|
||||
|
||||
-- TODO: honour the accept-status argument.
|
||||
instance ClientF ~ f => RunClient (Free f) where
|
||||
runRequest req = liftF (RunRequest req id)
|
||||
runRequestAcceptStatus _ req = liftF (RunRequest req id)
|
||||
throwClientError = liftF . Throw
|
||||
|
|
|
|||
|
|
@ -108,6 +108,7 @@ test-suite spec
|
|||
, kan-extensions
|
||||
, servant-client
|
||||
, servant-client-core
|
||||
, sop-core
|
||||
, stm
|
||||
, text
|
||||
, transformers
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ import GHC.Generics
|
|||
import Network.HTTP.Media
|
||||
(renderHeader)
|
||||
import Network.HTTP.Types
|
||||
(hContentType, renderQuery, statusCode)
|
||||
(hContentType, renderQuery, statusCode, Status)
|
||||
import Servant.Client.Core
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
|
@ -155,14 +155,14 @@ instance Alt ClientM where
|
|||
a <!> b = a `catchError` \_ -> b
|
||||
|
||||
instance RunClient ClientM where
|
||||
runRequest = performRequest
|
||||
runRequestAcceptStatus = performRequest
|
||||
throwClientError = throwError
|
||||
|
||||
runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
|
||||
runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
|
||||
|
||||
performRequest :: Request -> ClientM Response
|
||||
performRequest req = do
|
||||
performRequest :: Maybe [Status] -> Request -> ClientM Response
|
||||
performRequest acceptStatus req = do
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
let clientRequest = createClientRequest burl req
|
||||
request <- case cookieJar' of
|
||||
|
|
@ -183,7 +183,10 @@ performRequest req = do
|
|||
let status = Client.responseStatus response
|
||||
status_code = statusCode status
|
||||
ourResponse = clientResponseToResponse id response
|
||||
unless (status_code >= 200 && status_code < 300) $
|
||||
goodStatus = case acceptStatus of
|
||||
Nothing -> status_code >= 200 && status_code < 300
|
||||
Just good -> status `elem` good
|
||||
unless goodStatus $ do
|
||||
throwError $ mkFailureResponse burl req ourResponse
|
||||
return ourResponse
|
||||
where
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ import Data.Time.Clock
|
|||
(getCurrentTime)
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Types
|
||||
(statusCode)
|
||||
(Status, statusCode)
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
||||
|
|
@ -112,7 +112,7 @@ instance Alt ClientM where
|
|||
a <!> b = a `catchError` \_ -> b
|
||||
|
||||
instance RunClient ClientM where
|
||||
runRequest = performRequest
|
||||
runRequestAcceptStatus = performRequest
|
||||
throwClientError = throwError
|
||||
|
||||
instance RunStreamingClient ClientM where
|
||||
|
|
@ -136,8 +136,8 @@ withClientM cm env k =
|
|||
runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
|
||||
runClientM cm env = withClientM cm env (evaluate . force)
|
||||
|
||||
performRequest :: Request -> ClientM Response
|
||||
performRequest req = do
|
||||
performRequest :: Maybe [Status] -> Request -> ClientM Response
|
||||
performRequest acceptStatus req = do
|
||||
-- TODO: should use Client.withResponse here too
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
let clientRequest = createClientRequest burl req
|
||||
|
|
@ -165,10 +165,14 @@ performRequest req = do
|
|||
let status = Client.responseStatus response
|
||||
status_code = statusCode status
|
||||
ourResponse = clientResponseToResponse id response
|
||||
unless (status_code >= 200 && status_code < 300) $
|
||||
goodStatus = case acceptStatus of
|
||||
Nothing -> status_code >= 200 && status_code < 300
|
||||
Just good -> status `elem` good
|
||||
unless goodStatus $ do
|
||||
throwError $ mkFailureResponse burl req ourResponse
|
||||
return ourResponse
|
||||
|
||||
-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
|
||||
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
|
||||
performWithStreamingRequest req k = do
|
||||
m <- asks manager
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
|
@ -26,10 +27,14 @@ import Control.Concurrent
|
|||
import Control.Monad.Error.Class
|
||||
(throwError)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as LazyByteString
|
||||
import Data.Char
|
||||
(chr, isPrint)
|
||||
import Data.Monoid ()
|
||||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
|
|
@ -47,8 +52,11 @@ import Servant.API
|
|||
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
|
||||
BasicAuthData (..), Capture, CaptureAll,
|
||||
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
|
||||
Headers, JSON, NoContent (NoContent), Post, QueryFlag,
|
||||
QueryParam, QueryParams, Raw, ReqBody, addHeader)
|
||||
Headers, JSON, MimeRender(mimeRender),
|
||||
MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
|
||||
Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
|
||||
StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
|
||||
addHeader)
|
||||
import Servant.Client
|
||||
import qualified Servant.Client.Core.Auth as Auth
|
||||
import Servant.Server
|
||||
|
|
@ -63,7 +71,7 @@ _ = client comprehensiveAPIWithoutStreaming
|
|||
data Person = Person
|
||||
{ _name :: String
|
||||
, _age :: Integer
|
||||
} deriving (Eq, Show, Generic)
|
||||
} deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
|
@ -74,6 +82,15 @@ instance FromForm Person
|
|||
instance Arbitrary Person where
|
||||
arbitrary = Person <$> arbitrary <*> arbitrary
|
||||
|
||||
instance MimeRender PlainText Person where
|
||||
mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show
|
||||
|
||||
instance MimeUnrender PlainText Person where
|
||||
mimeUnrender _ =
|
||||
-- This does not handle any errors, but it should be fine for tests
|
||||
Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict
|
||||
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
|
|
@ -105,6 +122,12 @@ type Api =
|
|||
:<|> "deleteContentType" :> DeleteNoContent
|
||||
:<|> "redirectWithCookie" :> Raw
|
||||
:<|> "empty" :> EmptyAPI
|
||||
:<|> "uverb-success-or-redirect" :>
|
||||
Capture "bool" Bool :>
|
||||
UVerb 'GET '[PlainText] '[WithStatus 200 Person,
|
||||
WithStatus 301 Text]
|
||||
:<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
|
||||
|
||||
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
|
@ -126,6 +149,10 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
|||
getRespHeaders :: ClientM (Headers TestHeaders Bool)
|
||||
getDeleteContentType :: ClientM NoContent
|
||||
getRedirectWithCookie :: HTTP.Method -> ClientM Response
|
||||
uverbGetSuccessOrRedirect :: Bool
|
||||
-> ClientM (Union '[WithStatus 200 Person,
|
||||
WithStatus 301 Text])
|
||||
uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
|
||||
|
||||
getRoot
|
||||
:<|> getGet
|
||||
|
|
@ -143,7 +170,9 @@ getRoot
|
|||
:<|> getRespHeaders
|
||||
:<|> getDeleteContentType
|
||||
:<|> getRedirectWithCookie
|
||||
:<|> EmptyClient = client api
|
||||
:<|> EmptyClient
|
||||
:<|> uverbGetSuccessOrRedirect
|
||||
:<|> uverbGetCreated = client api
|
||||
|
||||
server :: Application
|
||||
server = serve api (
|
||||
|
|
@ -166,7 +195,12 @@ server = serve api (
|
|||
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
|
||||
:<|> return NoContent
|
||||
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
|
||||
:<|> emptyServer)
|
||||
:<|> emptyServer
|
||||
:<|> (\shouldRedirect -> if shouldRedirect
|
||||
then respond (WithStatus @301 ("redirecting" :: Text))
|
||||
else respond (WithStatus @200 alice ))
|
||||
:<|> respond (WithStatus @201 carol)
|
||||
)
|
||||
|
||||
type FailApi =
|
||||
"get" :> Raw
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
|
@ -31,6 +32,8 @@ import Data.Foldable
|
|||
import Data.Maybe
|
||||
(listToMaybe)
|
||||
import Data.Monoid ()
|
||||
import Data.Text
|
||||
(Text)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Test.Hspec
|
||||
|
|
@ -39,7 +42,7 @@ import Test.HUnit
|
|||
import Test.QuickCheck
|
||||
|
||||
import Servant.API
|
||||
(NoContent (NoContent), getHeaders)
|
||||
(NoContent (NoContent), WithStatus(WithStatus), getHeaders)
|
||||
import Servant.Client
|
||||
import qualified Servant.Client.Core.Request as Req
|
||||
import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
|
||||
|
|
@ -151,3 +154,23 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
|
||||
return $
|
||||
result === Right (cap, num, flag, body)
|
||||
|
||||
context "With a route that can either return success or redirect" $ do
|
||||
it "Redirects when appropriate" $ \(_, baseUrl) -> do
|
||||
eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl
|
||||
case eitherResponse of
|
||||
Left clientError -> fail $ show clientError
|
||||
Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting")
|
||||
|
||||
it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do
|
||||
eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl
|
||||
case eitherResponse of
|
||||
Left clientError -> fail $ show clientError
|
||||
Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice)
|
||||
|
||||
context "with a route that uses uverb but only has a single response" $
|
||||
it "returns the expected response" $ \(_, baseUrl) -> do
|
||||
eitherResponse <- runClient (uverbGetCreated) baseUrl
|
||||
case eitherResponse of
|
||||
Left clientError -> fail $ show clientError
|
||||
Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ instance Alt ClientM where
|
|||
a <!> b = a `catchError` \_ -> b
|
||||
|
||||
instance RunClient ClientM where
|
||||
runRequest = performRequest
|
||||
runRequestAcceptStatus = performRequest
|
||||
throwClientError = throwError
|
||||
|
||||
instance RunStreamingClient ClientM where
|
||||
|
|
@ -155,8 +155,8 @@ withClientM cm env k =
|
|||
let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
|
||||
in f k
|
||||
|
||||
performRequest :: Request -> ClientM Response
|
||||
performRequest req = do
|
||||
performRequest :: Maybe [Status] -> Request -> ClientM Response
|
||||
performRequest acceptStatus req = do
|
||||
ClientEnv burl conn <- ask
|
||||
let (req', body) = requestToClientRequest burl req
|
||||
x <- ClientM $ lift $ lift $ Codensity $ \k -> do
|
||||
|
|
@ -165,7 +165,10 @@ performRequest req = do
|
|||
let sc = Client.getStatusCode res'
|
||||
lbs <- BSL.fromChunks <$> Streams.toList body'
|
||||
let res'' = clientResponseToResponse res' lbs
|
||||
if sc >= 200 && sc < 300
|
||||
goodStatus = case acceptStatus of
|
||||
Nothing -> sc >= 200 && sc < 300
|
||||
Just good -> sc `elem` (statusCode <$> good)
|
||||
if goodStatus
|
||||
then k (Right res'')
|
||||
else k (Left (mkFailureResponse burl req res''))
|
||||
|
||||
|
|
|
|||
|
|
@ -51,6 +51,7 @@ library
|
|||
Servant.Server.Internal.RoutingApplication
|
||||
Servant.Server.Internal.ServerError
|
||||
Servant.Server.StaticFiles
|
||||
Servant.Server.UVerb
|
||||
|
||||
-- deprecated
|
||||
exposed-modules:
|
||||
|
|
@ -84,6 +85,7 @@ library
|
|||
, network-uri >= 2.6.1.0 && < 2.8
|
||||
, monad-control >= 1.0.2.3 && < 1.1
|
||||
, network >= 2.8 && < 3.2
|
||||
, sop-core >= 0.4.0.0 && < 0.6
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
, resourcet >= 1.2.2 && < 1.3
|
||||
, tagged >= 0.8.6 && < 0.9
|
||||
|
|
@ -94,6 +96,7 @@ library
|
|||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
||||
ghc-options: -Wall -Wno-redundant-constraints
|
||||
|
||||
executable greet
|
||||
|
|
|
|||
|
|
@ -110,6 +110,7 @@ module Servant.Server
|
|||
-- * Re-exports
|
||||
, Application
|
||||
, Tagged (..)
|
||||
, module Servant.Server.UVerb
|
||||
|
||||
) where
|
||||
|
||||
|
|
@ -122,6 +123,7 @@ import Data.Text
|
|||
import Network.Wai
|
||||
(Application)
|
||||
import Servant.Server.Internal
|
||||
import Servant.Server.UVerb
|
||||
|
||||
|
||||
-- * Implementing Servers
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ import Network.Socket
|
|||
(SockAddr)
|
||||
import Network.Wai
|
||||
(Application, Request, httpVersion, isSecure, lazyRequestBody,
|
||||
queryString, remoteHost, requestBody, requestHeaders,
|
||||
queryString, remoteHost, getRequestBodyChunk, requestHeaders,
|
||||
requestMethod, responseLBS, responseStream, vault)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
|
@ -681,7 +681,7 @@ instance
|
|||
bodyCheck fromRS = withRequest $ \req -> do
|
||||
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
|
||||
let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
|
||||
let body = requestBody req
|
||||
let body = getRequestBodyChunk req
|
||||
let rs = S.fromAction B.null body
|
||||
let rs' = fromRS $ framingUnrender' rs
|
||||
return rs'
|
||||
|
|
|
|||
96
servant-server/src/Servant/Server/UVerb.hs
Normal file
96
servant-server/src/Servant/Server/UVerb.hs
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
|
||||
module Servant.Server.UVerb
|
||||
( respond,
|
||||
IsServerResource,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.SOP (I (I))
|
||||
import Data.SOP.Constraint (All, And)
|
||||
import Data.String.Conversions (LBS, cs)
|
||||
import Network.HTTP.Types (Status, hContentType)
|
||||
import Network.Wai (responseLBS)
|
||||
import Servant.API (ReflectMethod, reflectMethod)
|
||||
import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
|
||||
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)
|
||||
import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
|
||||
|
||||
|
||||
-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
|
||||
-- and will construct a union value in an 'Applicative' (eg. 'Server').
|
||||
respond ::
|
||||
forall (x :: *) (xs :: [*]) (f :: * -> *).
|
||||
(Applicative f, HasStatus x, IsMember x xs) =>
|
||||
x ->
|
||||
f (Union xs)
|
||||
respond = pure . inject . I
|
||||
|
||||
-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.
|
||||
type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus
|
||||
|
||||
instance
|
||||
( ReflectMethod method,
|
||||
AllMime contentTypes,
|
||||
All (IsServerResource contentTypes) as,
|
||||
Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
|
||||
-- wihtout; client is a bit of a corner case, because it dispatches
|
||||
-- the parser based on the status code. with this uniqueness
|
||||
-- constraint it won't have to run more than one parser in weird
|
||||
-- corner cases.
|
||||
) =>
|
||||
HasServer (UVerb method contentTypes as) context
|
||||
where
|
||||
type ServerT (UVerb method contentTypes as) m = m (Union as)
|
||||
|
||||
hoistServerWithContext _ _ nt s = nt s
|
||||
|
||||
route ::
|
||||
forall env.
|
||||
Proxy (UVerb method contentTypes as) ->
|
||||
Context context ->
|
||||
Delayed env (Server (UVerb method contentTypes as)) ->
|
||||
Router env
|
||||
route _proxy _ctx action = leafRouter route'
|
||||
where
|
||||
method = reflectMethod (Proxy @method)
|
||||
route' env request cont = do
|
||||
let action' :: Delayed env (Handler (Union as))
|
||||
action' =
|
||||
action
|
||||
`addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
|
||||
mkProxy :: a -> Proxy a
|
||||
mkProxy _ = Proxy
|
||||
|
||||
runAction action' env request cont $ \(output :: Union as) -> do
|
||||
let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))
|
||||
encodeResource res =
|
||||
( statusOf $ mkProxy res,
|
||||
handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res
|
||||
)
|
||||
pickResource :: Union as -> (Status, Maybe (LBS, LBS))
|
||||
pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource
|
||||
|
||||
case pickResource output of
|
||||
(_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
|
||||
(status, Just (contentT, body)) ->
|
||||
let bdy = if allowedMethodHead method request then "" else body
|
||||
in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy
|
||||
|
|
@ -7,7 +7,6 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||
|
||||
module Servant.ServerSpec where
|
||||
|
|
@ -49,14 +48,16 @@ import Network.Wai.Test
|
|||
import Servant.API
|
||||
((:<|>) (..), (:>), AuthProtect, BasicAuth,
|
||||
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
|
||||
Delete, EmptyAPI, Get, Header, Headers, HttpVersion,
|
||||
IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
|
||||
NoFraming, OctetStream, Patch, PlainText, Post, Put,
|
||||
QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
|
||||
SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)
|
||||
Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,
|
||||
HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),
|
||||
NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,
|
||||
Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,
|
||||
ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,
|
||||
UVerb, Verb, addHeader)
|
||||
import Servant.Server
|
||||
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
|
||||
emptyServer, err401, err403, err404, serve, serveWithContext)
|
||||
emptyServer, err401, err403, err404, respond, serve,
|
||||
serveWithContext)
|
||||
import Servant.Test.ComprehensiveAPI
|
||||
import qualified Servant.Types.SourceT as S
|
||||
import Test.Hspec
|
||||
|
|
@ -87,6 +88,7 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
|
|||
spec :: Spec
|
||||
spec = do
|
||||
verbSpec
|
||||
uverbSpec
|
||||
captureSpec
|
||||
captureAllSpec
|
||||
queryParamSpec
|
||||
|
|
@ -253,8 +255,8 @@ captureSpec = do
|
|||
|
||||
with (return (serve
|
||||
(Proxy :: Proxy (Capture "captured" String :> Raw))
|
||||
(\ "captured" -> Tagged $ \request_ respond ->
|
||||
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
|
||||
(\ "captured" -> Tagged $ \request_ sendResponse ->
|
||||
sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
|
||||
it "strips the captured path snippet from pathInfo" $ do
|
||||
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
|
||||
|
||||
|
|
@ -305,8 +307,8 @@ captureAllSpec = do
|
|||
|
||||
with (return (serve
|
||||
(Proxy :: Proxy (CaptureAll "segments" String :> Raw))
|
||||
(\ _captured -> Tagged $ \request_ respond ->
|
||||
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
|
||||
(\ _captured -> Tagged $ \request_ sendResponse ->
|
||||
sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
|
||||
it "consumes everything from pathInfo" $ do
|
||||
get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
|
||||
|
||||
|
|
@ -544,8 +546,8 @@ rawApi :: Proxy RawApi
|
|||
rawApi = Proxy
|
||||
|
||||
rawApplication :: Show a => (Request -> a) -> Tagged m Application
|
||||
rawApplication f = Tagged $ \request_ respond ->
|
||||
respond $ responseLBS ok200 []
|
||||
rawApplication f = Tagged $ \request_ sendResponse ->
|
||||
sendResponse $ responseLBS ok200 []
|
||||
(cs $ show $ f request_)
|
||||
|
||||
rawSpec :: Spec
|
||||
|
|
@ -706,7 +708,7 @@ basicAuthApi = Proxy
|
|||
basicAuthServer :: Server BasicAuthAPI
|
||||
basicAuthServer =
|
||||
const (return jerry) :<|>
|
||||
(Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
|
||||
(Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
|
||||
|
||||
basicAuthContext :: Context '[ BasicAuthCheck () ]
|
||||
basicAuthContext =
|
||||
|
|
@ -751,7 +753,7 @@ genAuthApi = Proxy
|
|||
|
||||
genAuthServer :: Server GenAuthAPI
|
||||
genAuthServer = const (return tweety)
|
||||
:<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
|
||||
:<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
|
||||
|
||||
type instance AuthServerData (AuthProtect "auth") = ()
|
||||
|
||||
|
|
@ -781,6 +783,73 @@ genAuthSpec = do
|
|||
it "plays nice with subsequent Raw endpoints" $ do
|
||||
get "/foo" `shouldRespondWith` 418
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * UVerb {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
newtype PersonResponse = PersonResponse Person
|
||||
deriving Generic
|
||||
instance ToJSON PersonResponse
|
||||
instance HasStatus PersonResponse where
|
||||
type StatusOf PersonResponse = 200
|
||||
|
||||
newtype RedirectResponse = RedirectResponse String
|
||||
deriving Generic
|
||||
instance ToJSON RedirectResponse
|
||||
instance HasStatus RedirectResponse where
|
||||
type StatusOf RedirectResponse = 301
|
||||
|
||||
newtype AnimalResponse = AnimalResponse Animal
|
||||
deriving Generic
|
||||
instance ToJSON AnimalResponse
|
||||
instance HasStatus AnimalResponse where
|
||||
type StatusOf AnimalResponse = 203
|
||||
|
||||
|
||||
type UVerbApi
|
||||
= "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]
|
||||
:<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]
|
||||
|
||||
uverbSpec :: Spec
|
||||
uverbSpec = describe "Servant.API.UVerb " $ do
|
||||
let
|
||||
joe = Person "joe" 42
|
||||
mouse = Animal "Mouse" 7
|
||||
|
||||
personHandler
|
||||
:: Bool
|
||||
-> Handler (Union '[PersonResponse
|
||||
,RedirectResponse])
|
||||
personHandler True = respond $ RedirectResponse "over there!"
|
||||
personHandler False = respond $ PersonResponse joe
|
||||
|
||||
animalHandler = respond $ AnimalResponse mouse
|
||||
|
||||
server :: Server UVerbApi
|
||||
server = personHandler :<|> animalHandler
|
||||
|
||||
with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do
|
||||
context "A route returning either 301/String or 200/Person" $ do
|
||||
context "when requesting the person" $ do
|
||||
let theRequest = THW.get "/person/false"
|
||||
it "returns status 200" $
|
||||
theRequest `shouldRespondWith` 200
|
||||
it "returns a person" $ do
|
||||
response <- theRequest
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just joe
|
||||
context "requesting the redirect" $
|
||||
it "returns a message and status 301" $
|
||||
THW.get "/person/true"
|
||||
`shouldRespondWith` "\"over there!\"" {matchStatus = 301}
|
||||
context "a route with a single response type" $ do
|
||||
let theRequest = THW.get "/animal"
|
||||
it "should return the defined status code" $
|
||||
theRequest `shouldRespondWith` 203
|
||||
it "should return the expected response" $ do
|
||||
response <- theRequest
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just mouse
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Test data types {{{
|
||||
|
|
|
|||
|
|
@ -54,6 +54,8 @@ library
|
|||
Servant.API.Stream
|
||||
Servant.API.Sub
|
||||
Servant.API.TypeLevel
|
||||
Servant.API.UVerb
|
||||
Servant.API.UVerb.Union
|
||||
Servant.API.Vault
|
||||
Servant.API.Verbs
|
||||
Servant.API.WithNamedContext
|
||||
|
|
@ -78,6 +80,7 @@ library
|
|||
base >= 4.9 && < 4.15
|
||||
, bytestring >= 0.10.8.1 && < 0.11
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, sop-core >= 0.4.0.0 && < 0.6
|
||||
, transformers >= 0.5.2.0 && < 0.6
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
|
||||
|
|
@ -108,11 +111,13 @@ library
|
|||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
other-extensions: CPP
|
||||
other-extensions: AllowAmbiguousTypes
|
||||
, CPP
|
||||
, ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
, ExplicitNamespaces
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, FunctionalDependencies
|
||||
|
|
@ -121,11 +126,13 @@ library
|
|||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, PolyKinds
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TupleSections
|
||||
, TypeFamilies
|
||||
, TypeOperators
|
||||
, UndecidableInstances
|
||||
|
||||
ghc-options: -Wall -Wno-redundant-constraints
|
||||
|
||||
test-suite spec
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ module Servant.API (
|
|||
|
||||
-- * Actual endpoints, distinguished by HTTP method
|
||||
module Servant.API.Verbs,
|
||||
module Servant.API.UVerb,
|
||||
|
||||
-- * Streaming endpoints, distinguished by HTTP method
|
||||
module Servant.API.Stream,
|
||||
|
|
@ -132,6 +133,9 @@ import Servant.API.Verbs
|
|||
PutCreated, PutNoContent, PutNonAuthoritative,
|
||||
ReflectMethod (reflectMethod), StdMethod (..),
|
||||
Verb, NoContentVerb)
|
||||
import Servant.API.UVerb
|
||||
(UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,
|
||||
WithStatus (..), IsMember, Unique, inject)
|
||||
import Servant.API.WithNamedContext
|
||||
(WithNamedContext)
|
||||
import Servant.Links
|
||||
|
|
|
|||
|
|
@ -419,7 +419,6 @@ instance MimeUnrender OctetStream BS.ByteString where
|
|||
mimeUnrender _ = Right . toStrict
|
||||
|
||||
|
||||
|
||||
-- $setup
|
||||
-- >>> :set -XFlexibleInstances
|
||||
-- >>> :set -XMultiParamTypeClasses
|
||||
|
|
|
|||
97
servant/src/Servant/API/UVerb.hs
Normal file
97
servant/src/Servant/API/UVerb.hs
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an
|
||||
-- open union of types, and specific status codes for each type in this union. (`UVerb` is
|
||||
-- short for `UnionVerb`)
|
||||
--
|
||||
-- This can be used for returning (rather than throwing) exceptions in a server as in, say
|
||||
-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or
|
||||
-- 201 created with a different body type, depending on the circumstances. (All of this can
|
||||
-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in
|
||||
-- the API types without something like `UVerb`.)
|
||||
--
|
||||
-- See <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> for a working example.
|
||||
module Servant.API.UVerb
|
||||
( UVerb,
|
||||
HasStatus (StatusOf),
|
||||
statusOf,
|
||||
HasStatuses (Statuses, statuses),
|
||||
WithStatus (..),
|
||||
module Servant.API.UVerb.Union,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import qualified GHC.Generics as GHC
|
||||
import GHC.TypeLits (Nat)
|
||||
import Network.HTTP.Types (Status, StdMethod)
|
||||
import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent)
|
||||
import Servant.API.Status (KnownStatus, statusVal)
|
||||
import Servant.API.UVerb.Union
|
||||
|
||||
class KnownStatus (StatusOf a) => HasStatus (a :: *) where
|
||||
type StatusOf (a :: *) :: Nat
|
||||
|
||||
statusOf :: forall a proxy. HasStatus a => proxy a -> Status
|
||||
statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
|
||||
|
||||
instance KnownStatus n => HasStatus (WithStatus n a) where
|
||||
type StatusOf (WithStatus n a) = n
|
||||
|
||||
-- | If an API can respond with 'NoContent' we assume that this will happen
|
||||
-- with the status code 204 No Content. If this needs to be overridden,
|
||||
-- 'WithStatus' can be used.
|
||||
instance HasStatus NoContent where
|
||||
type StatusOf NoContent = 204
|
||||
|
||||
class HasStatuses (as :: [*]) where
|
||||
type Statuses (as :: [*]) :: [Nat]
|
||||
statuses :: Proxy as -> [Status]
|
||||
|
||||
instance HasStatuses '[] where
|
||||
type Statuses '[] = '[]
|
||||
statuses _ = []
|
||||
|
||||
instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where
|
||||
type Statuses (a ': as) = StatusOf a ': Statuses as
|
||||
statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as)
|
||||
|
||||
newtype WithStatus (k :: Nat) a = WithStatus a
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a)
|
||||
|
||||
instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a)
|
||||
|
||||
instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where
|
||||
mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
|
||||
|
||||
instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where
|
||||
mimeUnrender contentTypeProxy input =
|
||||
WithStatus <$> mimeUnrender contentTypeProxy input
|
||||
|
||||
-- | A variant of 'Verb' that can have any of a number of response values and status codes.
|
||||
--
|
||||
-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write
|
||||
-- instances for 'HasServer' etc. for the latter, getting them for the former for free.
|
||||
-- Something like:
|
||||
--
|
||||
-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@
|
||||
--
|
||||
-- Backwards compatibility is tricky, though: this type alias would mean people would have to
|
||||
-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.
|
||||
data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])
|
||||
147
servant/src/Servant/API/UVerb/Union.hs
Normal file
147
servant/src/Servant/API/UVerb/Union.hs
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ExplicitNamespaces #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-
|
||||
|
||||
Copyright Dennis Gosnell (c) 2017-2018
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Author name here nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
-}
|
||||
|
||||
-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by
|
||||
-- [world-piece](https://github.com/cdepillabout/world-peace).
|
||||
module Servant.API.UVerb.Union
|
||||
( IsMember
|
||||
, Unique
|
||||
, Union
|
||||
, inject
|
||||
, eject
|
||||
, foldMapUnion
|
||||
, matchUnion
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Proxy (Proxy)
|
||||
import Data.SOP.BasicFunctors (I, unI)
|
||||
import Data.SOP.Constraint
|
||||
import Data.SOP.NS
|
||||
import Data.Type.Bool (If)
|
||||
import Data.Type.Equality (type (==))
|
||||
import GHC.TypeLits
|
||||
|
||||
type Union = NS I
|
||||
|
||||
-- | Convenience function to apply a function to an unknown union element using a type class.
|
||||
-- All elements of the union must have instances in the type class, and the function is
|
||||
-- applied unconditionally.
|
||||
--
|
||||
-- See also: 'matchUnion'.
|
||||
foldMapUnion ::
|
||||
forall (c :: * -> Constraint) (a :: *) (as :: [*]).
|
||||
All c as =>
|
||||
Proxy c ->
|
||||
(forall x. c x => x -> a) ->
|
||||
Union as ->
|
||||
a
|
||||
foldMapUnion proxy go = cfoldMap_NS proxy (go . unI)
|
||||
|
||||
-- | Convenience function to extract a union element using 'cast', ie. return the value if the
|
||||
-- selected type happens to be the actual type of the union in this value, or 'Nothing'
|
||||
-- otherwise.
|
||||
--
|
||||
-- See also: 'foldMapUnion'.
|
||||
matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a
|
||||
matchUnion = fmap unI . eject
|
||||
|
||||
-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop
|
||||
|
||||
-- (this could to go sop-core, except it's probably too specialized to the servant use-case.)
|
||||
|
||||
type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as)
|
||||
|
||||
class UElem x xs where
|
||||
inject :: f x -> NS f xs
|
||||
eject :: NS f xs -> Maybe (f x)
|
||||
|
||||
instance {-# OVERLAPPING #-} UElem x (x ': xs) where
|
||||
inject = Z
|
||||
eject (Z x) = Just x
|
||||
eject _ = Nothing
|
||||
|
||||
instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where
|
||||
inject = S . inject
|
||||
eject (Z _) = Nothing
|
||||
eject (S ns) = eject ns
|
||||
|
||||
-- | Check whether @a@ is in list. This will throw nice errors if the element is not in the
|
||||
-- list, or if there is a duplicate in the list.
|
||||
type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where
|
||||
CheckElemIsMember a as =
|
||||
If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as))
|
||||
|
||||
type NoElementError (r :: k) (rs :: [k]) =
|
||||
'Text "Expected one of:"
|
||||
':$$: 'Text " " ':<>: 'ShowType rs
|
||||
':$$: 'Text "But got:"
|
||||
':$$: 'Text " " ':<>: 'ShowType r
|
||||
|
||||
type DuplicateElementError (rs :: [k]) =
|
||||
'Text "Duplicate element in list:"
|
||||
':$$: 'Text " " ':<>: 'ShowType rs
|
||||
|
||||
type family Elem (x :: k) (xs :: [k]) :: Bool where
|
||||
Elem _ '[] = 'False
|
||||
Elem x (x' ': xs) =
|
||||
If (x == x') 'True (Elem x xs)
|
||||
|
||||
type family Unique xs :: Constraint where
|
||||
Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
|
||||
|
||||
type family Nubbed xs :: Bool where
|
||||
Nubbed '[] = 'True
|
||||
Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs)
|
||||
|
||||
_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False
|
||||
, Nubbed '[Int, Int, Bool] ~ 'False
|
||||
, Nubbed '[Int, Bool] ~ 'True
|
||||
)
|
||||
=> a) -> a
|
||||
_testNubbed = id
|
||||
Loading…
Reference in a new issue