51dbd82 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #375 from haskell-servant/auth-basic

51dbd82Aaron Levin11 years ago

servant-client/CHANGELOG.md+1

compare with master

unifiedsplit

@@ -8,6 +8,7 @@ HEAD

8* Use `http-api-data` instead of `Servant.Common.Text`

9* Client functions now consider any 2xx successful.

10* Remove matrix params.

11+* Added support for Basic authentication

120.4.1

130.4.1

13-----

14-----

servant-client/servant-client.cabal+2

@@ -28,11 +28,13 @@ library

28 exposed-modules:

29 Servant.Client

30 Servant.Common.BaseUrl

31+ Servant.Common.BasicAuth

31 Servant.Common.Req

32 Servant.Common.Req

32 build-depends:

33 build-depends:

33 base >=4.7 && <5

34 base >=4.7 && <5

34 , aeson

35 , aeson

35 , attoparsec

36 , attoparsec

37+ , base64-bytestring

36 , bytestring

38 , bytestring

37 , exceptions

39 , exceptions

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

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

servant-client/src/Servant/Client.hs+10

@@ -37,6 +37,7 @@ import qualified Network.HTTP.Types as H

37import qualified Network.HTTP.Types.Header as HTTP

38import Servant.API

39import Servant.Common.BaseUrl

40+import Servant.Common.BasicAuth

40import Servant.Common.Req

41import Servant.Common.Req

42-- * Accessing APIs as a Client

43-- * Accessing APIs as a Client

@@ -424,6 +425,15 @@ instance HasClient subapi =>

424 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

425 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

425

426

427

428+-- * Basic Authentication

429+

430+instance HasClient api => HasClient (BasicAuth realm usr :> api) where

431+ type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api

432+

433+ clientWithRoute Proxy req baseurl manager val =

434+ clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager

435+

436+

427{- Note [Non-Empty Content Types]

437{- Note [Non-Empty Content Types]

428~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

438~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

429Rather than have

439Rather than have

servant-client/src/Servant/Common/BasicAuth.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

3+{-# LANGUAGE TypeFamilies #-}

5+-- | Basic Authentication for clients

7+module Servant.Common.BasicAuth (

8+ basicAuthReq

9+ ) where

10+

11+import Data.ByteString.Base64 (encode)

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

13+import Data.Text.Encoding (decodeUtf8)

14+import Servant.Common.Req (addHeader, Req)

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

16+

17+-- | Authenticate a request using Basic Authentication

18+basicAuthReq :: BasicAuthData -> Req -> Req

19+basicAuthReq (BasicAuthData user pass) req =

20+ let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))

21+ in addHeader "Authorization" authText req

servant-client/test/Servant/ClientSpec.hs+40

@@ -62,6 +62,7 @@ spec = describe "Servant.Client" $ do

62 sucessSpec

63 failSpec

64 wrappedApiSpec

65+ basicAuthSpec

66-- * test data types

67-- * test data types

@@ -148,6 +149,29 @@ failServer = serve failApi (

148 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")

149 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")

149 )

150 )

150

151

152+

153+-- * auth stuff

154+

155+type BasicAuthAPI =

156+ BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person

157+

158+basicAuthAPI :: Proxy BasicAuthAPI

159+basicAuthAPI = Proxy

160+

161+basicAuthHandler :: BasicAuthCheck ()

162+basicAuthHandler =

163+ let check (BasicAuthData username password) =

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

165+ then return (Authorized ())

166+ else return Unauthorized

167+ in BasicAuthCheck check

168+

169+serverContext :: Context '[ BasicAuthCheck () ]

170+serverContext = basicAuthHandler :. EmptyContext

171+

172+basicAuthServer :: Application

173+basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))

174+

151{-# NOINLINE manager #-}

175{-# NOINLINE manager #-}

152manager :: C.Manager

176manager :: C.Manager

153manager = unsafePerformIO $ C.newManager C.defaultManagerSettings

177manager = unsafePerformIO $ C.newManager C.defaultManagerSettings

@@ -292,6 +316,22 @@ data WrappedApi where

292 HasClient api, Client api ~ ExceptT ServantError IO ()) =>

316 HasClient api, Client api ~ ExceptT ServantError IO ()) =>

