From d33214d3761e0d8ebbc8a96bf544a5e077c14d88 Mon Sep 17 00:00:00 2001
From: Nick B <nick@declension.net>
Date: Sat, 11 Mar 2017 11:19:57 +0000
Subject: [PATCH] Fix Path delimiting:

  * Add test API with multiple Path elements
  * Add basic test using this API, generating an endpoint to validate that query path delimiting is happening correctly (that fails on `master`)
  * Fix (re)creation of path to prepend `/` to each new path section, but only if it's non-empty (this fixes the trailing slashes, but still allows users to use a `:> "foo/" :>...` if their API demands trailing slashes)
  * Update / fix the existing test that now fails slightly differently (i.e. the trailing slash in `failplz/` is gone)

Fixes #22.
---
 .../QuickCheck/Internal/HasGenRequest.hs      |  7 +++++-
 test/Servant/QuickCheck/InternalSpec.hs       | 22 +++++++++++++++++--
 2 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs
index 010842f..9ba7452 100644
--- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs
+++ b/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)
diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs
index 0e6c053..3cf9716 100644
--- a/test/Servant/QuickCheck/InternalSpec.hs
+++ b/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