104ac29 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Add BasicAuth support to servant-server

104ac29aaron levin11 years ago

servant-server/servant-server.cabal+3

compare with master

unifiedsplit

@@ -38,6 +38,7 @@ library

38 Servant.Server

39 Servant.Server.Internal

40 Servant.Server.Internal.Context

41+ Servant.Server.Internal.BasicAuth

41 Servant.Server.Internal.Enter

42 Servant.Server.Internal.Enter

42 Servant.Server.Internal.Router

43 Servant.Server.Internal.Router

43 Servant.Server.Internal.RoutingApplication

44 Servant.Server.Internal.RoutingApplication

@@ -47,6 +48,7 @@ library

47 base >= 4.7 && < 5

48 base >= 4.7 && < 5

48 , aeson >= 0.7 && < 0.12

49 , aeson >= 0.7 && < 0.12

49 , attoparsec >= 0.12 && < 0.14

50 , attoparsec >= 0.12 && < 0.14

51+ , base64-bytestring == 1.0.*

50 , bytestring >= 0.10 && < 0.11

52 , bytestring >= 0.10 && < 0.11

51 , containers >= 0.5 && < 0.6

53 , containers >= 0.5 && < 0.6

52 , http-api-data >= 0.1 && < 0.3

54 , http-api-data >= 0.1 && < 0.3

@@ -67,6 +69,7 @@ library

67 , wai >= 3.0 && < 3.3

69 , wai >= 3.0 && < 3.3

68 , wai-app-static >= 3.0 && < 3.2

70 , wai-app-static >= 3.0 && < 3.2

69 , warp >= 3.0 && < 3.3

71 , warp >= 3.0 && < 3.3

72+ , word8 == 0.1.*

71 hs-source-dirs: src

74 hs-source-dirs: src

72 default-language: Haskell2010

75 default-language: Haskell2010

servant-server/src/Servant/Server.hs+6−1

@@ -45,6 +45,11 @@ module Servant.Server

45 , NamedContext(..)

46 , descendIntoNamedContext

48+

49+ -- * Basic Authentication

50+ , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)

51+ , BasicAuthResult(..)

52+

48 -- * Default error type

53 -- * Default error type

49 , ServantErr(..)

54 , ServantErr(..)

50 -- ** 3XX

55 -- ** 3XX

@@ -119,7 +124,7 @@ serveWithContext :: (HasServer layout context)

119 => Proxy layout -> Context context -> Server layout -> Application

124 => Proxy layout -> Context context -> Server layout -> Application

120serveWithContext p context server = toApplication (runRouter (route p context d))

125serveWithContext p context server = toApplication (runRouter (route p context d))

121 where

126 where

122− d = Delayed r r r (\ _ _ -> Route server)

127+ d = Delayed r r r r (\ _ _ _ -> Route server)

123 r = return (Route ())

128 r = return (Route ())

124

129

125

130

servant-server/src/Servant/Server/Internal.hs+24−1

@@ -16,6 +16,7 @@

16module Servant.Server.Internal

17 ( module Servant.Server.Internal

18 , module Servant.Server.Internal.Context

19+ , module Servant.Server.Internal.BasicAuth

19 , module Servant.Server.Internal.Router

20 , module Servant.Server.Internal.Router

20 , module Servant.Server.Internal.RoutingApplication

21 , module Servant.Server.Internal.RoutingApplication

21 , module Servant.Server.Internal.ServantErr

22 , module Servant.Server.Internal.ServantErr

@@ -26,6 +27,7 @@ import Control.Applicative ((<$>))

26#endif

27#endif

27import Control.Monad.Trans.Except (ExceptT)

28import Control.Monad.Trans.Except (ExceptT)

28import qualified Data.ByteString as B

29import qualified Data.ByteString as B

30+import qualified Data.ByteString.Char8 as BC8

29import qualified Data.ByteString.Lazy as BL

31import qualified Data.ByteString.Lazy as BL

30import qualified Data.Map as M

32import qualified Data.Map as M

31import Data.Maybe (fromMaybe, mapMaybe)

33import Data.Maybe (fromMaybe, mapMaybe)

@@ -48,7 +50,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe,

48 parseQueryParamMaybe,

50 parseQueryParamMaybe,

49 parseUrlPieceMaybe)

