@@ -8,76 +8,102 @@
88{-# LANGUAGE ScopedTypeVariables #-}
99{-# LANGUAGE UndecidableInstances #-}
1010
11−-- | Type safe internal links.
11+-- | Type safe generation of internal links.
1212--
13−-- Provides the function 'mkLink':
13+-- Given an API with a few endpoints:
1414--
15−-- @
16−-- {-# LANGUAGE DataKinds #-}
17−-- {-# LANGUAGE TypeFamilies #-}
18−-- {-# LANGUAGE TypeOperators #-}
15+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
16+-- >>> import Servant.API
17+-- >>> import Servant.Utils.Links
18+-- >>> import Data.Proxy
19+-- >>>
20+-- >>>
21+-- >>>
22+-- >>> type Hello = "hello" :> Get Int
23+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete
24+-- >>> type API = Hello :<|> Bye
25+-- >>> let api = Proxy :: Proxy API
1926--
20−-- import Servant.API
21−-- import Servant.Utils.Links
27+-- It is possible to generate links that are guaranteed to be within 'API' with
28+-- 'safeLink'.
2229--
23−-- -- You might want to put some custom types in your API
24−-- data Thing = Thing
30+-- The first argument to 'safeLink' is a symbol representing the endpoint you
31+-- would like to point to. This will need to end in a verb like Get, or Post.
2532--
26−-- -- If you want these to form part of a valid URL, just add them to the
27−-- -- open type family IsElem' like so:
28−-- type instance IsElem' e (Thing :> s) = IsElem e s
33+-- You may omit 'QueryParam's and the like should you not want to provide them,
34+-- but certain other types like 'Capture' must be included.
2935--
30−-- type API = "hello" :> Thing :> Get Int
31−-- :<|> "bye" :> QueryParam "name" String :> Post Bool
36+-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
37+-- magical: if parameters are included that could take input it will return a
38+-- function that accepts that input and generates a link.
3239--
33−-- api :: API
34−-- api = undefined
40+-- This is best shown with an example. Here, a link is generated with no
41+-- parameters:
3542--
36−-- link1 :: "hello" :> Get Int
37−-- link1 = undefined
43+-- >>> let hello = Proxy :: Proxy ("hello" :> Get Int)
44+-- >>> print $ safeLink hello api
45+-- hello
3846--
39−-- link2 :: "hello" :> Delete
40−-- link2 = undefined
47+-- If the API has an endpoint with parameters then we can generate links with
48+-- or without those:
4149--
42−-- main :: IO ()
43−-- main =
44−-- -- typechecks, prints "/hello"'
45−-- let Link str = mkLink link1 api
46−-- in putStrLn str
50+-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete)
51+-- >>> print $ safeLink with api "Hubert"
52+-- bye?name=Hubert
4753--
48−-- -- doesn't typecheck
49−-- -- mkLink link2 api
50−-- @
54+-- >>> let without = Proxy :: Proxy ("bye" :> Delete)
55+-- >>> print $ safeLink without api
56+-- bye
5157--
52−-- That is, 'mkLink' takes two arguments, a link and a sitemap, and
53−-- returns a 'Link', but only typechecks if the link proxy is a valid link,
54−-- and part of the sitemap.
58+-- Attempting to construct a link to an endpoint that does not exist in api
59+-- will result in a type error like this:
5560--
56−-- __N.B.:__ 'mkLink' assumes a capture matches any string (without slashes).
61+-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete)
62+-- >>> safeLink bad_link api
63+-- <BLANKLINE>
64+-- <interactive>:56:1:
65+-- Could not deduce (Or
66+-- (IsElem' Delete (Get Int))
67+-- (IsElem'
68+-- ("hello" :> Delete)
69+-- ("bye" :> (QueryParam "name" String :> Delete))))
70+-- arising from a use of ‘safeLink’
71+-- In the expression: safeLink bad_link api
72+-- In an equation for ‘it’: it = safeLink bad_link api
73+--
74+-- This error is essentially saying that the type family couldn't find
75+-- bad_link under api after trying the open (but empty) type family
76+-- `IsElem'` as a last resort.
5777module Servant.Utils.Links (
58− -- * Link and mkLink
59− -- | The only end-user utilities
60− mkLink
61− , Link, unLink
62− -- * Internal
63− -- | These functions will likely only be of interest if you are writing
64− -- more API combinators and would like to extend the behavior of
65− -- 'mkLink'
66− , ValidLinkIn()
67− , VLinkHelper(..)
68− , IsElem
69− , IsElem'
70− , IsLink
71− ) where
78+ -- * Building and using safe links
79+ --
80+ -- | Note that 'URI' is Network.URI.URI from the network-uri package.
81+ safeLink
82+ , URI(..)
83+ -- * Adding custom types
84+ , HasLink(..)
85+ , linkURI
86+ , Link
87+ , IsElem'
88+ -- * Illustrative exports
89+ , IsElem
90+ , Or
91+) where
7292
93+import Data.List
7394import Data.Proxy ( Proxy(..) )
74−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
95+import Data.Text (Text, unpack)
96+import Data.Monoid ( Monoid(..), (<>) )
97+import Network.URI ( URI(..), escapeURIString, isUnreserved )
98+import GHC.TypeLits ( KnownSymbol, symbolVal )
7599import GHC.Exts(Constraint)
76100
101+import Servant.Common.Text
77102import Servant.API.Capture ( Capture )
78103import Servant.API.ReqBody ( ReqBody )
79104import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
80105import Servant.API.MatrixParam ( MatrixParam, MatrixParams, MatrixFlag )
106+import Servant.API.Header ( Header )
81107import Servant.API.Get ( Get )
82108import Servant.API.Post ( Post )
83109import Servant.API.Put ( Put )
@@ -86,20 +112,27 @@ import Servant.API.Sub ( type (:>) )
86112import Servant.API.Raw ( Raw )
87113import Servant.API.Alternative ( type (:<|>) )
88114
89−
115+-- | If either a or b produce an empty constraint, produce an empty constraint.
90116type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
91117 Or () b = ()
92118 Or a () = ()
93119
94−type family And (a :: Constraint) (b :: Constraint) :: Constraint where
95− And () () = ()
96−
120+-- | You may use this type family to tell the type checker that your custom type
121+-- is a valid part of a link like so:
122+--
123+-- Not that 'IsElem' is called, which mutually recurses back to `IsElem'`
124+--
125+-- >>> data CustomThing
126+-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s
127+--
128+-- Now you can add a HasLink instance and you are ready to go.
97129type family IsElem' a s :: Constraint
98130
99−type family IsElem a s :: Constraint where
131+-- | Closed type family, check if endpoint is within api
132+type family IsElem endpoint api :: Constraint where
100133 IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
101134 IsElem (e :> sa) (e :> sb) = IsElem sa sb
102− IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
135+ IsElem sa (Header x :> sb) = IsElem sa sb
103136 IsElem sa (ReqBody x :> sb) = IsElem sa sb
104137 IsElem sa (QueryParam x y :> sb) = IsElem sa sb
105138 IsElem sa (QueryParams x y :> sb) = IsElem sa sb
@@ -110,45 +143,187 @@ type family IsElem a s :: Constraint where
110143 IsElem e e = ()
111144 IsElem e a = IsElem' e a
112145
113−type family IsLink'' l :: Constraint where
114− IsLink'' (e :> Get x) = IsLink' e
115− IsLink'' (e :> Post x) = IsLink' e
116− IsLink'' (e :> Put x) = IsLink' e
117− IsLink'' (e :> Delete) = IsLink' e
118− IsLink'' (e :> Raw) = IsLink' e
146+-- | A safe link datatype.
147+-- The only way of constructing a 'Link' is using 'safeLink', which means any
148+-- 'Link' is guaranteed to be part of the mentioned API.
149+data Link = Link
150+ { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]
151+ , _queryParams :: [Param Query]
152+ } deriving Show
153+
119154
120−type family IsLink' e :: Constraint where
121− IsLink' (f :: Symbol) = ()
155+-- Phantom types for Param
156+data Matrix
157+data Query
122158
123−type family IsLink e :: Constraint where
124− IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b))
125− (IsLink'' (a :> b))
159+-- | Query/Matrix param
160+data Param a
161+ = SingleParam String Text
162+ | ArrayElemParam String Text
163+ | FlagParam String
164+ deriving Show
126165
166+addSegment :: String -> Link -> Link
167+addSegment seg l = l { _segments = _segments l ++ [seg] }
127168
128−-- | The 'ValidLinkIn f s' constraint holds when 's' is an API that
129−-- contains 'f', and 'f' is a link.
130−class ValidLinkIn f s where
131− mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f`
132− -- is an URI within `s`
169+addQueryParam :: Param Query -> Link -> Link
170+addQueryParam qp l =
171+ l { _queryParams = _queryParams l ++ [qp] }
133172
134−instance ( IsElem f s
135− , IsLink f
136− , VLinkHelper f) => ValidLinkIn f s where
137− mkLink _ _ = Link (vlh (Proxy :: Proxy f))
173+-- Not particularly efficient for many updates. Something to optimise if it's
174+-- a problem.
175+addMatrixParam :: Param Matrix -> Link -> Link
176+addMatrixParam param l = l { _segments = f (_segments l) }
177+ where
178+ f [] = []
179+ f xs = init xs ++ [g (last xs)]
180+ -- Modify the segment at the "top" of the stack
181+ g :: String -> String
182+ g seg =
183+ case param of
184+ SingleParam k v -> seg <> ";" <> k <> "=" <> escape (unpack v)
185+ ArrayElemParam k v -> seg <> ";" <> k <> "[]=" <> escape (unpack v)
186+ FlagParam k -> seg <> ";" <> k
138187
139−-- | A safe link datatype.
140−-- The only way of constructing a 'Link' is using 'mkLink', which means any
141−-- 'Link' is guaranteed to be part of the mentioned API.
142−newtype Link = Link { unLink :: String } deriving Show
188+instance Monoid Link where
189+ mempty = Link mempty mempty
190+ mappend (Link a1 b1) (Link a2 b2) =
191+ Link (a1 <> a2) (b1 <> b2)
192+
193+linkURI :: Link -> URI
194+linkURI (Link segments q_params) =
195+ URI mempty -- No scheme (relative)
196+ Nothing -- Or authority (relative)
197+ (intercalate "/" segments)
198+ (makeQueries q_params) mempty
199+ where
200+ makeQueries :: [Param Query] -> String
201+ makeQueries [] = ""
202+ makeQueries xs =
203+ "?" <> intercalate "&" (fmap makeQuery xs)
204+
205+ makeQuery :: Param Query -> String
206+ makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (unpack v)
207+ makeQuery (SingleParam k v) = escape k <> "=" <> escape (unpack v)
208+ makeQuery (FlagParam k) = escape k
209+
210+escape :: String -> String
211+escape = escapeURIString isUnreserved
212+
213+-- | Create a valid (by construction) relative URI with query params.
214+--
215+-- This function will only typecheck if `endpoint` is part of the API `api`
216+safeLink
217+ :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
218+ => Proxy endpoint -- ^ The API endpoint you would like to point to
219+ -> Proxy api -- ^ The whole API that you this endpoint is a part of
220+ -> MkLink endpoint
221+safeLink endpoint _ = link endpoint mempty
222+
223+-- | Construct a link for an endpoint
224+class HasLink endpoint where
225+ type MkLink endpoint
226+ link :: Proxy endpoint -- ^ The API endpoint you would like to point to
227+ -> Link
228+ -> MkLink endpoint
229+
230+-- Naked symbol instance
231+instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
232+ type MkLink (sym :> sub) = MkLink sub
233+ link _ =
234+ link (Proxy :: Proxy sub) . addSegment seg
235+ where
236+ seg = symbolVal (Proxy :: Proxy sym)
237+
238+
239+-- QueryParam instances
240+instance (KnownSymbol sym, ToText v, HasLink sub)
241+ => HasLink (QueryParam sym v :> sub) where
242+ type MkLink (QueryParam sym v :> sub) = v -> MkLink sub
243+ link _ l v =
244+ link (Proxy :: Proxy sub)
245+ (addQueryParam (SingleParam k (toText v)) l)
246+ where
247+ k :: String
248+ k = symbolVal (Proxy :: Proxy sym)
249+
250+instance (KnownSymbol sym, ToText v, HasLink sub)
251+ => HasLink (QueryParams sym v :> sub) where
252+ type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub
253+ link _ l =
254+ link (Proxy :: Proxy sub) .
255+ foldl' (\l' v -> addQueryParam (ArrayElemParam k (toText v)) l') l
256+ where
257+ k = symbolVal (Proxy :: Proxy sym)
258+
259+instance (KnownSymbol sym, HasLink sub)
260+ => HasLink (QueryFlag sym :> sub) where
261+ type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub
262+ link _ l False =
263+ link (Proxy :: Proxy sub) l
264+ link _ l True =
265+ link (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
266+ where
267+ k = symbolVal (Proxy :: Proxy sym)
268+
269+-- MatrixParam instances
270+instance (KnownSymbol sym, ToText v, HasLink sub)
271+ => HasLink (MatrixParam sym v :> sub) where
272+ type MkLink (MatrixParam sym v :> sub) = v -> MkLink sub
273+ link _ l v =
274+ link (Proxy :: Proxy sub) $
275+ addMatrixParam (SingleParam k (toText v)) l
276+ where
277+ k = symbolVal (Proxy :: Proxy sym)
278+
279+instance (KnownSymbol sym, ToText v, HasLink sub)
280+ => HasLink (MatrixParams sym v :> sub) where
281+ type MkLink (MatrixParams sym v :> sub) = [v] -> MkLink sub
282+ link _ l =
283+ link (Proxy :: Proxy sub) .
284+ foldl' (\l' v -> addMatrixParam (ArrayElemParam k (toText v)) l') l
285+ where
286+ k = symbolVal (Proxy :: Proxy sym)
287+
288+instance (KnownSymbol sym, HasLink sub)
289+ => HasLink (MatrixFlag sym :> sub) where
290+ type MkLink (MatrixFlag sym :> sub) = Bool -> MkLink sub
291+ link _ l False =
292+ link (Proxy :: Proxy sub) l
293+ link _ l True =
294+ link (Proxy :: Proxy sub) $ addMatrixParam (FlagParam k) l
295+ where
296+ k = symbolVal (Proxy :: Proxy sym)
297+
298+-- Misc instances
299+instance HasLink sub => HasLink (ReqBody a :> sub) where
300+ type MkLink (ReqBody a :> sub) = MkLink sub
301+ link _ = link (Proxy :: Proxy sub)
302+
303+instance (ToText v, HasLink sub)
304+ => HasLink (Capture sym v :> sub) where
305+ type MkLink (Capture sym v :> sub) = v -> MkLink sub
306+ link _ l v =
307+ link (Proxy :: Proxy sub) $
308+ addSegment (escape . unpack $ toText v) l
309+
310+-- Verb (terminal) instances
311+instance HasLink (Get r) where
312+ type MkLink (Get r) = URI
313+ link _ = linkURI
143314
144−class VLinkHelper f where
145− vlh :: forall proxy. proxy f -> String
315+instance HasLink (Post r) where
316+ type MkLink (Post r) = URI
317+ link _ = linkURI
146318
147−instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where
148− vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e)
319+instance HasLink (Put r) where
320+ type MkLink (Put r) = URI
321+ link _ = linkURI
149322
150−instance VLinkHelper (Get x) where
151− vlh _ = ""
323+instance HasLink Delete where
324+ type MkLink Delete = URI
325+ link _ = linkURI
152326
153−instance VLinkHelper (Post x) where
154− vlh _ = ""
327+instance HasLink Raw where
328+ type MkLink Raw = URI
329+ link _ = linkURI