51dbd82 · typeable/servant

servant-client/CHANGELOG.md+1

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

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

99* Client functions now consider any 2xx successful.

1010* Remove matrix params.

11+* Added support for Basic authentication

1112

12130.4.1

1314-----

servant-client/servant-client.cabal+2

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

2828 exposed-modules:

2929 Servant.Client

3030 Servant.Common.BaseUrl

31+ Servant.Common.BasicAuth

3132 Servant.Common.Req

3233 build-depends:

3334 base >=4.7 && <5

3435 , aeson

3536 , attoparsec

37+ , base64-bytestring

3638 , bytestring

3739 , exceptions

3840 , 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

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

3838import Servant.API

3939import Servant.Common.BaseUrl

40+import Servant.Common.BasicAuth

4041import Servant.Common.Req

4142

4243-- * Accessing APIs as a Client

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

424425 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

425426

426427

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+

427437{- Note [Non-Empty Content Types]

428438~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

429439Rather than have

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

3+{-# LANGUAGE TypeFamilies #-}

4+

5+-- | Basic Authentication for clients

6+

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

6262 sucessSpec

6363 failSpec

6464 wrappedApiSpec

65+ basicAuthSpec

6566

6667-- * test data types

6768

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

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

149150 )

150151

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+

151175{-# NOINLINE manager #-}

152176manager :: C.Manager

153177manager = unsafePerformIO $ C.newManager C.defaultManagerSettings

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

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

293317 Proxy api -> WrappedApi

294318

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"

295335

296336-- * utils

297337

servant-docs/CHANGELOG.md+1

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

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

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

1111* Remove matrix params.

12+* Added support for Basic authentication

1213

13140.4

1415---

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

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

2222

2323import Control.Applicative

2424import Control.Arrow (second)

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

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

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

2727import qualified Control.Monad.Omega as Omega

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

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

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

141141 } deriving (Eq, Show)

142142

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+

143149instance Ord DocIntro where

144150 compare = comparing _introTitle

145151

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

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

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

232238data Action = Action

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

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

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

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

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

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

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

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

248255-- types from the very left.

249256combineAction :: Action -> Action -> Action

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

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

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

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

252259

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

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

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

268275 []

269276 []

270277 []

278+ []

271279 defResponse

272280

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

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

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

278286

279287-- gimme some lenses

288+makeLenses ''DocAuthentication

280289makeLenses ''DocOptions

281290makeLenses ''API

282291makeLenses ''Endpoint

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

454463

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

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

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

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

458467 allHeaderToSample (Proxy :: Proxy ls)

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

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

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

504513class ToCapture c where

505514 toCapture :: Proxy c -> DocCapture

506515

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

517+class ToAuthInfo a where

518+ toAuthInfo :: Proxy a -> DocAuthentication

519+

507520-- | Generate documentation in Markdown format for

508521-- the given 'API'.

509522markdown :: API -> String

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

516529 str :

517530 "" :

518531 notesStr (action ^. notes) ++

532+ authStr (action ^. authInfo) ++

519533 capturesStr (action ^. captures) ++

520534 headersStr (action ^. headers) ++

521535 paramsStr (action ^. params) ++

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

548562 "" :

549563 []

550564

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+

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

552580 capturesStr [] = []

553581 capturesStr l =

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

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

798826 docsFor Proxy = docsFor (Proxy :: Proxy sublayout)

799827

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+

800835-- ToSample instances for simple types

801836instance ToSample ()

802837instance 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 #-}

6+

7+module Main where

8+

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

8989 hs-source-dirs: wai-middleware

9090 default-language: Haskell2010

9191

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+

92108executable auth-combinator

93109 main-is: auth-combinator.hs

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

servant-server/CHANGELOG.md+1

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

1111* Remove `RouteMismatch`.

1212* Redefined constructors of `RouteResult`.

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

14+* Added support for Basic Authentication

1415

15160.4.1

1617-----

servant-server/servant-server.cabal+3

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

3838 Servant.Server

3939 Servant.Server.Internal

4040 Servant.Server.Internal.Context

41+ Servant.Server.Internal.BasicAuth

4142 Servant.Server.Internal.Enter

4243 Servant.Server.Internal.Router

4344 Servant.Server.Internal.RoutingApplication

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

4748 base >= 4.7 && < 5

4849 , aeson >= 0.7 && < 0.12

4950 , attoparsec >= 0.12 && < 0.14

51+ , base64-bytestring == 1.0.*

5052 , bytestring >= 0.10 && < 0.11

5153 , containers >= 0.5 && < 0.6

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

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

6769 , wai >= 3.0 && < 3.3

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

6971 , warp >= 3.0 && < 3.3

72+ , word8 == 0.1.*

7073

7174 hs-source-dirs: src

7275 default-language: Haskell2010

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

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

4545 , NamedContext(..)

4646 , descendIntoNamedContext

4747

48+

49+ -- * Basic Authentication

50+ , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)

