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

Second Iteration of Authentication

Browse source 
Implemented with the AuthProtected data family as per alp's suggestion.
This commit is contained in:
Andres Loeh 2015-06-01 22:39:12 +02:00 committed by Arian van Putten
parent d2e2122933
commit 272091effe
7 changed files with 305 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-server/servant-server.cabal
View file

@ -36,6 +36,7 @@ library
Servant Servant
Servant.Server Servant.Server
Servant.Server.Internal Servant.Server.Internal
Servant.Server.Internal.Authentication
Servant.Server.Internal.Enter Servant.Server.Internal.Enter
Servant.Server.Internal.PathInfo Servant.Server.Internal.PathInfo
Servant.Server.Internal.Router Servant.Server.Internal.Router

173
servant-server/src/Servant/Server/Internal.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -27,38 +28,60 @@ import Control.Monad.Trans.Except (ExceptT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as B
import Data.ByteString.Base64 (decodeLenient) import Data.ByteString.Base64 (decodeLenient)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Data.Maybe (mapMaybe, fromMaybe) import Data.Maybe (mapMaybe, fromMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>), ConvertibleStrings) import Data.String.Conversions (cs, (<>), ConvertibleStrings)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding (decodeUtf8,
encodeUtf8)
import Data.Typeable import Data.Typeable
import Data.Word8 (isSpace, _colon, toLower) import GHC.TypeLits (KnownSymbol,
import GHC.TypeLits (KnownSymbol, symbolVal) symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header,
ResponseHeaders)
import Network.Socket (SockAddr) import Network.Socket (SockAddr)
import Network.Wai (Application, isSecure, httpVersion, Request, Response, import Network.Wai (Application,
ResponseReceived, lazyRequestBody, httpVersion,
pathInfo, rawQueryString, remoteHost, isSecure,
requestBody, requestHeaders, lazyRequestBody,
requestMethod, responseLBS, rawQueryString,
strictRequestBody, vault) remoteHost,
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, requestHeaders,
Delete, Get, Header, IsSecure(Secure, NotSecure), requestMethod,
MatrixFlag, MatrixParam, MatrixParams, responseLBS, vault)
Patch, Post, Put, QueryFlag, import Servant.API ((:<|>) (..), (:>),
QueryParam, QueryParams, Raw, Capture, Delete,
RemoteHost, ReqBody, Vault) Get, Header, IsSecure (Secure, NotSecure),
MatrixFlag,
MatrixParam,
MatrixParams,
Patch, Post, Put,
QueryFlag,
QueryParam,
QueryParams, Raw,
RemoteHost,
ReqBody, Vault)
import Servant.API.Authentication (AuthPolicy (Strict, Lax),
AuthProtect,
AuthProtected)
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..)) AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, import Servant.API.ResponseHeaders (GetHeaders,
getHeaders) Headers,
getHeaders,
getResponse)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
import Servant.Server.Internal.Authentication (AuthData (authData),
AuthProtected (..),
checkAuthStrict,
onMissingAuthData,
onUnauthenticated)
import Servant.Server.Internal.PathInfo import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.Router import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
@ -71,18 +94,6 @@ class HasServer layout where
type Server layout = ServerT layout (ExceptT ServantErr IO) type Server layout = ServerT layout (ExceptT ServantErr IO)
-- | A type-indexed class to encapsulate Basic authentication handling.
-- Authentication handling is indexed by the lookup type.
--
-- > data ExampleAuthDB
-- > data ExampleUser
-- > instance BasicAuthLookup ExampleAuthDB where
-- > type BasicAuthVal = ExampleUser
-- > basicAuthLookup _ _ _ = return Nothing
class BasicAuthLookup lookup where
type BasicAuthVal lookup :: *
basicAuthLookup :: Proxy lookup -> B.ByteString -> B.ByteString -> IO (Maybe (BasicAuthVal lookup))
-- * Instances -- * Instances
-- | A server for @a ':<|>' b@ first tries to match the request against the route -- | A server for @a ':<|>' b@ first tries to match the request against the route
@ -246,54 +257,74 @@ instance
route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-- | Authentication -- | Authentication in Strict mode.
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
( HasServer sublayout (AuthData authdata , HasServer sublayout) => HasServer (AuthProtect authdata (usr :: *) 'Strict :> sublayout) where
, BasicAuthLookup lookup
, KnownSymbol realm
)
=> HasServer (BasicAuth realm lookup :> sublayout) where
type ServerT (BasicAuth realm lookup :> sublayout) m type ServerT (AuthProtect authdata usr 'Strict :> sublayout) m = AuthProtected authdata usr (usr -> ServerT sublayout m) 'Strict
= BasicAuthVal lookup -> ServerT sublayout m
route _ action request respond = route _ subserver = WithRequest $ \req ->
case lookup "Authorization" (requestHeaders request) of route (Proxy :: Proxy sublayout) $ do
Nothing -> respond . succeedWith $ authFailure401 -- Note: this may perform IO for each attempt at matching.
Just authBs -> rr <- routeResult <$> subserver
-- ripped from: https://hackage.haskell.org/package/wai-extra-1.3.4.5/docs/src/Network-Wai-Middleware-HttpAuth.html#basicAuth
let (x,y) = B.break isSpace authBs in
if B.map toLower x == "basic"
-- check base64-encoded password
then checkB64AndRespond (B.dropWhile isSpace y)
-- Authenticaiton header is not Basic, fail with 401.
else respond . succeedWith $ authFailure401
where
realmBytes = (fromString . symbolVal) (Proxy :: Proxy realm)
headerBytes = "Basic realm=\"" <> realmBytes <> "\""
authFailure401 = responseLBS status401 [("WWW-Authenticate", headerBytes)] ""
checkB64AndRespond encoded =
case B.uncons passwordWithColonAtHead of
Just (_, password) -> do
-- let's check these credentials using the user-provided lookup method
maybeAuthData <- basicAuthLookup (Proxy :: Proxy lookup) username password
case maybeAuthData of
Nothing -> respond . succeedWith $ authFailure403
(Just authData) ->
route (Proxy :: Proxy sublayout) (action authData) request respond
-- no username:password present case rr of
Nothing -> respond . succeedWith $ authFailure401 -- Successful route match, so we extract the author-provided
where -- auth data.
authFailure403 = responseLBS status403 [] "" Right authProtectionStrict ->
raw = decodeLenient encoded case authData req of
-- split username and password at the colon ':' char. -- could not pull authenticate data out of the request
(username, passwordWithColonAtHead) = B.breakByte _colon raw Nothing -> do
-- we're in strict mode: don't let the request go
-- call the provided "on missing auth" handler
resp <- onMissingAuthData (authHandlers authProtectionStrict)
return $ failWith (RouteMismatch resp)
-- succesfully pulled auth data out of the Request
Just authData' -> do
mUsr <- (checkAuthStrict authProtectionStrict) authData'
case mUsr of
-- this user is not authenticated.
Nothing -> do
resp <- onUnauthenticated (authHandlers authProtectionStrict) authData'
return $ failWith (RouteMismatch resp)
-- this user is authenticated.
Just usr ->
(return . succeedWith . subServerStrict authProtectionStrict) usr
-- route did not match, propagate failure.
Left rMismatch ->
return (failWith rMismatch)
-- | Authentication in Lax mode.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(AuthData authdata , HasServer sublayout) => HasServer (AuthProtect authdata (usr :: *) 'Lax :> sublayout) where
type ServerT (AuthProtect authdata usr 'Lax :> sublayout) m = AuthProtected authdata usr (Maybe usr -> ServerT sublayout m) 'Lax
route _ subserver = WithRequest $ \req ->
route (Proxy :: Proxy sublayout) $ do
-- Note: this may perform IO for each attempt at matching.
rr <- routeResult <$> subserver
-- Successful route match, so we extract the author-provided
-- auth data.
case rr of
-- route matched, extract author-provided lax authentication data
Right authProtectionLax -> do
-- extract a user from the request object and perform
-- authentication on it. In Lax mode, we just pass `Maybe usr`
-- to the autho.
musr <- maybe (pure Nothing) (checkAuthLax authProtectionLax) (authData req)
(return . succeedWith . subServerLax authProtectionLax) musr
-- route did not match, propagate failure
Left rMismatch ->
return (failWith rMismatch)
-- | When implementing the handler for a 'Get' endpoint, -- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
@ -722,7 +753,9 @@ instance (KnownSymbol sym, HasServer sublayout)
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string Nothing -> False -- param not in the query string
route (Proxy :: Proxy sublayout) (feedTo subserver param) route (Proxy :: Proxy sublayout) (feedTo subserver param)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver False) _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True

102
servant-server/src/Servant/Server/Internal/Authentication.hs Normal file
View file

@ -0,0 +1,102 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Server.Internal.Authentication
( AuthProtected (..)
, AuthData (..)
, AuthHandlers (..)
, basicAuthLax
, basicAuthStrict
, laxProtect
, strictProtect
) where
import Control.Monad (guard)
import qualified Data.ByteString as B
import Data.ByteString.Base64 (decodeLenient)
import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.Word8 (isSpace, toLower, _colon)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types.Status (status401)
import Network.Wai (Request, Response, requestHeaders,
responseBuilder)
import Servant.API.Authentication (AuthPolicy (Strict, Lax),
AuthProtected,
BasicAuth (BasicAuth))
-- | Class to represent the ability to extract authentication-related
-- data from a 'Request' object.
class AuthData a where
authData :: Request -> Maybe a
-- | handlers to deal with authentication failures.
data AuthHandlers authData = AuthHandlers
{ -- we couldn't find the right type of auth data (or any, for that matter)
onMissingauthData :: IO Response
,
-- we found the right type of auth data in the request but the check failed
onUnauthenticated :: authData -> IO Response
}
-- | concrete type to provide when in 'Strict' mode.
data instance AuthProtected authData usr subserver 'Strict =
AuthProtectedStrict { checkAuthStrict :: authData -> IO (Maybe usr)
, subServerStrict :: subserver
, authHandlers :: AuthHandlers authData
}
-- | concrete type to provide when in 'Lax' mode.
data instance AuthProtected authData usr subserver 'Lax =
AuthProtectedLax { checkAuthLax :: authData -> IO (Maybe usr)
, subServerLax :: subserver
}
-- | handy function to build an auth-protected bit of API with a Lax policy
laxProtect :: (authData -> IO (Maybe usr)) -- ^ check auth
-> subserver -- ^ the handlers for the auth-aware bits of the API
-> AuthProtected authData usr subserver 'Lax
laxProtect = AuthProtectedLax
-- | handy function to build an auth-protected bit of API with a Strict policy
strictProtect :: (authData -> IO (Maybe usr)) -- ^ check auth
-> subserver -- ^ handlers for the auth-protected bits of the API
-> AuthHandlers authData -- ^ functions to call on auth failure
-> AuthProtected authData usr subserver 'Strict
strictProtect = AuthProtectedStrict
-- | 'BasicAuth' instance for authData
instance AuthData (BasicAuth realm) where
authData request = do
authBs <- lookup "Authorization" (requestHeaders request)
let (x,y) = B.break isSpace authBs
guard (B.map toLower x == "basic")
-- decode the base64-encoded username and password
let (username, passWithColonAtHead) = B.break (== _colon) (decodeLenient (B.dropWhile isSpace y))
(_, password) <- B.uncons passWithColonAtHead
return $ BasicAuth username password
-- | handlers for Basic Authentication.
basicAuthHandlers :: forall realm. KnownSymbol realm => AuthHandlers (BasicAuth realm)
basicAuthHandlers =
let realmBytes = (fromString . symbolVal) (Proxy :: Proxy realm)
headerBytes = "Basic realm=\"" <> realmBytes <> "\""
authFailure = responseBuilder status401 [("WWW-Authenticate", headerBytes)] mempty in
AuthHandlers (return authFailure) ((const . return) authFailure)
-- | Basic authentication combinator with strict failure.
basicAuthStrict :: KnownSymbol realm
=> (BasicAuth realm -> IO (Maybe usr))
-> subserver
-> AuthProtected (BasicAuth realm) usr subserver 'Strict
basicAuthStrict check subserver = strictProtect check subserver basicAuthHandlers
-- | Basic authentication combinator with lax failure.
basicAuthLax :: KnownSymbol realm
=> (BasicAuth realm -> IO (Maybe usr))
-> subserver
-> AuthProtected (BasicAuth realm) usr subserver 'Lax
basicAuthLax = laxProtect

17
servant-server/src/Servant/Server/Internal/Enter.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
@ -24,9 +25,16 @@ import qualified Control.Monad.State.Lazy as LState
import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.State.Strict as SState
import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Lazy as LWriter
import qualified Control.Monad.Writer.Strict as SWriter import qualified Control.Monad.Writer.Strict as SWriter
import qualified Control.Monad.State.Lazy as LState
import qualified Control.Monad.State.Strict as SState
import qualified Control.Monad.Writer.Lazy as LWriter
import qualified Control.Monad.Writer.Strict as SWriter
import Data.Typeable import Data.Typeable
import Servant.API import Servant.API
import Servant.API.Authentication
import Servant.Server.Internal.Authentication (AuthProtected (AuthProtectedStrict, AuthProtectedLax))
class Enter typ arg ret | typ arg -> ret, typ ret -> arg where class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
enter :: arg -> typ -> ret enter :: arg -> typ -> ret
@ -95,3 +103,12 @@ squashNat = Nat squash
-- | Like @mmorph@'s `generalize`. -- | Like @mmorph@'s `generalize`.
generalizeNat :: Applicative m => Identity :~> m generalizeNat :: Applicative m => Identity :~> m
generalizeNat = Nat (pure . runIdentity) generalizeNat = Nat (pure . runIdentity)
-- | 'Enter' instance for AuthProtectedStrict
instance Enter subserver arg ret => Enter (AuthProtected authData usr subserver 'Strict) arg (AuthProtected authData usr ret 'Strict) where
enter arg (AuthProtectedStrict check subserver handlers) = AuthProtectedStrict check (enter arg subserver) handlers
-- | 'Enter' instance for AuthProtectedLax
instance Enter subserver arg ret => Enter (AuthProtected authData usr subserver 'Lax) arg (AuthProtected authData usr ret 'Lax) where
enter arg (AuthProtectedLax check subserver) = AuthProtectedLax check (enter arg subserver)

43
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -16,8 +16,7 @@ import Data.IORef (newIORef, readIORef,
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.String (fromString) import Data.String (fromString)
import Network.HTTP.Types hiding (Header, import Network.HTTP.Types hiding (Header, ResponseHeaders)
ResponseHeaders)
import Network.Wai (Application, Request, import Network.Wai (Application, Request,
Response, ResponseReceived, Response, ResponseReceived,
requestBody, responseLBS, requestBody, responseLBS,
@ -32,7 +31,7 @@ type RoutingApplication =
-- | A wrapper around @'Either' 'RouteMismatch' a@. -- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a = newtype RouteResult a =
RR { routeResult :: Either RouteMismatch a } RR { routeResult :: Either RouteMismatch a }
deriving (Eq, Show, Functor, Applicative) deriving (Show, Functor, Applicative, Monad)
-- | If we get a `Right`, it has precedence over everything else. -- | If we get a `Right`, it has precedence over everything else.
-- --
@ -52,8 +51,21 @@ data RouteMismatch =
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type | UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. | HttpError Status [Header] (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Ord, Show) | RouteMismatch Response -- ^ an arbitrary mismatch with custom Response.
instance Show RouteMismatch where
show = const "hello"
-- | specialized 'Less Than' for use with Monoid RouteMismatch
(<=:) :: RouteMismatch -> RouteMismatch -> Bool
{-# INLINE (<=:) #-}
NotFound <=: _ = True
WrongMethod <=: rmm = not (rmm <=: NotFound)
UnsupportedMediaType <=: rmm = not (rmm <=: WrongMethod)
InvalidBody _ <=: rmm = not (rmm <=: UnsupportedMediaType)
HttpError _ _ _ <=: rmm = not (rmm <=: (InvalidBody ""))
RouteMismatch _ <=: _ = False
instance Monoid RouteMismatch where instance Monoid RouteMismatch where
mempty = NotFound mempty = NotFound
@ -62,7 +74,20 @@ instance Monoid RouteMismatch where
-- --
-- "As one judge said to the other, 'Be just and if you can't be just, be -- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs -- arbitrary'" -- William Burroughs
mappend = max --
-- It used to be the case that `mappend = max` but getting rid of the `Eq`
-- and `Ord` instance meant we had to roll out our own max ;\
rmm `mappend` NotFound = rmm
NotFound `mappend` rmm = rmm
WrongMethod `mappend` rmm | rmm <=: WrongMethod = WrongMethod
WrongMethod `mappend` rmm = rmm
UnsupportedMediaType `mappend` rmm | rmm <=: UnsupportedMediaType = UnsupportedMediaType
UnsupportedMediaType `mappend` rmm = rmm
i@(InvalidBody _) `mappend` rmm | rmm <=: i = i
InvalidBody _ `mappend` rmm = rmm
h@(HttpError _ _ _) `mappend` rmm | rmm <=: h = h
HttpError _ _ _ `mappend` rmm = rmm
r@(RouteMismatch _) `mappend` _ = r
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
| Called !B.ByteString | Called !B.ByteString
@ -102,8 +127,10 @@ toApplication ra request respond = do
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) = routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) = routingRespond (Left (HttpError status headers body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body respond $ responseLBS status headers $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Left (RouteMismatch resp)) =
respond resp
routingRespond (Right response) = routingRespond (Right response) =
respond response respond response

4
servant-server/test/Servant/ServerSpec.hs
View file

@ -659,7 +659,7 @@ prioErrorsSpec = describe "PrioErrors" $ do
-- | Test server error functionality. -- | Test server error functionality.
errorsSpec :: Spec errorsSpec :: Spec
errorsSpec = do errorsSpec = do
let he = HttpError status409 (Just "A custom error") let he = HttpError status409 [] (Just "A custom error")
let ib = InvalidBody "The body is invalid" let ib = InvalidBody "The body is invalid"
let wm = WrongMethod let wm = WrongMethod
let nf = NotFound let nf = NotFound
@ -789,4 +789,4 @@ authRequiredSpec = do
foo401 <- get "/foo" foo401 <- get "/foo"
bar401 <- get "/bar" bar401 <- get "/bar"
WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"foo-realm\"" foo401) WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"foo-realm\"" foo401)
WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"foo-realm\"" bar401) WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"bar-realm\"" bar401)

35
servant/src/Servant/API/Authentication.hs
View file

@ -1,24 +1,31 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Authentication (BasicAuth) where module Servant.API.Authentication where
import Data.ByteString (ByteString)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol) import GHC.TypeLits (Symbol)
-- | we can be either Strict or Lax.
-- Strict: all handlers under 'AuthProtect' take a 'usr' argument.
-- when auth fails, we call user-supplied handlers to respond.
-- Lax: all handlers under 'AuthProtect' take a 'Maybe usr' argument.
-- when auth fails, we call the handlers with 'Nothing'.
data AuthPolicy = Strict | Lax
-- | the combinator to be used in API types
data AuthProtect authdata usr (policy :: AuthPolicy)
-- | what we'll ask user to provide at the server-level when we see a
-- 'AuthProtect' combinator in an API type
data family AuthProtected authdata usr subserver :: AuthPolicy -> *
-- | Basic Authentication with respect to a specified @realm@ and a @lookup@ -- | Basic Authentication with respect to a specified @realm@ and a @lookup@
-- type to encapsulate authentication logic. -- type to encapsulate authentication logic.
-- data BasicAuth (realm :: Symbol) = BasicAuth { baUser :: ByteString
-- Example: , baPass :: ByteString
-- >>> type MyApi = BasicAuth "book-realm" DB :> "books" :> Get '[JSON] [Book] } deriving (Eq, Show, Typeable)
data BasicAuth (realm :: Symbol) lookup
deriving (Typeable)
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data DB
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }