Links: add allLinks function and MkLink instance for (:<|>)

This lets you generate all links at once, which is useful in
conjunction with servant-generic.
This commit is contained in:
Robert Hensing 2017-11-06 14:42:41 +01:00 committed by Oleg Grenrus
parent a4b69d432b
commit 7410b4faa8
2 changed files with 30 additions and 0 deletions

View file

@ -84,6 +84,7 @@ module Servant.Utils.Links (
-- --
-- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
safeLink safeLink
, allLinks
, URI(..) , URI(..)
-- * Adding custom types -- * Adding custom types
, HasLink(..) , HasLink(..)
@ -108,6 +109,7 @@ import Prelude ()
import Prelude.Compat import Prelude.Compat
import Web.HttpApiData import Web.HttpApiData
import Servant.API.Alternative ( (:<|>)((:<|>)) )
import Servant.API.BasicAuth ( BasicAuth ) import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture, CaptureAll ) import Servant.API.Capture ( Capture, CaptureAll )
import Servant.API.ReqBody ( ReqBody ) import Servant.API.ReqBody ( ReqBody )
@ -220,6 +222,16 @@ safeLink
-> MkLink endpoint -> MkLink endpoint
safeLink _ endpoint = toLink endpoint (Link mempty mempty) safeLink _ endpoint = toLink endpoint (Link mempty mempty)
-- | Create all links in an API.
--
-- Note that the @api@ type must be restricted to the endpoints that have
-- valid links to them.
allLinks
:: forall api. HasLink api
=> Proxy api
-> MkLink api
allLinks api = toLink api (Link mempty mempty)
-- | Construct a toLink for an endpoint. -- | Construct a toLink for an endpoint.
class HasLink endpoint where class HasLink endpoint where
type MkLink endpoint type MkLink endpoint
@ -266,6 +278,11 @@ instance (KnownSymbol sym, HasLink sub)
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
-- :<|> instance - Generate all links at once
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
type MkLink (a :<|> b) = MkLink a :<|> MkLink b
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l
-- Misc instances -- Misc instances
instance HasLink sub => HasLink (ReqBody ct a :> sub) where instance HasLink sub => HasLink (ReqBody ct a :> sub) where
type MkLink (ReqBody ct a :> sub) = MkLink sub type MkLink (ReqBody ct a :> sub) = MkLink sub

View file

@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Utils.LinksSpec where module Servant.Utils.LinksSpec where
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
@ -10,6 +11,7 @@ import Test.Hspec (Expectation, Spec, describe, it,
import Data.String (fromString) import Data.String (fromString)
import Servant.API import Servant.API
import Servant.Utils.Links (allLinks)
type TestApi = type TestApi =
-- Capture and query params -- Capture and query params
@ -27,6 +29,10 @@ type TestApi =
:<|> "raw" :> Raw :<|> "raw" :> Raw
:<|> NoEndpoint :<|> NoEndpoint
type LinkableApi =
"all" :> CaptureAll "names" String :> Get '[JSON] NoContent
:<|> "get" :> Get '[JSON] NoContent
apiLink :: (IsElem endpoint TestApi, HasLink endpoint) apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
=> Proxy endpoint -> MkLink endpoint => Proxy endpoint -> MkLink endpoint
@ -67,6 +73,13 @@ spec = describe "Servant.Utils.Links" $ do
apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete" apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"
apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"
it "can generate all links for an API that has only linkable endpoints" $ do
let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)
simple
`shouldBeLink` "get"
allNames ["Seneca", "Aurelius"]
`shouldBeLink` "all/Seneca/Aurelius"
-- | -- |
-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,