51+ , BasicAuthResult(..)

52+

4853 -- * Default error type

4954 , ServantErr(..)

5055 -- ** 3XX

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

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

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

121126 where

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

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

123128 r = return (Route ())

124129

125130

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

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

1616module Servant.Server.Internal

1717 ( module Servant.Server.Internal

1818 , module Servant.Server.Internal.Context

19+ , module Servant.Server.Internal.BasicAuth

1920 , module Servant.Server.Internal.Router

2021 , module Servant.Server.Internal.RoutingApplication

2122 , module Servant.Server.Internal.ServantErr

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

2627#endif

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

2829import qualified Data.ByteString as B

30+import qualified Data.ByteString.Char8 as BC8

2931import qualified Data.ByteString.Lazy as BL

3032import qualified Data.Map as M

3133import Data.Maybe (fromMaybe, mapMaybe)

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

4850 parseQueryParamMaybe,

4951 parseUrlPieceMaybe)

5052

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

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

5254 Verb, ReflectMethod(reflectMethod),

5355 IsSecure(..), Header,

5456 QueryFlag, QueryParam, QueryParams,

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

6365 getResponse)

6466

6567import Servant.Server.Internal.Context

68+import Servant.Server.Internal.BasicAuth

6669import Servant.Server.Internal.Router

6770import Servant.Server.Internal.RoutingApplication

6871import Servant.Server.Internal.ServantErr

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

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

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

452455

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+

453476pathIsEmpty :: Request -> Bool

454477pathIsEmpty = go . pathInfo

455478 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 #-}

5+

6+module Servant.Server.Internal.BasicAuth where

7+

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

