Skip to content

Commit a32345e

Browse files
worm2fedworm2fed
committed
Add Describe to provide description for headers
1 parent 02242e9 commit a32345e

File tree

12 files changed

+110
-18
lines changed

12 files changed

+110
-18
lines changed

‎servant-client-core/src/Servant/Client/Core/HasClient.hs‎

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ import Control.Arrow
3232
(left, (+++))
3333
import Control.Monad
3434
(unless)
35-
import qualified Data.ByteString as BS
3635
import qualified Data.ByteString.Lazy as BL
3736
import Data.Either
3837
(partitionEithers)
@@ -69,7 +68,7 @@ import Network.HTTP.Types
6968
import qualified Network.HTTP.Types as H
7069
import Servant.API
7170
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
72-
BuildHeadersTo (..), Capture', CaptureAll, Description,
71+
BuildHeadersTo (..), Capture', CaptureAll, Describe, Description,
7372
EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
7473
FromSourceIO (..), Header', Headers (..), HttpVersion,
7574
IsSecure, MimeRender (mimeRender),
@@ -78,7 +77,7 @@ import Servant.API
7877
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
7978
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
8079
Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
81-
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
80+
getResponse, toEncodedUrlPiece, NamedRoutes)
8281
import Servant.API.Generic
8382
(GenericMode(..), ToServant, ToServantApi
8483
, GenericServant, toServant, fromServant)
@@ -532,6 +531,14 @@ instance HasClient m api => HasClient m (Description desc :> api) where
532531

533532
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
534533

534+
-- | Ignore @'Description'@ in client functions.
535+
instance HasClient m (h :> api) => HasClient m (Describe desc h :> api) where
536+
type Client m (Describe desc h :> api) = Client m (h :> api)
537+
538+
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy (h :> api))
539+
540+
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy (h :> api)) f cl
541+
535542
-- | If you use a 'QueryParam' in one of your endpoints in your API,
536543
-- the corresponding querying function will automatically take
537544
-- an additional argument of the type specified by your 'QueryParam',

