diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -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 diff --git a/src/Servant/API.hs b/src/Servant/API.hs --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -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 (..)) diff --git a/src/Servant/API/Generic.hs b/src/Servant/API/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Generic.hs @@ -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 diff --git a/src/Servant/API/Verbs.hs b/src/Servant/API/Verbs.hs --- a/src/Servant/API/Verbs.hs +++ b/src/Servant/API/Verbs.hs @@ -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. diff --git a/src/Servant/Links.hs b/src/Servant/Links.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Links.hs @@ -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) diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -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 diff --git a/test/Servant/LinksSpec.hs b/test/Servant/LinksSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/LinksSpec.hs @@ -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) +-- ... +-- ... +-- ... +-- +-- 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 diff --git a/test/Servant/Utils/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs deleted file mode 100644 --- a/test/Servant/Utils/LinksSpec.hs +++ /dev/null @@ -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) --- ... --- ... --- ... --- --- 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