51 parseUrlPieceMaybe)

51−import Servant.API ((:<|>) (..), (:>), Capture,

53+import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

52 Verb, ReflectMethod(reflectMethod),

54 Verb, ReflectMethod(reflectMethod),

53 IsSecure(..), Header,

55 IsSecure(..), Header,

54 QueryFlag, QueryParam, QueryParams,

56 QueryFlag, QueryParam, QueryParams,

@@ -63,6 +65,7 @@ import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

63 getResponse)

65 getResponse)

65import Servant.Server.Internal.Context

67import Servant.Server.Internal.Context

68+import Servant.Server.Internal.BasicAuth

66import Servant.Server.Internal.Router

69import Servant.Server.Internal.Router

67import Servant.Server.Internal.RoutingApplication

70import Servant.Server.Internal.RoutingApplication

68import Servant.Server.Internal.ServantErr

71import Servant.Server.Internal.ServantErr

@@ -450,6 +453,26 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where

450 route Proxy context subserver = WithRequest $ \req ->

453 route Proxy context subserver = WithRequest $ \req ->

451 route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)

454 route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)

452

455

456+-- * Basic Authentication

457+

458+-- | Basic Authentication

459+instance ( KnownSymbol realm

460+ , HasServer api config

461+ , HasConfigEntry config (BasicAuthCheck usr)

462+ )

463+ => HasServer (BasicAuth realm usr :> api) config where

464+

465+ type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m

466+

467+ route Proxy config subserver = WithRequest $ \ request ->

468+ route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)

469+ where

470+ realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)

471+ basicAuthConfig = getConfigEntry config

472+ authCheck req = runBasicAuth req realm basicAuthConfig

473+

474+-- * helpers

475+

453pathIsEmpty :: Request -> Bool

476pathIsEmpty :: Request -> Bool

454pathIsEmpty = go . pathInfo

477pathIsEmpty = go . pathInfo

455 where go [] = True

478 where go [] = True

servant-server/src/Servant/Server/Internal/BasicAuth.hsnew file+69

@@ -0,0 +1,69 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveDataTypeable #-}

4+{-# LANGUAGE OverloadedStrings #-}

6+module Servant.Server.Internal.BasicAuth where

8+import Control.Monad (guard)

9+import qualified Data.ByteString as BS

10+import Data.ByteString.Base64 (decodeLenient)

11+import Data.Monoid ((<>))

12+import Data.Typeable (Typeable)

13+import Data.Word8 (isSpace, toLower, _colon)

14+import GHC.Generics

15+import Network.HTTP.Types (Header)

16+import Network.Wai (Request, requestHeaders)

17+

18+import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))

19+import Servant.Server.Internal.RoutingApplication

20+import Servant.Server.Internal.ServantErr

21+

22+-- * Basic Auth

23+

24+-- | servant-server's current implementation of basic authentication is not

25+-- immune to certian kinds of timing attacks. Decoding payloads does not take

26+-- a fixed amount of time.

27+

28+-- | The result of authentication/authorization

29+data BasicAuthResult usr

30+ = Unauthorized

31+ | BadPassword

32+ | NoSuchUser

33+ | Authorized usr

34+ deriving (Eq, Show, Read, Generic, Typeable, Functor)

35+

36+-- | Datatype wrapping a function used to check authentication.

37+newtype BasicAuthCheck usr = BasicAuthCheck

38+ { unBasicAuthCheck :: BasicAuthData

39+ -> IO (BasicAuthResult usr)

40+ }

41+ deriving (Generic, Typeable, Functor)

42+

43+-- | Internal method to make a basic-auth challenge

44+mkBAChallengerHdr :: BS.ByteString -> Header

45+mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"")

46+

47+-- | Find and decode an 'Authorization' header from the request as Basic Auth

48+decodeBAHdr :: Request -> Maybe BasicAuthData

49+decodeBAHdr req = do

