diff --git a/servant.cabal b/servant.cabal index 60ac7563..d433ce8b 100644 --- a/servant.cabal +++ b/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 diff --git a/src/Servant/API.hs b/src/Servant/API.hs index 9de66ea2..035033d6 100644 --- a/src/Servant/API.hs +++ b/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 diff --git a/src/Servant/API/Elem.hs b/src/Servant/API/Elem.hs new file mode 100644 index 00000000..4a5b7555 --- /dev/null +++ b/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 _ = "" + diff --git a/test/Servant/API/ElemSpec.hs b/test/Servant/API/ElemSpec.hs new file mode 100644 index 00000000..385d8ae3 --- /dev/null +++ b/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 + diff --git a/test/Servant/API/QQSpec.hs b/test/Servant/API/QQSpec.hs index eb27b84f..addf0559 100644 --- a/test/Servant/API/QQSpec.hs +++ b/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