diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,24 @@ # Changelog for biscuit-servant +## 0.3.0.0 + +- use biscuit-haskell 0.3.0.0 +- GHC 9.2 support +- custom error handlers and token post-processing + +## 0.2.1.0 + +- use biscuit-haskell 0.2.1.0 + +## 0.2.0.1 + +- use biscuit-haskell 0.2.0.1 + +## 0.2.0.0 + +- use biscuit-haskell 0.2.0.0 +- allow effectful verification + ## 0.1.1.0 Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -44,7 +44,7 @@ singleUserHandler :: Int -> AppM User singleUserHandler uid = - withAuthorizer [authorizer|allow if right("getUser", ${uid})|] $ + withAuthorizer [authorizer|allow if right("getUser", {uid})|] $ let user = find (\user -> userId user == uid) allUsers in maybe (throwError error404) (\user -> pure user) user ``` diff --git a/biscuit-servant.cabal b/biscuit-servant.cabal --- a/biscuit-servant.cabal +++ b/biscuit-servant.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: biscuit-servant -version: 0.2.1.0 +version: 0.3.0.0 category: Security synopsis: Servant support for the Biscuit security token description: Please see the README on GitHub at @@ -13,6 +13,7 @@ license: BSD3 license-file: LICENSE build-type: Simple +tested-with: GHC ==8.10.7 || == 9.0.2 || ==9.2.4 extra-source-files: README.md ChangeLog.md @@ -33,10 +34,10 @@ ghc-options: -Wall build-depends: base >= 4.7 && <5, - biscuit-haskell >= 0.2.1.0 && < 0.3, - bytestring ^>= 0.10, + biscuit-haskell >= 0.3 && < 0.4, + bytestring >= 0.10 && <0.12, mtl ^>= 2.2, - text ^>= 1.2, + text >= 1.2 && <3, servant-server >= 0.18 && < 0.20, wai ^>= 3.2 default-language: Haskell2010 @@ -57,6 +58,7 @@ , bytestring , hspec , http-client + , mtl , servant , servant-server , servant-client diff --git a/src/Auth/Biscuit/Servant.hs b/src/Auth/Biscuit/Servant.hs --- a/src/Auth/Biscuit/Servant.hs +++ b/src/Auth/Biscuit/Servant.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Auth.Biscuit.Servant ( @@ -13,14 +15,24 @@ RequireBiscuit , authHandler , genBiscuitCtx + -- *** Custom parsing and error handling + , authHandlerWith + , genBiscuitCtxWith + , BiscuitConfig (..) + , defaultBiscuitConfig -- ** Supplying a authorizer for a single endpoint -- $singleEndpointAuthorizer , checkBiscuit , checkBiscuitM + -- *** Custom parsing and error handling + , checkBiscuitWith + , checkBiscuitMWith -- ** Decorate regular handlers with composable authorizers -- $composableAuthorizers - , WithAuthorizer (..) + , WithAuthorizer' (..) + , WithAuthorizer , handleBiscuit + , handleBiscuitWith , withAuthorizer , withAuthorizer_ , withAuthorizerM @@ -31,20 +43,25 @@ , withPriorityAuthorizer , withFallbackAuthorizerM , withPriorityAuthorizerM + -- *** Extract information from an authorized token + -- $tokenPostProcessing + , withTransformation , module Biscuit ) where import Auth.Biscuit as Biscuit -import Data.Kind (Type) import Control.Applicative (liftA2) import Control.Monad.Except (MonadError, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT, lift, runReaderT) -import Data.Bifunctor (first) +import Control.Monad.Reader (ReaderT (..), lift, + runReaderT, withReaderT) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LBS +import Data.Either (fromRight) +import Data.Kind (Type) import Network.Wai import Servant (AuthProtect) import Servant.Server @@ -61,15 +78,15 @@ -- $apitypes -- --- To protect and endpoint (or a whole API tree), you can use 'RequireBiscuit' +-- To protect an endpoint (or a whole API tree), you can use 'RequireBiscuit' -- like so: -- --- -- > type API = RequireBiscuit :> ProtectedAPI -- > type ProtectedAPI = -- > "endpoint1" :> Get '[JSON] Int -- > :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int -- > :<|> "endpoint3" :> Get '[JSON] Int +-- > :<|> "endpoint4" :> Get '[JSON] Int -- > -- > app :: PublicKey -> Application -- > app publicKey = @@ -117,11 +134,11 @@ -- > // the biscuit can decide if it's still valid -- > // this show how to run an effectful check with -- > // checkBiscuitM (getting the current time is an effect) --- > time(${now}); +-- > time({now}); -- > // only allow biscuits granting access to the endpoint tagged "two" --- > // AND for the provided int value. This show how the checks can depend +-- > // AND for the provided int value. This shows how the checks can depend -- > // on the http request contents. --- > allow if right("two", ${value}); +-- > allow if right("two", {value}); -- > |] -- > checkBiscuitM biscuit authorizer -- > (pure 2) @@ -154,19 +171,19 @@ -- > -- > handler2 :: Int -> WithAuthorizer Handler Int -- > handler2 value = withAuthorizer --- > [authorizer|allow if right("two", ${value});|] +-- > [authorizer|allow if right("two", {value});|] -- > (pure 2) -- > -- > handler3 :: WithAuthorizer Handler Int -- > handler3 = withAuthorizer --- > [authorizer|allow if right("three");|] +-- > [authorizer|deny if true;|] -- > (pure 3) -- > -- > server :: Biscuit OpenOrSealed Verified -> Server ProtectedAPI -- > server biscuit = -- > let nowFact = do -- > now <- liftIO getCurrentTime --- > pure [authorizer|time(${now});|] +-- > pure [authorizer|time({now});|] -- > handleAuth :: WithAuthorizer Handler x -> Handler x -- > handleAuth = -- > handleBiscuit biscuit @@ -186,29 +203,56 @@ -- > handlers = handler1 :<|> handler2 :<|> handler3 -- > in hoistServer @ProtectedAPI Proxy handleAuth handlers -- > -- ^ this will apply `handleAuth` on all 'ProtectedAPI' endpoints. +-- +-- $tokenPostProcessing +-- +-- By default, an `AuthorizedBiscuit` value is available through `MonadReader` in all +-- `WithAuthorizer` handlers. In many cases, a post-processing step is needed to extract +-- meaningful information from the token (for instance extracting a user id and then fetching +-- user information from the database). In order to avoid repeating this operation in every +-- endpoint, `withTransformation` allows to do it for whole API trees. +-- +-- > handler4 :: WithAuthorizer Handler Int +-- > handler4 = withTransformation extractUserId $ +-- > withAuthorizer [authorizer|allow if user($user_id); |] $ do +-- > userId <- ask -- we can access the extracted user id directly +-- > pure userId +-- > +-- > -- given a @AuthorizedBiscuit OpenOrSealed@, we can extract information from +-- > -- the token. This step can perform effects (for instance `IO`, or `MonadError`). +-- > extractUserId :: AuthorizedBiscuit OpenOrSealed -> Handler Int +-- > extractUserId AuthorizedBiscuit{authorizationSuccess} = do +-- > let b = bindings $ matchedAllowQuery authorizationSuccess +-- > in maybe (throwError err403) pure $ getSingleVariableValue b "user_id" --- | Type used to protect and API tree, requiring a biscuit token +-- | Type used to protect an API tree, requiring a biscuit token -- to be attached to requests. The associated auth handler will -- only check the biscuit signature. Checking the datalog part -- usually requires endpoint-specific information, and has to -- be performed separately with either 'checkBiscuit' (for simple -- use-cases) or 'handleBiscuit' (for more complex use-cases). type RequireBiscuit = AuthProtect "biscuit" + +-- | The result of a 'RequireBiscuit' check will be a @Biscuit OpenOrSealed Verified@: +-- a biscuit that's been successfully parsed, with its signatures verified. type instance AuthServerData RequireBiscuit = Biscuit OpenOrSealed Verified -- | Wrapper for a servant handler, equipped with a biscuit 'Authorizer' -- that will be used to authorize the request. If the authorization -- succeeds, the handler is ran. --- The handler itself is given access to the verified biscuit through --- a @ReaderT (Biscuit OpenOrSealed Verified)@. -data WithAuthorizer (m :: Type -> Type) (a :: Type) +-- The handler itself is given access to the authorized biscuit (or another +-- value derived from it) through a @ReaderT@ wrapper +data WithAuthorizer' (t :: Type) (m :: Type -> Type) (a :: Type) = WithAuthorizer - { handler_ :: ReaderT (Biscuit OpenOrSealed Verified) m a + { handler_ :: ReaderT t m a -- ^ the wrapped handler, in a 'ReaderT' to give easy access to the biscuit , authorizer_ :: m Authorizer -- ^ the 'Authorizer' associated to the handler } +-- | Default wrapper giving access to the @AuthorizedBiscuit@ directly. +type WithAuthorizer = WithAuthorizer' (AuthorizedBiscuit OpenOrSealed) + -- | Combines the provided 'Authorizer' to the 'Authorizer' attached to the wrapped -- handler. /facts/, /rules/ and /checks/ are unordered, but /policies/ have a -- specific order. 'withFallbackAuthorizer' puts the provided policies at the /bottom/ @@ -223,8 +267,8 @@ -- or to query a database), you can use 'withFallbackAuthorizerM' instead. withFallbackAuthorizer :: Functor m => Authorizer - -> WithAuthorizer m a - -> WithAuthorizer m a + -> WithAuthorizer' t m a + -> WithAuthorizer' t m a withFallbackAuthorizer newV h@WithAuthorizer{authorizer_} = h { authorizer_ = (<> newV) <$> authorizer_ } @@ -242,8 +286,8 @@ -- you can use 'withFallbackAuthorizer' instead. withFallbackAuthorizerM :: Applicative m => m Authorizer - -> WithAuthorizer m a - -> WithAuthorizer m a + -> WithAuthorizer' t m a + -> WithAuthorizer' t m a withFallbackAuthorizerM newV h@WithAuthorizer{authorizer_} = h { authorizer_ = liftA2 (<>) authorizer_ newV } @@ -280,8 +324,8 @@ -- you can use 'withFallbackAuthorizer' instead. withPriorityAuthorizerM :: Applicative m => m Authorizer - -> WithAuthorizer m a - -> WithAuthorizer m a + -> WithAuthorizer' t m a + -> WithAuthorizer' t m a withPriorityAuthorizerM newV h@WithAuthorizer{authorizer_} = h { authorizer_ = liftA2 (<>) newV authorizer_ } @@ -293,9 +337,9 @@ -- If you need to perform effects to compute the authorizer (eg. to get the current date, -- or to query a database), you can use 'withAuthorizerM' instead. withAuthorizer :: Applicative m - => Authorizer - -> ReaderT (Biscuit OpenOrSealed Verified) m a - -> WithAuthorizer m a + => Authorizer + -> ReaderT t m a + -> WithAuthorizer' t m a withAuthorizer v handler_ = WithAuthorizer { handler_ @@ -310,8 +354,8 @@ -- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects, -- you can use 'withAuthorizer' instead. withAuthorizerM :: m Authorizer - -> ReaderT (Biscuit OpenOrSealed Verified) m a - -> WithAuthorizer m a + -> ReaderT t m a + -> WithAuthorizer' t m a withAuthorizerM authorizer_ handler_ = WithAuthorizer { handler_ @@ -324,7 +368,7 @@ -- -- If you need to perform effects to compute the authorizer (eg. to get the current date, -- or to query a database), you can use 'withAuthorizerM_' instead. -withAuthorizer_ :: Monad m => Authorizer -> m a -> WithAuthorizer m a +withAuthorizer_ :: Monad m => Authorizer -> m a -> WithAuthorizer' t m a withAuthorizer_ v = withAuthorizer v . lift -- | Wraps an existing handler block, attaching a 'Authorizer'. The handler can be @@ -335,7 +379,7 @@ -- -- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects, -- you can use 'withAuthorizer_' instead. -withAuthorizerM_ :: Monad m => m Authorizer -> m a -> WithAuthorizer m a +withAuthorizerM_ :: Monad m => m Authorizer -> m a -> WithAuthorizer' t m a withAuthorizerM_ v = withAuthorizerM v . lift -- | Wraps an existing handler block, attaching an empty 'Authorizer'. The handler has @@ -348,8 +392,8 @@ -- 'withFallbackAuthorizer' or 'withPriorityAuthorizer' to apply policies on several -- handlers at the same time (with 'hoistServer' for instance). noAuthorizer :: Applicative m - => ReaderT (Biscuit OpenOrSealed Verified) m a - -> WithAuthorizer m a + => ReaderT t m a + -> WithAuthorizer' t m a noAuthorizer = withAuthorizer mempty -- | Wraps an existing handler block, attaching an empty 'Authorizer'. The handler can be @@ -360,41 +404,103 @@ -- context, and the authorizer context is applied on the whole API tree through -- 'withFallbackAuthorizer' or 'withPriorityAuthorizer' to apply policies on several -- handlers at the same time (with 'hoistServer' for instance). -noAuthorizer_ :: Monad m => m a -> WithAuthorizer m a +noAuthorizer_ :: Monad m => m a -> WithAuthorizer' t m a noAuthorizer_ = noAuthorizer . lift --- | Extracts a biscuit from an http request, assuming: +-- | Configuration record for use with `authHandlerWith`. If you don't care about details, +-- you should use `authHandler` instead, which provides sensible defaults. +data BiscuitConfig e + = BiscuitConfig + { parserConfig :: ParserConfig Handler + -- ^ how to parse a serialized biscuit (this includes public key and revocation checks) + , extractSerializedBiscuit :: Request -> Either e ByteString + -- ^ how to extract the serialized biscuit from the request + , onExtractionError :: forall a. e -> Handler a + -- ^ what to do when the biscuit cannot be extracted from the request + , onParseError :: forall a. ParseError -> Handler a + -- ^ what to do when the biscuit cannot be parsed + } + +-- | Default configuration used by `authHandler`. -- +-- It assumes: +-- -- - the biscuit is b64-encoded -- - prefixed with the @Bearer @ string -- - in the @Authorization@ header -extractBiscuit :: PublicKey - -> Request - -> Either String (Biscuit OpenOrSealed Verified) -extractBiscuit pk req = do +-- +-- It always uses the same public key and does not perform revocation checks. It returns +-- text-based 401 errors. +defaultBiscuitConfig :: PublicKey -> BiscuitConfig String +defaultBiscuitConfig publicKey = BiscuitConfig + { parserConfig = ParserConfig + { getPublicKey = const publicKey + , isRevoked = const $ pure False + , encoding = UrlBase64 + } + , extractSerializedBiscuit = readFromAuthHeader + , onExtractionError = throwError . defaultInvalidBiscuitError . Right + , onParseError = throwError . defaultInvalidBiscuitError . Left + } + +-- | Read a serialized biscuit from the @Authorization@ header, assuming it is prefixed +-- by @Bearer@. +readFromAuthHeader :: Request -> Either String ByteString +readFromAuthHeader req = do let note e = maybe (Left e) Right authHeader <- note "Missing Authorization header" . lookup "Authorization" $ requestHeaders req - b64Token <- note "Not a Bearer token" $ BS.stripPrefix "Bearer " authHeader - first (const "Not a B64-encoded biscuit") $ parseB64 pk b64Token + note "Not a Bearer token" $ BS.stripPrefix "Bearer " authHeader +-- | Default 401 error returned if the biscuit can't be extracted or fails to parse. +defaultInvalidBiscuitError :: Either ParseError String -> ServerError +defaultInvalidBiscuitError e = + let s = fromRight "Not a B64-encoded biscuit" e + in err401 { errBody = LBS.fromStrict (C8.pack s) } + +-- | Default 403 error returned if the biscuit fails authorization. +defaultUnauthorizedBiscuitError :: ExecutionError -> ServerError +defaultUnauthorizedBiscuitError _ = + err403 { errBody = "Biscuit failed checks" } + -- | Servant authorization handler. This extracts the biscuit from the request, -- checks its signature (but not the datalog part) and returns a 'Biscuit' --- upon success. -authHandler :: PublicKey - -> AuthHandler Request (Biscuit OpenOrSealed Verified) -authHandler publicKey = mkAuthHandler handler +-- upon success. See `BiscuitConfig` for configuration details. +authHandlerWith :: BiscuitConfig e + -> AuthHandler Request (Biscuit OpenOrSealed Verified) +authHandlerWith BiscuitConfig{..} = mkAuthHandler handler where - authError s = err401 { errBody = LBS.fromStrict (C8.pack s) } - orError = either (throwError . authError) pure - handler req = - orError $ extractBiscuit publicKey req + orExtractionError = either onExtractionError pure + orParseError = either onParseError pure + handler req = do + bs <- orExtractionError $ extractSerializedBiscuit req + orParseError =<< parseWith parserConfig bs +-- | Default servant authorization handler. This extracts the biscuit from the request, +-- checks its signature (but not the datalog part) and returns a 'Biscuit' +-- upon success. If you need to customize token extraction or error handling, you can +-- use `authHandlerWith` instead. +authHandler :: PublicKey -> AuthHandler Request (Biscuit OpenOrSealed Verified) +authHandler = authHandlerWith . defaultBiscuitConfig + -- | Helper function generating a servant context containing the authorization --- handler. +-- handler. The token will be read as a b64-url string (prefixed with @Bearer@) +-- in the @Authorization@ header. +-- +-- If you need custom error handling or token parsing, you can use 'genBiscuitCtxWith' +-- instead. genBiscuitCtx :: PublicKey -> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)] genBiscuitCtx pk = authHandler pk :. EmptyContext +-- | Helper function generating a servant context containing the authorization +-- handler, with the provided configuration. +-- +-- If you don't need custom error handling or token extraction, you can use +-- 'genBiscuitCtx' instead. +genBiscuitCtxWith :: BiscuitConfig e + -> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)] +genBiscuitCtxWith c = authHandlerWith c :. EmptyContext + -- | Given a biscuit (provided by the servant authorization mechanism), -- verify its validity (with the provided 'Authorizer'). -- @@ -411,13 +517,33 @@ -> Authorizer -> m a -> m a -checkBiscuit vb v h = do - res <- liftIO $ authorizeBiscuit vb v - case res of - Left e -> do liftIO $ print e - throwError $ err401 { errBody = "Biscuit failed checks" } - Right _ -> h +checkBiscuit vb = do + checkBiscuitM vb . pure +-- | Given a biscuit (provided by the servant authorization mechanism), +-- verify its validity (with the provided 'Authorizer'). +-- If the authorization fails, the provided error handler will be used to return +-- an error. +-- +-- If you need to perform effects in the verification phase (eg to get the current time, +-- or if you need to issue a DB query to retrieve extra information needed to check the token), +-- you can use 'checkBiscuitMWith' instead. +-- +-- If you don't want a custom error handler, you can use 'checkBiscuit' instead. +-- +-- If you don't want to pass the biscuit manually to all the endpoints or want to +-- blanket apply authorizers on whole API trees, you can consider using 'withAuthorizer' +-- (on endpoints), 'withFallbackAuthorizer' and 'withPriorityAuthorizer' (on API sub-trees) +-- and 'handleBiscuit' (on the whole API). +checkBiscuitWith :: (MonadIO m, MonadError ServerError m) + => (forall b. ExecutionError -> m b) + -> Biscuit OpenOrSealed Verified + -> Authorizer + -> ReaderT (AuthorizedBiscuit OpenOrSealed) m a + -> m a +checkBiscuitWith onError vb = + checkBiscuitMWith onError vb . pure + -- | Given a 'Biscuit' (provided by the servant authorization mechanism), -- verify its validity (with the provided 'Authorizer', which can be effectful). -- @@ -434,12 +560,35 @@ -> m a -> m a checkBiscuitM vb mv h = do + let onError = throwError . defaultUnauthorizedBiscuitError + in checkBiscuitMWith onError vb mv (lift h) + +-- | Given a 'Biscuit' (provided by the servant authorization mechanism), +-- verify its validity (with the provided 'Authorizer', which can be effectful). +-- If the authorization fails, the provided error handler will be used to return +-- an error. +-- +-- If you don't need to run any effects in the verifying phase, you can use 'checkBiscuitWith' +-- instead. +-- +-- If you don't want a custom error handler, you can use 'checkBiscuitM' instead. +-- +-- If you don't want to pass the biscuit manually to all the endpoints or want to blanket apply +-- authorizers on whole API trees, you can consider using 'withAuthorizer' (on endpoints), +-- 'withFallbackAuthorizer' and 'withPriorityAuthorizer' (on API sub-trees) and 'handleBiscuit' +-- (on the whole API). +checkBiscuitMWith :: (MonadIO m, MonadError ServerError m) + => (forall b. ExecutionError -> m b) + -> Biscuit OpenOrSealed Verified + -> m Authorizer + -> ReaderT (AuthorizedBiscuit OpenOrSealed) m a + -> m a +checkBiscuitMWith onError vb mv h = do v <- mv res <- liftIO $ authorizeBiscuit vb v case res of - Left e -> do liftIO $ print e - throwError $ err401 { errBody = "Biscuit failed checks" } - Right _ -> h + Left e -> onError e + Right as -> runReaderT h as -- | Given a handler wrapped in a 'WithAuthorizer', use the attached 'Authorizer' to -- verify the provided biscuit and return an error as needed. @@ -451,5 +600,42 @@ -> WithAuthorizer m a -> m a handleBiscuit b WithAuthorizer{authorizer_, handler_} = - let h = runReaderT handler_ b - in checkBiscuitM b authorizer_ h + let onError = throwError . defaultUnauthorizedBiscuitError + in checkBiscuitMWith onError b authorizer_ handler_ + +-- | Given a handler wrapped in a 'WithAuthorizer', use the attached 'Authorizer' to +-- verify the provided biscuit and return an error as needed, with the provided error +-- handler. +-- +-- If you don't want to provide the error handler, you can use 'handleBiscuit' which +-- uses a default error handler +-- +-- For simpler use cases, consider using 'checkBiscuitWith' instead, which works on regular +-- servant handlers. +handleBiscuitWith :: (MonadIO m, MonadError ServerError m) + => (forall b. ExecutionError -> m b) + -> Biscuit OpenOrSealed Verified + -> WithAuthorizer m a + -> m a +handleBiscuitWith onError b WithAuthorizer{authorizer_, handler_} = + checkBiscuitMWith onError b authorizer_ handler_ + +-- | Transform the context provided by 'WithAuthorizer'' in an effectful way. +-- This is useful to turn an 'AuthorizedBiscuit' into a custom type. +-- Transformations can be chained within an API tree as long as the outermost value +-- is a 'WithAuthorizer', that can be handled by 'handleBiscuit'. +withTransformation :: Monad m + => (t -> m t') + -- ^ context transformation function. @t@ will usually be + -- @AuthorizedBiscuit OpenOrSealed@ + -> WithAuthorizer' t' m a + -- ^ wrapped handler with reader access to a @t'@ value + -- (derived from an @AuthorizedBiscuit OpenOrSealed@) + -> WithAuthorizer' t m a + -- ^ wrapped handler with reader access to a @t@ value + -- (usually @AuthorizedBiscuit OpenOrSealed@) +withTransformation compute wa@WithAuthorizer{handler_} = + let newHandler = do + t' <- ReaderT compute + withReaderT (const t') handler_ + in wa { handler_ = newHandler } diff --git a/test/AppWithAuthorizer.hs b/test/AppWithAuthorizer.hs --- a/test/AppWithAuthorizer.hs +++ b/test/AppWithAuthorizer.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} @@ -9,6 +10,7 @@ import Auth.Biscuit import Auth.Biscuit.Servant import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) import Data.Text (Text) import Data.Time (getCurrentTime) import Servant @@ -28,15 +30,22 @@ call3 :: Text -> ClientM Int call3 b = - let (_ :<|> _ :<|> e3) = client @API Proxy (protect b) + let (_ :<|> _ :<|> e3 :<|> _) = client @API Proxy (protect b) in e3 +call4 :: Text -> ClientM Int +call4 b = + let (_ :<|> _ :<|> _ :<|> e4) = client @API Proxy (protect b) + in e4 + type H = WithAuthorizer Handler +type H' = WithAuthorizer' Int Handler type API = RequireBiscuit :> ProtectedAPI type ProtectedAPI = "endpoint1" :> Get '[JSON] Int :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int :<|> "endpoint3" :> Get '[JSON] Int + :<|> "endpoint4" :> Get '[JSON] Int app :: PublicKey -> Application app appPublicKey = @@ -46,21 +55,31 @@ server b = let nowFact = do now <- liftIO getCurrentTime - pure [authorizer|time(${now});|] + pure [authorizer|time({now});|] handleAuth :: WithAuthorizer Handler x -> Handler x handleAuth = handleBiscuit b . withPriorityAuthorizerM nowFact . withPriorityAuthorizer [authorizer|allow if right("admin");|] . withFallbackAuthorizer [authorizer|allow if right("anon");|] - handlers = handler1 :<|> handler2 :<|> handler3 + handlers = handler1 :<|> handler2 :<|> handler3 :<|> handler4 in hoistServer @ProtectedAPI Proxy handleAuth handlers handler1 :: H Int handler1 = withAuthorizer [authorizer|allow if right("one");|] $ pure 1 handler2 :: Int -> H Int -handler2 v = withAuthorizer [authorizer|allow if right("two", ${v});|] $ pure 2 +handler2 v = withAuthorizer [authorizer|allow if right("two", {v});|] $ pure 2 handler3 :: H Int handler3 = withAuthorizer [authorizer|deny if true;|] $ pure 3 + +handler4 :: H Int +handler4 = withTransformation extractUserId $ + withAuthorizer [authorizer|allow if user($user_id); |] $ do + ask + +extractUserId :: AuthorizedBiscuit OpenOrSealed -> Handler Int +extractUserId AuthorizedBiscuit{authorizationSuccess} = do + let b = getBindings authorizationSuccess + in maybe (throwError err403) pure $ getSingleVariableValue b "user_id" diff --git a/test/ClientHelpers.hs b/test/ClientHelpers.hs --- a/test/ClientHelpers.hs +++ b/test/ClientHelpers.hs @@ -5,16 +5,16 @@ module ClientHelpers where import Data.Bifunctor (first) -import Data.ByteString +import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) import Data.Text (Text) import Network.HTTP.Client (defaultManagerSettings, newManager) import qualified Network.Wai.Handler.Warp as Warp import Servant import Servant.Client +import qualified Servant.Client.Core as ClientCore import Servant.Client.Core (AuthClientData, AuthenticatedRequest, mkAuthenticatedRequest) -import qualified Servant.Client.Core as ClientCore protect :: Text -> AuthenticatedRequest (AuthProtect "biscuit") protect b = mkAuthenticatedRequest b (ClientCore.addHeader "Authorization" . ("Bearer " <>)) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,7 +13,7 @@ import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Test.Hspec -import AppWithAuthorizer (app, call1, call2, call3) +import AppWithAuthorizer (app, call1, call2, call3, call4) import ClientHelpers (runC, withApp) main :: IO () @@ -28,6 +28,7 @@ e22 <- toText <$> mkE2Biscuit 2 appSecretKey ttld <- toText <$> (addTtl later =<< mkAdminBiscuit appSecretKey) expd <- toText <$> (addTtl earlier =<< mkAdminBiscuit appSecretKey) + e4 <- toText <$> mkE4Biscuit 42 appSecretKey print adminB hspec $ around (withApp $ app appPk) $ @@ -48,6 +49,8 @@ it "Effectful verification should work as expected" $ \port -> do runC port (call1 ttld) `shouldReturn` Right 1 runC port (call1 expd) `shouldReturn` Left (Just "Biscuit failed checks") + it "Token post-processing should work as expected" $ \port -> do + runC port (call4 e4) `shouldReturn` Right 42 appSecretKey :: SecretKey appSecretKey = fromJust . parseSecretKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209" @@ -65,8 +68,11 @@ mkE1Biscuit sk = mkBiscuit sk [block|right("one");|] mkE2Biscuit :: Int -> SecretKey -> IO (Biscuit Open Verified) -mkE2Biscuit v sk = mkBiscuit sk [block|right("two", ${v});|] +mkE2Biscuit v sk = mkBiscuit sk [block|right("two", {v});|] +mkE4Biscuit :: Int -> SecretKey -> IO (Biscuit Open Verified) +mkE4Biscuit v sk = mkBiscuit sk [block|user({v});|] + addTtl :: UTCTime -> Biscuit Open Verified -> IO (Biscuit Open Verified) addTtl expiration = - addBlock [block|check if time($now), $now < ${expiration};|] + addBlock [block|check if time($now), $now < {expiration};|]