git.iko.soy/typeable/servant
on master help sign in
Type safe links.
commit11f82633daeff5d9a89867d02fefa00f0a654c69 authorJulian K. Arni <jkarni@gmail.com> dateMon 27 Oct 2014, 15:52 (12 years ago) parentfd636ea
5 files changed+139−1
compare with master
unifiedsplit
servant.cabal+1 src/Servant/API.hs+3 src/Servant/API/Elem.hs+83 test/Servant/API/ElemSpec.hs+52 test/Servant/API/QQSpec.hs−1
servant.cabal+1
@@ -20,6 +20,7 @@ library
2020 Servant.API
2121 Servant.API.Capture
2222 Servant.API.Delete
23+ Servant.API.Elem
2324 Servant.API.Get
2425 Servant.API.Post
2526 Servant.API.Put
src/Servant/API.hs+3
@@ -27,10 +27,13 @@ module Servant.API (
2727 -- * Utilities
2828 -- | QuasiQuotes for endpoints
2929 module Servant.API.QQ,
30+ -- | Type-safe internal URLs
31+ module Servant.API.Elem,
3032 ) where
3133
3234import Servant.API.Capture
3335import Servant.API.Delete
36+import Servant.API.Elem (mkLink)
3437import Servant.API.Get
3538import Servant.API.Post
3639import Servant.API.Put
src/Servant/API/Elem.hsnew file+83
@@ -0,0 +1,83 @@
1+{-# LANGUAGE PolyKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+module Servant.API.Elem where
10+
11+import Data.Proxy
12+import GHC.TypeLits
13+
14+import Servant.API.Capture
15+import Servant.API.ReqBody
16+import Servant.API.QueryParam
17+import Servant.API.Get
18+import Servant.API.Post
19+import Servant.API.Put
20+import Servant.API.Delete
21+import Servant.API.Sub
22+import Servant.API.Alternative
23+
24+
25+type family Or a b where
26+ Or 'False 'False = 'False
27+ Or 'True b = 'True
28+ Or a 'True = 'True
29+
30+type family And a b where
31+ And 'True 'True = 'True
32+ And a 'False = 'False
33+ And 'False b = 'False
34+
35+type family IsElem a s where
36+ IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
37+ IsElem (e :> sa) (e :> sb) = IsElem sa sb
38+ IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
39+ IsElem sa (ReqBody x :> sb) = IsElem sa sb
40+ IsElem sa (QueryParam x y :> sb) = IsElem sa sb
41+ IsElem e e = 'True
42+ IsElem e a = 'False
43+
44+type family IsLink'' l where
45+ IsLink'' (e :> Get x) = IsLink' e
46+ IsLink'' (e :> Post x) = IsLink' e
47+ IsLink'' (e :> Put x) = IsLink' e
48+ IsLink'' (e :> Delete) = IsLink' e
49+ IsLink'' a = 'False
50+
51+type family IsLink' e where
52+ IsLink' (f :: Symbol) = 'True
53+
54+type family IsLink e where
55+ IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b))
56+ (IsLink'' (a :> b))
57+
58+
59+-- | The 'ValidLinkIn f s' constraint holds when 's' is an API that
60+-- contains 'f', and 'f' is a link.
61+class ValidLinkIn f s where
62+ mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f`
63+ -- is an URI within `s`
64+
65+instance ( IsElem f s ~ 'True
66+ , IsLink f ~ 'True
67+ , VLinkHelper f) => ValidLinkIn f s where
68+ mkLink _ _ = Link (vlh (Proxy :: Proxy f))
69+
70+data Link = Link String deriving Show
71+
72+class VLinkHelper f where
73+ vlh :: forall proxy. proxy f -> String
74+
75+instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where
76+ vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e)
77+
78+instance VLinkHelper (Get x) where
79+ vlh _ = ""
80+
81+instance VLinkHelper (Post x) where
82+ vlh _ = ""
83+
test/Servant/API/ElemSpec.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE TypeOperators #-}
4+module Servant.API.ElemSpec where
5+
6+import Test.Hspec
7+
8+import Servant.API
9+import Servant.API.Elem (IsElem, IsLink)
10+import Servant.API.QQSpec ( (~>) )
11+
12+type TestApi =
13+ "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Get Bool
14+ :<|> "greet" :> ReqBody 'True :> Post Bool
15+
16+type TestLink = "hello" :> "hi" :> Get Bool
17+type TestLink2 = "greet" :> Post Bool
18+
19+type BadTestLink = "hallo" :> "hi" :> Get Bool
20+type BadTestLink2 = "greet" :> Get Bool
21+
22+type NotALink = "hello" :> Capture "x" Bool :> Get Bool
23+type NotALink2 = "hello" :> ReqBody 'True :> Get Bool
24+
25+data Proxy x = Proxy
26+class ReflectT (x::Bool) where { reflected :: Proxy x -> Bool }
27+instance ReflectT 'True where { reflected _ = True }
28+instance ReflectT 'False where { reflected _ = False }
29+
30+spec :: Spec
31+spec = describe "Servant.API.Elem" $ do
32+ isElem
33+ isLink
34+
35+isElem :: Spec
36+isElem = describe "IsElem" $ do
37+ it "is True when the first argument is an url within the second" $ do
38+ reflected (Proxy::Proxy (IsElem TestLink TestApi)) ~> True
39+ reflected (Proxy::Proxy (IsElem TestLink2 TestApi)) ~> True
40+ it "is False when the first argument is not an url within the second" $ do
41+ reflected (Proxy::Proxy (IsElem BadTestLink TestApi)) ~> False
42+ reflected (Proxy::Proxy (IsElem BadTestLink2 TestApi)) ~> False
43+
44+isLink :: Spec
45+isLink = describe "IsLink" $ do
46+ it "is True when all Subs are paths and the last is a method" $ do
47+ reflected (Proxy::Proxy (IsLink TestLink)) ~> True
48+ reflected (Proxy::Proxy (IsLink TestLink2)) ~> True
49+ it "is False of anything with captures" $ do
50+ reflected (Proxy::Proxy (IsLink NotALink)) ~> False
51+ reflected (Proxy::Proxy (IsLink NotALink2)) ~> False
52+
test/Servant/API/QQSpec.hs−1
@@ -12,7 +12,6 @@ module Servant.API.QQSpec where
1212import Test.Hspec
1313
1414import Servant.API
15−{-import Servant.API.QQ-}
1615
1716--------------------------------------------------------------------------
1817-- Types for testing