Skip to content

Commit 46663f2

Browse files
phadejphadej
committed
Add safeLink'
Resolves #952
1 parent a66aa8a commit 46663f2

File tree

2 files changed

+124
-76
lines changed

2 files changed

+124
-76
lines changed

‎servant/src/Servant/Utils/Links.hs

Lines changed: 123 additions & 75 deletions
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,6 @@
1919
-- >>> import Servant.Utils.Links
2020
-- >>> import Data.Proxy
2121
-- >>>
22-
-- >>>
23-
-- >>>
2422
-- >>> type Hello = "hello" :> Get '[JSON] Int
2523
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
2624
-- >>> type API = Hello :<|> Bye
@@ -63,10 +61,24 @@
6361
-- >>> :set -XConstraintKinds
6462
-- >>> :{
6563
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
66-
-- >>> => Proxy endpoint -> MkLink endpoint
64+
-- >>> => Proxy endpoint -> MkLink endpoint Link
6765
-- >>> apiLink = safeLink api
6866
-- >>> :}
6967
--
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+
--
7082
-- Attempting to construct a link to an endpoint that does not exist in api
7183
-- will result in a type error like this:
7284
--
@@ -86,7 +98,9 @@ module Servant.Utils.Links (
8698
--
8799
-- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
88100
safeLink
101+
, safeLink'
89102
, allLinks
103+
, allLinks'
90104
, URI(..)
91105
-- * Adding custom types
92106
, HasLink(..)
@@ -109,8 +123,6 @@ import Data.Singletons.Bool
109123
(SBool (..), SBoolI (..))
110124
import qualified Data.Text as Text
111125
import qualified Data.Text.Encoding as TE
112-
import Data.Type.Bool
113-
(If)
114126
import Data.Type.Bool
115127
(If)
116128
import GHC.TypeLits
@@ -278,8 +290,18 @@ safeLink
278290
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
279291
=> Proxy api -- ^ The whole API that this endpoint is a part of
280292
-> Proxy endpoint -- ^ The API endpoint you would like to point to
281-
-> MkLink endpoint
282-
safeLink _ endpoint = toLink endpoint (Link mempty mempty)
293+
-> MkLink endpoint Link
294+
safeLink = safeLink' id
295+
296+
-- | More general 'safeLink'.
297+
--
298+
safeLink'
299+
:: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
300+
=> (Link -> a)
301+
-> Proxy api -- ^ The whole API that this endpoint is a part of
302+
-> Proxy endpoint -- ^ The API endpoint you would like to point to
303+
-> MkLink endpoint a
304+
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
283305

284306
-- | Create all links in an API.
285307
--
@@ -295,37 +317,47 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty)
295317
--
296318
-- Note: nested APIs don't work well with this approach
297319
--
298-
-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double))
299-
-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: *
320+
-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
321+
-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
300322
-- = Char -> (Int -> Link) :<|> (Double -> Link)
301-
--
302323
allLinks
303324
:: forall api. HasLink api
304325
=> Proxy api
305-
-> MkLink api
306-
allLinks api = toLink api (Link mempty mempty)
326+
-> MkLink api Link
327+
allLinks = allLinks' id
328+
329+
-- | More general 'allLinks'. See `safeLink'`.
330+
allLinks'
331+
:: forall api a. HasLink api
332+
=> (Link -> a)
333+
-> Proxy api
334+
-> MkLink api a
335+
allLinks' toA api = toLink toA api (Link mempty mempty)
307336

308337
-- | Construct a toLink for an endpoint.
309338
class HasLink endpoint where
310-
type MkLink endpoint
311-
toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to
312-
-> Link
313-
-> MkLink endpoint
339+
type MkLink endpoint (a :: *)
340+
toLink
341+
:: (Link -> a)
342+
-> Proxy endpoint -- ^ The API endpoint you would like to point to
343+
-> Link
344+
-> MkLink endpoint a
314345

315346
-- Naked symbol instance
316347
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
317-
type MkLink (sym :> sub) = MkLink sub
318-
toLink _ =
319-
toLink (Proxy :: Proxy sub) . addSegment (escaped seg)
348+
type MkLink (sym :> sub) a = MkLink sub a
349+
toLink toA _ =
350+
toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
320351
where
321352
seg = symbolVal (Proxy :: Proxy sym)
322353

