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