Add Describe to provide description for headers

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

@@ -32,7 +32,6 @@ import           Control.Arrow
                  (left, (+++))
 import           Control.Monad
                  (unless)
-import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import           Data.Either
                  (partitionEithers)
@@ -69,7 +68,7 @@ import           Network.HTTP.Types
 import qualified Network.HTTP.Types                       as H
 import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
-                 BuildHeadersTo (..), Capture', CaptureAll, Description,
+                 BuildHeadersTo (..), Capture', CaptureAll, Describe, Description,
                  EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
                  FromSourceIO (..), Header', Headers (..), HttpVersion,
                  IsSecure, MimeRender (mimeRender),
@@ -78,7 +77,7 @@ import           Servant.API
                  ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
                  StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
                  Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
-                 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
+                 getResponse, toEncodedUrlPiece, NamedRoutes)
 import           Servant.API.Generic
                  (GenericMode(..), ToServant, ToServantApi
                  , GenericServant, toServant, fromServant)
@@ -532,6 +531,14 @@ instance HasClient m api => HasClient m (Description desc :> api) where
 
   hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
 
+-- | Ignore @'Description'@ in client functions.
+instance HasClient m (h :> api) => HasClient m (Describe desc h :> api) where
+  type Client m (Describe desc h :> api) = Client m (h :> api)
+
+  clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy (h :> api))
+
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy (h :> api)) f cl
+
 -- | If you use a 'QueryParam' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
 -- an additional argument of the type specified by your 'QueryParam',

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

@@ -55,7 +55,7 @@ import           Data.String.Conversions
 import           Data.Text
                  (Text, unpack)
 import           GHC.Generics
