Merge pull request #1699 from RaoulHC/NamedRoutes-IsElem

Add missing IsElem instance for NamedRoutes

Author: ysangkok

cabal.project

@@ -58,6 +58,10 @@ optimization: False
 constraints: crypton < 0, crypton-connection < 0, crypton-x509 < 0, crypton-x509-store < 0, crypton-x509-system < 0, crypton-x509-validation < 0
 constraints: warp < 3.3.26
 
+-- wreq-0.5.4.1 doesn't seem to work with ghc-8.6.5
+if (impl(ghc < 8.8))
+  constraints: wreq == 0.5.4.0
+
 allow-newer: servant-js:base
 
 -- Print ticks so that doctest type querying is consistent across GHC versions.

changelog.d/1699

@@ -0,0 +1,7 @@
+synopsis: Add NamedRoutes instance to IsElem
+prs: #1699
+issues: #1674
+description: {
+Add missing IsElem instance for NamedRoutes, this allows links to be checked
+with `safeLink`.
+}

servant/src/Servant/API/TypeLevel.hs

@@ -64,6 +64,10 @@ import           Servant.API.QueryParam
                  (QueryFlag, QueryParam, QueryParams)
 import           Servant.API.ReqBody
                  (ReqBody)
+import           Servant.API.NamedRoutes
+                 (NamedRoutes)
+import           Servant.API.Generic
+                 (ToServantApi)
 import           Servant.API.Sub
                  (type (:>))
 import           Servant.API.Verbs
@@ -143,6 +147,7 @@ type family IsElem endpoint api :: Constraint where
   IsElem (Verb m s ct typ) (Verb m s ct' typ)
                                           = IsSubList ct ct'
   IsElem e e                              = ()
+  IsElem e (NamedRoutes rs)               = IsElem e (ToServantApi rs)
   IsElem e a                              = IsElem' e a
 
 -- | Check whether @sub@ is a sub-API of @api@.

servant/test/Servant/LinksSpec.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE ConstraintKinds     #-}
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators       #-}
 module Servant.LinksSpec where
 
+import           GHC.Generics
+                 (Generic)
 import           Data.Proxy
                  (Proxy (..))
 import           Data.String
@@ -44,17 +47,51 @@ type LinkableApi =
        "all" :> CaptureAll "names" String :> Get '[JSON] NoContent
   :<|> "get" :> Get '[JSON] NoContent
 
-
 apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
          => Proxy endpoint -> MkLink endpoint Link
 apiLink = safeLink (Proxy :: Proxy TestApi)
 
+
+newtype QuuxRoutes mode = QuuxRoutes
+  { corge :: mode :- "corge" :> Post '[PlainText] NoContent
+  } deriving Generic
+
+newtype WaldoRoutes mode = WaldoRoutes
+  { waldo :: mode :- "waldo" :> Get '[JSON] NoContent
+  } deriving Generic
+
+data FooRoutes mode = FooRoutes
+  { baz :: mode :- "baz" :> Get '[JSON] NoContent
+  , qux :: mode :- "qux" :> NamedRoutes QuuxRoutes
+  , quux :: mode :- "quux" :> QueryParam "grault" String :> Get '[JSON] NoContent
+  , garply :: mode :- "garply" :> Capture "garply" String
+           :> Capture "garplyNum" Int :> NamedRoutes WaldoRoutes
+  } deriving Generic
+
+data BaseRoutes mode = BaseRoutes
+  { foo :: mode :- "foo" :> NamedRoutes FooRoutes
+  , bar :: mode :- "bar" :> Get '[JSON] NoContent
+  } deriving Generic
+
+recordApiLink
+  :: (IsElem endpoint (NamedRoutes BaseRoutes), HasLink endpoint)
+  => Proxy endpoint -> MkLink endpoint Link
+recordApiLink = safeLink (Proxy :: Proxy (NamedRoutes BaseRoutes))
+
 -- | Convert a link to a URI and ensure that this maps to the given string
 -- given string
 shouldBeLink :: Link -> String -> Expectation
 shouldBeLink link expected =
     toUrlPiece link `shouldBe` fromString expected
 
+(//) :: a -> (a -> b) -> b
+x // f = f x
+infixl 1 //
+
+(/:) :: (a -> b -> c) -> b -> a -> c
+(/:) = flip
+infixl 2 /:
+
 spec :: Spec
 spec = describe "Servant.Links" $ do
     it "generates correct links for capture query params" $ do
@@ -106,6 +143,33 @@ spec = describe "Servant.Links" $ do
         let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw
         firstLink `shouldBeLink` ""
 
+    it "Generate links from record fields accessors" $ do
+      fieldLink bar `shouldBeLink` "bar"
+      (fieldLink foo // baz)  `shouldBeLink` "foo/baz"
+      (fieldLink foo // qux // corge) `shouldBeLink` "foo/qux/corge"
+      (fieldLink foo // quux /: Nothing) `shouldBeLink` "foo/quux"
+      (fieldLink foo // quux /: Just "floop") `shouldBeLink` "foo/quux?grault=floop"
+      (fieldLink foo // garply /: "captureme" /: 42 // waldo)
+        `shouldBeLink` "foo/garply/captureme/42/waldo"
+
+    it "Check links from record fields" $ do
+      let sub1 = Proxy :: Proxy ("bar" :> Get '[JSON] NoContent)
+      recordApiLink sub1 `shouldBeLink` "bar"
+
+      let sub2 = Proxy :: Proxy ("foo" :> "baz" :> Get '[JSON] NoContent)
+      recordApiLink sub2 `shouldBeLink` "foo/baz"
+
+      let sub3 = Proxy :: Proxy ("foo" :> "quux" :> QueryParam "grault" String
+                                       :> Get '[JSON] NoContent)
+      recordApiLink sub3 (Just "floop") `shouldBeLink` "foo/quux?grault=floop"
+
+      let sub4 :: Proxy ("foo" :> "garply" :> Capture "garplyText" String
+                       :> Capture "garplyInt" Int :> "waldo"
+                       :> Get '[JSON] NoContent)
+          sub4 = Proxy
+      recordApiLink sub4 "captureme" 42
+        `shouldBeLink` "foo/garply/captureme/42/waldo"
+
 -- The doctests below aren't run on CI, setting that up is tricky.
 -- They are run by makefile rule, however.