‎servant-docs/src/Servant/Docs/Internal.hs‎

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ import Data.String.Conversions
5555
import Data.Text
5656
(Text, unpack)
5757
import GHC.Generics
58-
(Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
58+
(K1(K1), M1(M1), U1(U1), V1,
5959
(:*:)((:*:)), (:+:)(L1, R1))
6060
import qualified GHC.Generics as G
6161
import GHC.TypeLits
@@ -561,6 +561,10 @@ instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
561561
mkHeader (Just x) = (headerName, cs $ toHeader x)
562562
mkHeader Nothing = (headerName, "<no header sample provided>")
563563

564+
instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
565+
=> AllHeaderSamples (Describe desc (Header h l) ': ls) where
566+
allHeaderToSample _ = allHeaderToSample (Proxy :: Proxy (Header h l ': ls))
567+
564568
-- | Synthesise a sample value of a type, encoded in the specified media types.
565569
sampleByteString
566570
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
@@ -1023,6 +1027,10 @@ instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
10231027
Just x -> cs $ toHeader x
10241028
Nothing -> "<no header sample provided>"
10251029

1030+
instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
1031+
=> HasDocs (Describe desc (Header' mods sym a) :> api) where
1032+
docsFor Proxy = docsFor (Proxy :: Proxy (Header' mods sym a :> api))
1033+
10261034
instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
10271035
=> HasDocs (QueryParam' mods sym a :> api) where
10281036

‎servant-docs/test/Servant/DocsSpec.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -190,13 +190,13 @@ newtype TestTreeM a = TestTreeM (Writer [TestTree] a)
190190
runTestTreeM :: TestTreeM () -> [TestTree]
191191
runTestTreeM (TestTreeM m) = snd (runWriter m)
192192

193-
class Describe r where
193+
class DescribeTest r where
194194
describe :: TestName -> TestTreeM () -> r
195195

196-
instance a ~ () => Describe (TestTreeM a) where
196+
instance a ~ () => DescribeTest (TestTreeM a) where
197197
describe n t = TestTreeM $ tell [ describe n t ]
198198

199-
instance Describe TestTree where
199+
instance DescribeTest TestTree where
200200
describe n t = testGroup n $ runTestTreeM t
201201

202202
it :: TestName -> Assertion -> TestTreeM ()

‎servant-foreign/src/Servant/Foreign/Internal.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -515,6 +515,13 @@ instance HasForeign lang ftype api
515515
foreignFor lang ftype Proxy req =
516516
foreignFor lang ftype (Proxy :: Proxy api) req
517517

518+
instance HasForeign lang ftype (h :> api)
519+
=> HasForeign lang ftype (Describe desc h :> api) where
520+
type Foreign ftype (Describe desc h :> api) = Foreign ftype (h :> api)
521+
522+
foreignFor lang ftype Proxy req =
523+
foreignFor lang ftype (Proxy :: Proxy (h :> api)) req
524+
518525
instance HasForeign lang ftype (ToServantApi r) => HasForeign lang ftype (NamedRoutes r) where
519526
type Foreign ftype (NamedRoutes r) = Foreign ftype (ToServantApi r)
520527

‎servant-server/src/Servant/Server/Internal.hs‎

Lines changed: 16 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,7 @@ import qualified Data.Text as T
5959
import Data.Typeable
6060
import GHC.Generics
6161
import GHC.TypeLits
62-
(KnownNat, KnownSymbol, TypeError, symbolVal)
62+
(ErrorMessage (..), KnownNat, KnownSymbol, TypeError, symbolVal)
6363
import qualified Network.HTTP.Media as NHM
6464
import Network.HTTP.Types hiding
6565
(Header, ResponseHeaders)
@@ -73,7 +73,7 @@ import Prelude ()
7373
import Prelude.Compat
7474
import Servant.API
7575
((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
76-
CaptureAll, Description, EmptyAPI, Fragment,
76+
CaptureAll, Describe, Description, EmptyAPI, Fragment,
7777
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
7878
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
7979
QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
@@ -111,8 +111,6 @@ import Servant.Server.Internal.RouteResult
111111
import Servant.Server.Internal.RoutingApplication
112112
import Servant.Server.Internal.ServerError
113113

114-
import GHC.TypeLits
115-
(ErrorMessage (..), TypeError)
116114
import Servant.API.TypeLevel
117115
(AtLeastOneFragment, FragmentUnique)
118116

@@ -485,6 +483,20 @@ instance
485483
<> headerName
486484
<> " failed: " <> e
487485

486+
instance
487+
(KnownSymbol sym, FromHttpApiData a, HasServer api context
488+
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
489+
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
490+
)
491+
=> HasServer (Describe desc (Header' mods sym a) :> api) context where
492+
------
493+
type ServerT (Describe desc (Header' mods sym a) :> api) m =
494+
RequestArgument mods a -> ServerT api m
495+
496+
hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy (Header' mods sym a :> api))
497+
498+
route _ = route (Proxy :: Proxy (Header' mods sym a :> api))
499+
488500
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
489501
-- this automatically requires your server-side handler to be a function
490502
-- that takes an argument of type @'Maybe' 'Text'@.

‎servant-server/test/Servant/ServerSpec.hs‎

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -53,8 +53,8 @@ import Network.Wai.Test
5353
import Servant.API
5454
((:<|>) (..), (:>), AuthProtect, BasicAuth,
5555
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
56-
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
57-
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
56+
Delete, Describe, EmptyAPI, Fragment, Get, HasStatus (StatusOf),
57+
Header, Headers, HttpVersion, IsSecure (..), JSON, Lenient,
5858
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
5959
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
6060
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
@@ -121,6 +121,7 @@ type VerbApi method status
121121
:<|> "noContent" :> NoContentVerb method
122122
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
123123
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
124+
:<|> "headerD" :> Verb method status '[JSON] (Headers '[Describe "desc" (Header "D" Int)] Person)
124125
:<|> "accept" :> ( Verb method status '[JSON] Person
125126
:<|> Verb method status '[PlainText] String
126127
)
@@ -133,6 +134,7 @@ verbSpec = describe "Servant.API.Verb" $ do
133134
:<|> return NoContent
134135
:<|> return (addHeader 5 alice)
135136
:<|> return (addHeader 10 NoContent)
137+
:<|> return (addHeader 5 alice)
136138
:<|> (return alice :<|> return "B")
137139
:<|> return (S.source ["bytestring"])
138140

@@ -177,6 +179,10 @@ verbSpec = describe "Servant.API.Verb" $ do
177179
liftIO $ statusCode (simpleStatus response2) `shouldBe` status
178180
liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
179181

182+
response3 <- THW.request method "/headerD" [] ""
183+
liftIO $ statusCode (simpleStatus response3) `shouldBe` status
184+
liftIO $ simpleHeaders response3 `shouldContain` [("D", "5")]
185+
180186
it "handles trailing '/' gracefully" $ do
181187
response <- THW.request method "/headerNC/" [] ""
182188
liftIO $ statusCode (simpleStatus response) `shouldBe` status

‎servant-swagger/src/Servant/Swagger/Internal.hs‎

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,6 @@ import Network.HTTP.Media (MediaType)
3838
import Servant.API
3939
import Servant.API.Description (FoldDescription,
4040
reflectDescription)
41-
import Servant.API.Generic (ToServantApi, AsApi)
4241
import Servant.API.Modifiers (FoldRequired)
4342

4443
import Servant.Swagger.Internal.TypeLevel.API
@@ -398,6 +397,20 @@ instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub)
398397
& paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
399398
& default_ ?~ toJSON False))
400399

400+
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol desc) => HasSwagger (Describe desc (Header' mods sym a) :> sub) where
401+
toSwagger _ = toSwagger (Proxy :: Proxy sub)
402+
& addParam param
403+
& addDefaultResponse400 tname
404+
where
405+
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
406+
param = mempty
407+
& name .~ tname
408+
& description ?~ Text.pack (symbolVal (Proxy :: Proxy desc))
409+
& required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
410+
& schema .~ ParamOther (mempty
411+
& in_ .~ ParamHeader
412+
& paramSchema .~ toParamSchema (Proxy :: Proxy a))
413+
401414
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
402415
toSwagger _ = toSwagger (Proxy :: Proxy sub)
403416
& addParam param

‎servant/src/Servant/API.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -96,7 +96,7 @@ import Servant.API.ContentTypes
9696
MimeUnrender (..), NoContent (NoContent), OctetStream,
9797
PlainText)
9898
import Servant.API.Description
99-
(Description, Summary)
99+
(Describe, Description, Summary)
100100
import Servant.API.Empty
101101
(EmptyAPI (..))
102102
import Servant.API.Experimental.Auth

‎servant/src/Servant/API/Description.hs‎

Lines changed: 17 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,9 +5,10 @@
55
{-# LANGUAGE ScopedTypeVariables #-}
66
{-# LANGUAGE TypeFamilies #-}
77
{-# LANGUAGE TypeOperators #-}
8-
{-# OPTIONS_HADDOCK not-home #-}
8+
{-# OPTIONS_HADDOCK not-home #-}
99
module Servant.API.Description (
1010
-- * Combinators
11+
Describe,
1112
Description,
1213
Summary,
1314
-- * Used as modifiers
@@ -46,6 +47,21 @@ data Summary (sym :: Symbol)
4647
data Description (sym :: Symbol)
4748
deriving (Typeable)
4849

50+
-- | Add a description to 'Header'.
51+
--
52+
-- Example:
53+
--
54+
-- >>> :{
55+
-- Describe "Indicates to the client total count of items in collection"
56+
-- (Header "Total-Count" Int)
57+
-- :}
58+
--
59+
-- NOTE: currently there is ability to provide description to `Header'` (note ')
60+
-- via mods (see 'FoldDescription'), but this is not possible for simple 'Header'.
61+
-- 'FoldDescription' should be reviewed in future.
62+
data Describe (sym :: Symbol) (a :: *)
63+
deriving (Typeable)
64+
4965
-- | Fold list of modifiers to extract description as a type-level String.
5066
--
5167
-- >>> :kind! FoldDescription '[]

‎servant/src/Servant/API/ResponseHeaders.hs‎

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@
1212
{-# LANGUAGE TypeOperators #-}
1313
{-# LANGUAGE UndecidableInstances #-}
1414
{-# OPTIONS_HADDOCK not-home #-}
15+
{-# LANGUAGE InstanceSigs #-}
1516

1617
-- | This module provides facilities for adding headers to a response.
1718
--
@@ -37,7 +38,7 @@ module Servant.API.ResponseHeaders
3738
import Control.DeepSeq
3839
(NFData (..))
3940
import Data.ByteString.Char8 as BS
40-
(ByteString, init, pack, unlines)
41+
(ByteString, pack)
4142
import qualified Data.CaseInsensitive as CI
4243
import qualified Data.List as L
4344
import Data.Proxy
@@ -51,6 +52,8 @@ import Web.HttpApiData
5152

5253
import Prelude ()
5354
import Prelude.Compat
55+
import Servant.API.Description
56+
(Describe)
5457
import Servant.API.Header
5558
(Header)
5659
import Servant.API.UVerb.Union
@@ -94,6 +97,8 @@ instance NFDataHList xs => NFData (HList xs) where
9497
type family HeaderValMap (f :: * -> *) (xs :: [*]) where
9598
HeaderValMap f '[] = '[]
9699
HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs
100+
HeaderValMap f (Describe desc (Header h x) ': xs)
101+
= Header h (f x) ': HeaderValMap f xs
97102

98103

99104
class BuildHeadersTo hs where
@@ -167,11 +172,24 @@ instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
167172
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
168173
addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
169174

175+
-- instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
176+
-- => AddHeader h v (Headers (fst ': rest) a) (Headers (Describe desc (Header h v) ': fst ': rest) a) where
177+
-- addOptionalHeader
178+
-- :: (KnownSymbol h, ToHttpApiData v)
179+
-- => ResponseHeader h v
180+
-- -> Headers (fst : rest) a
181+
-- -> Headers (Header h v: fst : rest) a
182+
-- addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
183+
170184
-- In this instance, 'a' parameter is decorated with a Header.
171185
instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
172186
=> AddHeader h v a new where
173187
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
174188

189+
-- instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Describe desc (Header h v)] a)
190+
-- => AddHeader h v a new where
191+
-- addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
192+
175193
-- Instances to decorate all responses in a 'Union' with headers. The functional
176194
-- dependencies force us to consider singleton lists as the base case in the
177195
-- recursion (it is impossible to determine h and v otherwise from old / new

0 commit comments

Comments
 (0)