293 Proxy api -> WrappedApi

317 Proxy api -> WrappedApi

294

318

319+basicAuthSpec :: Spec

320+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do

321+ context "Authentication works when requests are properly authenticated" $ do

322+

323+ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

324+ let getBasic = client basicAuthAPI baseUrl manager

325+ let basicAuthData = BasicAuthData "servant" "server"

326+ (left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice

327+

328+ context "Authentication is rejected when requests are not authenticated properly" $ do

329+

330+ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

331+ let getBasic = client basicAuthAPI baseUrl manager

332+ let basicAuthData = BasicAuthData "not" "password"

333+ Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)

334+ responseStatus `shouldBe` Status 403 "Forbidden"

295

335

296-- * utils

336-- * utils

297

337

servant-docs/CHANGELOG.md+1

@@ -9,6 +9,7 @@ HEAD

9* Move `toSample` out of `ToSample` class

10* Add a few helper functions to define `toSamples`

11* Remove matrix params.

12+* Added support for Basic authentication

130.4

140.4

14---

15---

servant-docs/src/Servant/Docs/Internal.hs+40−5

@@ -22,7 +22,7 @@ module Servant.Docs.Internal where

23import Control.Applicative

24import Control.Arrow (second)

25−import Control.Lens (makeLenses, over, traversed, (%~),

25+import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),

26 (&), (.~), (<>~), (^.), (|>))

27import qualified Control.Monad.Omega as Omega

28import Data.ByteString.Conversion (ToByteString, toByteString)

@@ -140,6 +140,12 @@ data DocIntro = DocIntro

140 , _introBody :: [String] -- ^ Each String is a paragraph.

141 } deriving (Eq, Show)

142

143+-- | A type to represent Authentication information about an endpoint.

144+data DocAuthentication = DocAuthentication

145+ { _authIntro :: String

146+ , _authDataRequired :: String

147+ } deriving (Eq, Ord, Show)

148+

143instance Ord DocIntro where

149instance Ord DocIntro where

144 compare = comparing _introTitle

150 compare = comparing _introTitle

145

151

@@ -230,7 +236,8 @@ defResponse = Response

230-- You can tweak an 'Action' (like the default 'defAction') with these lenses

236-- You can tweak an 'Action' (like the default 'defAction') with these lenses

231-- to transform an action and add some information to it.

237-- to transform an action and add some information to it.

232data Action = Action

238data Action = Action

239+ { _authInfo :: [DocAuthentication] -- user supplied info

233− { _captures :: [DocCapture] -- type collected + user supplied info

240+ , _captures :: [DocCapture] -- type collected + user supplied info

234 , _headers :: [Text] -- type collected

241 , _headers :: [Text] -- type collected

235 , _params :: [DocQueryParam] -- type collected + user supplied info

242 , _params :: [DocQueryParam] -- type collected + user supplied info

236 , _notes :: [DocNote] -- user supplied

243 , _notes :: [DocNote] -- user supplied

@@ -247,8 +254,8 @@ data Action = Action

247-- 'combineAction' to mush two together taking the response, body and content

254-- 'combineAction' to mush two together taking the response, body and content

248-- types from the very left.

255-- types from the very left.

249combineAction :: Action -> Action -> Action

256combineAction :: Action -> Action -> Action

250−Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =

257+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =

251− Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp

258+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp

252

259

253-- Default 'Action'. Has no 'captures', no GET 'params', expects

260-- Default 'Action'. Has no 'captures', no GET 'params', expects

254-- no request body ('rqbody') and the typical response is 'defResponse'.

261-- no request body ('rqbody') and the typical response is 'defResponse'.

@@ -268,6 +275,7 @@ defAction =

268 []

275 []

269 []

276 []

270 []

277 []

278+ []

271 defResponse

279 defResponse

272

280

273-- | Create an API that's comprised of a single endpoint.

281-- | Create an API that's comprised of a single endpoint.

@@ -277,6 +285,7 @@ single :: Endpoint -> Action -> API

277single e a = API mempty (HM.singleton e a)

285single e a = API mempty (HM.singleton e a)

278

286

279-- gimme some lenses

287-- gimme some lenses

288+makeLenses ''DocAuthentication

280makeLenses ''DocOptions

289makeLenses ''DocOptions

281makeLenses ''API

290makeLenses ''API

282makeLenses ''Endpoint

291makeLenses ''Endpoint

@@ -454,7 +463,7 @@ instance AllHeaderSamples '[] where

454

463

455instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)

464instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)

