Second Iteration of Authentication
Implemented with the AuthProtected data family as per alp's suggestion.
This commit is contained in:
parent
d2e2122933
commit
272091effe
7 changed files with 305 additions and 118 deletions
|
@ -36,6 +36,7 @@ library
|
|||
Servant
|
||||
Servant.Server
|
||||
Servant.Server.Internal
|
||||
Servant.Server.Internal.Authentication
|
||||
Servant.Server.Internal.Enter
|
||||
Servant.Server.Internal.PathInfo
|
||||
Servant.Server.Internal.Router
|
||||
|
|
|
@ -1,15 +1,16 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#endif
|
||||
|
||||
module Servant.Server.Internal
|
||||
|
@ -21,44 +22,66 @@ module Servant.Server.Internal
|
|||
) where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.ByteString as B
|
||||
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.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>), ConvertibleStrings)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>), ConvertibleStrings)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8,
|
||||
encodeUtf8)
|
||||
import Data.Typeable
|
||||
import Data.Word8 (isSpace, _colon, toLower)
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application, isSecure, httpVersion, Request, Response,
|
||||
ResponseReceived, lazyRequestBody,
|
||||
pathInfo, rawQueryString, remoteHost,
|
||||
requestBody, requestHeaders,
|
||||
requestMethod, responseLBS,
|
||||
strictRequestBody, vault)
|
||||
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
|
||||
Delete, Get, Header, IsSecure(Secure, NotSecure),
|
||||
MatrixFlag, MatrixParam, MatrixParams,
|
||||
Patch, Post, Put, QueryFlag,
|
||||
QueryParam, QueryParams, Raw,
|
||||
RemoteHost, ReqBody, Vault)
|
||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
||||
AllCTRender (..),
|
||||
AllCTUnrender (..))
|
||||
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
|
||||
getHeaders)
|
||||
import Servant.Common.Text (FromText, fromText)
|
||||
|
||||
import GHC.TypeLits (KnownSymbol,
|
||||
symbolVal)
|
||||
import Network.HTTP.Types hiding (Header,
|
||||
ResponseHeaders)
|
||||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application,
|
||||
httpVersion,
|
||||
isSecure,
|
||||
lazyRequestBody,
|
||||
rawQueryString,
|
||||
remoteHost,
|
||||
requestHeaders,
|
||||
requestMethod,
|
||||
responseLBS, vault)
|
||||
import Servant.API ((:<|>) (..), (:>),
|
||||
Capture, Delete,
|
||||
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 (..),
|
||||
AllCTRender (..),
|
||||
AllCTUnrender (..))
|
||||
import Servant.API.ResponseHeaders (GetHeaders,
|
||||
Headers,
|
||||
getHeaders,
|
||||
getResponse)
|
||||
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.Router
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
|
@ -71,18 +94,6 @@ class HasServer layout where
|
|||
|
||||
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
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Authentication
|
||||
-- | Authentication in Strict mode.
|
||||
instance
|
||||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPABLE #-}
|
||||
#endif
|
||||
( HasServer sublayout
|
||||
, BasicAuthLookup lookup
|
||||
, KnownSymbol realm
|
||||
)
|
||||
=> HasServer (BasicAuth realm lookup :> sublayout) where
|
||||
(AuthData authdata , HasServer sublayout) => HasServer (AuthProtect authdata (usr :: *) 'Strict :> sublayout) where
|
||||
|
||||
type ServerT (BasicAuth realm lookup :> sublayout) m
|
||||
= BasicAuthVal lookup -> ServerT sublayout m
|
||||
type ServerT (AuthProtect authdata usr 'Strict :> sublayout) m = AuthProtected authdata usr (usr -> ServerT sublayout m) 'Strict
|
||||
|
||||
route _ action request respond =
|
||||
case lookup "Authorization" (requestHeaders request) of
|
||||
Nothing -> respond . succeedWith $ authFailure401
|
||||
Just authBs ->
|
||||
-- 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
|
||||
route _ subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy sublayout) $ do
|
||||
-- Note: this may perform IO for each attempt at matching.
|
||||
rr <- routeResult <$> subserver
|
||||
|
||||
-- no username:password present
|
||||
Nothing -> respond . succeedWith $ authFailure401
|
||||
where
|
||||
authFailure403 = responseLBS status403 [] ""
|
||||
raw = decodeLenient encoded
|
||||
-- split username and password at the colon ':' char.
|
||||
(username, passwordWithColonAtHead) = B.breakByte _colon raw
|
||||
case rr of
|
||||
-- Successful route match, so we extract the author-provided
|
||||
-- auth data.
|
||||
Right authProtectionStrict ->
|
||||
case authData req of
|
||||
-- could not pull authenticate data out of the request
|
||||
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,
|
||||
-- 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 (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
|
||||
route (Proxy :: Proxy sublayout) (feedTo subserver param)
|
||||
|
||||
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
|
|
102
servant-server/src/Servant/Server/Internal/Authentication.hs
Normal file
102
servant-server/src/Servant/Server/Internal/Authentication.hs
Normal 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
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
|
@ -13,7 +14,7 @@ module Servant.Server.Internal.Enter where
|
|||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative
|
||||
#endif
|
||||
import qualified Control.Category as C
|
||||
import qualified Control.Category as C
|
||||
#if MIN_VERSION_mtl(2,2,1)
|
||||
import Control.Monad.Except
|
||||
#endif
|
||||
|
@ -24,9 +25,16 @@ 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 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 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
|
||||
enter :: arg -> typ -> ret
|
||||
|
||||
|
@ -95,3 +103,12 @@ squashNat = Nat squash
|
|||
-- | Like @mmorph@'s `generalize`.
|
||||
generalizeNat :: Applicative m => Identity :~> m
|
||||
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)
|
||||
|
|
|
@ -16,8 +16,7 @@ import Data.IORef (newIORef, readIORef,
|
|||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (fromString)
|
||||
import Network.HTTP.Types hiding (Header,
|
||||
ResponseHeaders)
|
||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||
import Network.Wai (Application, Request,
|
||||
Response, ResponseReceived,
|
||||
requestBody, responseLBS,
|
||||
|
@ -32,7 +31,7 @@ type RoutingApplication =
|
|||
-- | A wrapper around @'Either' 'RouteMismatch' a@.
|
||||
newtype RouteResult 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.
|
||||
--
|
||||
|
@ -52,8 +51,21 @@ data RouteMismatch =
|
|||
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
|
||||
| UnsupportedMediaType -- ^ request body has unsupported media type
|
||||
| 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.
|
||||
deriving (Eq, Ord, Show)
|
||||
| HttpError Status [Header] (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
|
||||
| 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
|
||||
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
|
||||
-- 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
|
||||
| Called !B.ByteString
|
||||
|
@ -102,8 +127,10 @@ toApplication ra request respond = do
|
|||
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
|
||||
routingRespond (Left UnsupportedMediaType) =
|
||||
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
|
||||
routingRespond (Left (HttpError status body)) =
|
||||
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
|
||||
routingRespond (Left (HttpError status headers body)) =
|
||||
respond $ responseLBS status headers $ fromMaybe (BL.fromStrict $ statusMessage status) body
|
||||
routingRespond (Left (RouteMismatch resp)) =
|
||||
respond resp
|
||||
routingRespond (Right response) =
|
||||
respond response
|
||||
|
||||
|
|
|
@ -659,7 +659,7 @@ prioErrorsSpec = describe "PrioErrors" $ do
|
|||
-- | Test server error functionality.
|
||||
errorsSpec :: Spec
|
||||
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 wm = WrongMethod
|
||||
let nf = NotFound
|
||||
|
@ -789,4 +789,4 @@ authRequiredSpec = do
|
|||
foo401 <- get "/foo"
|
||||
bar401 <- get "/bar"
|
||||
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)
|
||||
|
|
|
@ -1,24 +1,31 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
module Servant.API.Authentication (BasicAuth) where
|
||||
module Servant.API.Authentication where
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.TypeLits (Symbol)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Typeable (Typeable)
|
||||
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@
|
||||
-- type to encapsulate authentication logic.
|
||||
--
|
||||
-- Example:
|
||||
-- >>> type MyApi = BasicAuth "book-realm" DB :> "books" :> Get '[JSON] [Book]
|
||||
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 }
|
||||
data BasicAuth (realm :: Symbol) = BasicAuth { baUser :: ByteString
|
||||
, baPass :: ByteString
|
||||
} deriving (Eq, Show, Typeable)
|
||||
|
|
Loading…
Reference in a new issue