@@ -0,0 +1,573 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-# OPTIONS_HADDOCK not-home #-}
12+
13+-- | Type safe generation of internal links.
14+--
15+-- Given an API with a few endpoints:
16+--
17+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
18+-- >>> import Servant.API
19+-- >>> import Servant.Links
20+-- >>> import Data.Proxy
21+-- >>>
22+-- >>> type Hello = "hello" :> Get '[JSON] Int
23+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
24+-- >>> type API = Hello :<|> Bye
25+-- >>> let api = Proxy :: Proxy API
26+--
27+-- It is possible to generate links that are guaranteed to be within 'API' with
28+-- 'safeLink'. The first argument to 'safeLink' is a type representing the API
29+-- you would like to restrict links to. The second argument is the destination
30+-- endpoint you would like the link to point to, this will need to end with a
31+-- verb like GET or POST. Further arguments may be required depending on the
32+-- type of the endpoint. If everything lines up you will get a 'Link' out the
33+-- other end.
34+--
35+-- You may omit 'QueryParam's and the like should you not want to provide them,
36+-- but types which form part of the URL path like 'Capture' must be included.
37+-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
38+-- magical: if parameters are included that could take input it will return a
39+-- function that accepts that input and generates a link. This is best shown
40+-- with an example. Here, a link is generated with no parameters:
41+--
42+-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
43+-- >>> toUrlPiece (safeLink api hello :: Link)
44+-- "hello"
45+--
46+-- If the API has an endpoint with parameters then we can generate links with
47+-- or without those:
48+--
49+-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
50+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
51+-- "bye?name=Hubert"
52+--
53+-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
54+-- >>> toUrlPiece $ safeLink api without
55+-- "bye"
56+--
57+-- If you would like create a helper for generating links only within that API,
58+-- you can partially apply safeLink if you specify a correct type signature
59+-- like so:
60+--
61+-- >>> :set -XConstraintKinds
62+-- >>> :{
63+-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
64+-- >>> => Proxy endpoint -> MkLink endpoint Link
65+-- >>> apiLink = safeLink api
66+-- >>> :}
67+--
68+-- `safeLink'` allows to make specialise the output:
69+--
70+-- >>> safeLink' toUrlPiece api without
71+-- "bye"
72+--
73+-- >>> :{
74+-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
75+-- >>> => Proxy endpoint -> MkLink endpoint Text
76+-- >>> apiTextLink = safeLink' toUrlPiece api
77+-- >>> :}
78+--
79+-- >>> apiTextLink without
80+-- "bye"
81+--
82+-- Attempting to construct a link to an endpoint that does not exist in api
83+-- will result in a type error like this:
84+--
85+-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
86+-- >>> safeLink api bad_link
87+-- ...
88+-- ...Could not deduce...
89+-- ...
90+--
91+-- This error is essentially saying that the type family couldn't find
92+-- bad_link under api after trying the open (but empty) type family
93+-- `IsElem'` as a last resort.
94+--
95+-- @since 0.14.1
96+module Servant.Links (
97+ module Servant.API.TypeLevel,
98+
99+ -- * Building and using safe links
100+ --
101+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
102+ safeLink
103+ , safeLink'
104+ , allLinks
105+ , allLinks'
106+ , URI(..)
107+ -- * Generics
108+ , AsLink
109+ , fieldLink
110+ , fieldLink'
111+ , allFieldLinks
112+ , allFieldLinks'
113+ -- * Adding custom types
114+ , HasLink(..)
115+ , Link
116+ , linkURI
117+ , linkURI'
118+ , LinkArrayElementStyle (..)
119+ -- ** Link accessors
120+ , Param (..)
121+ , linkSegments
122+ , linkQueryParams
123+) where
124+
125+import Data.List
126+import Data.Proxy
127+ (Proxy (..))
128+import Data.Semigroup
129+ ((<>))
130+import Data.Singletons.Bool
131+ (SBool (..), SBoolI (..))
132+import qualified Data.Text as Text
133+import qualified Data.Text.Encoding as TE
134+import Data.Type.Bool
135+ (If)
136+import GHC.TypeLits
137+ (KnownSymbol, symbolVal)
138+import Network.URI
139+ (URI (..), escapeURIString, isUnreserved)
140+import Prelude ()
141+import Prelude.Compat
142+
143+import Servant.API.Alternative
144+ ((:<|>) ((:<|>)))
145+import Servant.API.BasicAuth
146+ (BasicAuth)
147+import Servant.API.Capture
148+ (Capture', CaptureAll)
149+import Servant.API.Description
150+ (Description, Summary)
151+import Servant.API.Empty
152+ (EmptyAPI (..))
153+import Servant.API.Experimental.Auth
154+ (AuthProtect)
155+import Servant.API.Generic
156+import Servant.API.Header
157+ (Header')
158+import Servant.API.HttpVersion
159+ (HttpVersion)
160+import Servant.API.IsSecure
161+ (IsSecure)
162+import Servant.API.Modifiers
163+ (FoldRequired)
164+import Servant.API.QueryParam
165+ (QueryFlag, QueryParam', QueryParams)
166+import Servant.API.Raw
167+ (Raw)
168+import Servant.API.RemoteHost
169+ (RemoteHost)
170+import Servant.API.ReqBody
171+ (ReqBody')
172+import Servant.API.Stream
173+ (Stream)
174+import Servant.API.Sub
175+ (type (:>))
176+import Servant.API.TypeLevel
177+import Servant.API.Vault
178+ (Vault)
179+import Servant.API.Verbs
180+ (Verb)
181+import Servant.API.WithNamedContext
182+ (WithNamedContext)
183+import Web.HttpApiData
184+
185+-- | A safe link datatype.
186+-- The only way of constructing a 'Link' is using 'safeLink', which means any
187+-- 'Link' is guaranteed to be part of the mentioned API.
188+data Link = Link
189+ { _segments :: [Escaped]
190+ , _queryParams :: [Param]
191+ } deriving Show
192+
193+newtype Escaped = Escaped String
194+
195+escaped :: String -> Escaped
196+escaped = Escaped . escapeURIString isUnreserved
197+
198+getEscaped :: Escaped -> String
199+getEscaped (Escaped s) = s
200+
201+instance Show Escaped where
202+ showsPrec d (Escaped s) = showsPrec d s
203+ show (Escaped s) = show s
204+
205+linkSegments :: Link -> [String]
206+linkSegments = map getEscaped . _segments
207+
208+linkQueryParams :: Link -> [Param]
209+linkQueryParams = _queryParams
210+
211+instance ToHttpApiData Link where
212+ toHeader = TE.encodeUtf8 . toUrlPiece
213+ toUrlPiece l =
214+ let uri = linkURI l
215+ in Text.pack $ uriPath uri ++ uriQuery uri
216+
217+-- | Query parameter.
218+data Param
219+ = SingleParam String Text.Text
220+ | ArrayElemParam String Text.Text
221+ | FlagParam String
222+ deriving Show
223+
224+addSegment :: Escaped -> Link -> Link
225+addSegment seg l = l { _segments = _segments l <> [seg] }
226+
227+addQueryParam :: Param -> Link -> Link
228+addQueryParam qp l =
229+ l { _queryParams = _queryParams l <> [qp] }
230+
231+-- | Transform 'Link' into 'URI'.
232+--
233+-- >>> type API = "something" :> Get '[JSON] Int
234+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
235+-- something
236+--
237+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
238+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
239+-- sum?x[]=1&x[]=2&x[]=3
240+--
241+-- >>> type API = "foo/bar" :> Get '[JSON] Int
242+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
243+-- foo%2Fbar
244+--
245+-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
246+-- >>> let someRoute = Proxy :: Proxy SomeRoute
247+-- >>> safeLink someRoute someRoute "test@example.com"
248+-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
249+--
250+-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
251+-- abc/test%40example.com
252+--
253+linkURI :: Link -> URI
254+linkURI = linkURI' LinkArrayElementBracket
255+
256+-- | How to encode array query elements.
257+data LinkArrayElementStyle
258+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
259+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@
260+ deriving (Eq, Ord, Show, Enum, Bounded)
261+
262+-- | Configurable 'linkURI'.
263+--
264+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
265+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
266+-- sum?x[]=1&x[]=2&x[]=3
267+--
268+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
269+-- sum?x=1&x=2&x=3
270+--
271+linkURI' :: LinkArrayElementStyle -> Link -> URI
272+linkURI' addBrackets (Link segments q_params) =
273+ URI mempty -- No scheme (relative)
274+ Nothing -- Or authority (relative)
275+ (intercalate "/" $ map getEscaped segments)
276+ (makeQueries q_params) mempty
277+ where
278+ makeQueries :: [Param] -> String
279+ makeQueries [] = ""
280+ makeQueries xs =
281+ "?" <> intercalate "&" (fmap makeQuery xs)
282+
283+ makeQuery :: Param -> String
284+ makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
285+ makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
286+ makeQuery (FlagParam k) = escape k
287+
288+ style = case addBrackets of
289+ LinkArrayElementBracket -> "[]="
290+ LinkArrayElementPlain -> "="
291+
292+escape :: String -> String
293+escape = escapeURIString isUnreserved
294+
295+-- | Create a valid (by construction) relative URI with query params.
296+--
297+-- This function will only typecheck if `endpoint` is part of the API `api`
298+safeLink
299+ :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
300+ => Proxy api -- ^ The whole API that this endpoint is a part of
301+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
302+ -> MkLink endpoint Link
303+safeLink = safeLink' id
304+
305+-- | More general 'safeLink'.
306+--
307+safeLink'
308+ :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
309+ => (Link -> a)
310+ -> Proxy api -- ^ The whole API that this endpoint is a part of
311+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
312+ -> MkLink endpoint a
313+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
314+
315+-- | Create all links in an API.
316+--
317+-- Note that the @api@ type must be restricted to the endpoints that have
318+-- valid links to them.
319+--
320+-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
321+-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
322+-- >>> :t fooLink
323+-- fooLink :: Text -> Link
324+-- >>> :t barLink
325+-- barLink :: Int -> Link
326+--
327+-- Note: nested APIs don't work well with this approach
328+--
329+-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
330+-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
331+-- = Char -> (Int -> Link) :<|> (Double -> Link)
332+allLinks
333+ :: forall api. HasLink api
334+ => Proxy api
335+ -> MkLink api Link
336+allLinks = allLinks' id
337+
338+-- | More general 'allLinks'. See `safeLink'`.
339+allLinks'
340+ :: forall api a. HasLink api
341+ => (Link -> a)
342+ -> Proxy api
343+ -> MkLink api a
344+allLinks' toA api = toLink toA api (Link mempty mempty)
345+
346+-------------------------------------------------------------------------------
347+-- Generics
348+-------------------------------------------------------------------------------
349+
350+-- | Given an API record field, create a link for that route. Only the field's
351+-- type is used.
352+--
353+-- @
354+-- data Record route = Record
355+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String
356+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
357+-- }
358+-- deriving ('Generic')
359+--
360+-- getLink :: Int -> Link
361+-- getLink = 'fieldLink' _get
362+-- @
363+--
364+-- @since 0.14.1
365+fieldLink
366+ :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint
367+ , GenericServant routes AsApi
368+ )
369+ => (routes AsApi -> endpoint)
370+ -> MkLink endpoint Link
371+fieldLink = fieldLink' id
372+
373+-- | More general version of 'fieldLink'
374+--
375+-- @since 0.14.1
376+fieldLink'
377+ :: forall routes endpoint a.
378+ ( IsElem endpoint (ToServantApi routes), HasLink endpoint
379+ , GenericServant routes AsApi
380+ )
381+ => (Link -> a)
382+ -> (routes AsApi -> endpoint)
383+ -> MkLink endpoint a
384+fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)
385+
386+-- | A type that specifies that an API record contains a set of links.
387+--
388+-- @since 0.14.1
389+data AsLink (a :: *)
390+instance GenericMode (AsLink a) where
391+ type (AsLink a) :- api = MkLink api a
392+
393+-- | Get all links as a record.
394+--
395+-- @since 0.14.1
396+allFieldLinks
397+ :: ( HasLink (ToServantApi routes)
398+ , GenericServant routes (AsLink Link)
399+ , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link
400+ )
401+ => routes (AsLink Link)
402+allFieldLinks = allFieldLinks' id
403+
404+-- | More general version of 'allFieldLinks'.
405+--
406+-- @since 0.14.1
407+allFieldLinks'
408+ :: forall routes a.
409+ ( HasLink (ToServantApi routes)
410+ , GenericServant routes (AsLink a)
411+ , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a
412+ )
413+ => (Link -> a)
414+ -> routes (AsLink a)
415+allFieldLinks' toA
416+ = fromServant
417+ $ allLinks' toA (Proxy :: Proxy (ToServantApi routes))
418+
419+-------------------------------------------------------------------------------
420+-- HasLink
421+-------------------------------------------------------------------------------
422+
423+-- | Construct a toLink for an endpoint.
424+class HasLink endpoint where
425+ type MkLink endpoint (a :: *)
426+ toLink
427+ :: (Link -> a)
428+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
429+ -> Link
430+ -> MkLink endpoint a
431+
432+-- Naked symbol instance
433+instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
434+ type MkLink (sym :> sub) a = MkLink sub a
435+ toLink toA _ =
436+ toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
437+ where
438+ seg = symbolVal (Proxy :: Proxy sym)
439+
440+-- QueryParam instances
441+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
442+ => HasLink (QueryParam' mods sym v :> sub)
443+ where
444+ type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
445+ toLink toA _ l mv =
446+ toLink toA (Proxy :: Proxy sub) $
447+ case sbool :: SBool (FoldRequired mods) of
448+ STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
449+ SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
450+ where
451+ k :: String
452+ k = symbolVal (Proxy :: Proxy sym)
453+
454+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
455+ => HasLink (QueryParams sym v :> sub)
456+ where
457+ type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
458+ toLink toA _ l =
459+ toLink toA (Proxy :: Proxy sub) .
460+ foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
461+ where
462+ k = symbolVal (Proxy :: Proxy sym)
463+
464+instance (KnownSymbol sym, HasLink sub)
465+ => HasLink (QueryFlag sym :> sub)
466+ where
467+ type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
468+ toLink toA _ l False =
469+ toLink toA (Proxy :: Proxy sub) l
470+ toLink toA _ l True =
471+ toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
472+ where
473+ k = symbolVal (Proxy :: Proxy sym)
474+
475+-- :<|> instance - Generate all links at once
476+instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
477+ type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
478+ toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
479+
480+-- Misc instances
481+instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
482+ type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
483+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
484+
485+instance (ToHttpApiData v, HasLink sub)
486+ => HasLink (Capture' mods sym v :> sub)
487+ where
488+ type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
489+ toLink toA _ l v =
490+ toLink toA (Proxy :: Proxy sub) $
491+ addSegment (escaped . Text.unpack $ toUrlPiece v) l
492+
493+instance (ToHttpApiData v, HasLink sub)
494+ => HasLink (CaptureAll sym v :> sub)
495+ where
496+ type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
497+ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
498+ foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
499+
500+instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
501+ type MkLink (Header' mods sym a :> sub) r = MkLink sub r
502+ toLink = simpleToLink (Proxy :: Proxy sub)
503+
504+instance HasLink sub => HasLink (Vault :> sub) where
505+ type MkLink (Vault :> sub) a = MkLink sub a
506+ toLink = simpleToLink (Proxy :: Proxy sub)
507+
508+instance HasLink sub => HasLink (Description s :> sub) where
509+ type MkLink (Description s :> sub) a = MkLink sub a
510+ toLink = simpleToLink (Proxy :: Proxy sub)
511+
512+instance HasLink sub => HasLink (Summary s :> sub) where
513+ type MkLink (Summary s :> sub) a = MkLink sub a
514+ toLink = simpleToLink (Proxy :: Proxy sub)
515+
516+instance HasLink sub => HasLink (HttpVersion :> sub) where
517+ type MkLink (HttpVersion:> sub) a = MkLink sub a
518+ toLink = simpleToLink (Proxy :: Proxy sub)
519+
520+instance HasLink sub => HasLink (IsSecure :> sub) where
521+ type MkLink (IsSecure :> sub) a = MkLink sub a
522+ toLink = simpleToLink (Proxy :: Proxy sub)
523+
524+instance HasLink sub => HasLink (WithNamedContext name context sub) where
525+ type MkLink (WithNamedContext name context sub) a = MkLink sub a
526+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
527+
528+instance HasLink sub => HasLink (RemoteHost :> sub) where
529+ type MkLink (RemoteHost :> sub) a = MkLink sub a
530+ toLink = simpleToLink (Proxy :: Proxy sub)
531+
532+instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
533+ type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
534+ toLink = simpleToLink (Proxy :: Proxy sub)
535+
536+instance HasLink EmptyAPI where
537+ type MkLink EmptyAPI a = EmptyAPI
538+ toLink _ _ _ = EmptyAPI
539+
540+-- Verb (terminal) instances
541+instance HasLink (Verb m s ct a) where
542+ type MkLink (Verb m s ct a) r = r
543+ toLink toA _ = toA
544+
545+instance HasLink Raw where
546+ type MkLink Raw a = a
547+ toLink toA _ = toA
548+
549+instance HasLink (Stream m status fr ct a) where
550+ type MkLink (Stream m status fr ct a) r = r
551+ toLink toA _ = toA
552+
553+-- AuthProtext instances
554+instance HasLink sub => HasLink (AuthProtect tag :> sub) where
555+ type MkLink (AuthProtect tag :> sub) a = MkLink sub a
556+ toLink = simpleToLink (Proxy :: Proxy sub)
557+
558+-- | Helper for implemneting 'toLink' for combinators not affecting link
559+-- structure.
560+simpleToLink
561+ :: forall sub a combinator.
562+ (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
563+ => Proxy sub
564+ -> (Link -> a)
565+ -> Proxy (combinator :> sub)
566+ -> Link
567+ -> MkLink (combinator :> sub) a
568+simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
569+
570+
571+-- $setup
572+-- >>> import Servant.API
573+-- >>> import Data.Text (Text)