50+ ah <- lookup "Authorization" $ requestHeaders req

51+ let (b, rest) = BS.break isSpace ah

52+ guard (BS.map toLower b == "basic")

53+ let decoded = decodeLenient (BS.dropWhile isSpace rest)

54+ let (username, passWithColonAtHead) = BS.break (== _colon) decoded

55+ (_, password) <- BS.uncons passWithColonAtHead

56+ return (BasicAuthData username password)

57+

58+-- | Run and check basic authentication, returning the appropriate http error per

59+-- the spec.

60+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)

61+runBasicAuth req realm (BasicAuthCheck ba) =

62+ case decodeBAHdr req of

63+ Nothing -> plzAuthenticate

64+ Just e -> ba e >>= \res -> case res of

65+ BadPassword -> plzAuthenticate

66+ NoSuchUser -> plzAuthenticate

67+ Unauthorized -> return $ Fail err403

68+ Authorized usr -> return $ Route usr

69+ where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+1

@@ -4,6 +4,7 @@

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE StandaloneDeriving #-}

8{-# LANGUAGE StandaloneDeriving #-}

8module Servant.Server.Internal.RoutingApplication where

9module Servant.Server.Internal.RoutingApplication where

servant-server/test/Servant/Server/ErrorSpec.hs+53−25

@@ -1,6 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

5{-# OPTIONS_GHC -fno-warn-orphans #-}

6{-# OPTIONS_GHC -fno-warn-orphans #-}

6module Servant.Server.ErrorSpec (spec) where

7module Servant.Server.ErrorSpec (spec) where

@@ -10,7 +11,8 @@ import Data.Aeson (encode)

10import qualified Data.ByteString.Char8 as BC

11import qualified Data.ByteString.Char8 as BC

11import qualified Data.ByteString.Lazy.Char8 as BCL

12import qualified Data.ByteString.Lazy.Char8 as BCL

12import Data.Proxy

13import Data.Proxy

13−import Network.HTTP.Types (hAccept, hContentType, methodGet,

14+import Network.HTTP.Types (hAccept, hAuthorization,

15+ hContentType, methodGet,

14 methodPost, methodPut)

16 methodPost, methodPut)

15import Safe (readMay)

17import Safe (readMay)

16import Test.Hspec

18import Test.Hspec

@@ -25,57 +27,79 @@ spec = describe "HTTP Errors" $ do

25 errorRetrySpec

27 errorRetrySpec

26 errorChoiceSpec

28 errorChoiceSpec

30+-- * Auth machinery (reused throughout)

31+

32+-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.

33+errorOrderAuthCheck :: BasicAuthCheck ()

34+errorOrderAuthCheck =

35+ let check (BasicAuthData username password) =

36+ if username == "servant" && password == "server"

37+ then return (Authorized ())

38+ else return Unauthorized

39+ in BasicAuthCheck check

40+

28------------------------------------------------------------------------------

41------------------------------------------------------------------------------

29-- * Error Order {{{

42-- * Error Order {{{

31type ErrorOrderApi = "home"

44type ErrorOrderApi = "home"

45+ :> BasicAuth "error-realm" ()

32 :> ReqBody '[JSON] Int

46 :> ReqBody '[JSON] Int

33 :> Capture "t" Int

47 :> Capture "t" Int

34 :> Post '[JSON] Int

48 :> Post '[JSON] Int

36−

37errorOrderApi :: Proxy ErrorOrderApi

50errorOrderApi :: Proxy ErrorOrderApi

38errorOrderApi = Proxy

51errorOrderApi = Proxy

40errorOrderServer :: Server ErrorOrderApi

53errorOrderServer :: Server ErrorOrderApi

41−errorOrderServer = \_ _ -> throwE err402

54+errorOrderServer = \_ _ _ -> throwE err402

43errorOrderSpec :: Spec

56errorOrderSpec :: Spec

57+errorOrderSpec =

44−errorOrderSpec = describe "HTTP error order"

58+ describe "HTTP error order" $

45− $ with (return $ serve errorOrderApi errorOrderServer) $ do

59+ with (return $ serve errorOrderApi

60+ (errorOrderAuthCheck :. EmptyConfig)

61+ errorOrderServer

62+ ) $ do

46 let badContentType = (hContentType, "text/plain")

63 let badContentType = (hContentType, "text/plain")

47 badAccept = (hAccept, "text/plain")

64 badAccept = (hAccept, "text/plain")

48 badMethod = methodGet

65 badMethod = methodGet

49 badUrl = "home/nonexistent"

66 badUrl = "home/nonexistent"

50 badBody = "nonsense"

67 badBody = "nonsense"

68+ badAuth = (hAuthorization, "Basic foofoofoo")

51 goodContentType = (hContentType, "application/json")

69 goodContentType = (hContentType, "application/json")

52 goodAccept = (hAccept, "application/json")

70 goodAccept = (hAccept, "application/json")

53 goodMethod = methodPost

71 goodMethod = methodPost

54 goodUrl = "home/2"

72 goodUrl = "home/2"

55 goodBody = encode (5 :: Int)

73 goodBody = encode (5 :: Int)

74+ -- username:password = servant:server

75+ goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")

57 it "has 404 as its highest priority error" $ do

77 it "has 404 as its highest priority error" $ do

58− request badMethod badUrl [badContentType, badAccept] badBody

78+ request badMethod badUrl [badAuth, badContentType, badAccept] badBody

59 `shouldRespondWith` 404

79 `shouldRespondWith` 404

61 it "has 405 as its second highest priority error" $ do

81 it "has 405 as its second highest priority error" $ do

62− request badMethod goodUrl [badContentType, badAccept] badBody

82+ request badMethod goodUrl [badAuth, badContentType, badAccept] badBody

63 `shouldRespondWith` 405

83 `shouldRespondWith` 405

65− it "has 415 as its third highest priority error" $ do

85+ it "has 401 as its third highest priority error (auth)" $ do

86+ request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody

87+ `shouldRespondWith` 401

88+

89+ it "has 415 as its fourth highest priority error" $ do

66− request goodMethod goodUrl [badContentType, badAccept] badBody

90+ request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody

67 `shouldRespondWith` 415

91 `shouldRespondWith` 415

69− it "has 400 as its fourth highest priority error" $ do

93+ it "has 400 as its fifth highest priority error" $ do

70− request goodMethod goodUrl [goodContentType, badAccept] badBody

94+ request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody

71 `shouldRespondWith` 400

95 `shouldRespondWith` 400

73− it "has 406 as its fifth highest priority error" $ do

97+ it "has 406 as its sixth highest priority error" $ do

74− request goodMethod goodUrl [goodContentType, badAccept] goodBody

98+ request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody

75 `shouldRespondWith` 406

99 `shouldRespondWith` 406

100

77 it "has handler-level errors as last priority" $ do

101 it "has handler-level errors as last priority" $ do

78− request goodMethod goodUrl [goodContentType, goodAccept] goodBody

102+ request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody

79 `shouldRespondWith` 402

103 `shouldRespondWith` 402

104

81type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer

105type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer

@@ -134,9 +158,12 @@ type ErrorRetryApi

134 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2

158 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2

135 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3

159 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3

136 :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4

160 :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4

161+ :<|> "a" :> BasicAuth "bar-realm" ()

137− :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5

162+ :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5

138− :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6

163+ :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6

164+

165+ :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7

139− :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7

166+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8

140

167

141errorRetryApi :: Proxy ErrorRetryApi

168errorRetryApi :: Proxy ErrorRetryApi

142errorRetryApi = Proxy

169errorRetryApi = Proxy

@@ -148,13 +175,18 @@ errorRetryServer

148 :<|> (\_ -> return 2)

175 :<|> (\_ -> return 2)

149 :<|> (\_ -> return 3)

176 :<|> (\_ -> return 3)

150 :<|> (\_ -> return 4)

177 :<|> (\_ -> return 4)

151− :<|> (\_ -> return 5)

178+ :<|> (\_ _ -> return 5)

152 :<|> (\_ -> return 6)

179 :<|> (\_ -> return 6)

153 :<|> (\_ -> return 7)

180 :<|> (\_ -> return 7)

181+ :<|> (\_ -> return 8)

154

182

155errorRetrySpec :: Spec

183errorRetrySpec :: Spec

184+errorRetrySpec =

156−errorRetrySpec = describe "Handler search"

185+ describe "Handler search" $

157− $ with (return $ serve errorRetryApi errorRetryServer) $ do

186+ with (return $ serve errorRetryApi

187+ (errorOrderAuthCheck :. EmptyConfig)

188+ errorRetryServer

189+ ) $ do

158

190

159 let jsonCT = (hContentType, "application/json")

191 let jsonCT = (hContentType, "application/json")

160 jsonAccept = (hAccept, "application/json")

192 jsonAccept = (hAccept, "application/json")

@@ -162,16 +194,12 @@ errorRetrySpec = describe "Handler search"

162

194

163 it "should continue when URLs don't match" $ do

195 it "should continue when URLs don't match" $ do

164 request methodPost "" [jsonCT, jsonAccept] jsonBody

196 request methodPost "" [jsonCT, jsonAccept] jsonBody

165− `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }

197+ `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) }

166

198

167 it "should continue when methods don't match" $ do

199 it "should continue when methods don't match" $ do

168 request methodGet "a" [jsonCT, jsonAccept] jsonBody

200 request methodGet "a" [jsonCT, jsonAccept] jsonBody

169 `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }

201 `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }

170

202

171− it "should not continue when body cannot be decoded" $ do

172− request methodPost "a" [jsonCT, jsonAccept] "a string"

173− `shouldRespondWith` 400

174−

175-- }}}

203-- }}}

