diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index eb76b253c..4445e6e8c 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/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', diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 970813d6d..35c64745e 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/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, "") +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 -> "" +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 diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 4a9efaee9..1b1cfae8c 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/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 () diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 71f1c9a0d..551c9480c 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/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) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index c3a7a2c32..943395374 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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'@. diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 89375736f..d7c7d06b9 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index 5f7a1ff30..22f129a95 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 80d36bc09..f2f185ea6 100644 --- a/servant/src/Servant/API.hs +++ b/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 diff --git a/servant/src/Servant/API/Description.hs b/servant/src/Servant/API/Description.hs index 18c54322f..d5343169b 100644 --- a/servant/src/Servant/API/Description.hs +++ b/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 '[] diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 490553c51..86f3312c8 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/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 diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 08f044dfe..a5217835e 100644 --- a/servant/src/Servant/Links.hs +++ b/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) diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index adfb5d25a..1f71a6fb5 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/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