From e52777c3a4dd1739839792a147a73d3af3971ddf Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 9 Feb 2018 12:05:30 +0200 Subject: [PATCH] Add description modifier helpers and parametrise Capture --- .../Servant/Client/Core/Internal/HasClient.hs | 6 +-- servant-docs/src/Servant/Docs/Internal.hs | 2 +- .../src/Servant/Foreign/Internal.hs | 4 +- servant-server/src/Servant/Server/Internal.hs | 14 +++--- servant/CHANGELOG.md | 6 ++- servant/src/Servant/API.hs | 2 +- servant/src/Servant/API/Capture.hs | 8 +-- servant/src/Servant/API/Description.hs | 50 +++++++++++++++++-- .../API/Internal/Test/ComprehensiveAPI.hs | 2 +- servant/src/Servant/Utils/Links.hs | 6 +-- 10 files changed, 73 insertions(+), 27 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 20a65db7..372e6027 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -34,7 +34,7 @@ import Servant.API ((:<|>) ((:<|>)), (:>), BuildHeadersTo (..), BuildFromStream (..), ByteStringParser (..), - Capture, CaptureAll, + Capture', CaptureAll, Description, EmptyAPI, FramingUnrender (..), Header', Headers (..), @@ -155,9 +155,9 @@ instance RunClient m => HasClient m EmptyAPI where -- > getBook = client myApi -- > -- then you can just use "getBook" to query that endpoint instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) - => HasClient m (Capture capture a :> api) where + => HasClient m (Capture' mods capture a :> api) where - type Client m (Capture capture a :> api) = + type Client m (Capture' mods capture a :> api) = a -> Client m api clientWithRoute pm Proxy req val = diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 26da3a1c..4ba7c962 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -795,7 +795,7 @@ instance HasDocs EmptyAPI where -- | @"books" :> 'Capture' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs. instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) - => HasDocs (Capture sym a :> api) where + => HasDocs (Capture' mods sym a :> api) where docsFor Proxy (endpoint, action) = docsFor subApiP (endpoint', action') diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 87892b69..69a21481 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -195,8 +195,8 @@ instance HasForeign lang ftype EmptyAPI where foreignFor Proxy Proxy Proxy _ = EmptyForeignAPI instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api) - => HasForeign lang ftype (Capture sym t :> api) where - type Foreign ftype (Capture sym t :> api) = Foreign ftype api + => HasForeign lang ftype (Capture' mods sym t :> api) where + type Foreign ftype (Capture' mods sym t :> api) = Foreign ftype api foreignFor lang Proxy Proxy req = foreignFor lang Proxy (Proxy :: Proxy api) $ diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 0a1f961d..65b71a63 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -67,7 +67,7 @@ import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) -import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, +import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture', CaptureAll, Verb, EmptyAPI, ReflectMethod(reflectMethod), IsSecure(..), Header', QueryFlag, @@ -164,9 +164,9 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) - => HasServer (Capture capture a :> api) context where + => HasServer (Capture' mods capture a :> api) context where - type ServerT (Capture capture a :> api) m = + type ServerT (Capture' mods capture a :> api) m = a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s @@ -749,14 +749,14 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA -- ... -- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. -- ...Maybe you haven't applied enough arguments to --- ...Capture "foo" +-- ...Capture' '[] "foo" -- ... -- -- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int) -- ... -- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. -- ...Maybe you haven't applied enough arguments to --- ...Capture "foo" +-- ...Capture' '[] "foo" -- ... -- instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context @@ -778,7 +778,7 @@ type HasServerArrowKindError arr = -- ... -- ...No instance HasServer (a -> b). -- ...Maybe you have used '->' instead of ':>' between --- ...Capture "foo" Int +-- ...Capture' '[] "foo" Int -- ...and -- ...Verb 'GET 200 '[JSON] Int -- ... @@ -787,7 +787,7 @@ type HasServerArrowKindError arr = -- ... -- ...No instance HasServer (a -> b). -- ...Maybe you have used '->' instead of ':>' between --- ...Capture "foo" Int +-- ...Capture' '[] "foo" Int -- ...and -- ...Verb 'GET 200 '[JSON] Int -- ... diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index a249d5b7..f7449e42 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -18,12 +18,16 @@ - [Querying an API - Querying Streaming APIs](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/Client.html#querying-streaming-apis) - *servant* Add `Servant.API.Modifiers` - ([#873](https://github.com/haskell-servant/servant/pull/873)) + ([#873](https://github.com/haskell-servant/servant/pull/873) + [#903](https://github.com/haskell-servant/servant/pull/903)) `QueryParam`, `Header` and `ReqBody` understand modifiers: - `Required` or `Optional` (resulting in `a` or `Maybe a` in handlers) - `Strict` or `Lenient` (resulting in `a` or `Either String a` in handlers) + Also you can use `Description` as a modifier, but it doesn't yet work + with `servant-docs`, only `servant-swagger`. [There is an issue.](https://github.com/haskell-servant/servant/issues/902) + - *servant-client* Support `http-client`’s `CookieJar` ([#897](https://github.com/haskell-servant/servant/pull/897) [#883](https://github.com/haskell-servant/servant/pull/883)) diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 9e9af80a..7ed610f3 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -74,7 +74,7 @@ module Servant.API ( import Servant.API.Alternative ((:<|>) (..)) import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) -import Servant.API.Capture (Capture, CaptureAll) +import Servant.API.Capture (Capture, Capture', CaptureAll) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, JSON, MimeRender (..), NoContent (NoContent), diff --git a/servant/src/Servant/API/Capture.hs b/servant/src/Servant/API/Capture.hs index 3db3cdd8..57317e7a 100644 --- a/servant/src/Servant/API/Capture.hs +++ b/servant/src/Servant/API/Capture.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Capture (Capture, CaptureAll) where +module Servant.API.Capture (Capture, Capture', CaptureAll) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) @@ -12,9 +12,11 @@ import GHC.TypeLits (Symbol) -- -- >>> -- GET /books/:isbn -- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -data Capture (sym :: Symbol) (a :: *) - deriving (Typeable) +type Capture = Capture' '[] -- todo +-- | 'Capture' which can be modified. For example with 'Description'. +data Capture' (mods :: [*]) (sym :: Symbol) (a :: *) + deriving (Typeable) -- | Capture all remaining values from the request path under a certain type -- @a@. diff --git a/servant/src/Servant/API/Description.hs b/servant/src/Servant/API/Description.hs index 1f3b408e..fee0bc8a 100644 --- a/servant/src/Servant/API/Description.hs +++ b/servant/src/Servant/API/Description.hs @@ -1,11 +1,25 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Description (Description, Summary) where +module Servant.API.Description ( + -- * Combinators + Description, + Summary, + -- * Used as modifiers + FoldDescription, + FoldDescription', + reflectDescription, + ) where import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import Data.Proxy (Proxy (..)) + -- | Add a short summary for (part of) API. -- -- Example: @@ -29,6 +43,32 @@ data Summary (sym :: Symbol) data Description (sym :: Symbol) deriving (Typeable) +-- | Fold modifier list to decide whether argument should be parsed strictly or leniently. +-- +-- >>> :kind! FoldDescription '[] +-- FoldDescription '[] :: Symbol +-- = "" +-- +-- >>> :kind! FoldDescription '[Required, Description "foobar", Lenient] +-- FoldDescription '[Required, Description "foobar", Lenient] :: Symbol +-- = "foobar" +-- +type FoldDescription mods = FoldDescription' "" mods + +-- | Implementation of 'FoldDescription'. +type family FoldDescription' (acc :: Symbol) (mods :: [*]) :: Symbol where + FoldDescription' acc '[] = acc + FoldDescription' acc (Description desc ': mods) = FoldDescription' desc mods + FoldDescription' acc (mod ': mods) = FoldDescription' acc mods + +-- | Reflect description to the term level. +-- +-- >>> reflectDescription (Proxy :: Proxy '[Required, Description "foobar", Lenient]) +-- "foobar" +-- +reflectDescription :: forall mods. KnownSymbol (FoldDescription mods) => Proxy mods -> String +reflectDescription _ = symbolVal (Proxy :: Proxy (FoldDescription mods)) + -- $setup -- >>> import Servant.API -- >>> import Data.Aeson diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index b628e88b..d6eb763c 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -22,7 +22,7 @@ comprehensiveAPI = Proxy type ComprehensiveAPIWithoutRaw = GET :<|> Get '[JSON] Int :<|> - Capture "foo" Int :> GET :<|> + Capture' '[Description "example description"] "foo" Int :> GET :<|> Header "foo" Int :> GET :<|> Header' '[Required, Lenient] "bar" Int :> GET :<|> HttpVersion :> GET :<|> diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 44921d1e..65c46861 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -115,7 +115,7 @@ import Prelude.Compat import Web.HttpApiData import Servant.API.Alternative ( (:<|>)((:<|>)) ) import Servant.API.BasicAuth ( BasicAuth ) -import Servant.API.Capture ( Capture, CaptureAll ) +import Servant.API.Capture ( Capture', CaptureAll ) import Servant.API.ReqBody ( ReqBody' ) import Servant.API.QueryParam ( QueryParam', QueryParams, QueryFlag ) import Servant.API.Header ( Header' ) @@ -336,8 +336,8 @@ instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where toLink _ = toLink (Proxy :: Proxy sub) instance (ToHttpApiData v, HasLink sub) - => HasLink (Capture sym v :> sub) where - type MkLink (Capture sym v :> sub) = v -> MkLink sub + => HasLink (Capture' mods sym v :> sub) where + type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub toLink _ l v = toLink (Proxy :: Proxy sub) $ addSegment (escaped . Text.unpack $ toUrlPiece v) l