-                 (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
+                 (K1(K1), M1(M1), U1(U1), V1,
                  (:*:)((:*:)), (:+:)(L1, R1))
 import qualified GHC.Generics               as G
 import           GHC.TypeLits
@@ -561,6 +561,10 @@ instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
             mkHeader (Just x) = (headerName, cs $ toHeader x)
             mkHeader Nothing  = (headerName, "<no header sample provided>")
 
+instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
+    => AllHeaderSamples (Describe desc (Header h l) ': ls) where
+    allHeaderToSample _ = allHeaderToSample (Proxy :: Proxy (Header h l ': ls))
+
 -- | Synthesise a sample value of a type, encoded in the specified media types.
 sampleByteString
     :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
@@ -1023,6 +1027,10 @@ instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
             Just x -> cs $ toHeader x
             Nothing -> "<no header sample provided>"
 
+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
+      => HasDocs (Describe desc (Header' mods sym a) :> api) where
+  docsFor Proxy = docsFor (Proxy :: Proxy (Header' mods sym a :> api))
+
 instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
       => HasDocs (QueryParam' mods sym a :> api) where
 

servant-docs/test/Servant/DocsSpec.hs

@@ -190,13 +190,13 @@ newtype TestTreeM a = TestTreeM (Writer [TestTree] a)
 runTestTreeM :: TestTreeM () -> [TestTree]
 runTestTreeM (TestTreeM m) = snd (runWriter m)
 
-class Describe r where
+class DescribeTest r where
     describe :: TestName -> TestTreeM () -> r
 
-instance a ~ () =>  Describe (TestTreeM a) where
+instance a ~ () =>  DescribeTest (TestTreeM a) where
     describe n t = TestTreeM $ tell [ describe n t ]
 
-instance Describe TestTree where
+instance DescribeTest TestTree where
     describe n t = testGroup n $ runTestTreeM t
 
 it :: TestName -> Assertion -> TestTreeM ()

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

@@ -515,6 +515,13 @@ instance HasForeign lang ftype api
   foreignFor lang ftype Proxy req =
     foreignFor lang ftype (Proxy :: Proxy api) req
 
+instance HasForeign lang ftype (h :> api)
+  => HasForeign lang ftype (Describe desc h :> api) where
+  type Foreign ftype (Describe desc h :> api) = Foreign ftype (h :> api)
+
+  foreignFor lang ftype Proxy req =
+    foreignFor lang ftype (Proxy :: Proxy (h :> api)) req
+
 instance HasForeign lang ftype (ToServantApi r) => HasForeign lang ftype (NamedRoutes r) where
   type Foreign ftype (NamedRoutes r) = Foreign ftype (ToServantApi r)
 

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

@@ -59,7 +59,7 @@ import qualified Data.Text                                  as T
 import           Data.Typeable
 import           GHC.Generics
 import           GHC.TypeLits
-                 (KnownNat, KnownSymbol, TypeError, symbolVal)
+                 (ErrorMessage (..), KnownNat, KnownSymbol, TypeError, symbolVal)
 import qualified Network.HTTP.Media                         as NHM
 import           Network.HTTP.Types                         hiding
                  (Header, ResponseHeaders)
@@ -73,7 +73,7 @@ import           Prelude ()
 import           Prelude.Compat
 import           Servant.API
                  ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
-                 CaptureAll, Description, EmptyAPI, Fragment,
+                 CaptureAll, Describe, Description, EmptyAPI, Fragment,
                  FramingRender (..), FramingUnrender (..), FromSourceIO (..),
                  Header', If, IsSecure (..), NoContentVerb, QueryFlag,
                  QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
@@ -111,8 +111,6 @@ import           Servant.Server.Internal.RouteResult
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServerError
 
-import           GHC.TypeLits
-                 (ErrorMessage (..), TypeError)
 import           Servant.API.TypeLevel
                  (AtLeastOneFragment, FragmentUnique)
 
@@ -485,6 +483,20 @@ instance
                     <> headerName
                     <> " failed: " <> e
 
+instance
+  (KnownSymbol sym, FromHttpApiData a, HasServer api context
+  , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
+  , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
+  )
+  => HasServer (Describe desc (Header' mods sym a) :> api) context where
+------
+  type ServerT (Describe desc (Header' mods sym a) :> api) m =
+    RequestArgument mods a -> ServerT api m
+
+  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy (Header' mods sym a :> api))
+
+  route _ = route (Proxy :: Proxy (Header' mods sym a :> api))
+
 -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
 -- that takes an argument of type @'Maybe' 'Text'@.

servant-server/test/Servant/ServerSpec.hs

@@ -53,8 +53,8 @@ import           Network.Wai.Test
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
-                 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
+                 Delete, Describe, EmptyAPI, Fragment, Get, HasStatus (StatusOf),
+                 Header, Headers, HttpVersion, IsSecure (..), JSON, Lenient,
                  NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
                  PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
                  RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
@@ -121,6 +121,7 @@ type VerbApi method status
  :<|> "noContent" :> NoContentVerb method
  :<|> "header"    :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
  :<|> "headerNC"  :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
+ :<|> "headerD"   :> Verb method status '[JSON] (Headers '[Describe "desc" (Header "D" Int)] Person)
  :<|> "accept"    :> (    Verb method status '[JSON] Person
                      :<|> Verb method status '[PlainText] String
                      )
@@ -133,6 +134,7 @@ verbSpec = describe "Servant.API.Verb" $ do
           :<|> return NoContent
           :<|> return (addHeader 5 alice)
           :<|> return (addHeader 10 NoContent)
+          :<|> return (addHeader 5 alice)
           :<|> (return alice :<|> return "B")
           :<|> return (S.source ["bytestring"])
 
@@ -177,6 +179,10 @@ verbSpec = describe "Servant.API.Verb" $ do
             liftIO $ statusCode (simpleStatus response2) `shouldBe` status
             liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
 
+            response3 <- THW.request method "/headerD" [] ""
+            liftIO $ statusCode (simpleStatus response3) `shouldBe` status
+            liftIO $ simpleHeaders response3 `shouldContain` [("D", "5")]
+
           it "handles trailing '/' gracefully" $ do
             response <- THW.request method "/headerNC/" [] ""
             liftIO $ statusCode (simpleStatus response) `shouldBe` status

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

@@ -38,7 +38,6 @@ import           Network.HTTP.Media                     (MediaType)
 import           Servant.API
 import           Servant.API.Description                (FoldDescription,
                                                          reflectDescription)
-import           Servant.API.Generic                    (ToServantApi, AsApi)
 import           Servant.API.Modifiers                  (FoldRequired)
 
 import           Servant.Swagger.Internal.TypeLevel.API
@@ -398,6 +397,20 @@ instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub)
             & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
                 & default_ ?~ toJSON False))
 
+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol desc) => HasSwagger (Describe desc (Header' mods  sym a) :> sub) where
+  toSwagger _ = toSwagger (Proxy :: Proxy sub)
+    & addParam param
+    & addDefaultResponse400 tname
+    where
+      tname = Text.pack (symbolVal (Proxy :: Proxy sym))
+      param = mempty
+        & name .~ tname
+        & description ?~ Text.pack (symbolVal (Proxy :: Proxy desc))
+        & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
+        & schema .~ ParamOther (mempty
+            & in_ .~ ParamHeader
+            & paramSchema .~ toParamSchema (Proxy :: Proxy a))
+
 instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods  sym a :> sub) where
   toSwagger _ = toSwagger (Proxy :: Proxy sub)
     & addParam param

servant/src/Servant/API.hs

@@ -96,7 +96,7 @@ import           Servant.API.ContentTypes
                  MimeUnrender (..), NoContent (NoContent), OctetStream,
                  PlainText)
 import           Servant.API.Description
-                 (Description, Summary)
+                 (Describe, Description, Summary)
 import           Servant.API.Empty
                  (EmptyAPI (..))
 import           Servant.API.Experimental.Auth

servant/src/Servant/API/Description.hs

@@ -5,9 +5,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
-{-# OPTIONS_HADDOCK not-home    #-}
+{-# OPTIONS_HADDOCK not-home     #-}
 module Servant.API.Description (
     -- * Combinators
+    Describe,
     Description,
     Summary,
     -- * Used as modifiers
@@ -46,6 +47,21 @@ data Summary (sym :: Symbol)
 data Description (sym :: Symbol)
     deriving (Typeable)
 
+-- | Add a description to 'Header'.
+--
+-- Example:
+--
+-- >>> :{
+-- Describe "Indicates to the client total count of items in collection"
+--  (Header "Total-Count" Int)
+-- :}
+--
+-- NOTE: currently there is ability to provide description to `Header'` (note ')
+-- via mods (see 'FoldDescription'), but this is not possible for simple 'Header'.
+-- 'FoldDescription' should be reviewed in future.
+data Describe (sym :: Symbol) (a :: *)
+    deriving (Typeable)
+
 -- | Fold list of modifiers to extract description as a type-level String.
 --
 -- >>> :kind! FoldDescription '[]

servant/src/Servant/API/ResponseHeaders.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
 {-# OPTIONS_HADDOCK not-home        #-}
+{-# LANGUAGE InstanceSigs #-}
 
 -- | This module provides facilities for adding headers to a response.
 --
@@ -37,7 +38,7 @@ module Servant.API.ResponseHeaders
 import           Control.DeepSeq
                  (NFData (..))
 import           Data.ByteString.Char8     as BS
-                 (ByteString, init, pack, unlines)
+                 (ByteString, pack)
 import qualified Data.CaseInsensitive      as CI
 import qualified Data.List                 as L
 import           Data.Proxy
@@ -51,6 +52,8 @@ import           Web.HttpApiData
 
 import           Prelude ()
 import           Prelude.Compat
+import           Servant.API.Description
+                 (Describe)
 import           Servant.API.Header
                  (Header)
 import           Servant.API.UVerb.Union
@@ -94,6 +97,8 @@ instance NFDataHList xs => NFData (HList xs) where
 type family HeaderValMap (f :: * -> *) (xs :: [*]) where
     HeaderValMap f '[]                = '[]
     HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs
+    HeaderValMap f (Describe desc (Header h x) ': xs)
+                                      = Header h (f x) ': HeaderValMap f xs
 
 
 class BuildHeadersTo hs where
@@ -167,11 +172,24 @@ instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
          => AddHeader h v (Headers (fst ': rest)  a) (Headers (Header h v  ': fst ': rest) a) where
     addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
 
+-- instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
+--          => AddHeader h v (Headers (fst ': rest)  a) (Headers (Describe desc (Header h v)  ': fst ': rest) a) where
+--     addOptionalHeader
+--       :: (KnownSymbol h, ToHttpApiData v)
+--       => ResponseHeader h v
+--       -> Headers (fst : rest) a
+--       -> Headers (Header h v: fst : rest) a
+--     addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
+
 -- In this instance, 'a' parameter is decorated with a Header.
 instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
          => AddHeader h v a new where
     addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
 
+-- instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Describe desc (Header h v)] a)
+--          => AddHeader h v a new where
+--     addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
+
 -- Instances to decorate all responses in a 'Union' with headers. The functional
 -- dependencies force us to consider singleton lists as the base case in the
 -- recursion (it is impossible to determine h and v otherwise from old / new

servant/src/Servant/Links.hs

@@ -154,7 +154,7 @@ import           Servant.API.BasicAuth
 import           Servant.API.Capture
                  (Capture', CaptureAll)
 import           Servant.API.Description
-                 (Description, Summary)
+                 (Describe, Description, Summary)
 import           Servant.API.Empty
                  (EmptyAPI (..))
 import           Servant.API.Experimental.Auth
@@ -548,6 +548,10 @@ instance HasLink sub => HasLink (Summary s :> sub) where
     type MkLink (Summary s :> sub) a = MkLink sub a
     toLink = simpleToLink (Proxy :: Proxy sub)
 
+instance HasLink sub => HasLink (Describe desc (Header' mods sym (a :: *)) :> sub) where
+    type MkLink (Describe desc (Header' mods sym (a :: *)) :> sub) r = MkLink sub r
+    toLink = simpleToLink (Proxy :: Proxy sub)
+
 instance HasLink sub => HasLink (HttpVersion :> sub) where
     type MkLink (HttpVersion:> sub) a = MkLink sub a
     toLink = simpleToLink (Proxy :: Proxy sub)

servant/src/Servant/Test/ComprehensiveAPI.hs

@@ -70,6 +70,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
     :<|> "capture-all"      :> CaptureAll "foo" Int :> GET
     :<|> "summary"          :> Summary "foo" :> GET
     :<|> "description"      :> Description "foo" :> GET
+    :<|> "describe"         :> Describe "example description" (Header "foo" Int) :> GET
     :<|> "alternative"      :> ("left" :> GET :<|> "right" :> GET)
     :<|> "fragment"         :> Fragment Int :> GET
     :<|> "resource"         :> WithResource Int :> GET