Merge pull request #25 from haskell-servant/canonical-types-rebased

Canonical types rebased
2015-04-20 09:37:40 +03:00 · 2015-04-20 09:37:40 +03:00 · 0173087166
parent 14f63520d0 d7fcf2b19b
commit 0173087166
4 changed files with 78 additions and 73 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -7,6 +7,7 @@
 * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
 * Support for PATCH
 * Make () instances expect No Content status code, and not try to decode body.
+* `Canonicalize` API types before generating client functions for them

 0.2.2
 -----
--- a/src/Servant/Client.hs
+++ b/src/Servant/Client.hs
@ -2,6 +2,7 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverlappingInstances #-}
@ -12,6 +13,7 @@
 module Servant.Client
  ( client
  , HasClient(..)
+  , Client
  , ServantError(..)
  , module Servant.Common.BaseUrl
  ) where
@ -45,15 +47,17 @@ import Servant.Common.Req
 -- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
 -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
 -- > (getAllBooks :<|> postNewBook) = client myApi
-client :: HasClient layout => Proxy layout -> Client layout
-client p = clientWithRoute p defReq
+client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
+client p = clientWithRoute (canonicalize p) defReq

 -- | This class lets us define how each API combinator
 -- influences the creation of an HTTP request. It's mostly
 -- an internal class, you can just use 'client'.
 class HasClient layout where
-  type Client layout :: *
-  clientWithRoute :: Proxy layout -> Req -> Client layout
+  type Client' layout :: *
+  clientWithRoute :: Proxy layout -> Req -> Client' layout
+
+type Client layout = Client' (Canonicalize layout)

 -- | A client querying function for @a ':<|>' b@ will actually hand you
 --   one function for querying @a@ and another one for querying @b@,
@ -69,7 +73,7 @@ class HasClient layout where
 -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
 -- > (getAllBooks :<|> postNewBook) = client myApi
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-  type Client (a :<|> b) = Client a :<|> Client b
+  type Client' (a :<|> b) = Client' a :<|> Client' b
  clientWithRoute Proxy req =
    clientWithRoute (Proxy :: Proxy a) req :<|>
    clientWithRoute (Proxy :: Proxy b) req
@ -96,8 +100,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
 instance (KnownSymbol capture, ToText a, HasClient sublayout)
      => HasClient (Capture capture a :> sublayout) where

-  type Client (Capture capture a :> sublayout) =
-    a -> Client sublayout
+  type Client' (Capture capture a :> sublayout) =
+    a -> Client' sublayout

  clientWithRoute Proxy req val =
    clientWithRoute (Proxy :: Proxy sublayout) $
