Merge pull request #28 from declension/22-fix-path-delimiting

Fix path delimiting (#22)

src/Servant/QuickCheck/Internal/HasGenRequest.hs

@@ -17,6 +17,7 @@ import Servant.Client           (BaseUrl (..), Scheme (..))
 import Test.QuickCheck          (Arbitrary (..), Gen, elements, oneof)
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BS (c2w)
 
 
 class HasGenRequest a where
@@ -31,7 +32,11 @@ instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
 instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
     genRequest _ = do
       old' <- old
-      return $ \burl -> let r = old' burl in r { path = new <> path r }
+      return $ \burl -> let r = old' burl
+                            oldPath = path r
+                            oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
+                            paths = filter (not . BS.null) [new, oldPath']
+                            in r { path = "/" <> BS.intercalate "/" paths }
       where
         old = genRequest (Proxy :: Proxy b)
         new = cs $ symbolVal (Proxy :: Proxy path)

test/Servant/QuickCheck/InternalSpec.hs

@@ -13,7 +13,7 @@ import           Test.Hspec.Core.Spec    (Arg, Example, Result (..),
                                           defaultParams, evaluateExample)
 import           Test.QuickCheck.Gen     (unGen)
 import           Test.QuickCheck.Random  (mkQCGen)
-import           Network.HTTP.Client     (queryString)
+import           Network.HTTP.Client     (queryString, path)
 
 #if MIN_VERSION_servant(0,8,0)
 import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
@@ -34,6 +34,7 @@ spec = do
   notLongerThanSpec
   queryParamsSpec
   queryFlagsSpec
+  deepPathSpec
 
 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@@ -52,7 +53,7 @@ serversEqualSpec = describe "serversEqual" $ do
           evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
       show err `shouldContain` "Body: 1"
       show err `shouldContain` "Body: 2"
-      show err `shouldContain` "Path: failplz/"
+      show err `shouldContain` "Path: /failplz"
 
 serverSatisfiesSpec :: Spec
 serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -113,6 +114,17 @@ isComprehensiveSpec = describe "HasGenRequest" $ do
     let _g = genRequest comprehensiveAPIWithoutRaw
     True `shouldBe` True -- This is a type-level check
 
+deepPathSpec :: Spec
+deepPathSpec = describe "Path components" $ do
+
+  it "are separated by slashes, without a trailing slash" $ do
+    let rng = mkQCGen 0
+        burl = BaseUrl Http "localhost" 80 ""
+        gen = genRequest deepAPI
+        req = (unGen gen rng 0) burl
+    path req `shouldBe` ("/one/two/three")
+
+
 queryParamsSpec :: Spec
 queryParamsSpec = describe "QueryParams" $ do
 
@@ -170,6 +182,12 @@ type API2 = "failplz" :> Get '[JSON] Int
 api2 :: Proxy API2
 api2 = Proxy
 
+type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
+
+deepAPI :: Proxy DeepAPI
+deepAPI = Proxy
+
+
 server2 :: IO (Server API2)
 server2 = return $ return 1