44{-# LANGUAGE TypeOperators #-}

55{-# LANGUAGE GADTs #-}

66{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE RecordWildCards #-}

78{-# LANGUAGE StandaloneDeriving #-}

89module Servant.Server.Internal.RoutingApplication where

910

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

5253-- static routes (can cause 404)

5354-- delayed captures (can cause 404)

5455-- methods (can cause 405)

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

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

5658-- accept header (can cause 406)

5759--

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

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

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

121123--

122−data Delayed :: * -> * where

123− Delayed :: IO (RouteResult a)

124− -> IO (RouteResult ())

125− -> IO (RouteResult b)

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

127− -> Delayed c

124+data Delayed c where

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

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

127+ , authD :: IO (RouteResult auth)

128+ , bodyD :: IO (RouteResult body)

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

130+ } -> Delayed c

128131

129132instance 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]

131140

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

133142addCapture :: Delayed (a -> b)

134143 -> IO (RouteResult a)

135144 -> Delayed b

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

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

145+addCapture Delayed{..} new

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]

138152

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

140154addMethodCheck :: Delayed a

141155 -> IO (RouteResult ())

142156 -> Delayed a

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

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

157+addMethodCheck Delayed{..} new

158+ = Delayed { capturesD = capturesD

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]

145176

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

147178addBodyCheck :: Delayed (a -> b)

148179 -> IO (RouteResult a)

149180 -> Delayed b

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

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

181+addBodyCheck Delayed{..} new

182+ = Delayed { capturesD = capturesD

183+ , methodD = methodD

184+ , authD = authD

185+ , bodyD = combineRouteResults (,) bodyD new

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

187+ } -- Note [Existential Record Update]

188+

152189

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

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

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

157194addAcceptCheck :: Delayed a

158195 -> IO (RouteResult ())

159196 -> Delayed a

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

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

197+addAcceptCheck Delayed{..} new

198+ = Delayed { capturesD = capturesD

199+ , methodD = methodD

200+ , authD = authD

201+ , bodyD = combineRouteResults const bodyD new

202+ , serverD = serverD

203+ } -- Note [Existential Record Update]

162204

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

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

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

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

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

192234-- 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.

193238runDelayed :: Delayed a

194239 -> IO (RouteResult a)

195−runDelayed (Delayed captures method body server) =

196− captures `bindRouteResults` \ c ->

197− method `bindRouteResults` \ _ ->

198− body `bindRouteResults` \ b ->

199− return (server c b)

240+runDelayed Delayed{..} =

241+ capturesD `bindRouteResults` \ c ->

242+ methodD `bindRouteResults` \ _ ->

243+ authD `bindRouteResults` \ a ->

244+ bodyD `bindRouteResults` \ b ->

245+ return (serverD c a b)

200246

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

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

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

215261 case e of

216262 Left err -> return . Route $ responseServantErr err

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

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE MultiParamTypeClasses #-}

33{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeFamilies #-}

45{-# LANGUAGE TypeOperators #-}

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

67module Servant.Server.ErrorSpec (spec) where

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

1011import qualified Data.ByteString.Char8 as BC

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

1213import Data.Proxy

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

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

15+ hContentType, methodGet,

1416 methodPost, methodPut)

1517import Safe (readMay)

1618import Test.Hspec

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

2527 errorRetrySpec

2628 errorChoiceSpec

2729

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+

2841------------------------------------------------------------------------------

2942-- * Error Order {{{

3043

3144type ErrorOrderApi = "home"

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

3246 :> ReqBody '[JSON] Int

3347 :> Capture "t" Int

3448 :> Post '[JSON] Int

3549

36−

3750errorOrderApi :: Proxy ErrorOrderApi

3851errorOrderApi = Proxy

3952

4053errorOrderServer :: Server ErrorOrderApi

41−errorOrderServer = \_ _ -> throwE err402

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

4255

4356errorOrderSpec :: Spec

44−errorOrderSpec = describe "HTTP error order"

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

57+errorOrderSpec =

58+ describe "HTTP error order" $

59+ with (return $ serveWithContext errorOrderApi

60+ (errorOrderAuthCheck :. EmptyContext)

61+ errorOrderServer

62+ ) $ do

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

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

4865 badMethod = methodGet

4966 badUrl = "home/nonexistent"

5067 badBody = "nonsense"

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

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

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

5371 goodMethod = methodPost

5472 goodUrl = "home/2"

5573 goodBody = encode (5 :: Int)

74+ -- username:password = servant:server

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

5676

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

58− request badMethod badUrl [badContentType, badAccept] badBody

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

5979 `shouldRespondWith` 404

6080

6181 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

6383 `shouldRespondWith` 405

6484

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

66− request goodMethod goodUrl [badContentType, badAccept] badBody

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

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

6791 `shouldRespondWith` 415

6892

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

70− request goodMethod goodUrl [goodContentType, badAccept] badBody

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

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

7195 `shouldRespondWith` 400

7296

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

74− request goodMethod goodUrl [goodContentType, badAccept] goodBody

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

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

7599 `shouldRespondWith` 406

76100

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

78− request goodMethod goodUrl [goodContentType, goodAccept] goodBody

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

79103 `shouldRespondWith` 402

80104

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

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

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

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

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

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

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

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

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

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

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

164+

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

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

140167

141168errorRetryApi :: Proxy ErrorRetryApi

142169errorRetryApi = Proxy

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

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

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

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

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

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

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

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

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

154182

155183errorRetrySpec :: Spec

156−errorRetrySpec = describe "Handler search"

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

184+errorRetrySpec =

185+ describe "Handler search" $

186+ with (return $ serveWithContext errorRetryApi

187+ (errorOrderAuthCheck :. EmptyContext)

188+ errorRetryServer

189+ ) $ do

158190

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

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

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

162194

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

164196 request methodPost "" [jsonCT, jsonAccept] jsonBody

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

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

166198

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

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

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

170202

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

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

173− `shouldRespondWith` 400

174−

175203-- }}}

176204------------------------------------------------------------------------------

177205-- * Error Choice {{{

servant-server/test/Servant/ServerSpec.hs+60−23

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

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

3939 runSession, simpleBody,

4040 simpleHeaders, simpleStatus)

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

42− Get, Header (..),

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

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

4343 Headers, HttpVersion,

4444 IsSecure (..), JSON,

4545 NoContent (..), Patch, PlainText,

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

4949 StdMethod (..), Verb, addHeader)

5050import Servant.API.Internal.Test.ComprehensiveAPI

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

52− serve, serveWithContext, Context(EmptyContext))

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

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

5454 shouldBe, shouldContain)

55+import qualified Test.Hspec.Wai as THW

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

56− matchStatus, request,

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

57+ matchStatus, shouldRespondWith,

58+ with, (<:>))

