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

Add response header support to UVerb

Browse Source
This commit is contained in:
Paolo Capriotti 2021-05-07 08:29:36 +02:00
parent 94a41ece61
commit 3fb8141cd7
3 changed files with 58 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
servant-server/servant-server.cabal
View File

@ -147,6 +147,7 @@ test-suite spec
, safe
, servant
, servant-server
, sop-core
, string-conversions
, text
, transformers

37
servant-server/src/Servant/Server/UVerb.hs
View File

@ -22,15 +22,17 @@ module Servant.Server.UVerb
)
where
import qualified Data.ByteString as B
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.HTTP.Types (Status, HeaderName, 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.API.ResponseHeaders (GetHeaders (..), Headers (..))
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), 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)
@ -43,8 +45,23 @@ respond ::
f (Union xs)
respond = pure . inject . I
class HasResponseHeaders a where
getResponseHeaders :: a -> [(HeaderName, B.ByteString)]
instance {-# OVERLAPPABLE #-} HasResponseHeaders a where
getResponseHeaders _ = []
instance {-# OVERLAPPING #-} (HasResponseHeaders a, GetHeaders (Headers h a))
=> HasResponseHeaders (Headers h a) where
getResponseHeaders x = getHeaders x <> getResponseHeaders (getResponse x)
instance {-# OVERLAPPING #-} HasResponseHeaders a
=> HasResponseHeaders (WithStatus n a) where
getResponseHeaders (WithStatus x) = getResponseHeaders x
-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.
type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus
type IsServerResource contentTypes =
AllCTRender contentTypes `And` HasStatus `And` HasResponseHeaders
instance
( ReflectMethod method,
@ -81,16 +98,18 @@ instance
mkProxy _ = Proxy
runAction action' env request cont $ \(output :: Union as) -> do
let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))
let encodeResource :: (AllCTRender contentTypes a, HasStatus a, HasResponseHeaders a)
=> a -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
encodeResource res =
( statusOf $ mkProxy res,
handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res
handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res,
getResponseHeaders res
)
pickResource :: Union as -> (Status, Maybe (LBS, LBS))
pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
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)) ->
(_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
(status, Just (contentT, body), headers) ->
let bdy = if allowedMethodHead method request then "" else body
in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy
in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

30
servant-server/test/Servant/ServerSpec.hs
View File

@ -28,6 +28,8 @@ import Data.Maybe
(fromMaybe)
import Data.Proxy
(Proxy (Proxy))
import Data.SOP
(I (..), NS (..))
import Data.String
(fromString)
import Data.String.Conversions
@ -53,7 +55,7 @@ import Servant.API
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, addHeader)
UVerb, Union, Verb, WithStatus (..), addHeader)
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
emptyServer, err401, err403, err404, respond, serve,
@ -98,6 +100,7 @@ spec = do
rawSpec
alternativeSpec
responseHeadersSpec
uverbResponseHeadersSpec
miscCombinatorSpec
basicAuthSpec
genAuthSpec
@ -684,6 +687,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
THW.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * uverbResponseHeaderSpec {{{
------------------------------------------------------------------------------
type UVerbHeaderResponse = '[
WithStatus 200 (Headers '[Header "H1" Int] String),
WithStatus 404 String ]
type UVerbResponseHeadersApi =
Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
uverbResponseHeadersSpec :: Spec
uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do
it "includes the headers in the response" $
THW.request methodGet "/true" [] ""
`shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]
, matchStatus = 200
}
-- }}}
------------------------------------------------------------------------------
-- * miscCombinatorSpec {{{