Type safe links.

servant.cabal

@@ -20,6 +20,7 @@ library
     Servant.API
     Servant.API.Capture
     Servant.API.Delete
+    Servant.API.Elem
     Servant.API.Get
     Servant.API.Post
     Servant.API.Put

src/Servant/API.hs

@@ -27,10 +27,13 @@ module Servant.API (
   -- * Utilities
   -- | QuasiQuotes for endpoints
   module Servant.API.QQ,
+  -- | Type-safe internal URLs
+  module Servant.API.Elem,
   ) where
 
 import Servant.API.Capture
 import Servant.API.Delete
+import Servant.API.Elem (mkLink)
 import Servant.API.Get
 import Servant.API.Post
 import Servant.API.Put

src/Servant/API/Elem.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Servant.API.Elem where
+
+import Data.Proxy
+import GHC.TypeLits
+
+import Servant.API.Capture
+import Servant.API.ReqBody
+import Servant.API.QueryParam
+import Servant.API.Get
+import Servant.API.Post
+import Servant.API.Put
+import Servant.API.Delete
+import Servant.API.Sub
+import Servant.API.Alternative
+
+
+type family Or a b where
+    Or 'False 'False = 'False
+    Or 'True b       = 'True
+    Or a 'True       = 'True
+
+type family And a b where
+    And 'True 'True = 'True
+    And a 'False    = 'False
+    And 'False b    = 'False
+
+type family IsElem a s where
+    IsElem e (sa :<|> sb)                = Or (IsElem e sa) (IsElem e sb)
+    IsElem (e :> sa) (e :> sb)           = IsElem sa sb
+    IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
+    IsElem sa (ReqBody x :> sb)          = IsElem sa sb
+    IsElem sa (QueryParam x y :> sb)     = IsElem sa sb
+    IsElem e e                           = 'True
+    IsElem e a                           = 'False
+
+type family IsLink'' l where
+    IsLink'' (e :> Get x)    = IsLink' e
+    IsLink'' (e :> Post x)   = IsLink' e
+    IsLink'' (e :> Put x)    = IsLink' e
+    IsLink'' (e :> Delete)   = IsLink' e
+    IsLink'' a               = 'False
+
+type family IsLink' e where
+    IsLink' (f :: Symbol)  = 'True
+
+type family IsLink e where
+    IsLink (a :> b)        = Or (And (IsLink' a) (IsLink'' b))
+                                (IsLink'' (a :> b))
+
+
+-- | The 'ValidLinkIn f s' constraint holds when 's' is an API that
+-- contains 'f', and 'f' is a link.
+class ValidLinkIn f s where
+    mkLink :: f -> s -> Link  -- ^ This function will only typecheck if `f`
+                              -- is an URI within `s`
+
+instance ( IsElem f s ~ 'True
+         , IsLink f ~ 'True
+         , VLinkHelper f) => ValidLinkIn f s where
+    mkLink _ _ = Link (vlh (Proxy :: Proxy f))
+
+data Link = Link String deriving Show
+
+class VLinkHelper f where
+    vlh :: forall proxy. proxy f -> String
+
+instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where
+    vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e)
+
+instance VLinkHelper (Get x) where
+    vlh _ = ""
+
+instance VLinkHelper (Post x) where
+    vlh _ = ""
+

test/Servant/API/ElemSpec.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeOperators #-}
+module Servant.API.ElemSpec where
+
+import Test.Hspec
+
+import Servant.API
+import Servant.API.Elem (IsElem, IsLink)
+import Servant.API.QQSpec ( (~>) )
+
+type TestApi =
+       "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Get Bool
+  :<|> "greet" :> ReqBody 'True :> Post Bool
+
+type TestLink = "hello" :> "hi" :> Get Bool
+type TestLink2 = "greet" :> Post Bool
+
+type BadTestLink = "hallo" :> "hi" :> Get Bool
+type BadTestLink2 = "greet" :> Get Bool
+
+type NotALink = "hello" :> Capture "x" Bool :> Get Bool
+type NotALink2 = "hello" :> ReqBody 'True :> Get Bool
+
+data Proxy x = Proxy
+class ReflectT (x::Bool) where { reflected :: Proxy x -> Bool }
+instance ReflectT 'True where { reflected _ = True }
+instance ReflectT 'False where { reflected _ = False }
+
+spec :: Spec
+spec = describe "Servant.API.Elem" $ do
+    isElem
+    isLink
+
+isElem :: Spec
+isElem = describe "IsElem" $ do
+    it "is True when the first argument is an url within the second" $ do
+       reflected (Proxy::Proxy (IsElem TestLink TestApi)) ~> True
+       reflected (Proxy::Proxy (IsElem TestLink2 TestApi)) ~> True
+    it "is False when the first argument is not an url within the second" $ do
+       reflected (Proxy::Proxy (IsElem BadTestLink TestApi)) ~> False
+       reflected (Proxy::Proxy (IsElem BadTestLink2 TestApi)) ~> False
+
+isLink :: Spec
+isLink = describe "IsLink" $ do
+    it "is True when all Subs are paths and the last is a method" $ do
+        reflected (Proxy::Proxy (IsLink TestLink)) ~> True
+        reflected (Proxy::Proxy (IsLink TestLink2)) ~> True
+    it "is False of anything with captures" $ do
+        reflected (Proxy::Proxy (IsLink NotALink)) ~> False
+        reflected (Proxy::Proxy (IsLink NotALink2)) ~> False
+

test/Servant/API/QQSpec.hs

@@ -12,7 +12,6 @@ module Servant.API.QQSpec where
 import Test.Hspec
 
 import Servant.API
-{-import Servant.API.QQ-}
 
 --------------------------------------------------------------------------
 -- Types for testing