176------------------------------------------------------------------------------

204------------------------------------------------------------------------------

177-- * Error Choice {{{

205-- * Error Choice {{{

servant-server/test/Servant/ServerSpec.hs+57−20

@@ -38,8 +38,8 @@ import Network.Wai.Internal (Response (ResponseBuilder))

38import Network.Wai.Test (defaultRequest, request,

39 runSession, simpleBody,

40 simpleHeaders, simpleStatus)

41−import Servant.API ((:<|>) (..), (:>), Capture, Delete,

41+import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),

42− Get, Header (..),

42+ Capture, Delete, Get, Header (..),

43 Headers, HttpVersion,

44 IsSecure (..), JSON,

45 NoContent (..), Patch, PlainText,

@@ -49,13 +49,16 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,

49 StdMethod (..), Verb, addHeader)

50import Servant.API.Internal.Test.ComprehensiveAPI

51import Servant.Server (ServantErr (..), Server, err404,

52− serve, serveWithContext, Context(EmptyContext))

52+ serve, serveWithContext, Context((:.), EmptyContext))

53import Test.Hspec (Spec, context, describe, it,

54 shouldBe, shouldContain)

55+import qualified Test.Hspec.Wai as THW

55import Test.Hspec.Wai (get, liftIO, matchHeaders,

56import Test.Hspec.Wai (get, liftIO, matchHeaders,

56− matchStatus, request,

57− shouldRespondWith, with, (<:>))

57+ matchStatus, shouldRespondWith,

58+ with, (<:>))

60+import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),

61+ BasicAuthResult(Authorized,Unauthorized))

59import Servant.Server.Internal.RoutingApplication

62import Servant.Server.Internal.RoutingApplication

60 (toApplication, RouteResult(..))

63 (toApplication, RouteResult(..))

61import Servant.Server.Internal.Router

64import Servant.Server.Internal.Router

@@ -86,6 +89,7 @@ spec = do

86 responseHeadersSpec

89 responseHeadersSpec

87 routerSpec

90 routerSpec

88 miscCombinatorSpec

91 miscCombinatorSpec

92+ basicAuthSpec

90------------------------------------------------------------------------------

94------------------------------------------------------------------------------

91-- * verbSpec {{{

95-- * verbSpec {{{

@@ -117,49 +121,49 @@ verbSpec = describe "Servant.API.Verb" $ do

117 -- HEAD and 214/215 need not return bodies

121 -- HEAD and 214/215 need not return bodies

118 unless (status `elem` [214, 215] || method == methodHead) $

122 unless (status `elem` [214, 215] || method == methodHead) $

119 it "returns the person" $ do

123 it "returns the person" $ do

120− response <- Test.Hspec.Wai.request method "/" [] ""

124+ response <- THW.request method "/" [] ""

121 liftIO $ statusCode (simpleStatus response) `shouldBe` status

125 liftIO $ statusCode (simpleStatus response) `shouldBe` status

122 liftIO $ decode' (simpleBody response) `shouldBe` Just alice

126 liftIO $ decode' (simpleBody response) `shouldBe` Just alice

123

127

124 it "returns no content on NoContent" $ do

128 it "returns no content on NoContent" $ do

125− response <- Test.Hspec.Wai.request method "/noContent" [] ""

129+ response <- THW.request method "/noContent" [] ""

126 liftIO $ statusCode (simpleStatus response) `shouldBe` status

130 liftIO $ statusCode (simpleStatus response) `shouldBe` status

127 liftIO $ simpleBody response `shouldBe` ""

131 liftIO $ simpleBody response `shouldBe` ""

128

132

129 -- HEAD should not return body

133 -- HEAD should not return body

130 when (method == methodHead) $

134 when (method == methodHead) $

131 it "HEAD returns no content body" $ do

135 it "HEAD returns no content body" $ do

132− response <- Test.Hspec.Wai.request method "/" [] ""

136+ response <- THW.request method "/" [] ""

133 liftIO $ simpleBody response `shouldBe` ""

137 liftIO $ simpleBody response `shouldBe` ""

134

138

135 it "throws 405 on wrong method " $ do

139 it "throws 405 on wrong method " $ do

136− Test.Hspec.Wai.request (wrongMethod method) "/" [] ""

140+ THW.request (wrongMethod method) "/" [] ""

137 `shouldRespondWith` 405

141 `shouldRespondWith` 405

138

142

139 it "returns headers" $ do

143 it "returns headers" $ do

140− response1 <- Test.Hspec.Wai.request method "/header" [] ""

144+ response1 <- THW.request method "/header" [] ""

141 liftIO $ statusCode (simpleStatus response1) `shouldBe` status

145 liftIO $ statusCode (simpleStatus response1) `shouldBe` status

142 liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]

146 liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]

143

147

144− response2 <- Test.Hspec.Wai.request method "/header" [] ""

148+ response2 <- THW.request method "/header" [] ""

145 liftIO $ statusCode (simpleStatus response2) `shouldBe` status

149 liftIO $ statusCode (simpleStatus response2) `shouldBe` status

146 liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]

150 liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]

147

151

148 it "handles trailing '/' gracefully" $ do

152 it "handles trailing '/' gracefully" $ do

149− response <- Test.Hspec.Wai.request method "/headerNC/" [] ""

153+ response <- THW.request method "/headerNC/" [] ""

150 liftIO $ statusCode (simpleStatus response) `shouldBe` status

154 liftIO $ statusCode (simpleStatus response) `shouldBe` status

151

155

152 it "returns 406 if the Accept header is not supported" $ do

156 it "returns 406 if the Accept header is not supported" $ do

153− Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

157+ THW.request method "" [(hAccept, "crazy/mime")] ""

154 `shouldRespondWith` 406

158 `shouldRespondWith` 406

155

159

156 it "responds if the Accept header is supported" $ do

160 it "responds if the Accept header is supported" $ do

157− response <- Test.Hspec.Wai.request method ""

161+ response <- THW.request method ""

158 [(hAccept, "application/json")] ""

162 [(hAccept, "application/json")] ""

159 liftIO $ statusCode (simpleStatus response) `shouldBe` status

163 liftIO $ statusCode (simpleStatus response) `shouldBe` status

160

164

161 it "sets the Content-Type header" $ do

165 it "sets the Content-Type header" $ do

162− response <- Test.Hspec.Wai.request method "" [] ""

166+ response <- THW.request method "" [] ""

163 liftIO $ simpleHeaders response `shouldContain`

167 liftIO $ simpleHeaders response `shouldContain`

164 [("Content-Type", "application/json")]

168 [("Content-Type", "application/json")]

165

169

@@ -306,7 +310,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do

306

310

307 let server :: Server ReqBodyApi

311 let server :: Server ReqBodyApi

308 server = return :<|> return . age

312 server = return :<|> return . age

309− mkReq method x = Test.Hspec.Wai.request method x

313+ mkReq method x = THW.request method x

310 [(hContentType, "application/json;charset=utf-8")]

314 [(hContentType, "application/json;charset=utf-8")]

311

315

312 with (return $ serve reqBodyApi server) $ do

316 with (return $ serve reqBodyApi server) $ do

@@ -319,7 +323,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do

319 mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400

323 mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400

320

324

321 it "responds with 415 if the request body media type is unsupported" $ do

325 it "responds with 415 if the request body media type is unsupported" $ do

322− Test.Hspec.Wai.request methodPost "/"

326+ THW.request methodPost "/"

323 [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415

327 [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415

324

328

325-- }}}

329-- }}}