456 => AllHeaderSamples (Header h l ': ls) where

465 => AllHeaderSamples (Header h l ': ls) where

457− allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :

466+ allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :

458 allHeaderToSample (Proxy :: Proxy ls)

467 allHeaderToSample (Proxy :: Proxy ls)

459 where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)

468 where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)

460 mkHeader (Just x) = (headerName, cs $ toByteString x)

469 mkHeader (Just x) = (headerName, cs $ toByteString x)

@@ -504,6 +513,10 @@ class ToParam t where

504class ToCapture c where

513class ToCapture c where

505 toCapture :: Proxy c -> DocCapture

514 toCapture :: Proxy c -> DocCapture

506

515

516+-- | The class that helps us get documentation for authenticated endpoints

517+class ToAuthInfo a where

518+ toAuthInfo :: Proxy a -> DocAuthentication

519+

507-- | Generate documentation in Markdown format for

520-- | Generate documentation in Markdown format for

508-- the given 'API'.

521-- the given 'API'.

509markdown :: API -> String

522markdown :: API -> String

@@ -516,6 +529,7 @@ markdown api = unlines $

516 str :

529 str :

517 "" :

530 "" :

518 notesStr (action ^. notes) ++

531 notesStr (action ^. notes) ++

532+ authStr (action ^. authInfo) ++

519 capturesStr (action ^. captures) ++

533 capturesStr (action ^. captures) ++

520 headersStr (action ^. headers) ++

534 headersStr (action ^. headers) ++

521 paramsStr (action ^. params) ++

535 paramsStr (action ^. params) ++

@@ -548,6 +562,20 @@ markdown api = unlines $

548 "" :

562 "" :

549 []

563 []

550

564

565+

566+ authStr :: [DocAuthentication] -> [String]

567+ authStr auths =

568+ let authIntros = mapped %~ view authIntro $ auths

569+ clientInfos = mapped %~ view authDataRequired $ auths

570+ in "#### Authentication":

571+ "":

572+ unlines authIntros :

573+ "":

574+ "Clients must supply the following data" :

575+ unlines clientInfos :

576+ "" :

577+ []

578+

551 capturesStr :: [DocCapture] -> [String]

579 capturesStr :: [DocCapture] -> [String]

552 capturesStr [] = []

580 capturesStr [] = []

553 capturesStr l =

581 capturesStr l =

@@ -797,6 +825,13 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where

797instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where

825instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where

798 docsFor Proxy = docsFor (Proxy :: Proxy sublayout)

826 docsFor Proxy = docsFor (Proxy :: Proxy sublayout)

799

827

828+instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where

829+ docsFor Proxy (endpoint, action) =

830+ docsFor (Proxy :: Proxy sublayout) (endpoint, action')

831+ where

832+ authProxy = Proxy :: Proxy (BasicAuth realm usr)

833+ action' = over authInfo (|> toAuthInfo authProxy) action

834+

800-- ToSample instances for simple types

835-- ToSample instances for simple types

801instance ToSample ()

836instance ToSample ()

802instance ToSample Bool

837instance ToSample Bool

servant-examples/basic-auth/basic-auth.hsnew file+105

@@ -0,0 +1,105 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

7+module Main where

9+import Data.Aeson (ToJSON)

10+import Data.Proxy (Proxy (Proxy))

11+import Data.Text (Text)

12+import GHC.Generics (Generic)

13+import Network.Wai.Handler.Warp (run)

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

15+ Get, JSON)

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

