diff --git a/servant/src/Servant/API/Authentication.hs b/servant/src/Servant/API/Authentication.hs index 09708946..5ca117b8 100644 --- a/servant/src/Servant/API/Authentication.hs +++ b/servant/src/Servant/API/Authentication.hs @@ -13,6 +13,7 @@ module Servant.API.Authentication , JWTAuth (..) , OnMissing (..) , OnUnauthenticated (..) +, SAuthPolicy (..) ) where @@ -28,6 +29,11 @@ import Data.Text (Text) -- when auth fails, we call the handlers with 'Nothing'. data AuthPolicy = Strict | Lax +-- | Singleton types for AuthPolicy +data SAuthPolicy (p :: AuthPolicy) where + SStrict :: SAuthPolicy 'Strict + SLax :: SAuthPolicy 'Lax + -- | the combinator to be used in API types data AuthProtect authdata usr (policy :: AuthPolicy) @@ -40,40 +46,44 @@ data AuthProtect authdata usr (policy :: AuthPolicy) -- it is Strict, then api authors can specify how to handle the response. -- About the type parameters: -- m: the monad errors are retrned in. For now just IO. --- e: an error type. For now just ServantErr. +-- responseError: an error response type. For now just ServantErr. -- policy: the policy to handle OnMissing. -data OnMissing m e (policy :: AuthPolicy) where - LaxMissing :: OnMissing m e 'Lax - StrictMissing :: m e -> OnMissing m e 'Strict +-- errorIndex: an ADT representing possible errors encountered while extracting +-- authentication data from a request. +data OnMissing m responseError (policy :: AuthPolicy) errorIndex where + LaxMissing :: OnMissing m responseError 'Lax errorIndex + StrictMissing :: (errorIndex -> m responseError) -> OnMissing m responseError 'Strict errorIndex -- | A GADT indexed by policy strictness that encompasses the ways -- users will handle the case where the authentication data provided is -- rejected. I.e. a username and password do not match in the database. -- About the type parameters: -- m: the monad errors are returned in. For now just IO. --- e: an error type. For now just ServantErr. +-- responseError: an error response type. For now just ServantErr. -- authData: the authentication data extracted from the request -- errorIndex: an index of error to give a user-provided, semantic meaning to the authentication failure. -- policy: the policy to handle OnUnauthenticated actions. -data OnUnauthenticated m e (policy :: AuthPolicy) errorIndex authData where +data OnUnauthenticated m responseError (policy :: AuthPolicy) errorIndex authData where LaxUnauthenticated :: OnUnauthenticated m e 'Lax errorIndex authData - StrictUnauthenticated :: (errorIndex -> authData -> m e) -> OnUnauthenticated m e 'Strict errorIndex authData + StrictUnauthenticated :: (errorIndex -> authData -> m responseError) + -> OnUnauthenticated m responseError 'Strict errorIndex authData -- | A GADT representing the data and functions required to protect a reasource for authentication. -- For an authenticated resource, we need to handle the scenario where authentication data is missing -- and where authentication data is present but not valid (e.g. uesrname + password not valid). -- m: the monad errors are retrned in. For now just IO. --- e: an error type. For now just ServantErr. --- missingPolicy: the policy to handle missing authentication data actions. --- unauthPolicy: the policy to handle rejected authentication attempts. +-- rError: an error response type. For now just ServantErr. +-- mPolicy: Missing Auth: the policy to handle missing authentication data actions. +-- mError: Missing Auth: ADT error index for possible missing auth failures +-- uPolicy: Unauthenticated: the policy to handle rejected authentication attempts. +-- uError: Unauthenticated: ADT error index for possible unauthentication failures -- authData: the type of authData present in a request (e.g. JWT token) --- errorIndex: an index of error to give a user-provided, semantic meaning to the authentication failure. -- usr: a data type extracted from the authenticated data. This data is likely fetched from a database. -- subserver: the rest of the servant API. -data AuthProtected m e (missingPolicy :: AuthPolicy) (unauthPolicy :: AuthPolicy) errorIndex authData usr subserver = - AuthProtected { onMissing :: OnMissing m e missingPolicy - , onUnathenticated :: OnUnauthenticated m e unauthPolicy errorIndex authData - , checkAuth :: authData -> m (Either errorIndex usr) +data AuthProtected m rError (mPolicy :: AuthPolicy) mError (uPolicy :: AuthPolicy) uError authData usr subserver = + AuthProtected { onMissing :: OnMissing m rError mPolicy mError + , onUnauthenticated :: OnUnauthenticated m rError uPolicy uError authData + , checkAuth :: authData -> m (Either uError usr) , subserver :: subserver }