@ -110,7 +114,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance HasClient Delete where
-  type Client Delete = BaseUrl -> EitherT ServantError IO ()
+  type Client' Delete = BaseUrl -> EitherT ServantError IO ()

  clientWithRoute Proxy req host =
    void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@ -120,14 +124,14 @@ instance HasClient Delete where
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
-  type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
+  type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
  clientWithRoute Proxy req host =
    performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host

 -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
 instance HasClient (Get (ct ': cts) ()) where
-  type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
  clientWithRoute Proxy req host =
    performRequestNoBody H.methodGet req [204] host

@ -159,12 +163,12 @@ instance HasClient (Get (ct ': cts) ()) where
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
      => HasClient (Header sym a :> sublayout) where

-  type Client (Header sym a :> sublayout) =
-    Maybe a -> Client sublayout
+  type Client' (Header sym a :> sublayout) =
+    Maybe a -> Client' sublayout

  clientWithRoute Proxy req mval =
    clientWithRoute (Proxy :: Proxy sublayout) $
-      maybe req (\value -> addHeader hname value req) mval
+      maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval

    where hname = symbolVal (Proxy :: Proxy sym)

@ -173,7 +177,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
-  type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+  type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

  clientWithRoute Proxy req uri =
    performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
@ -181,7 +185,7 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
 -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
 instance HasClient (Post (ct ': cts) ()) where
-  type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
  clientWithRoute Proxy req host =
    void $ performRequestNoBody H.methodPost req [204] host

@ -190,7 +194,7 @@ instance HasClient (Post (ct ': cts) ()) where
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
-  type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+  type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

  clientWithRoute Proxy req host =
    performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
@ -198,7 +202,7 @@ instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
 -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
 instance HasClient (Put (ct ': cts) ()) where
-  type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
  clientWithRoute Proxy req host =
    void $ performRequestNoBody H.methodPut req [204] host

@ -207,7 +211,7 @@ instance HasClient (Put (ct ': cts) ()) where
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
-  type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+  type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

  clientWithRoute Proxy req host =
    performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
@ -215,7 +219,7 @@ instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
 -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
 instance HasClient (Patch (ct ': cts) ()) where
-  type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
  clientWithRoute Proxy req host =
    void $ performRequestNoBody H.methodPatch req [204] host

@ -247,8 +251,8 @@ instance HasClient (Patch (ct ': cts) ()) where
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
      => HasClient (QueryParam sym a :> sublayout) where

-  type Client (QueryParam sym a :> sublayout) =
-    Maybe a -> Client sublayout
+  type Client' (QueryParam sym a :> sublayout) =
+    Maybe a -> Client' sublayout

  -- if mparam = Nothing, we don't add it to the query string
  clientWithRoute Proxy req mparam =
@ -289,8 +293,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
      => HasClient (QueryParams sym a :> sublayout) where

-  type Client (QueryParams sym a :> sublayout) =
-    [a] -> Client sublayout
+  type Client' (QueryParams sym a :> sublayout) =
+    [a] -> Client' sublayout

  clientWithRoute Proxy req paramlist =
    clientWithRoute (Proxy :: Proxy sublayout) $
@ -324,8 +328,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, HasClient sublayout)
      => HasClient (QueryFlag sym :> sublayout) where

-  type Client (QueryFlag sym :> sublayout) =
-    Bool -> Client sublayout
+  type Client' (QueryFlag sym :> sublayout) =
+    Bool -> Client' sublayout

  clientWithRoute Proxy req flag =
    clientWithRoute (Proxy :: Proxy sublayout) $
@ -363,8 +367,8 @@ instance (KnownSymbol sym, HasClient sublayout)
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
      => HasClient (MatrixParam sym a :> sublayout) where

-  type Client (MatrixParam sym a :> sublayout) =
-    Maybe a -> Client sublayout
+  type Client' (MatrixParam sym a :> sublayout) =
+    Maybe a -> Client' sublayout

  -- if mparam = Nothing, we don't add it to the query string
  clientWithRoute Proxy req mparam =
@ -404,8 +408,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
      => HasClient (MatrixParams sym a :> sublayout) where

-  type Client (MatrixParams sym a :> sublayout) =
-    [a] -> Client sublayout
+  type Client' (MatrixParams sym a :> sublayout) =
+    [a] -> Client' sublayout

  clientWithRoute Proxy req paramlist =
    clientWithRoute (Proxy :: Proxy sublayout) $
@ -439,8 +443,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, HasClient sublayout)
      => HasClient (MatrixFlag sym :> sublayout) where

-  type Client (MatrixFlag sym :> sublayout) =
-    Bool -> Client sublayout
+  type Client' (MatrixFlag sym :> sublayout) =
+    Bool -> Client' sublayout

  clientWithRoute Proxy req flag =
    clientWithRoute (Proxy :: Proxy sublayout) $
@ -453,9 +457,9 @@ instance (KnownSymbol sym, HasClient sublayout)
 -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- back the full `Response`.
 instance HasClient Raw where
-  type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
+  type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)

-  clientWithRoute :: Proxy Raw -> Req -> Client Raw
+  clientWithRoute :: Proxy Raw -> Req -> Client' Raw
  clientWithRoute Proxy req httpMethod host = do
    performRequest httpMethod req (const True) host

@ -480,17 +484,17 @@ instance HasClient Raw where
 instance (MimeRender ct a, HasClient sublayout)
      => HasClient (ReqBody (ct ': cts) a :> sublayout) where

-  type Client (ReqBody (ct ': cts) a :> sublayout) =
-    a -> Client sublayout
+  type Client' (ReqBody (ct ': cts) a :> sublayout) =
+    a -> Client' sublayout

  clientWithRoute Proxy req body =
    clientWithRoute (Proxy :: Proxy sublayout) $ do
      let ctProxy = Proxy :: Proxy ct
-      setRQBody (toByteString ctProxy body) (contentType ctProxy) req
+      setRQBody (mimeRender ctProxy body) (contentType ctProxy) req

 -- | Make the querying function append @path@ to the request path.
 instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
-  type Client (path :> sublayout) = Client sublayout
+  type Client' (path :> sublayout) = Client' sublayout

  clientWithRoute Proxy req =
     clientWithRoute (Proxy :: Proxy sublayout) $
--- a/src/Servant/Common/Req.hs
+++ b/src/Servant/Common/Req.hs
@ -172,7 +172,7 @@ performRequestCT ct reqMethod req wantedStatus reqHost = do
  either
    (left . (\s -> DecodeFailure s respCT respBody))
    return
-    (fromByteString ct respBody)
+    (mimeUnrender ct respBody)

 performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
 performRequestNoBody reqMethod req wantedStatus reqHost = do
--- a/test/Servant/ClientSpec.hs
+++ b/test/Servant/ClientSpec.hs
@ -1,42 +1,42 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators      #-}
 {-# OPTIONS_GHC -fcontext-stack=25 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.ClientSpec where

-import Control.Applicative
-import qualified Control.Arrow as Arrow
-import Control.Concurrent
-import Control.Exception
-import Control.Monad.Trans.Either
-import Data.Aeson
-import Data.ByteString.Lazy (ByteString)
-import Data.Char
-import Data.Foldable (forM_)
-import Data.Monoid
-import Data.Proxy
-import qualified Data.Text as T
-import GHC.Generics
-import qualified Network.HTTP.Client as C
-import Network.HTTP.Media
-import Network.HTTP.Types
-import Network.Socket
-import Network.Wai hiding (Response)
-import Network.Wai.Handler.Warp
-import Test.Hspec
-import Test.Hspec.QuickCheck
-import Test.HUnit
-import Test.QuickCheck
+import           Control.Applicative
+import qualified Control.Arrow              as Arrow
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad.Trans.Either
+import           Data.Aeson
+import           Data.ByteString.Lazy       (ByteString)
+import           Data.Char
+import           Data.Foldable              (forM_)
+import           Data.Monoid
+import           Data.Proxy
+import qualified Data.Text                  as T
+import           GHC.Generics
+import qualified Network.HTTP.Client        as C
+import           Network.HTTP.Media
+import           Network.HTTP.Types
+import           Network.Socket
+import           Network.Wai                hiding (Response)
+import           Network.Wai.Handler.Warp
+import           Test.Hspec
+import           Test.Hspec.QuickCheck
+import           Test.HUnit
+import           Test.QuickCheck

-import Servant.API
-import Servant.Client
-import Servant.Server
+import           Servant.API
+import           Servant.Client
+import           Servant.Server

 -- * test data types

@ -289,8 +289,8 @@ spec = do
        _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

 data WrappedApi where
-  WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
-                 HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
+  WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
+                 HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
    Proxy api -> WrappedApi