323354
-- QueryParam instances
324355
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
325-
=> HasLink (QueryParam' mods sym v :> sub) where
326-
type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub
327-
toLink _ l mv =
328-
toLink (Proxy :: Proxy sub) $
356+
=> HasLink (QueryParam' mods sym v :> sub)
357+
where
358+
type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
359+
toLink toA _ l mv =
360+
toLink toA (Proxy :: Proxy sub) $
329361
case sbool :: SBool (FoldRequired mods) of
330362
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
331363
SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
@@ -334,105 +366,121 @@ instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mo
334366
k = symbolVal (Proxy :: Proxy sym)
335367

336368
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
337-
=> HasLink (QueryParams sym v :> sub) where
338-
type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub
339-
toLink _ l =
340-
toLink (Proxy :: Proxy sub) .
369+
=> HasLink (QueryParams sym v :> sub)
370+
where
371+
type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
372+
toLink toA _ l =
373+
toLink toA (Proxy :: Proxy sub) .
341374
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
342375
where
343376
k = symbolVal (Proxy :: Proxy sym)
344377

345378
instance (KnownSymbol sym, HasLink sub)
346-
=> HasLink (QueryFlag sym :> sub) where
347-
type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub
348-
toLink _ l False =
349-
toLink (Proxy :: Proxy sub) l
350-
toLink _ l True =
351-
toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
379+
=> HasLink (QueryFlag sym :> sub)
380+
where
381+
type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
382+
toLink toA _ l False =
383+
toLink toA (Proxy :: Proxy sub) l
384+
toLink toA _ l True =
385+
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
352386
where
353387
k = symbolVal (Proxy :: Proxy sym)
354388

355389
-- :<|> instance - Generate all links at once
356390
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
357-
type MkLink (a :<|> b) = MkLink a :<|> MkLink b
358-
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l
391+
type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
392+
toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
359393

360394
-- Misc instances
361395
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
362-
type MkLink (ReqBody' mods ct a :> sub) = MkLink sub
363-
toLink _ = toLink (Proxy :: Proxy sub)
396+
type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
397+
toLink toA _ = toLink toA (Proxy :: Proxy sub)
364398

365399
instance (ToHttpApiData v, HasLink sub)
366-
=> HasLink (Capture' mods sym v :> sub) where
367-
type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub
368-
toLink _ l v =
369-
toLink (Proxy :: Proxy sub) $
400+
=> HasLink (Capture' mods sym v :> sub)
401+
where
402+
type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
403+
toLink toA _ l v =
404+
toLink toA (Proxy :: Proxy sub) $
370405
addSegment (escaped . Text.unpack $ toUrlPiece v) l
371406

372407
instance (ToHttpApiData v, HasLink sub)
373-
=> HasLink (CaptureAll sym v :> sub) where
374-
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub
375-
toLink _ l vs =
376-
toLink (Proxy :: Proxy sub) $
377-
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
408+
=> HasLink (CaptureAll sym v :> sub)
409+
where
410+
type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
411+
toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
412+
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
378413

379-
instance HasLink sub => HasLink (Header' mods sym a :> sub) where
380-
type MkLink (Header' mods sym a :> sub) = MkLink sub
381-
toLink _ = toLink (Proxy :: Proxy sub)
414+
instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
415+
type MkLink (Header' mods sym a :> sub) r = MkLink sub r
416+
toLink = simpleToLink (Proxy :: Proxy sub)
382417

383418
instance HasLink sub => HasLink (Vault :> sub) where
384-
type MkLink (Vault :> sub) = MkLink sub
385-
toLink _ = toLink (Proxy :: Proxy sub)
419+
type MkLink (Vault :> sub) a = MkLink sub a
420+
toLink = simpleToLink (Proxy :: Proxy sub)
386421

387422
instance HasLink sub => HasLink (Description s :> sub) where
388-
type MkLink (Description s :> sub) = MkLink sub
389-
toLink _ = toLink (Proxy :: Proxy sub)
423+
type MkLink (Description s :> sub) a = MkLink sub a
424+
toLink = simpleToLink (Proxy :: Proxy sub)
390425

391426
instance HasLink sub => HasLink (Summary s :> sub) where
392-
type MkLink (Summary s :> sub) = MkLink sub
393-
toLink _ = toLink (Proxy :: Proxy sub)
427+
type MkLink (Summary s :> sub) a = MkLink sub a
428+
toLink = simpleToLink (Proxy :: Proxy sub)
394429

395430
instance HasLink sub => HasLink (HttpVersion :> sub) where
396-
type MkLink (HttpVersion:> sub) = MkLink sub
397-
toLink _ = toLink (Proxy :: Proxy sub)
431+
type MkLink (HttpVersion:> sub) a = MkLink sub a
432+
toLink = simpleToLink (Proxy :: Proxy sub)
398433

399434
instance HasLink sub => HasLink (IsSecure :> sub) where
400-
type MkLink (IsSecure :> sub) = MkLink sub
401-
toLink _ = toLink (Proxy :: Proxy sub)
435+
type MkLink (IsSecure :> sub) a = MkLink sub a
436+
toLink = simpleToLink (Proxy :: Proxy sub)
402437

403438
instance HasLink sub => HasLink (WithNamedContext name context sub) where
404-
type MkLink (WithNamedContext name context sub) = MkLink sub
405-
toLink _ = toLink (Proxy :: Proxy sub)
439+
type MkLink (WithNamedContext name context sub) a = MkLink sub a
440+
toLink toA _ = toLink toA (Proxy :: Proxy sub)
406441

407442
instance HasLink sub => HasLink (RemoteHost :> sub) where
408-
type MkLink (RemoteHost :> sub) = MkLink sub
409-
toLink _ = toLink (Proxy :: Proxy sub)
443+
type MkLink (RemoteHost :> sub) a = MkLink sub a
444+
toLink = simpleToLink (Proxy :: Proxy sub)
410445

411446
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
412-
type MkLink (BasicAuth realm a :> sub) = MkLink sub
413-
toLink _ = toLink (Proxy :: Proxy sub)
447+
type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
448+
toLink = simpleToLink (Proxy :: Proxy sub)
414449

415450
instance HasLink EmptyAPI where
416-
type MkLink EmptyAPI = EmptyAPI
417-
toLink _ _ = EmptyAPI
451+
type MkLink EmptyAPI a = EmptyAPI
452+
toLink _ _ _ = EmptyAPI
418453

419454
-- Verb (terminal) instances
420455
instance HasLink (Verb m s ct a) where
421-
type MkLink (Verb m s ct a) = Link
422-
toLink _ = id
456+
type MkLink (Verb m s ct a) r = r
457+
toLink toA _ = toA
423458

424459
instance HasLink Raw where
425-
type MkLink Raw = Link
426-
toLink _ = id
460+
type MkLink Raw a = a
461+
toLink toA _ = toA
427462

428463
instance HasLink (Stream m fr ct a) where
429-
type MkLink (Stream m fr ct a) = Link
430-
toLink _ = id
464+
type MkLink (Stream m fr ct a) r = r
465+
toLink toA _ = toA
431466

432467
-- AuthProtext instances
433468
instance HasLink sub => HasLink (AuthProtect tag :> sub) where
434-
type MkLink (AuthProtect tag :> sub) = MkLink sub
435-
toLink _ = toLink (Proxy :: Proxy sub)
469+
type MkLink (AuthProtect tag :> sub) a = MkLink sub a
470+
toLink = simpleToLink (Proxy :: Proxy sub)
471+
472+
-- | Helper for implemneting 'toLink' for combinators not affecting link
473+
-- structure.
474+
simpleToLink
475+
:: forall sub a combinator.
476+
(HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
477+
=> Proxy sub
478+
-> (Link -> a)
479+
-> Proxy (combinator :> sub)
480+
-> Link
481+
-> MkLink (combinator :> sub) a
482+
simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
483+
436484

437485
-- $setup
438486
-- >>> import Servant.API

‎servant/test/Servant/Utils/LinksSpec.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@ type LinkableApi =
4141

4242

4343
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
44-
=> Proxy endpoint -> MkLink endpoint
44+
=> Proxy endpoint -> MkLink endpoint Link
4545
apiLink = safeLink (Proxy :: Proxy TestApi)
4646

4747
-- | Convert a link to a URI and ensure that this maps to the given string

0 commit comments

Comments
 (0)