@@ -455,19 +459,19 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

455

459

456 it "includes the headers in the response" $

460 it "includes the headers in the response" $

457 forM_ methods $ \method ->

461 forM_ methods $ \method ->

458− Test.Hspec.Wai.request method "/" [] ""

462+ THW.request method "/" [] ""

459 `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]

463 `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]

460 , matchStatus = 200

464 , matchStatus = 200

461 }

465 }

462

466

463 it "responds with not found for non-existent endpoints" $

467 it "responds with not found for non-existent endpoints" $

464 forM_ methods $ \method ->

468 forM_ methods $ \method ->

465− Test.Hspec.Wai.request method "blahblah" [] ""

469+ THW.request method "blahblah" [] ""

466 `shouldRespondWith` 404

470 `shouldRespondWith` 404

467

471

468 it "returns 406 if the Accept header is not supported" $

472 it "returns 406 if the Accept header is not supported" $

469 forM_ methods $ \method ->

473 forM_ methods $ \method ->

470− Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

474+ THW.request method "" [(hAccept, "crazy/mime")] ""

471 `shouldRespondWith` 406

475 `shouldRespondWith` 406

472

476

473-- }}}

477-- }}}

@@ -527,6 +531,39 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $

527 go "/host" "\"0.0.0.0:0\""