17+import Servant.Server (BasicAuthCheck (BasicAuthCheck),

18+ BasicAuthResult( Authorized

19+ , Unauthorized

20+ ),

21+ Context ((:.), EmptyContext), Server,

22+ serveWithContext)

23+

24+-- | let's define some types that our API returns.

25+

26+-- | private data that needs protection

27+newtype PrivateData = PrivateData { ssshhh :: Text }

28+ deriving (Eq, Show, Generic)

29+

30+instance ToJSON PrivateData

31+

32+-- | public data that anyone can use.

33+newtype PublicData = PublicData { somedata :: Text }

34+ deriving (Eq, Show, Generic)

35+

36+instance ToJSON PublicData

37+

38+-- | A user we'll grab from the database when we authenticate someone

39+newtype User = User { userName :: Text }

40+ deriving (Eq, Show)

41+

42+-- | a type to wrap our public api

43+type PublicAPI = Get '[JSON] [PublicData]

44+

45+-- | a type to wrap our private api

46+type PrivateAPI = Get '[JSON] PrivateData

47+

48+-- | our API

49+type API = "public" :> PublicAPI

50+ :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI

51+

52+-- | a value holding a proxy of our API type

53+api :: Proxy API

54+api = Proxy

55+

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

57+authCheck :: BasicAuthCheck User

58+authCheck =

59+ let check (BasicAuthData username password) =

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

61+ then return (Authorized (User "servant"))

62+ else return Unauthorized

63+ in BasicAuthCheck check

64+

65+-- | We need to supply our handlers with the right Context. In this case,

66+-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value

67+-- tagged with "foo-tag" This context is then supplied to 'server' and threaded

68+-- to the BasicAuth HasServer handlers.

69+serverContext :: Context (BasicAuthCheck User ': '[])

70+serverContext = authCheck :. EmptyContext

71+

72+-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.

73+-- In particular, for the BasicAuth protected handler, we need to supply a function

74+-- that takes 'User' as an argument.

75+server :: Server API

76+server =

77+ let publicAPIHandler = return [PublicData "foo", PublicData "bar"]

78+ privateAPIHandler (user :: User) = return (PrivateData (userName user))

79+ in publicAPIHandler :<|> privateAPIHandler

80+

81+-- | hello, server!

82+main :: IO ()

83+main = run 8080 (serveWithContext api serverContext server)

84+

85+{- Sample session

86+

87+$ curl -XGET localhost:8080/public

88+[{"somedata":"foo"},{"somedata":"bar"}

89+

90+$ curl -iXGET localhost:8080/private

91+HTTP/1.1 401 Unauthorized

92+transfer-encoding: chunked

93+Date: Thu, 07 Jan 2016 22:36:38 GMT

94+Server: Warp/3.1.8

95+WWW-Authenticate: Basic realm="foo-realm"

96+

97+$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI="

98+HTTP/1.1 200 OK

99+transfer-encoding: chunked

100+Date: Thu, 07 Jan 2016 22:37:58 GMT

101+Server: Warp/3.1.8

102+Content-Type: application/json

103+

104+{"ssshhh":"servant"}

105+-}

servant-examples/servant-examples.cabal+16

@@ -89,6 +89,22 @@ executable wai-middleware

89 hs-source-dirs: wai-middleware

90 default-language: Haskell2010

92+executable basic-auth

93+ main-is: basic-auth.hs

94+ ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing

95+ build-depends:

96+ aeson >= 0.8

97+ , base >= 4.7 && < 5

98+ , bytestring

99+ , http-types

100+ , servant == 0.5.*

101+ , servant-server == 0.5.*

102+ , text

103+ , wai

104+ , warp

105+ hs-source-dirs: basic-auth

106+ default-language: Haskell2010

107+

92executable auth-combinator

108executable auth-combinator

93 main-is: auth-combinator.hs

109 main-is: auth-combinator.hs

94 ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing

110 ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing

servant-server/CHANGELOG.md+1

@@ -11,6 +11,7 @@ HEAD

11* Remove `RouteMismatch`.

12* Redefined constructors of `RouteResult`.

13* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)

