git.iko.soy/typeable/servant
on master help sign in
Add BasicAuth support to servant-server
commit104ac29bf8da2891cd4e4b875d279efeaa6807db authoraaron levin <aaron.levin@soundcloud.com> dateWed 17 Feb 2016, 19:56 (11 years ago) parent9966e5b
8 files changed+214−47
compare with master
unifiedsplit
servant-server/servant-server.cabal+3 servant-server/src/Servant/Server.hs+6−1 servant-server/src/Servant/Server/Internal.hs+24−1 servant-server/src/Servant/Server/Internal/BasicAuth.hs+69 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+1 servant-server/test/Servant/Server/ErrorSpec.hs+53−25 servant-server/test/Servant/ServerSpec.hs+57−20 servant/servant.cabal+1
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 config
461+ , HasConfigEntry config (BasicAuthCheck usr)
462+ )
463+ => HasServer (BasicAuth realm usr :> api) config where
464+
465+ type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
466+
467+ route Proxy config subserver = WithRequest $ \ request ->
468+ route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
469+ where
470+ realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
471+ basicAuthConfig = getConfigEntry config
472+ authCheck req = runBasicAuth req realm basicAuthConfig
473+
474+-- * helpers
475+
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+1
@@ -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
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 $ serve errorOrderApi
60+ (errorOrderAuthCheck :. EmptyConfig)
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 $ serve errorRetryApi
187+ (errorOrderAuthCheck :. EmptyConfig)
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+57−20
@@ -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,13 +49,16 @@ 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
@@ -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-- }}}
@@ -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/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