servant 0.14 → 0.14.1
raw patch · 9 files changed
+890/−634 lines, 9 filesdep ~QuickCheckdep ~basedep ~doctest
Dependency ranges changed: QuickCheck, base, doctest
Files
- CHANGELOG.md +13/−0
- servant.cabal +9/−4
- src/Servant/API.hs +3/−3
- src/Servant/API/Generic.hs +146/−0
- src/Servant/API/Verbs.hs +1/−1
- src/Servant/Links.hs +573/−0
- src/Servant/Utils/Links.hs +4/−485
- test/Servant/LinksSpec.hs +141/−0
- test/Servant/Utils/LinksSpec.hs +0/−141
CHANGELOG.md view
@@ -1,5 +1,18 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14.1+------++- Merge in (and slightly refactor) `servant-generic`+ (by [Patrick Chilton](https://github.com/chpatrick))+ into `servant` (`Servant.API.Generic`),+ `servant-client-code` (`Servant.Client.Generic`)+ and `servant-server` (`Servant.Server.Generic`).++- Deprecate `Servant.Utils.Links`, use `Servant.Links`.++- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.+ 0.14 ----
servant.cabal view
@@ -1,5 +1,5 @@ name: servant-version: 0.14+version: 0.14.1 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them@@ -46,6 +46,7 @@ Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth+ Servant.API.Generic Servant.API.Header Servant.API.HttpVersion Servant.API.Internal.Test.ComprehensiveAPI@@ -62,6 +63,10 @@ Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext+ Servant.Links++ -- Deprecated modules, to be removed in late 2019+ exposed-modules: Servant.Utils.Links Servant.Utils.Enter @@ -133,8 +138,8 @@ other-modules: Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec- Servant.Utils.LinksSpec Servant.Utils.EnterSpec+ Servant.LinksSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends:@@ -164,7 +169,7 @@ build-depends: base , servant- , doctest >= 0.15.0 && <0.16+ , doctest >= 0.15.0 && <0.17 -- We test Links failure with doctest, so we need extra dependencies build-depends:@@ -179,4 +184,4 @@ x-doctest-options: -fdiagnostics-color=never include-dirs: include x-doctest-source-dirs: test- x-doctest-modules: Servant.Utils.LinksSpec+ x-doctest-modules: Servant.LinksSpec
src/Servant/API.hs view
@@ -63,8 +63,8 @@ module Servant.API.Experimental.Auth, -- | General Authentication - -- * Utilities- module Servant.Utils.Links,+ -- * Links+ module Servant.Links, -- | Type-safe internal URIs -- * Re-exports@@ -134,7 +134,7 @@ ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext)-import Servant.Utils.Links+import Servant.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
+ src/Servant/API/Generic.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+-- | Define servant servers from record types. Generics for the win.+--+-- The usage is simple, if you only need a collection of routes. First you+-- define a record with field types prefixed by a parameter `route`:+--+-- @+-- data Routes route = Routes+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool+-- }+-- deriving ('Generic')+-- @+--+-- You can get a 'Proxy' of the server using+--+-- @+-- api :: Proxy (ToServantApi Routes)+-- api = genericApi (Proxy :: Proxy Routes)+-- @+--+-- Using 'genericApi' is better as it checks that instances exists,+-- i.e. you get better error messages than simply using 'Proxy' value.+--+-- __Note:__ in 0.14 series this module isn't re-exported from 'Servant.API'.+--+-- "Servant.API.Generic" is based on @servant-generic@ package by+-- [Patrick Chilton](https://github.com/chpatrick)+--+-- @since 0.14.1+module Servant.API.Generic (+ GenericMode (..),+ GenericServant,+ ToServant,+ toServant,+ fromServant,+ -- * AsApi+ AsApi,+ ToServantApi,+ genericApi,+ -- * Utility+ GServantProduct,+ -- * re-exports+ Generic (Rep),+ ) where++-- Based on servant-generic licensed under MIT License+--+-- Copyright (c) 2017 Patrick Chilton+--+-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be included in all+-- copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.++import Data.Proxy+ (Proxy (..))+import GHC.Generics+ ((:*:) (..), Generic (..), K1 (..), M1 (..))++import Servant.API.Alternative++-- | A constraint alias, for work with 'mode' and 'routes'.+type GenericServant routes mode = (GenericMode mode, Generic (routes mode), GServantProduct (Rep (routes mode)))++-- | A class with a type family that applies an appropriate type family to the @api@+-- parameter. For example, 'AsApi' will leave @api@ untouched, while+-- @'AsServerT' m@ will produce @'ServerT' api m@.+class GenericMode mode where+ type mode :- api :: *++infixl 0 :-++-- | Turns a generic product type into a tree of `:<|>` combinators.+type ToServant routes mode = GToServant (Rep (routes mode))++type ToServantApi routes = ToServant routes AsApi++-- | See `ToServant`, but at value-level.+toServant+ :: GenericServant routes mode+ => routes mode -> ToServant routes mode+toServant = gtoServant . from++-- | Inverse of `toServant`.+--+-- This can be used to turn 'generated' values such as client functions into records.+--+-- You may need to provide a type signature for the /output/ type (your record type).+fromServant+ :: GenericServant routes mode+ => ToServant routes mode -> routes mode+fromServant = to . gfromServant++-- | A type that specifies that an API record contains an API definition. Only useful at type-level.+data AsApi+instance GenericMode AsApi where+ type AsApi :- api = api++-- | Get a 'Proxy' of an API type.+genericApi+ :: GenericServant routes AsApi+ => Proxy routes+ -> Proxy (ToServantApi routes)+genericApi _ = Proxy++-------------------------------------------------------------------------------+-- Class+-------------------------------------------------------------------------------+++class GServantProduct f where+ type GToServant f+ gtoServant :: f p -> GToServant f+ gfromServant :: GToServant f -> f p++instance GServantProduct f => GServantProduct (M1 i c f) where+ type GToServant (M1 i c f) = GToServant f+ gtoServant = gtoServant . unM1+ gfromServant = M1 . gfromServant++instance (GServantProduct l, GServantProduct r) => GServantProduct (l :*: r) where+ type GToServant (l :*: r) = GToServant l :<|> GToServant r+ gtoServant (l :*: r) = gtoServant l :<|> gtoServant r+ gfromServant (l :<|> r) = gfromServant l :*: gfromServant r++instance GServantProduct (K1 i c) where+ type GToServant (K1 i c) = c+ gtoServant = unK1+ gfromServant = K1
src/Servant/API/Verbs.hs view
@@ -58,7 +58,7 @@ -- -- If the resource cannot be created immediately, use 'PostAccepted'. ----- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header+-- Consider using 'Servant.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code.
+ src/Servant/Links.hs view
@@ -0,0 +1,573 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Type safe generation of internal links.+--+-- Given an API with a few endpoints:+--+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators+-- >>> import Servant.API+-- >>> import Servant.Links+-- >>> import Data.Proxy+-- >>>+-- >>> type Hello = "hello" :> Get '[JSON] Int+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent+-- >>> type API = Hello :<|> Bye+-- >>> let api = Proxy :: Proxy API+--+-- It is possible to generate links that are guaranteed to be within 'API' with+-- 'safeLink'. The first argument to 'safeLink' is a type representing the API+-- you would like to restrict links to. The second argument is the destination+-- endpoint you would like the link to point to, this will need to end with a+-- verb like GET or POST. Further arguments may be required depending on the+-- type of the endpoint. If everything lines up you will get a 'Link' out the+-- other end.+--+-- You may omit 'QueryParam's and the like should you not want to provide them,+-- but types which form part of the URL path like 'Capture' must be included.+-- The reason you may want to omit 'QueryParam's is that safeLink is a bit+-- magical: if parameters are included that could take input it will return a+-- function that accepts that input and generates a link. This is best shown+-- with an example. Here, a link is generated with no parameters:+--+-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)+-- >>> toUrlPiece (safeLink api hello :: Link)+-- "hello"+--+-- If the API has an endpoint with parameters then we can generate links with+-- or without those:+--+-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")+-- "bye?name=Hubert"+--+-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)+-- >>> toUrlPiece $ safeLink api without+-- "bye"+--+-- If you would like create a helper for generating links only within that API,+-- you can partially apply safeLink if you specify a correct type signature+-- like so:+--+-- >>> :set -XConstraintKinds+-- >>> :{+-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)+-- >>> => Proxy endpoint -> MkLink endpoint Link+-- >>> apiLink = safeLink api+-- >>> :}+--+-- `safeLink'` allows to make specialise the output:+--+-- >>> safeLink' toUrlPiece api without+-- "bye"+--+-- >>> :{+-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)+-- >>> => Proxy endpoint -> MkLink endpoint Text+-- >>> apiTextLink = safeLink' toUrlPiece api+-- >>> :}+--+-- >>> apiTextLink without+-- "bye"+--+-- Attempting to construct a link to an endpoint that does not exist in api+-- will result in a type error like this:+--+-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)+-- >>> safeLink api bad_link+-- ...+-- ...Could not deduce...+-- ...+--+-- This error is essentially saying that the type family couldn't find+-- bad_link under api after trying the open (but empty) type family+-- `IsElem'` as a last resort.+--+-- @since 0.14.1+module Servant.Links (+ module Servant.API.TypeLevel,++ -- * Building and using safe links+ --+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.+ safeLink+ , safeLink'+ , allLinks+ , allLinks'+ , URI(..)+ -- * Generics+ , AsLink+ , fieldLink+ , fieldLink'+ , allFieldLinks+ , allFieldLinks'+ -- * Adding custom types+ , HasLink(..)+ , Link+ , linkURI+ , linkURI'+ , LinkArrayElementStyle (..)+ -- ** Link accessors+ , Param (..)+ , linkSegments+ , linkQueryParams+) where++import Data.List+import Data.Proxy+ (Proxy (..))+import Data.Semigroup+ ((<>))+import Data.Singletons.Bool+ (SBool (..), SBoolI (..))+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import Data.Type.Bool+ (If)+import GHC.TypeLits+ (KnownSymbol, symbolVal)+import Network.URI+ (URI (..), escapeURIString, isUnreserved)+import Prelude ()+import Prelude.Compat++import Servant.API.Alternative+ ((:<|>) ((:<|>)))+import Servant.API.BasicAuth+ (BasicAuth)+import Servant.API.Capture+ (Capture', CaptureAll)+import Servant.API.Description+ (Description, Summary)+import Servant.API.Empty+ (EmptyAPI (..))+import Servant.API.Experimental.Auth+ (AuthProtect)+import Servant.API.Generic+import Servant.API.Header+ (Header')+import Servant.API.HttpVersion+ (HttpVersion)+import Servant.API.IsSecure+ (IsSecure)+import Servant.API.Modifiers+ (FoldRequired)+import Servant.API.QueryParam+ (QueryFlag, QueryParam', QueryParams)+import Servant.API.Raw+ (Raw)+import Servant.API.RemoteHost+ (RemoteHost)+import Servant.API.ReqBody+ (ReqBody')+import Servant.API.Stream+ (Stream)+import Servant.API.Sub+ (type (:>))+import Servant.API.TypeLevel+import Servant.API.Vault+ (Vault)+import Servant.API.Verbs+ (Verb)+import Servant.API.WithNamedContext+ (WithNamedContext)+import Web.HttpApiData++-- | A safe link datatype.+-- The only way of constructing a 'Link' is using 'safeLink', which means any+-- 'Link' is guaranteed to be part of the mentioned API.+data Link = Link+ { _segments :: [Escaped]+ , _queryParams :: [Param]+ } deriving Show++newtype Escaped = Escaped String++escaped :: String -> Escaped+escaped = Escaped . escapeURIString isUnreserved++getEscaped :: Escaped -> String+getEscaped (Escaped s) = s++instance Show Escaped where+ showsPrec d (Escaped s) = showsPrec d s+ show (Escaped s) = show s++linkSegments :: Link -> [String]+linkSegments = map getEscaped . _segments++linkQueryParams :: Link -> [Param]+linkQueryParams = _queryParams++instance ToHttpApiData Link where+ toHeader = TE.encodeUtf8 . toUrlPiece+ toUrlPiece l =+ let uri = linkURI l+ in Text.pack $ uriPath uri ++ uriQuery uri++-- | Query parameter.+data Param+ = SingleParam String Text.Text+ | ArrayElemParam String Text.Text+ | FlagParam String+ deriving Show++addSegment :: Escaped -> Link -> Link+addSegment seg l = l { _segments = _segments l <> [seg] }++addQueryParam :: Param -> Link -> Link+addQueryParam qp l =+ l { _queryParams = _queryParams l <> [qp] }++-- | Transform 'Link' into 'URI'.+--+-- >>> type API = "something" :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)+-- something+--+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x[]=1&x[]=2&x[]=3+--+-- >>> type API = "foo/bar" :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)+-- foo%2Fbar+--+-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()+-- >>> let someRoute = Proxy :: Proxy SomeRoute+-- >>> safeLink someRoute someRoute "test@example.com"+-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}+--+-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"+-- abc/test%40example.com+--+linkURI :: Link -> URI+linkURI = linkURI' LinkArrayElementBracket++-- | How to encode array query elements.+data LinkArrayElementStyle+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@+ deriving (Eq, Ord, Show, Enum, Bounded)++-- | Configurable 'linkURI'.+--+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x[]=1&x[]=2&x[]=3+--+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x=1&x=2&x=3+--+linkURI' :: LinkArrayElementStyle -> Link -> URI+linkURI' addBrackets (Link segments q_params) =+ URI mempty -- No scheme (relative)+ Nothing -- Or authority (relative)+ (intercalate "/" $ map getEscaped segments)+ (makeQueries q_params) mempty+ where+ makeQueries :: [Param] -> String+ makeQueries [] = ""+ makeQueries xs =+ "?" <> intercalate "&" (fmap makeQuery xs)++ makeQuery :: Param -> String+ makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)+ makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)+ makeQuery (FlagParam k) = escape k++ style = case addBrackets of+ LinkArrayElementBracket -> "[]="+ LinkArrayElementPlain -> "="++escape :: String -> String+escape = escapeURIString isUnreserved++-- | Create a valid (by construction) relative URI with query params.+--+-- This function will only typecheck if `endpoint` is part of the API `api`+safeLink+ :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)+ => Proxy api -- ^ The whole API that this endpoint is a part of+ -> Proxy endpoint -- ^ The API endpoint you would like to point to+ -> MkLink endpoint Link+safeLink = safeLink' id++-- | More general 'safeLink'.+--+safeLink'+ :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)+ => (Link -> a)+ -> Proxy api -- ^ The whole API that this endpoint is a part of+ -> Proxy endpoint -- ^ The API endpoint you would like to point to+ -> MkLink endpoint a+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)++-- | Create all links in an API.+--+-- Note that the @api@ type must be restricted to the endpoints that have+-- valid links to them.+--+-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double+-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)+-- >>> :t fooLink+-- fooLink :: Text -> Link+-- >>> :t barLink+-- barLink :: Int -> Link+--+-- Note: nested APIs don't work well with this approach+--+-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link+-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *+-- = Char -> (Int -> Link) :<|> (Double -> Link)+allLinks+ :: forall api. HasLink api+ => Proxy api+ -> MkLink api Link+allLinks = allLinks' id++-- | More general 'allLinks'. See `safeLink'`.+allLinks'+ :: forall api a. HasLink api+ => (Link -> a)+ -> Proxy api+ -> MkLink api a+allLinks' toA api = toLink toA api (Link mempty mempty)++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++-- | Given an API record field, create a link for that route. Only the field's+-- type is used.+--+-- @+-- data Record route = Record+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool+-- }+-- deriving ('Generic')+--+-- getLink :: Int -> Link+-- getLink = 'fieldLink' _get+-- @+--+-- @since 0.14.1+fieldLink+ :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint+ , GenericServant routes AsApi+ )+ => (routes AsApi -> endpoint)+ -> MkLink endpoint Link+fieldLink = fieldLink' id++-- | More general version of 'fieldLink'+--+-- @since 0.14.1+fieldLink'+ :: forall routes endpoint a.+ ( IsElem endpoint (ToServantApi routes), HasLink endpoint+ , GenericServant routes AsApi+ )+ => (Link -> a)+ -> (routes AsApi -> endpoint)+ -> MkLink endpoint a+fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)++-- | A type that specifies that an API record contains a set of links.+--+-- @since 0.14.1+data AsLink (a :: *)+instance GenericMode (AsLink a) where+ type (AsLink a) :- api = MkLink api a++-- | Get all links as a record.+--+-- @since 0.14.1+allFieldLinks+ :: ( HasLink (ToServantApi routes)+ , GenericServant routes (AsLink Link)+ , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link+ )+ => routes (AsLink Link)+allFieldLinks = allFieldLinks' id++-- | More general version of 'allFieldLinks'.+--+-- @since 0.14.1+allFieldLinks'+ :: forall routes a.+ ( HasLink (ToServantApi routes)+ , GenericServant routes (AsLink a)+ , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a+ )+ => (Link -> a)+ -> routes (AsLink a)+allFieldLinks' toA+ = fromServant+ $ allLinks' toA (Proxy :: Proxy (ToServantApi routes))++-------------------------------------------------------------------------------+-- HasLink+-------------------------------------------------------------------------------++-- | Construct a toLink for an endpoint.+class HasLink endpoint where+ type MkLink endpoint (a :: *)+ toLink+ :: (Link -> a)+ -> Proxy endpoint -- ^ The API endpoint you would like to point to+ -> Link+ -> MkLink endpoint a++-- Naked symbol instance+instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where+ type MkLink (sym :> sub) a = MkLink sub a+ toLink toA _ =+ toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)+ where+ seg = symbolVal (Proxy :: Proxy sym)++-- QueryParam instances+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))+ => HasLink (QueryParam' mods sym v :> sub)+ where+ type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a+ toLink toA _ l mv =+ toLink toA (Proxy :: Proxy sub) $+ case sbool :: SBool (FoldRequired mods) of+ STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l+ SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l+ where+ k :: String+ k = symbolVal (Proxy :: Proxy sym)++instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)+ => HasLink (QueryParams sym v :> sub)+ where+ type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a+ toLink toA _ l =+ toLink toA (Proxy :: Proxy sub) .+ foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l+ where+ k = symbolVal (Proxy :: Proxy sym)++instance (KnownSymbol sym, HasLink sub)+ => HasLink (QueryFlag sym :> sub)+ where+ type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a+ toLink toA _ l False =+ toLink toA (Proxy :: Proxy sub) l+ toLink toA _ l True =+ toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l+ where+ k = symbolVal (Proxy :: Proxy sym)++-- :<|> instance - Generate all links at once+instance (HasLink a, HasLink b) => HasLink (a :<|> b) where+ type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r+ toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l++-- Misc instances+instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where+ type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r+ toLink toA _ = toLink toA (Proxy :: Proxy sub)++instance (ToHttpApiData v, HasLink sub)+ => HasLink (Capture' mods sym v :> sub)+ where+ type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a+ toLink toA _ l v =+ toLink toA (Proxy :: Proxy sub) $+ addSegment (escaped . Text.unpack $ toUrlPiece v) l++instance (ToHttpApiData v, HasLink sub)+ => HasLink (CaptureAll sym v :> sub)+ where+ type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a+ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $+ foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs++instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where+ type MkLink (Header' mods sym a :> sub) r = MkLink sub r+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (Vault :> sub) where+ type MkLink (Vault :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (Description s :> sub) where+ type MkLink (Description s :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++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 (HttpVersion :> sub) where+ type MkLink (HttpVersion:> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (IsSecure :> sub) where+ type MkLink (IsSecure :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (WithNamedContext name context sub) where+ type MkLink (WithNamedContext name context sub) a = MkLink sub a+ toLink toA _ = toLink toA (Proxy :: Proxy sub)++instance HasLink sub => HasLink (RemoteHost :> sub) where+ type MkLink (RemoteHost :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (BasicAuth realm a :> sub) where+ type MkLink (BasicAuth realm a :> sub) r = MkLink sub r+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink EmptyAPI where+ type MkLink EmptyAPI a = EmptyAPI+ toLink _ _ _ = EmptyAPI++-- Verb (terminal) instances+instance HasLink (Verb m s ct a) where+ type MkLink (Verb m s ct a) r = r+ toLink toA _ = toA++instance HasLink Raw where+ type MkLink Raw a = a+ toLink toA _ = toA++instance HasLink (Stream m status fr ct a) where+ type MkLink (Stream m status fr ct a) r = r+ toLink toA _ = toA++-- AuthProtext instances+instance HasLink sub => HasLink (AuthProtect tag :> sub) where+ type MkLink (AuthProtect tag :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++-- | Helper for implemneting 'toLink' for combinators not affecting link+-- structure.+simpleToLink+ :: forall sub a combinator.+ (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)+ => Proxy sub+ -> (Link -> a)+ -> Proxy (combinator :> sub)+ -> Link+ -> MkLink (combinator :> sub) a+simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)+++-- $setup+-- >>> import Servant.API+-- >>> import Data.Text (Text)
src/Servant/Utils/Links.hs view
@@ -1,487 +1,6 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_HADDOCK not-home #-}---- | Type safe generation of internal links.------ Given an API with a few endpoints:------ >>> :set -XDataKinds -XTypeFamilies -XTypeOperators--- >>> import Servant.API--- >>> import Servant.Utils.Links--- >>> import Data.Proxy--- >>>--- >>> type Hello = "hello" :> Get '[JSON] Int--- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent--- >>> type API = Hello :<|> Bye--- >>> let api = Proxy :: Proxy API------ It is possible to generate links that are guaranteed to be within 'API' with--- 'safeLink'. The first argument to 'safeLink' is a type representing the API--- you would like to restrict links to. The second argument is the destination--- endpoint you would like the link to point to, this will need to end with a--- verb like GET or POST. Further arguments may be required depending on the--- type of the endpoint. If everything lines up you will get a 'Link' out the--- other end.------ You may omit 'QueryParam's and the like should you not want to provide them,--- but types which form part of the URL path like 'Capture' must be included.--- The reason you may want to omit 'QueryParam's is that safeLink is a bit--- magical: if parameters are included that could take input it will return a--- function that accepts that input and generates a link. This is best shown--- with an example. Here, a link is generated with no parameters:------ >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)--- >>> toUrlPiece (safeLink api hello :: Link)--- "hello"------ If the API has an endpoint with parameters then we can generate links with--- or without those:------ >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)--- >>> toUrlPiece $ safeLink api with (Just "Hubert")--- "bye?name=Hubert"------ >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)--- >>> toUrlPiece $ safeLink api without--- "bye"------ If you would like create a helper for generating links only within that API,--- you can partially apply safeLink if you specify a correct type signature--- like so:------ >>> :set -XConstraintKinds--- >>> :{--- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)--- >>> => Proxy endpoint -> MkLink endpoint Link--- >>> apiLink = safeLink api--- >>> :}------ `safeLink'` allows to make specialise the output:------ >>> safeLink' toUrlPiece api without--- "bye"------ >>> :{--- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)--- >>> => Proxy endpoint -> MkLink endpoint Text--- >>> apiTextLink = safeLink' toUrlPiece api--- >>> :}------ >>> apiTextLink without--- "bye"------ Attempting to construct a link to an endpoint that does not exist in api--- will result in a type error like this:------ >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)--- >>> safeLink api bad_link--- ...--- ...Could not deduce...--- ...------ This error is essentially saying that the type family couldn't find--- bad_link under api after trying the open (but empty) type family--- `IsElem'` as a last resort.-module Servant.Utils.Links (- module Servant.API.TypeLevel,-- -- * Building and using safe links- --- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.- safeLink- , safeLink'- , allLinks- , allLinks'- , URI(..)- -- * Adding custom types- , HasLink(..)- , Link- , linkURI- , linkURI'- , LinkArrayElementStyle (..)- -- ** Link accessors- , Param (..)- , linkSegments- , linkQueryParams-) where--import Data.List-import Data.Proxy- (Proxy (..))-import Data.Semigroup- ((<>))-import Data.Singletons.Bool- (SBool (..), SBoolI (..))-import qualified Data.Text as Text-import qualified Data.Text.Encoding as TE-import Data.Type.Bool- (If)-import GHC.TypeLits- (KnownSymbol, symbolVal)-import Network.URI- (URI (..), escapeURIString, isUnreserved)-import Prelude ()-import Prelude.Compat--import Servant.API.Alternative- ((:<|>) ((:<|>)))-import Servant.API.BasicAuth- (BasicAuth)-import Servant.API.Capture- (Capture', CaptureAll)-import Servant.API.Description- (Description, Summary)-import Servant.API.Empty- (EmptyAPI (..))-import Servant.API.Experimental.Auth- (AuthProtect)-import Servant.API.Header- (Header')-import Servant.API.HttpVersion- (HttpVersion)-import Servant.API.IsSecure- (IsSecure)-import Servant.API.Modifiers- (FoldRequired)-import Servant.API.QueryParam- (QueryFlag, QueryParam', QueryParams)-import Servant.API.Raw- (Raw)-import Servant.API.RemoteHost- (RemoteHost)-import Servant.API.ReqBody- (ReqBody')-import Servant.API.Stream- (Stream)-import Servant.API.Sub- (type (:>))-import Servant.API.TypeLevel-import Servant.API.Vault- (Vault)-import Servant.API.Verbs- (Verb)-import Servant.API.WithNamedContext- (WithNamedContext)-import Web.HttpApiData---- | A safe link datatype.--- The only way of constructing a 'Link' is using 'safeLink', which means any--- 'Link' is guaranteed to be part of the mentioned API.-data Link = Link- { _segments :: [Escaped]- , _queryParams :: [Param]- } deriving Show--newtype Escaped = Escaped String--escaped :: String -> Escaped-escaped = Escaped . escapeURIString isUnreserved--getEscaped :: Escaped -> String-getEscaped (Escaped s) = s--instance Show Escaped where- showsPrec d (Escaped s) = showsPrec d s- show (Escaped s) = show s--linkSegments :: Link -> [String]-linkSegments = map getEscaped . _segments--linkQueryParams :: Link -> [Param]-linkQueryParams = _queryParams--instance ToHttpApiData Link where- toHeader = TE.encodeUtf8 . toUrlPiece- toUrlPiece l =- let uri = linkURI l- in Text.pack $ uriPath uri ++ uriQuery uri---- | Query parameter.-data Param- = SingleParam String Text.Text- | ArrayElemParam String Text.Text- | FlagParam String- deriving Show--addSegment :: Escaped -> Link -> Link-addSegment seg l = l { _segments = _segments l <> [seg] }--addQueryParam :: Param -> Link -> Link-addQueryParam qp l =- l { _queryParams = _queryParams l <> [qp] }---- | Transform 'Link' into 'URI'.------ >>> type API = "something" :> Get '[JSON] Int--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)--- something------ >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]--- sum?x[]=1&x[]=2&x[]=3------ >>> type API = "foo/bar" :> Get '[JSON] Int--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)--- foo%2Fbar------ >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()--- >>> let someRoute = Proxy :: Proxy SomeRoute--- >>> safeLink someRoute someRoute "test@example.com"--- Link {_segments = ["abc","test%40example.com"], _queryParams = []}------ >>> linkURI $ safeLink someRoute someRoute "test@example.com"--- abc/test%40example.com----linkURI :: Link -> URI-linkURI = linkURI' LinkArrayElementBracket---- | How to encode array query elements.-data LinkArrayElementStyle- = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@- | LinkArrayElementPlain -- ^ @foo=1&foo=2@- deriving (Eq, Ord, Show, Enum, Bounded)---- | Configurable 'linkURI'.------ >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int--- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]--- sum?x[]=1&x[]=2&x[]=3------ >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]--- sum?x=1&x=2&x=3----linkURI' :: LinkArrayElementStyle -> Link -> URI-linkURI' addBrackets (Link segments q_params) =- URI mempty -- No scheme (relative)- Nothing -- Or authority (relative)- (intercalate "/" $ map getEscaped segments)- (makeQueries q_params) mempty+module Servant.Utils.Links+ {-# DEPRECATED "Use Servant.Links." #-}+ ( module Servant.Links ) where- makeQueries :: [Param] -> String- makeQueries [] = ""- makeQueries xs =- "?" <> intercalate "&" (fmap makeQuery xs) - makeQuery :: Param -> String- makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)- makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)- makeQuery (FlagParam k) = escape k-- style = case addBrackets of- LinkArrayElementBracket -> "[]="- LinkArrayElementPlain -> "="--escape :: String -> String-escape = escapeURIString isUnreserved---- | Create a valid (by construction) relative URI with query params.------ This function will only typecheck if `endpoint` is part of the API `api`-safeLink- :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)- => Proxy api -- ^ The whole API that this endpoint is a part of- -> Proxy endpoint -- ^ The API endpoint you would like to point to- -> MkLink endpoint Link-safeLink = safeLink' id---- | More general 'safeLink'.----safeLink'- :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)- => (Link -> a)- -> Proxy api -- ^ The whole API that this endpoint is a part of- -> Proxy endpoint -- ^ The API endpoint you would like to point to- -> MkLink endpoint a-safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)---- | Create all links in an API.------ Note that the @api@ type must be restricted to the endpoints that have--- valid links to them.------ >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double--- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)--- >>> :t fooLink--- fooLink :: Text -> Link--- >>> :t barLink--- barLink :: Int -> Link------ Note: nested APIs don't work well with this approach------ >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link--- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *--- = Char -> (Int -> Link) :<|> (Double -> Link)-allLinks- :: forall api. HasLink api- => Proxy api- -> MkLink api Link-allLinks = allLinks' id---- | More general 'allLinks'. See `safeLink'`.-allLinks'- :: forall api a. HasLink api- => (Link -> a)- -> Proxy api- -> MkLink api a-allLinks' toA api = toLink toA api (Link mempty mempty)---- | Construct a toLink for an endpoint.-class HasLink endpoint where- type MkLink endpoint (a :: *)- toLink- :: (Link -> a)- -> Proxy endpoint -- ^ The API endpoint you would like to point to- -> Link- -> MkLink endpoint a---- Naked symbol instance-instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where- type MkLink (sym :> sub) a = MkLink sub a- toLink toA _ =- toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)- where- seg = symbolVal (Proxy :: Proxy sym)---- QueryParam instances-instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))- => HasLink (QueryParam' mods sym v :> sub)- where- type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a- toLink toA _ l mv =- toLink toA (Proxy :: Proxy sub) $- case sbool :: SBool (FoldRequired mods) of- STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l- SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l- where- k :: String- k = symbolVal (Proxy :: Proxy sym)--instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)- => HasLink (QueryParams sym v :> sub)- where- type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a- toLink toA _ l =- toLink toA (Proxy :: Proxy sub) .- foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l- where- k = symbolVal (Proxy :: Proxy sym)--instance (KnownSymbol sym, HasLink sub)- => HasLink (QueryFlag sym :> sub)- where- type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a- toLink toA _ l False =- toLink toA (Proxy :: Proxy sub) l- toLink toA _ l True =- toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l- where- k = symbolVal (Proxy :: Proxy sym)---- :<|> instance - Generate all links at once-instance (HasLink a, HasLink b) => HasLink (a :<|> b) where- type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r- toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l---- Misc instances-instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where- type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r- toLink toA _ = toLink toA (Proxy :: Proxy sub)--instance (ToHttpApiData v, HasLink sub)- => HasLink (Capture' mods sym v :> sub)- where- type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a- toLink toA _ l v =- toLink toA (Proxy :: Proxy sub) $- addSegment (escaped . Text.unpack $ toUrlPiece v) l--instance (ToHttpApiData v, HasLink sub)- => HasLink (CaptureAll sym v :> sub)- where- type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a- toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $- foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs--instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where- type MkLink (Header' mods sym a :> sub) r = MkLink sub r- toLink = simpleToLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (Vault :> sub) where- type MkLink (Vault :> sub) a = MkLink sub a- toLink = simpleToLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (Description s :> sub) where- type MkLink (Description s :> sub) a = MkLink sub a- toLink = simpleToLink (Proxy :: Proxy sub)--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 (HttpVersion :> sub) where- type MkLink (HttpVersion:> sub) a = MkLink sub a- toLink = simpleToLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (IsSecure :> sub) where- type MkLink (IsSecure :> sub) a = MkLink sub a- toLink = simpleToLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (WithNamedContext name context sub) where- type MkLink (WithNamedContext name context sub) a = MkLink sub a- toLink toA _ = toLink toA (Proxy :: Proxy sub)--instance HasLink sub => HasLink (RemoteHost :> sub) where- type MkLink (RemoteHost :> sub) a = MkLink sub a- toLink = simpleToLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (BasicAuth realm a :> sub) where- type MkLink (BasicAuth realm a :> sub) r = MkLink sub r- toLink = simpleToLink (Proxy :: Proxy sub)--instance HasLink EmptyAPI where- type MkLink EmptyAPI a = EmptyAPI- toLink _ _ _ = EmptyAPI---- Verb (terminal) instances-instance HasLink (Verb m s ct a) where- type MkLink (Verb m s ct a) r = r- toLink toA _ = toA--instance HasLink Raw where- type MkLink Raw a = a- toLink toA _ = toA--instance HasLink (Stream m fr ct a) where- type MkLink (Stream m fr ct a) r = r- toLink toA _ = toA---- AuthProtext instances-instance HasLink sub => HasLink (AuthProtect tag :> sub) where- type MkLink (AuthProtect tag :> sub) a = MkLink sub a- toLink = simpleToLink (Proxy :: Proxy sub)---- | Helper for implemneting 'toLink' for combinators not affecting link--- structure.-simpleToLink- :: forall sub a combinator.- (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)- => Proxy sub- -> (Link -> a)- -> Proxy (combinator :> sub)- -> Link- -> MkLink (combinator :> sub) a-simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)----- $setup--- >>> import Servant.API--- >>> import Data.Text (Text)+import Servant.Links
+ test/Servant/LinksSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ < 709+{-# OPTIONS_GHC -fcontext-stack=41 #-}+#endif+module Servant.LinksSpec where++import Data.Proxy (Proxy (..))+import Test.Hspec (Expectation, Spec, describe, it,+ shouldBe)+import Data.String (fromString)++import Servant.API+import Servant.Links+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)++type TestApi =+ -- Capture and query params+ "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent+ :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent+ :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent++ -- Flags+ :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent++ -- All of the verbs+ :<|> "get" :> Get '[JSON] NoContent+ :<|> "put" :> Put '[JSON] NoContent+ :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] NoContent+ :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent+ :<|> "raw" :> Raw+ :<|> NoEndpoint++type LinkableApi =+ "all" :> CaptureAll "names" String :> Get '[JSON] NoContent+ :<|> "get" :> Get '[JSON] NoContent+++apiLink :: (IsElem endpoint TestApi, HasLink endpoint)+ => Proxy endpoint -> MkLink endpoint Link+apiLink = safeLink (Proxy :: Proxy TestApi)++-- | Convert a link to a URI and ensure that this maps to the given string+-- given string+shouldBeLink :: Link -> String -> Expectation+shouldBeLink link expected =+ toUrlPiece link `shouldBe` fromString expected++spec :: Spec+spec = describe "Servant.Links" $ do+ it "generates correct links for capture query params" $ do+ let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)+ apiLink l1 "hi" `shouldBeLink` "hello/hi"++ let l2 = Proxy :: Proxy ("hello" :> Capture "name" String+ :> QueryParam "capital" Bool+ :> Delete '[JSON] NoContent)+ apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"++ let l4 = Proxy :: Proxy ("hi" :> Capture "name" String+ :> QueryParam' '[Required] "capital" Bool+ :> Delete '[JSON] NoContent)+ apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false"++ it "generates correct links for CaptureAll" $ do+ apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))+ ["roads", "lead", "to", "rome"]+ `shouldBeLink` "all/roads/lead/to/rome"++ it "generates correct links for query flags" $ do+ let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"+ :> QueryFlag "fast" :> Delete '[JSON] NoContent)+ apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"+ apiLink l1 False True `shouldBeLink` "balls?fast"++ it "generates correct links for all of the verbs" $ do+ apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"+ apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"+ apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"+ apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"+ apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"++ it "can generate all links for an API that has only linkable endpoints" $ do+ let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)+ simple `shouldBeLink` "get"+ allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius"++ it "can generate all links for ComprehensiveAPIWithoutRaw" $ do+ let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw+ firstLink `shouldBeLink` ""++-- |+-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,+-- we'll just use doctest+--+-- with TypeError comparing for errors is difficult.+--+-- >>> apiLink (Proxy :: Proxy WrongPath)+-- ...+-- ......:...:...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongReturnType)+-- ...+-- ...Could not deduce...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongContentType)+-- ...+-- ......:...:...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongMethod)+-- ...+-- ...Could not deduce...+-- ...+--+-- >>> apiLink (Proxy :: Proxy NotALink)+-- ...+-- ...Could not deduce...+-- ...+--+-- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)+-- ...+-- <interactive>...+-- ...+--+-- sanity check+-- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)+-- "get"+type WrongPath = "getTypo" :> Get '[JSON] NoContent+type WrongReturnType = "get" :> Get '[JSON] Bool+type WrongContentType = "get" :> Get '[OctetStream] NoContent+type WrongMethod = "get" :> Post '[JSON] NoContent+type NotALink = "hello" :> ReqBody '[JSON] Bool :> Get '[JSON] Bool+type AllGood = "get" :> Get '[JSON] NoContent+type NoEndpoint = "empty" :> EmptyAPI
− test/Servant/Utils/LinksSpec.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ < 709-{-# OPTIONS_GHC -fcontext-stack=41 #-}-#endif-module Servant.Utils.LinksSpec where--import Data.Proxy (Proxy (..))-import Test.Hspec (Expectation, Spec, describe, it,- shouldBe)-import Data.String (fromString)--import Servant.API-import Servant.Utils.Links-import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)--type TestApi =- -- Capture and query params- "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent- :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent- :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent-- -- Flags- :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent-- -- All of the verbs- :<|> "get" :> Get '[JSON] NoContent- :<|> "put" :> Put '[JSON] NoContent- :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] NoContent- :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent- :<|> "raw" :> Raw- :<|> NoEndpoint--type LinkableApi =- "all" :> CaptureAll "names" String :> Get '[JSON] NoContent- :<|> "get" :> Get '[JSON] NoContent---apiLink :: (IsElem endpoint TestApi, HasLink endpoint)- => Proxy endpoint -> MkLink endpoint Link-apiLink = safeLink (Proxy :: Proxy TestApi)---- | Convert a link to a URI and ensure that this maps to the given string--- given string-shouldBeLink :: Link -> String -> Expectation-shouldBeLink link expected =- toUrlPiece link `shouldBe` fromString expected--spec :: Spec-spec = describe "Servant.Utils.Links" $ do- it "generates correct links for capture query params" $ do- let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)- apiLink l1 "hi" `shouldBeLink` "hello/hi"-- let l2 = Proxy :: Proxy ("hello" :> Capture "name" String- :> QueryParam "capital" Bool- :> Delete '[JSON] NoContent)- apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"-- let l4 = Proxy :: Proxy ("hi" :> Capture "name" String- :> QueryParam' '[Required] "capital" Bool- :> Delete '[JSON] NoContent)- apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false"-- it "generates correct links for CaptureAll" $ do- apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))- ["roads", "lead", "to", "rome"]- `shouldBeLink` "all/roads/lead/to/rome"-- it "generates correct links for query flags" $ do- let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"- :> QueryFlag "fast" :> Delete '[JSON] NoContent)- apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"- apiLink l1 False True `shouldBeLink` "balls?fast"-- it "generates correct links for all of the verbs" $ do- apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"- apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"- apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"- apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"- apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"-- it "can generate all links for an API that has only linkable endpoints" $ do- let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)- simple `shouldBeLink` "get"- allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius"-- it "can generate all links for ComprehensiveAPIWithoutRaw" $ do- let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw- firstLink `shouldBeLink` ""---- |--- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,--- we'll just use doctest------ with TypeError comparing for errors is difficult.------ >>> apiLink (Proxy :: Proxy WrongPath)--- ...--- ......:...:...--- ...------ >>> apiLink (Proxy :: Proxy WrongReturnType)--- ...--- ...Could not deduce...--- ...------ >>> apiLink (Proxy :: Proxy WrongContentType)--- ...--- ......:...:...--- ...------ >>> apiLink (Proxy :: Proxy WrongMethod)--- ...--- ...Could not deduce...--- ...------ >>> apiLink (Proxy :: Proxy NotALink)--- ...--- ...Could not deduce...--- ...------ >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)--- ...--- <interactive>...--- ...------ sanity check--- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)--- "get"-type WrongPath = "getTypo" :> Get '[JSON] NoContent-type WrongReturnType = "get" :> Get '[JSON] Bool-type WrongContentType = "get" :> Get '[OctetStream] NoContent-type WrongMethod = "get" :> Post '[JSON] NoContent-type NotALink = "hello" :> ReqBody '[JSON] Bool :> Get '[JSON] Bool-type AllGood = "get" :> Get '[JSON] NoContent-type NoEndpoint = "empty" :> EmptyAPI