14+* Added support for Basic Authentication

150.4.1

160.4.1

16-----

17-----

servant-server/servant-server.cabal+3

@@ -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 context

461+ , HasContextEntry context (BasicAuthCheck usr)

462+ )

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

464+

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

466+

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

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

469+ where

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

471+ basicAuthContext = getContextEntry context

472+ authCheck req = runBasicAuth req realm basicAuthContext

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+73−20

@@ -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

@@ -52,6 +53,7 @@ toApplication ra request respond = ra request routingRespond

52-- static routes (can cause 404)

53-- static routes (can cause 404)

53-- delayed captures (can cause 404)

54-- delayed captures (can cause 404)

54-- methods (can cause 405)

55-- methods (can cause 405)

56+-- authentication and authorization (can cause 401, 403)

55-- delayed body (can cause 415, 400)

57-- delayed body (can cause 415, 400)

56-- accept header (can cause 406)

58-- accept header (can cause 406)

57--

59--

@@ -119,36 +121,71 @@ toApplication ra request respond = ra request routingRespond

119-- The accept header check can be performed as the final

121-- The accept header check can be performed as the final

120-- computation in this block. It can cause a 406.

122-- computation in this block. It can cause a 406.

121--

123--

122−data Delayed :: * -> * where

124+data Delayed c where

123− Delayed :: IO (RouteResult a)

125+ Delayed :: { capturesD :: IO (RouteResult captures)

124− -> IO (RouteResult ())

126+ , methodD :: IO (RouteResult ())

125− -> IO (RouteResult b)

127+ , authD :: IO (RouteResult auth)

128+ , bodyD :: IO (RouteResult body)

126− -> (a -> b -> RouteResult c)

129+ , serverD :: (captures -> auth -> body -> RouteResult c)

127− -> Delayed c

130+ } -> Delayed c

128

131

129instance Functor Delayed where

132instance Functor Delayed where

130− fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g)

133+ fmap f Delayed{..}

134+ = Delayed { capturesD = capturesD

135+ , methodD = methodD

136+ , authD = authD

137+ , bodyD = bodyD

138+ , serverD = (fmap.fmap.fmap.fmap) f serverD

139+ } -- Note [Existential Record Update]

131

140

132-- | Add a capture to the end of the capture block.

141-- | Add a capture to the end of the capture block.

133addCapture :: Delayed (a -> b)

142addCapture :: Delayed (a -> b)

134 -> IO (RouteResult a)

143 -> IO (RouteResult a)

135 -> Delayed b

144 -> Delayed b

136−addCapture (Delayed captures method body server) new =

145+addCapture Delayed{..} new

137− Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)

146+ = Delayed { capturesD = combineRouteResults (,) capturesD new

147+ , methodD = methodD

148+ , authD = authD

149+ , bodyD = bodyD

150+ , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z

151+ } -- Note [Existential Record Update]

138

152

139-- | Add a method check to the end of the method block.

153-- | Add a method check to the end of the method block.

140addMethodCheck :: Delayed a

154addMethodCheck :: Delayed a

141 -> IO (RouteResult ())

155 -> IO (RouteResult ())

142 -> Delayed a

156 -> Delayed a

143−addMethodCheck (Delayed captures method body server) new =

157+addMethodCheck Delayed{..} new

158+ = Delayed { capturesD = capturesD

144− Delayed captures (combineRouteResults const method new) body server

159+ , methodD = combineRouteResults const methodD new

160+ , authD = authD

161+ , bodyD = bodyD

162+ , serverD = serverD

163+ } -- Note [Existential Record Update]

164+

165+-- | Add an auth check to the end of the auth block.

166+addAuthCheck :: Delayed (a -> b)

