Merge pull request #666 from phadej/bug-fix-for-haslink

Bug fix for haslink

Author: phadej

servant/CHANGELOG.md

@@ -4,6 +4,10 @@
 * Use `NT` from `natural-transformation` for `Enter`
   ([#616](https://github.com/haskell-servant/servant/issues/616))
 
+* Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link`
+  use its `ToHttpApiData` instance or `linkURI`.
+  ([#527](https://github.com/haskell-servant/servant/issues/527))
+
 0.9.1
 ------
 

servant/src/Servant/API.hs

@@ -101,7 +101,7 @@ import           Servant.API.Verbs           (PostCreated, Delete, DeleteAccepte
                                               ReflectMethod (reflectMethod),
                                               Verb, StdMethod(..))
 import           Servant.API.WithNamedContext (WithNamedContext)
-import           Servant.Utils.Links         (HasLink (..), IsElem, IsElem',
+import           Servant.Utils.Links         (HasLink (..), Link, IsElem, IsElem',
                                               URI (..), safeLink)
 import           Web.HttpApiData             (FromHttpApiData (..),
                                               ToHttpApiData (..))

servant/src/Servant/Utils/Links.hs

@@ -30,7 +30,7 @@
 -- you would like to restrict links to. The second argument is the destination
 -- endpoint you would like the link to point to, this will need to end with a
 -- verb like GET or POST. Further arguments may be required depending on the
--- type of the endpoint. If everything lines up you will get a 'URI' out the
+-- type of the endpoint. If everything lines up you will get a 'Link' out the
 -- other end.
 --
 -- You may omit 'QueryParam's and the like should you not want to provide them,
@@ -41,19 +41,19 @@
 -- with an example. Here, a link is generated with no parameters:
 --
 -- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
--- >>> print (safeLink api hello :: URI)
--- hello
+-- >>> toUrlPiece (safeLink api hello :: Link)
+-- "hello"
 --
 -- If the API has an endpoint with parameters then we can generate links with
 -- or without those:
 --
 -- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
--- >>> print $ safeLink api with (Just "Hubert")
--- bye?name=Hubert
+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
+-- "bye?name=Hubert"
 --
 -- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
--- >>> print $ safeLink api without
--- bye
+-- >>> toUrlPiece $ safeLink api without
+-- "bye"
 --
 -- If you would like create a helper for generating links only within that API,
 -- you can partially apply safeLink if you specify a correct type signature
@@ -94,11 +94,11 @@ module Servant.Utils.Links (
   , Or
 ) where
 
-import qualified Data.ByteString.Char8 as BSC
 import           Data.List
 import           Data.Monoid.Compat    ( (<>) )
 import           Data.Proxy            ( Proxy(..) )
 import qualified Data.Text             as Text
+import qualified Data.Text.Encoding    as TE
 import           GHC.Exts              (Constraint)
 import           GHC.TypeLits          ( KnownSymbol, symbolVal )
 import           Network.URI           ( URI(..), escapeURIString, isUnreserved )
@@ -126,8 +126,10 @@ data Link = Link
   } deriving Show
 
 instance ToHttpApiData Link where
-    toUrlPiece = Text.pack . show
-    toHeader   = BSC.pack . show
+    toHeader   = TE.encodeUtf8 . toUrlPiece
+    toUrlPiece l =
+        let uri = linkURI l
+        in Text.pack $ uriPath uri ++ uriQuery uri
 
 -- | If either a or b produce an empty constraint, produce an empty constraint.
 type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
@@ -307,9 +309,9 @@ instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
 
 -- Verb (terminal) instances
 instance HasLink (Verb m s ct a) where
-    type MkLink (Verb m s ct a) = URI
-    toLink _ = linkURI
+    type MkLink (Verb m s ct a) = Link
+    toLink _ = id 
 
 instance HasLink Raw where
-    type MkLink Raw = URI
-    toLink _ = linkURI
+    type MkLink Raw = Link
+    toLink _ = id

servant/test/Servant/Utils/LinksSpec.hs

@@ -7,6 +7,7 @@ module Servant.Utils.LinksSpec where
 import           Data.Proxy              (Proxy (..))
 import           Test.Hspec              (Expectation, Spec, describe, it,
                                           shouldBe)
+import           Data.String             (fromString)
 
 import           Servant.API
 
@@ -32,38 +33,38 @@ apiLink = safeLink (Proxy :: Proxy TestApi)
 
 -- | Convert a link to a URI and ensure that this maps to the given string
 -- given string
-shouldBeURI :: URI -> String -> Expectation
-shouldBeURI link expected =
-    show link `shouldBe` expected
+shouldBeLink :: Link -> String -> Expectation
+shouldBeLink link expected =
+    toUrlPiece link `shouldBe` fromString expected
 
 spec :: Spec
 spec = describe "Servant.Utils.Links" $ do
     it "generates correct links for capture query params" $ do
         let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)
-        apiLink l1 "hi" `shouldBeURI` "hello/hi"
+        apiLink l1 "hi" `shouldBeLink` "hello/hi"
 
         let l2 = Proxy :: Proxy ("hello" :> Capture "name" String
                                          :> QueryParam "capital" Bool
                                          :> Delete '[JSON] NoContent)
-        apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
+        apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"
 
     it "generates correct links for CaptureAll" $ do
         apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
           ["roads", "lead", "to", "rome"]
-          `shouldBeURI` "all/roads/lead/to/rome"
+          `shouldBeLink` "all/roads/lead/to/rome"
 
     it "generates correct links for query flags" $ do
         let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
                                          :> QueryFlag "fast" :> Delete '[JSON] NoContent)
-        apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"
-        apiLink l1 False True `shouldBeURI` "balls?fast"
+        apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"
+        apiLink l1 False True `shouldBeLink` "balls?fast"
 
     it "generates correct links for all of the verbs" $ do
-        apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeURI` "get"
-        apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeURI` "put"
-        apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeURI` "post"
-        apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeURI` "delete"
-        apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"
+        apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"
+        apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"
+        apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"
+        apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"
+        apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"
 
 
 -- |
@@ -96,8 +97,8 @@ spec = describe "Servant.Utils.Links" $ do
 -- ...
 --
 -- sanity check
--- >>> apiLink (Proxy :: Proxy AllGood)
--- get
+-- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)
+-- "get"
 type WrongPath = "getTypo" :> Get '[JSON] NoContent
 type WrongReturnType = "get" :> Get '[JSON] Bool
 type WrongContentType = "get" :> Get '[OctetStream] NoContent

stack.yaml

@@ -15,5 +15,4 @@ extra-deps:
 - hspec-core-2.3.2
 - hspec-wai-0.8.0
 - hspec-expectations-0.8.2
-- call-stack-0.1.0
-resolver: lts-6.0
+resolver: lts-6.27