b1a6d88845
We've previously used functions in the Router type to provide information for subrouters. But this accesses the Requests too early, and breaks sharing of the router structure in general, causing the Router or large parts of the Router to be recomputed on every request. We now do not use functions anymore, and properly compute all static parts of the router first, and gain access to the request only in Delayed. This also turns the code used within Delayed into a proper monad now called DelayedIO, making some of the code using it a bit nicer.
69 lines
3.0 KiB
Haskell
69 lines
3.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Servant.Server.Experimental.Auth where
|
|
|
|
import Control.Monad.Trans (liftIO)
|
|
import Control.Monad.Trans.Except (runExceptT)
|
|
import Data.Proxy (Proxy (Proxy))
|
|
import Data.Typeable (Typeable)
|
|
import GHC.Generics (Generic)
|
|
import Network.Wai (Request)
|
|
|
|
import Servant ((:>))
|
|
import Servant.API.Experimental.Auth
|
|
import Servant.Server.Internal (HasContextEntry,
|
|
HasServer, ServerT,
|
|
getContextEntry,
|
|
route)
|
|
import Servant.Server.Internal.RoutingApplication (addAuthCheck,
|
|
delayedFailFatal,
|
|
DelayedIO,
|
|
withRequest)
|
|
import Servant.Server.Internal.ServantErr (Handler)
|
|
|
|
-- * General Auth
|
|
|
|
-- | Specify the type of data returned after we've authenticated a request.
|
|
-- quite often this is some `User` datatype.
|
|
--
|
|
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
|
type family AuthServerData a :: *
|
|
|
|
-- | Handlers for AuthProtected resources
|
|
--
|
|
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
|
newtype AuthHandler r usr = AuthHandler
|
|
{ unAuthHandler :: r -> Handler usr }
|
|
deriving (Generic, Typeable)
|
|
|
|
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
|
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
|
|
mkAuthHandler = AuthHandler
|
|
|
|
-- | Known orphan instance.
|
|
instance ( HasServer api context
|
|
, HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
|
|
)
|
|
=> HasServer (AuthProtect tag :> api) context where
|
|
|
|
type ServerT (AuthProtect tag :> api) m =
|
|
AuthServerData (AuthProtect tag) -> ServerT api m
|
|
|
|
route Proxy context subserver =
|
|
route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
|
|
where
|
|
authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
|
|
authHandler = unAuthHandler (getContextEntry context)
|
|
authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
|
|
authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler
|