167+ -> IO (RouteResult a)

168+ -> Delayed b

169+addAuthCheck Delayed{..} new

170+ = Delayed { capturesD = capturesD

171+ , methodD = methodD

172+ , authD = combineRouteResults (,) authD new

173+ , bodyD = bodyD

174+ , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z

175+ } -- Note [Existential Record Update]

145

176

146-- | Add a body check to the end of the body block.

177-- | Add a body check to the end of the body block.

147addBodyCheck :: Delayed (a -> b)

178addBodyCheck :: Delayed (a -> b)

148 -> IO (RouteResult a)

179 -> IO (RouteResult a)

149 -> Delayed b

180 -> Delayed b

150−addBodyCheck (Delayed captures method body server) new =

181+addBodyCheck Delayed{..} new

182+ = Delayed { capturesD = capturesD

183+ , methodD = methodD

184+ , authD = authD

151− Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)

185+ , bodyD = combineRouteResults (,) bodyD new

186+ , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z

187+ } -- Note [Existential Record Update]

188+

152

189

153-- | Add an accept header check to the end of the body block.

190-- | Add an accept header check to the end of the body block.

154-- The accept header check should occur after the body check,

191-- The accept header check should occur after the body check,

@@ -157,8 +194,13 @@ addBodyCheck (Delayed captures method body server) new =

157addAcceptCheck :: Delayed a

194addAcceptCheck :: Delayed a

158 -> IO (RouteResult ())

195 -> IO (RouteResult ())

159 -> Delayed a

196 -> Delayed a

160−addAcceptCheck (Delayed captures method body server) new =

197+addAcceptCheck Delayed{..} new

198+ = Delayed { capturesD = capturesD

199+ , methodD = methodD

200+ , authD = authD

161− Delayed captures method (combineRouteResults const body new) server

201+ , bodyD = combineRouteResults const bodyD new

202+ , serverD = serverD

203+ } -- Note [Existential Record Update]

162

204

163-- | Many combinators extract information that is passed to

205-- | Many combinators extract information that is passed to

164-- the handler without the possibility of failure. In such a

206-- the handler without the possibility of failure. In such a

@@ -190,13 +232,17 @@ combineRouteResults f m1 m2 =

190-- | Run a delayed server. Performs all scheduled operations

232-- | Run a delayed server. Performs all scheduled operations

191-- in order, and passes the results from the capture and body

233-- in order, and passes the results from the capture and body

192-- blocks on to the actual handler.

234-- blocks on to the actual handler.

235+--

236+-- This should only be called once per request; otherwise the guarantees about

237+-- effect and HTTP error ordering break down.

193runDelayed :: Delayed a

238runDelayed :: Delayed a

194 -> IO (RouteResult a)

239 -> IO (RouteResult a)

195−runDelayed (Delayed captures method body server) =

240+runDelayed Delayed{..} =

196− captures `bindRouteResults` \ c ->

241+ capturesD `bindRouteResults` \ c ->

197− method `bindRouteResults` \ _ ->

242+ methodD `bindRouteResults` \ _ ->

243+ authD `bindRouteResults` \ a ->

198− body `bindRouteResults` \ b ->

244+ bodyD `bindRouteResults` \ b ->

199− return (server c b)

245+ return (serverD c a b)

200

246

201-- | Runs a delayed server and the resulting action.

247-- | Runs a delayed server and the resulting action.

202-- Takes a continuation that lets us send a response.

248-- Takes a continuation that lets us send a response.

@@ -215,3 +261,10 @@ runAction action respond k = runDelayed action >>= go >>= respond

215 case e of

261 case e of

216 Left err -> return . Route $ responseServantErr err

262 Left err -> return . Route $ responseServantErr err

217 Right x -> return $! k x

263 Right x -> return $! k x

264+

265+{- Note [Existential Record Update]

266+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

267+

268+Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot

269+do the more succint thing - just update the records we actually change.

270+-}

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 $ serveWithContext errorOrderApi

