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

HasServer instances for new GADT-based auth

Browse source
This commit is contained in:
aaron levin 2015-12-24 18:01:23 +01:00
parent 8db2a0bb6e
commit 007e8586c5
2 changed files with 49 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -61,7 +61,8 @@ import Servant.API ((:<|>) (..), (:>),
ReqBody, Vault) ReqBody, Vault)
import Servant.API.Authentication (AuthPolicy (Strict, Lax), import Servant.API.Authentication (AuthPolicy (Strict, Lax),
AuthProtect, AuthProtect,
AuthProtected) AuthProtected,
SAuthPolicy(SLax,SStrict))
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..), AllCTUnrender (..),
@ -71,11 +72,7 @@ import Servant.API.ResponseHeaders (GetHeaders,
Headers, Headers,
getHeaders, getHeaders,
getResponse) getResponse)
import Servant.Server.Internal.Authentication (AuthData (authData), import Servant.Server.Internal.Authentication (AuthData (authData))
AuthProtected (..),
checkAuthStrict,
AuthHandlers(onMissingAuthData,
onUnauthenticated))
import Servant.Server.Internal.Router import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
@ -263,34 +260,61 @@ instance
route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-- | Authentication in Strict mode. -- | Authentication in Missing x Unauth = Strict x Strict mode
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(AuthData authdata , HasServer sublayout) => HasServer (AuthProtect authdata (usr :: *) 'Strict :> sublayout) where (AuthData authData mError, HasServer sublayout) => HasServer (AuthProtect authData (usr :: *) 'Strict (mError :: *) 'Strict (uError :: *) :> sublayout) where
type ServerT (AuthProtect authData usr 'Strict mError 'Strict uError :> sublayout) m =
type ServerT (AuthProtect authdata usr 'Strict :> sublayout) m = AuthProtected authdata usr (usr -> ServerT sublayout m) 'Strict AuthProtected IO ServantErr 'Strict mError 'Strict uError authData usr (usr -> ServerT sublayout m)
route _ subserver = WithRequest $ \ request -> route _ subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) (addAuthStrictCheck subserver (authCheck request)) route (Proxy :: Proxy sublayout) (addAuthCheck SStrict SStrict subserver (authCheck request))
where where
authCheck req = pure . Route $ authData req authCheck req = pure . Route $ authData req
-- | Authentication in Lax mode. -- | Authentication in Missing x Unauth = Strict x Lax mode
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(AuthData authdata , HasServer sublayout) => HasServer (AuthProtect authdata (usr :: *) 'Lax :> sublayout) where (AuthData authData mError, HasServer sublayout) => HasServer (AuthProtect authData (usr :: *) 'Strict (mError :: *) 'Lax (uError :: *) :> sublayout) where
type ServerT (AuthProtect authData usr 'Strict mError 'Lax uError :> sublayout) m =
type ServerT (AuthProtect authdata usr 'Lax :> sublayout) m = AuthProtected authdata usr (Maybe usr -> ServerT sublayout m) 'Lax AuthProtected IO ServantErr 'Strict mError 'Lax uError authData usr (Either uError usr -> ServerT sublayout m)
route _ subserver = WithRequest $ \ request -> route _ subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) (addAuthLaxCheck subserver (authCheck request)) route (Proxy :: Proxy sublayout) (addAuthCheck SStrict SLax subserver (authCheck request))
where where
authCheck req = pure . Route $ authData req authCheck req = pure . Route $ authData req
-- | Authentication in Missing x Unauth = Lax x Strict mode
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(AuthData authData mError, HasServer sublayout) => HasServer (AuthProtect authData (usr :: *) 'Lax (mError :: *) 'Strict (uError :: *) :> sublayout) where
type ServerT (AuthProtect authData usr 'Lax mError 'Strict uError :> sublayout) m =
AuthProtected IO ServantErr 'Lax mError 'Strict uError authData usr (Either mError usr -> ServerT sublayout m)
route _ subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) (addAuthCheck SLax SStrict subserver (authCheck request))
where
authCheck req = pure . Route $ authData req
-- | Authentication in Missing x Unauth = Lax x Lax mode
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(AuthData authData mError, HasServer sublayout) => HasServer (AuthProtect authData (usr :: *) 'Lax (mError :: *) 'Lax (uError :: *) :> sublayout) where
type ServerT (AuthProtect authData usr 'Lax mError 'Lax uError :> sublayout) m =
AuthProtected IO ServantErr 'Lax mError 'Lax uError authData usr (Either (Either mError uError) usr -> ServerT sublayout m)
route _ subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) (addAuthCheck SLax SLax subserver (authCheck request))
where
authCheck req = pure . Route $ authData req
-- | 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'

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

@ -29,7 +29,7 @@ import Data.Typeable
import Servant.API import Servant.API
import Servant.API.Authentication import Servant.API.Authentication
import Servant.Server.Internal.Authentication (AuthProtected (AuthProtectedStrict, AuthProtectedLax)) -- 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
@ -100,11 +100,9 @@ squashNat = Nat squash
generalizeNat :: Applicative m => Identity :~> m generalizeNat :: Applicative m => Identity :~> m
generalizeNat = Nat (pure . runIdentity) generalizeNat = Nat (pure . runIdentity)
-- | 'Enter' instance for AuthProtectedStrict -- | 'Enter' instance for AuthProtected
instance Enter subserver arg ret => Enter (AuthProtected authData usr subserver 'Strict) arg (AuthProtected authData usr ret 'Strict) where instance Enter subserver arg ret => Enter (AuthProtected m e mP mE uP uE authData usr subserver)
enter arg (AuthProtectedStrict check handlers subserver) = AuthProtectedStrict check handlers (enter arg subserver) arg
(AuthProtected m e mP mE uP uE authData usr ret)
where
-- | 'Enter' instance for AuthProtectedLax enter arg (AuthProtected mHandler uHandler check sub) = AuthProtected mHandler uHandler check (enter arg sub)
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)