eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Fix servant-client to work with tagged Auth

Browse source
This commit is contained in:
aaron levin 2015-12-28 00:54:34 +01:00
parent 0285ddf707
commit 2b84f245cb
2 changed files with 19 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
servant-client/src/Servant/Client.hs
View file

@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@ -122,8 +123,8 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
where p = unpack (toUrlPiece val)
-- | Authentication
instance (AuthenticateRequest authdata, HasClient sublayout) => HasClient (AuthProtect authdata (usr :: *) mPolicy mError uPolicy uError :> sublayout) where
type Client (AuthProtect authdata usr mPolicy mError uPolicy uError :> sublayout) = authdata -> Client sublayout
instance (AuthenticateRequest authdata, HasClient sublayout) => HasClient (AuthProtect (tag :: k) authdata (usr :: *) mPolicy mError uPolicy uError :> sublayout) where
type Client (AuthProtect tag authdata usr mPolicy mError uPolicy uError :> sublayout) = authdata -> Client sublayout
clientWithRoute Proxy req baseurl manager val =
clientWithRoute (Proxy :: Proxy sublayout)

26
servant-client/test/Servant/ClientSpec.hs
View file

@ -29,7 +29,7 @@ import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.Aeson
import Data.Aeson hiding ((.:))
import Data.ByteString.Lazy (ByteString)
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
@ -56,6 +56,7 @@ import Servant.API.Authentication
import Servant.Client
import Servant.Client.Authentication()
import Servant.Server
import Servant.Server.Internal.Config()
spec :: Spec
spec = describe "Servant.Client" $ do
@ -110,7 +111,7 @@ type Api =
ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> AuthProtect (BasicAuth "realm") Person 'Strict () 'Strict () :> Get '[JSON] Person
:<|> (AuthProtect "auth-tag" (BasicAuth "realm") Person 'Strict () 'Strict () :> Get '[JSON] Person)
:<|> "deleteContentType" :> Delete '[JSON] ()
-- base64-encoded "servant:server"
@ -128,7 +129,11 @@ api :: Proxy Api
api = Proxy
server :: Application
server = serve api (
server =
let authProtection = basicAuthStrict basicAuthCheck
config :: Config '[ConfigEntry "auth-tag" (AuthProtected IO ServantErr 'Strict () 'Strict () (BasicAuth "realm") Person)]
config = authProtection .: EmptyConfig
in serve api config (
return alice
:<|> return ()
:<|> (\ name -> return $ Person name 0)
@ -143,7 +148,7 @@ server = serve api (
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> basicAuthStrict basicAuthCheck (const . return $ alice)
:<|> (const . return $ alice)
:<|> return ()
)
@ -156,7 +161,7 @@ failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi (
failServer = serve failApi EmptyConfig (
(\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
@ -256,7 +261,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
wrappedApiSpec :: Spec
wrappedApiSpec = describe "error status codes" $ do
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
let serveW a = serve a EmptyConfig $ throwE $ ServantErr 500 "error message" "" []
context "are correctly handled by the client" $
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
@ -313,10 +318,11 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi
WrappedApi :: ( HasServer api, Server api ~ ExceptT ServantErr IO a
, HasClient api, Client api ~ ExceptT ServantError IO ()
, HasCfg api '[]
) => Proxy (api :: *)
-> WrappedApi
-- * utils