5859

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

61+ BasicAuthResult(Authorized,Unauthorized))

5962import Servant.Server.Internal.RoutingApplication

6063 (toApplication, RouteResult(..))

6164import Servant.Server.Internal.Router

6265 (tweakResponse, runRouter,

6366 Router, Router'(LeafRouter))

6467import Servant.Server.Internal.Context

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

68+ (NamedContext(..))

6669

6770-- * comprehensive api test

6871

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

8689 responseHeadersSpec

8790 routerSpec

8891 miscCombinatorSpec

92+ basicAuthSpec

8993

9094------------------------------------------------------------------------------

9195-- * verbSpec {{{

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

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

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

119123 it "returns the person" $ do

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

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

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

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

123127

124128 it "returns no content on NoContent" $ do

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

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

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

127131 liftIO $ simpleBody response `shouldBe` ""

128132

129133 -- HEAD should not return body

130134 when (method == methodHead) $

131135 it "HEAD returns no content body" $ do

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

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

133137 liftIO $ simpleBody response `shouldBe` ""

134138

135139 it "throws 405 on wrong method " $ do

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

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

137141 `shouldRespondWith` 405

138142

139143 it "returns headers" $ do

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

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

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

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

143147

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

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

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

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

147151

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

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

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

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

151155

152156 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")] ""

154158 `shouldRespondWith` 406

155159

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

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

161+ response <- THW.request method ""

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

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

160164

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

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

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

163167 liftIO $ simpleHeaders response `shouldContain`

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

165169

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

306310

307311 let server :: Server ReqBodyApi

308312 server = return :<|> return . age

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

313+ mkReq method x = THW.request method x

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

311315

312316 with (return $ serve reqBodyApi server) $ do

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

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

320324

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

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

326+ THW.request methodPost "/"

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

324328

325329-- }}}

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

343347 expectsString Nothing = error "Expected a string"

344348

345349 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")]

347351

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

349353 delete' "/" "" `shouldRespondWith` 200

350354

351355 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")]

353357

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

355359 delete' "/" "" `shouldRespondWith` 200

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

455459

456460 it "includes the headers in the response" $

457461 forM_ methods $ \method ->

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

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

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

460464 , matchStatus = 200

461465 }

462466

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

464468 forM_ methods $ \method ->

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

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

466470 `shouldRespondWith` 404

467471

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

469473 forM_ methods $ \method ->

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

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

471475 `shouldRespondWith` 406

472476

473477-- }}}

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

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

528532

529533 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+

530567-- }}}

531568------------------------------------------------------------------------------

532569-- * Test data types {{{

servant/CHANGELOG.md+1

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

1010* Add PlainText String MimeRender and MimeUnrender instances.

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

1212type synonyms of it.

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

1314

14150.4.2

1516-----

servant/servant.cabal+1

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

2727 exposed-modules:

2828 Servant.API

2929 Servant.API.Alternative

30+ Servant.API.BasicAuth

3031 Servant.API.Capture

3132 Servant.API.ContentTypes

3233 Servant.API.Header

servant/src/Servant/API.hs+4

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

2929 -- * Actual endpoints, distinguished by HTTP method

3030 module Servant.API.Verbs,

3131

32+ -- * Authentication

33+ module Servant.API.BasicAuth,

34+

3235 -- * Content Types

3336 module Servant.API.ContentTypes,

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

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

5154 ) where

5255

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

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

5458import Servant.API.Capture (Capture)

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

5660 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

6+

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