60+ (errorOrderAuthCheck :. EmptyContext)

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 $ serveWithContext errorRetryApi

187+ (errorOrderAuthCheck :. EmptyContext)

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+60−23

@@ -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,20 +49,23 @@ 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

62 (tweakResponse, runRouter,

65 (tweakResponse, runRouter,

63 Router, Router'(LeafRouter))

66 Router, Router'(LeafRouter))

64import Servant.Server.Internal.Context

67import Servant.Server.Internal.Context

65− (Context(..), NamedContext(..))

68+ (NamedContext(..))

67-- * comprehensive api test

70-- * comprehensive api test

@@ -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-- }}}

@@ -343,13 +347,13 @@ headerSpec = describe "Servant.API.Header" $ do

343 expectsString Nothing = error "Expected a string"

347 expectsString Nothing = error "Expected a string"

344

348

345 with (return (serve headerApi expectsInt)) $ do

349 with (return (serve headerApi expectsInt)) $ do

346− let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]

350+ let delete' x = THW.request methodDelete x [("MyHeader", "5")]

347

351

348 it "passes the header to the handler (Int)" $

352 it "passes the header to the handler (Int)" $

349 delete' "/" "" `shouldRespondWith` 200

353 delete' "/" "" `shouldRespondWith` 200

350

354

351 with (return (serve headerApi expectsString)) $ do

355 with (return (serve headerApi expectsString)) $ do

352− let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]

356+ let delete' x = THW.request methodDelete x [("MyHeader", "more from you")]

353

357

354 it "passes the header to the handler (String)" $

358 it "passes the header to the handler (String)" $

355 delete' "/" "" `shouldRespondWith` 200

359 delete' "/" "" `shouldRespondWith` 200

@@ -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/CHANGELOG.md+1

@@ -10,6 +10,7 @@ HEAD

10* Add PlainText String MimeRender and MimeUnrender instances.

11* Add new `Verbs` combinator, and make all existing and new verb combinators

12type synonyms of it.

13+* Add `BasicAuth` combinator to support Basic authentication

140.4.2

150.4.2

15-----

16-----

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

servant/src/Servant/API.hs+4

@@ -29,6 +29,9 @@ module Servant.API (

29 -- * Actual endpoints, distinguished by HTTP method

30 module Servant.API.Verbs,

32+ -- * Authentication

33+ module Servant.API.BasicAuth,

34+

32 -- * Content Types

35 -- * Content Types

33 module Servant.API.ContentTypes,

36 module Servant.API.ContentTypes,

34 -- | Serializing and deserializing types based on @Accept@ and

37 -- | Serializing and deserializing types based on @Accept@ and

@@ -51,6 +54,7 @@ module Servant.API (

51 ) where

54 ) where

53import Servant.API.Alternative ((:<|>) (..))

56import Servant.API.Alternative ((:<|>) (..))

57+import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))

54import Servant.API.Capture (Capture)

58import Servant.API.Capture (Capture)

55import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

59import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

56 FromFormUrlEncoded (..), JSON,

60 FromFormUrlEncoded (..), JSON,

servant/src/Servant/API/BasicAuth.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE PolyKinds #-}

5+module Servant.API.BasicAuth where

7+import Data.ByteString (ByteString)

8+import Data.Typeable (Typeable)

9+import GHC.TypeLits (Symbol)

10+

11+

12+-- | Combinator for <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.

13+--

14+-- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or

15+-- encrypted. Note also that because the same credentials are sent on every

16+-- request, Basic Auth is not as secure as some alternatives. Further, the

17+-- implementation in servant-server does not protect against some types of

18+-- timing attacks.

19+--

20+-- In Basic Auth, username and password are base64-encoded and transmitted via

21+-- the @Authorization@ header. Handshakes are not required, making it

22+-- relatively efficient.

23+data BasicAuth (realm :: Symbol) (userData :: *)

24+ deriving (Typeable)

25+

26+-- | A simple datatype to hold data required to decorate a request

27+data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString

28+ , basicAuthPassword :: !ByteString

29+ }