failing test case for static client

just to clarify on how to use it properly

doc/tutorial/tutorial.cabal

@@ -1,5 +1,5 @@
 name:                tutorial
-version:             0.6
+version:             0.6.1
 synopsis:            The servant tutorial
 homepage:            http://haskell-servant.github.io/
 license:             BSD3

servant-blaze/servant-blaze.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                servant-blaze
-version:             0.6
+version:             0.6.1
 synopsis:            Blaze-html support for servant
 -- description:
 homepage:            http://haskell-servant.github.io/

servant-cassava/servant-cassava.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                servant-cassava
-version:             0.6
+version:             0.6.1
 synopsis:            Servant CSV content-type for cassava
 -- description:
 homepage:            http://haskell-servant.github.io/

servant-client/servant-client.cabal

@@ -1,5 +1,5 @@
 name:                servant-client
-version:             0.6
+version:             0.6.1
 synopsis: automatical derivation of querying functions for servant webservices
 description:
   This library lets you derive automatically Haskell functions that

servant-client/src/Servant/Client.hs

@@ -1,14 +1,16 @@
-{-# LANGUAGE CPP                  #-}
+{-# LANGUAGE CPP                    #-}
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE InstanceSigs         #-}
+{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE InstanceSigs           #-}
-{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE OverloadedStrings      #-}
-{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE PolyKinds              #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
 
 #include "overlapping-compat.h"
 -- | This module provides 'client' which can automatically generate
@@ -18,6 +20,7 @@ module Servant.Client
   ( AuthClientData
   , AuthenticateReq(..)
   , client
+  , staticClient
   , HasClient(..)
   , ClientM
   , mkAuthenticateReq
@@ -60,6 +63,36 @@ import           Servant.Common.Req
 client :: HasClient layout => Proxy layout -> Client layout
 client p = clientWithRoute p defReq
 
+
+class Foo layout where
+  type StaticClient layout :: *
+  staticClient :: Proxy layout -> BaseUrl -> StaticClient layout
+
+instance (Foo left, Foo right) => Foo (left :<|> right) where
+  type StaticClient (left :<|> right) = StaticClient left :<|> StaticClient right
+  staticClient p url =
+    staticClient pleft url :<|>
+    staticClient pright url
+    where pleft = Proxy :: Proxy left
+          pright = Proxy :: Proxy right
+
+instance OVERLAPPABLE_ (Client (combinator :> api) ~ Client api, Foo api) => Foo (combinator :> api) where
+  type StaticClient (combinator :> api) = StaticClient api
+  staticClient p url = staticClient (Proxy :: Proxy api) url
+
+instance OVERLAPPING_ (MimeRender ct a, Client (ReqBody (ct ': cts) a :> sublayout) ~ (a -> Client sublayout), Foo sublayout)
+      => Foo (ReqBody (ct ': cts) a :> sublayout) where
+  type StaticClient (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout
+  staticClient p url = _
+
+instance (Client (Verb method status ctypes result) ~ (Manager -> BaseUrl -> ClientM result), ctypes ~ (c ': ct), MimeUnrender c result, ReflectMethod method) => Foo (Verb method status ctypes result) where
+  type StaticClient (Verb method status ctypes result) = Manager -> ClientM result
+  staticClient p url = \ mgr -> (client p) mgr url
+
+instance Foo Raw where
+  type StaticClient Raw = H.Method -> Manager -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
+  staticClient p url = \h m -> (client p) h m url
+
 -- | 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'.

servant-client/test/Servant/ClientSpec.hs

@@ -296,6 +296,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
             return $
               result === Right (cap, num, flag, body)
 
+    describe "staticClient" $ do
+      it "allows to pass in the BaseUrl to staticClient" $ \(_, baseUrl) -> do
+        let getGet' :: C.Manager -> ClientM Person
+            getGet' :<|> _ = staticClient api baseUrl
+        (left show <$> runExceptT (getGet' manager)) `shouldReturn` Right alice
 
 wrappedApiSpec :: Spec
 wrappedApiSpec = describe "error status codes" $ do

servant-docs/servant-docs.cabal

@@ -1,5 +1,5 @@
 name:                servant-docs
-version:             0.6
+version:             0.6.1
 synopsis:            generate API docs for your servant webservice
 description:
   Library for generating API docs from a servant API definition.

servant-foreign/servant-foreign.cabal

@@ -1,5 +1,5 @@
 name:                servant-foreign
-version:             0.6
+version:             0.6.1
 synopsis:            Helpers for generating clients for servant APIs in any programming language
 description:
   Helper types and functions for generating client functions for servant APIs in any programming language

servant-js/servant-js.cabal

@@ -1,5 +1,5 @@
 name:                servant-js
-version:             0.6
+version:             0.6.1
 synopsis:            Automatically derive javascript functions to query servant webservices.
 description:
   Automatically derive javascript functions to query servant webservices.

servant-lucid/servant-lucid.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                servant-lucid
-version:             0.6
+version:             0.6.1
 synopsis:            Servant support for lucid
 -- description:
 homepage:            http://haskell-servant.github.io/

servant-mock/servant-mock.cabal

@@ -1,5 +1,5 @@
 name:                servant-mock
-version:             0.6
+version:             0.6.1
 synopsis:            Derive a mock server for free from your servant API types
 description:
   Derive a mock server for free from your servant API types

servant-server/CHANGELOG.md

@@ -1,3 +1,11 @@
+0.6.1
+-----
+
+* If servers use the `BasicAuth` combinator and receive requests with missing or
+  invalid credentials, the resulting error responses (401 and 403) could be
+  overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal`
+  and the error responses can't be overwritten anymore.
+
 0.6
 ---
 

servant-server/servant-server.cabal

@@ -1,5 +1,5 @@
 name:                servant-server
-version:             0.6
+version:             0.6.1
 synopsis:            A family of combinators for defining webservices APIs and serving them
 description:
   A family of combinators for defining webservices APIs and serving them

servant-server/src/Servant/Server/Experimental/Auth.hs

@@ -63,4 +63,3 @@ instance ( HasServer api context
       where
         authHandler = unAuthHandler (getContextEntry context)
         authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
-

servant-server/test/Servant/ServerSpec.hs

@@ -52,7 +52,7 @@ import           Servant.API                ((:<|>) (..), (:>), AuthProtect,
                                              Raw, RemoteHost, ReqBody,
                                              StdMethod (..), Verb, addHeader)
 import           Servant.API.Internal.Test.ComprehensiveAPI
-import           Servant.Server             (ServantErr (..), Server, err401, err404,
+import           Servant.Server             (ServantErr (..), Server, err401, err403, err404,
                                              serve, serveWithContext, Context((:.), EmptyContext))
 import           Test.Hspec                 (Spec, context, describe, it,
                                              shouldBe, shouldContain)
@@ -606,11 +606,10 @@ type instance AuthServerData (AuthProtect "auth") = ()
 
 genAuthContext :: Context '[AuthHandler Request ()]
 genAuthContext =
-  let authHandler = (\req ->
+  let authHandler = \req -> case lookup "Auth" (requestHeaders req) of
-        if elem ("Auth", "secret") (requestHeaders req)
+        Just "secret" -> return ()
-        then return ()
+        Just _ -> throwE err403
-        else throwE err401
+        Nothing -> throwE err401
-        )
   in mkAuthHandler authHandler :. EmptyContext
 
 genAuthSpec :: Spec
@@ -622,6 +621,9 @@ genAuthSpec = do
         it "returns 401 when missing headers" $ do
           get "/auth" `shouldRespondWith` 401
 
+        it "returns 403 on wrong passwords" $ do
+          THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403
+
         it "returns 200 with the right header" $ do
           THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200
 

servant/servant.cabal

@@ -1,5 +1,5 @@
 name:                servant
-version:             0.6
+version:             0.6.1
 synopsis:            A family of combinators for defining webservices APIs
 description:
   A family of combinators for defining webservices APIs and serving them
@@ -96,6 +96,7 @@ test-suite spec
       Servant.API.ContentTypesSpec
       Servant.API.ResponseHeadersSpec
       Servant.Utils.LinksSpec
+      Servant.Utils.MapSpec
   build-depends:
       base == 4.*
     , aeson

servant/src/Servant/Utils/Map.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+module Servant.Utils.Map (mapLeaves) where
+
+import           Servant.API
+
+class Mappable s t a b where
+  mapLeaves :: (forall x . a x -> b x) -> s -> t
+
+instance Mappable (a x) (b x) a b where
+  mapLeaves f a = f a
+
+instance Mappable s t a b => Mappable (arg -> s) (arg -> t) a b where
+  mapLeaves f s = mapLeaves f $ s
+
+instance (Mappable left left' a b, Mappable right right' a b) => Mappable (left :<|> right) (left' :<|> right') a b where
+  mapLeaves f (left :<|> right) = mapLeaves f left :<|> mapLeaves f right

servant/test/Servant/Utils/MapSpec.hs

@@ -0,0 +1,27 @@
+module Servant.Utils.MapSpec where
+
+import           Test.Hspec
+
+import           Data.Functor.Identity
+import           Servant.API
+import           Servant.Utils.Map
+spec :: Spec
+spec = describe "Map" $ do
+  it "maps " $ do
+    let foo :: Bool -> Int -> String
+        foo _ b = show b
+
+        bar :: () -> String -> Int -> Double
+        bar _ _ i = fromIntegral i
+
+        foobar = foo :<|> bar
+
+        convert :: (Int -> a) -> Identity a
+        convert f = Identity $ f 42
+
+        foo' :: Bool -> Identity String
+        bar' :: () -> String -> Identity Double
+        foo' :<|> bar' = mapLeaves convert foobar
+
+    foo' True `shouldBe` Identity "42"
+    bar' () "" `shouldBe` Identity (42 :: Double)

sources.txt

@@ -1,10 +1,10 @@
 servant
-servant-cassava
+servant-server
 servant-client
+servant-cassava
 servant-docs
 servant-foreign
 servant-js
-servant-server
 servant-blaze
 servant-lucid
 servant-mock