531 go "/host" "\"0.0.0.0:0\""

528

532

529 where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res

533 where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res

534+

535+-- }}}

536+------------------------------------------------------------------------------

537+-- * Authentication {{{

538+------------------------------------------------------------------------------

539+

540+type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal

541+

542+basicAuthApi :: Proxy BasicAuthAPI

543+basicAuthApi = Proxy

544+basicAuthServer :: Server BasicAuthAPI

545+basicAuthServer = const (return jerry)

546+

547+basicAuthContext :: Context '[ BasicAuthCheck () ]

548+basicAuthContext =

549+ let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) ->

550+ if usr == "servant" && pass == "server"

551+ then return (Authorized ())

552+ else return Unauthorized

553+ )

554+ in basicHandler :. EmptyContext

555+

556+basicAuthSpec :: Spec

557+basicAuthSpec = do

558+ describe "Servant.API.BasicAuth" $ do

559+ with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do

560+

561+ context "Basic Authentication" $ do

562+ it "returns with 401 with bad password" $ do

563+ get "/basic" `shouldRespondWith` 401

564+ it "returns 200 with the right password" $ do

565+ THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200

566+

530-- }}}

567-- }}}

531------------------------------------------------------------------------------

568------------------------------------------------------------------------------

532-- * Test data types {{{

569-- * Test data types {{{

servant/servant.cabal+1

@@ -27,6 +27,7 @@ library

27 exposed-modules:

28 Servant.API

29 Servant.API.Alternative

30+ Servant.API.BasicAuth

30 Servant.API.Capture

31 Servant.API.Capture

31 Servant.API.ContentTypes

32 Servant.API.ContentTypes

32 Servant.API.Header

33 Servant.API.Header