From 2c02287b6b036487204e248b1a2d3435a9eb9d62 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 25 Jun 2018 01:36:20 +0300 Subject: [PATCH] Move Servant.Utils.Links -> Servant.Links. Fixes #997. --- servant-server/src/Servant.hs | 4 +- .../src/Servant/Server/Internal/Context.hs | 2 +- servant/servant.cabal | 8 +- servant/src/Servant/API.hs | 6 +- servant/src/Servant/API/Verbs.hs | 2 +- servant/src/Servant/Links.hs | 487 +++++++++++++++++ servant/src/Servant/Utils/Links.hs | 489 +----------------- servant/test/Servant/{Utils => }/LinksSpec.hs | 6 +- 8 files changed, 507 insertions(+), 497 deletions(-) create mode 100644 servant/src/Servant/Links.hs rename servant/test/Servant/{Utils => }/LinksSpec.hs (97%) diff --git a/servant-server/src/Servant.hs b/servant-server/src/Servant.hs index ed24756d..843d0644 100644 --- a/servant-server/src/Servant.hs +++ b/servant-server/src/Servant.hs @@ -6,7 +6,7 @@ module Servant ( -- | For implementing servers for servant APIs. module Servant.Server, -- | Utilities on top of the servant core - module Servant.Utils.Links, + module Servant.Links, module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..), @@ -17,5 +17,5 @@ import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Server -import Servant.Utils.Links +import Servant.Links import Servant.Utils.StaticFiles diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index 3dd3a898..6060624a 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -18,7 +18,7 @@ import GHC.TypeLits -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using --- with 'Servant.Utils.Enter'.) If you don't use combinators that +-- with 'hoistServer'.) If you don't use combinators that -- require any context entries, you can just use 'Servant.Server.serve' as always. -- -- If you are using combinators that require a non-empty 'Context' you have to diff --git a/servant/servant.cabal b/servant/servant.cabal index f18fad5a..3b48fa98 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -62,6 +62,10 @@ library Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext + Servant.Links + + -- Deprecated modules, to be removed in late 2019 + exposed-modules: Servant.Utils.Links -- Bundled with GHC: Lower bound to not force re-installs @@ -131,7 +135,7 @@ test-suite spec other-modules: Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec - Servant.Utils.LinksSpec + Servant.LinksSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: @@ -176,4 +180,4 @@ test-suite doctests 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/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 35233f61..c0ceec3c 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -63,8 +63,8 @@ module Servant.API ( 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 @@ import Servant.API.Verbs 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/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index a82e8a04..f6381602 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -58,7 +58,7 @@ type Patch = Verb 'PATCH 200 -- -- 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/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs new file mode 100644 index 00000000..7e2e539f --- /dev/null +++ b/servant/src/Servant/Links.hs @@ -0,0 +1,487 @@ +{-# 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. +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(..) + -- * 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 + 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 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/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 84eaf2bb..df10ffc6 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/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 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) +import Servant.Links diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs similarity index 97% rename from servant/test/Servant/Utils/LinksSpec.hs rename to servant/test/Servant/LinksSpec.hs index 1ebb0fc6..9cd5b0de 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -7,7 +7,7 @@ #if __GLASGOW_HASKELL__ < 709 {-# OPTIONS_GHC -fcontext-stack=41 #-} #endif -module Servant.Utils.LinksSpec where +module Servant.LinksSpec where import Data.Proxy (Proxy (..)) import Test.Hspec (Expectation, Spec, describe, it, @@ -15,7 +15,7 @@ import Test.Hspec (Expectation, Spec, describe, it, import Data.String (fromString) import Servant.API -import Servant.Utils.Links +import Servant.Links import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) type TestApi = @@ -51,7 +51,7 @@ shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected spec :: Spec -spec = describe "Servant.Utils.Links" $ do +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"