diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,53 @@ -# Biscuit-based auth for servant apps + + +# biscuit-servant 🤖 [![Hackage][hackage]][hackage-url] + +> **Servant combinators to enable biscuit validation in your API trees** + +## Usage + +```Haskell +type AppM = WithAuthorizer Handler +type API = RequireBiscuit :> ProtectedAPI + +-- /users +-- /users/:userId +type ProtectedAPI = + "users" :> ( Get '[JSON] [User] + :<|> Capture "userId" Int :> Get '[JSON] User + ) +app :: PublicKey -> Application +app pk = serveWithContext @API Proxy (genBiscuitCtx pk) server + +server :: Server API +server biscuit = + let handlers = userListHandler :<|> singleUserHandler + handleAuth = + handleBiscuit biscuit + -- `allow if right("admin");` will be the first policy + -- for every endpoint. + -- Policies added by endpoints (or sub-apis) will tried after this one. + . withPriorityAuthorizer [authorizer|allow if right("admin");|] + -- `deny if true;` will be the last policy for every endpoint. + -- Policies added by endpoints (or sub-apis) will tried before this one. + . withFallbackAuthorizer [authorizer|deny if true;|] + in hoistServer @ProtectedAPI Proxy handleAuth handlers + +allUsers :: [User] +allUsers = [ User 1 "Danielle" "George" + , User 2 "Albert" "Einstein" + ] + +userListHandler :: AppM [User] +userListHandler = withAuthorizer [authorizer|allow if right("userList")|] + $ pure allUsers + +singleUserHandler :: Int -> AppM User +singleUserHandler uid = + withAuthorizer [authorizer|allow if right("getUser", ${uid})|] $ + let user = find (\user -> userId user == uid) allUsers + in maybe (throwError error404) (\user -> pure user) user +``` + +[Hackage]: https://img.shields.io/hackage/v/biscuit-haskell?color=purple&style=flat-square +[hackage-url]: https://hackage.haskell.org/package/biscuit-servant 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.1.1.0 +version: 0.2.0.0 category: Security synopsis: Servant support for the Biscuit security token description: Please see the README on GitHub at @@ -33,7 +33,7 @@ ghc-options: -Wall build-depends: base >= 4.7 && <5, - biscuit-haskell ^>= 0.1, + biscuit-haskell ^>= 0.2, bytestring ^>= 0.10, mtl ^>= 2.2, text ^>= 1.2, @@ -45,7 +45,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - AppWithVerifier + AppWithAuthorizer ClientHelpers hs-source-dirs: test @@ -62,5 +62,6 @@ , servant-client , servant-client-core , text + , time , warp default-language: Haskell2010 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 @@ -5,25 +5,38 @@ {-# LANGUAGE TypeFamilies #-} module Auth.Biscuit.Servant ( - -- Servant Auth Handler + -- * Protecting a servant API with biscuits + -- $presentation + + -- ** Annotating servant API types + -- $apitypes RequireBiscuit , authHandler , genBiscuitCtx + -- ** Supplying a authorizer for a single endpoint + -- $singleEndpointAuthorizer , checkBiscuit - -- Decorate regular handlers with composable verifiers - , WithVerifier (..) + , checkBiscuitM + -- ** Decorate regular handlers with composable authorizers + -- $composableAuthorizers + , WithAuthorizer (..) , handleBiscuit - , withVerifier - , withVerifier_ - , noVerifier - , noVerifier_ - , withFallbackVerifier - , withPriorityVerifier + , withAuthorizer + , withAuthorizer_ + , withAuthorizerM + , withAuthorizerM_ + , noAuthorizer + , noAuthorizer_ + , withFallbackAuthorizer + , withPriorityAuthorizer + , withFallbackAuthorizerM + , withPriorityAuthorizerM + + , module Biscuit ) where -import Auth.Biscuit (Biscuit, PublicKey, Verifier, - checkBiscuitSignature, - parseB64, verifyBiscuit) +import Auth.Biscuit as Biscuit +import Control.Applicative (liftA2) import Control.Monad.Except (MonadError, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, lift, runReaderT) @@ -36,6 +49,143 @@ import Servant.Server import Servant.Server.Experimental.Auth +-- $presentation +-- +-- Biscuit are bearer tokens that can be used to protect API endpoints. +-- This package provides utilities to protect servant endpoints with such +-- tokens. +-- +-- The token will be extracted from the @Authorization@ header, and must +-- be base64-encoded, prefixed with the @Bearer @ string. + +-- $apitypes +-- +-- To protect and 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 +-- > +-- > app :: PublicKey -> Application +-- > app publicKey = +-- > -- servant needs access to the biscuit /public/ +-- > -- key to be able to check biscuit signatures. +-- > -- The public key can be read from the environment +-- > -- and parsed using 'parsePublicKeyHex' for instance. +-- > serveWithContext +-- > (Proxy :: Proxy API) +-- > (genBiscuitCtx publicKey) +-- > server +-- > +-- > -- server :: Biscuit OpenOrSealed Verified -> Server ProtectedAPI +-- > server :: Server API +-- > server biscuit = … -- this will be detailed later +-- +-- This will instruct servant to extract the biscuit from the requests and +-- check its signature. /It will not/, however, run any datalog check (as +-- the checks typically depend on the request contents). +-- +-- $singleEndpointAuthorizer +-- +-- The corresponding @Server API@ value will be a @Biscuit OpenOrSealed Verified -> Server ProtectedAPI@. +-- The next step is to provide a 'Authorizer' so that the biscuit datalog can be +-- verified. For that, you can use 'checkBiscuit' (or 'checkBiscuitM' for effectful checks). +-- +-- > server :: Server API +-- > server biscuit = h1 biscuit +-- > :<|> h2 biscuit +-- > :<|> h3 biscuit +-- > +-- > h1 :: Biscuit OpenOrSealed Verified -> Handler Int +-- > h1 biscuit = +-- > checkBiscuit biscuit +-- > [authorizer|allow if right("one");|] +-- > -- ^ only allow biscuits granting access to the endpoint tagged "one" +-- > (pure 1) +-- > +-- > h2 :: Biscuit OpenOrSealed Verified -> Int -> Handler Int +-- > h2 biscuit value = +-- > let authorizer' = do +-- > now <- liftIO getCurrentTime +-- > pure [authorizer| +-- > // provide the current time so that TTL checks embedded in +-- > // 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}); +-- > // only allow biscuits granting access to the endpoint tagged "two" +-- > // AND for the provided int value. This show how the checks can depend +-- > // on the http request contents. +-- > allow if right("two", ${value}); +-- > |] +-- > checkBiscuitM biscuit authorizer +-- > (pure 2) +-- > +-- > h3 :: Biscuit OpenOrSealed Verified -> Handler Int +-- > h3 biscuit = +-- > checkBiscuit biscuit +-- > [authorizer|deny if true;|] +-- > -- ^ reject every biscuit +-- > (pure 3) +-- +-- $composableAuthorizers +-- +-- 'checkBiscuit' allows you to describe validation rules endpoint by endpoint. If your +-- application has a lot of endpoints with the same policies, it can become tedious to +-- maintain. +-- +-- 'biscuit-servant' provides a way to apply authorizers on whole API trees, +-- in a composable way, thanks to 'hoistServer'. 'hoistServer' is a mechanism +-- provided by servant-server that lets apply a transformation function to whole +-- API trees. +-- +-- > -- 'withAuthorizer' wraps a 'Handler' and lets you attach a authorizer to a +-- > -- specific endoint. This authorizer may be combined with other authorizers +-- > -- attached to the whole API tree +-- > handler1 :: WithAuthorizer Handler Int +-- > handler1 = withAuthorizer +-- > [authorizer|allow if right("one");|] +-- > (pure 1) +-- > +-- > handler2 :: Int -> WithAuthorizer Handler Int +-- > handler2 value = withAuthorizer +-- > [authorizer|allow if right("two", ${value});|] +-- > (pure 2) +-- > +-- > handler3 :: WithAuthorizer Handler Int +-- > handler3 = withAuthorizer +-- > [authorizer|allow if right("three");|] +-- > (pure 3) +-- > +-- > server :: Biscuit OpenOrSealed Verified -> Server ProtectedAPI +-- > server biscuit = +-- > let nowFact = do +-- > now <- liftIO getCurrentTime +-- > pure [authorizer|time(${now});|] +-- > handleAuth :: WithAuthorizer Handler x -> Handler x +-- > handleAuth = +-- > handleBiscuit biscuit +-- > -- ^ this runs datalog checks on the biscuit, based on authorizers attached to +-- > -- the handlers +-- > . withPriorityAuthorizerM nowFact +-- > -- ^ this provides the current time to the verification context so that biscuits with +-- > -- a TTL can check if they are still valid. +-- > -- Authorizers can be provided in a monadic context (it has to be the same monad as +-- > -- the handlers themselves, so here it's 'Handler'). +-- > . withPriorityAuthorizer [authorizer|allow if right("admin");|] +-- > -- ^ this policy will be tried /before/ any endpoint policy, so `endpoint3` will be +-- > -- reachable with an admin biscuit +-- > . withFallbackAuthorizer [authorizer|allow if right("anon");|] +-- > -- ^ this policy will be tried /after/ the endpoints policies, so `endpoint3` will +-- > -- *not* be reachable with an anon macaroon. +-- > handlers = handler1 :<|> handler2 :<|> handler3 +-- > in hoistServer @ProtectedAPI Proxy handleAuth handlers +-- > -- ^ this will apply `handleAuth` on all 'ProtectedAPI' endpoints. + -- | Type used to protect and 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 @@ -43,147 +193,262 @@ -- be performed separately with either 'checkBiscuit' (for simple -- use-cases) or 'handleBiscuit' (for more complex use-cases). type RequireBiscuit = AuthProtect "biscuit" -type instance AuthServerData RequireBiscuit = CheckedBiscuit - --- | A biscuit which signature has already been verified. --- Since the biscuit lib checks the signature while verifying the datalog --- part, the public key is needed. 'CheckedBiscuit' carries the public key --- used for verifying the signature so that the datalog verification part --- can use it. -data CheckedBiscuit = CheckedBiscuit PublicKey Biscuit +type instance AuthServerData RequireBiscuit = Biscuit OpenOrSealed Verified --- | Wrapper for a servant handler, equipped with a biscuit 'Verifier' +-- | 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'. -data WithVerifier m a - = WithVerifier - { handler_ :: ReaderT Biscuit m a +-- a @ReaderT (Biscuit OpenOrSealed Verified)@. +data WithAuthorizer m a + = WithAuthorizer + { handler_ :: ReaderT (Biscuit OpenOrSealed Verified) m a -- ^ the wrapped handler, in a 'ReaderT' to give easy access to the biscuit - , verifier_ :: Verifier - -- ^ the 'Verifier' associated to the handler + , authorizer_ :: m Authorizer + -- ^ the 'Authorizer' associated to the handler } --- | Combines the provided 'Verifier' to the 'Verifier' attached to the wrapped --- handler. _facts_, _rules_ and _checked_ are unordered, but _policies_ have a --- specific order. 'withFallbackVerifier' puts the provided policies at the _bottom_ --- of the list (ie as _fallback_ policies). +-- | 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/ +-- of the list (ie as /fallback/ policies): these policies will be tried /after/ +-- the policies declared through 'withPriorityAuthorizer' and after the policies +-- declared by the endpoints. +-- -- If you want the policies to be tried before the ones of the wrapped handler, you --- can use 'withPriorityVerifier'. -withFallbackVerifier :: Verifier - -> WithVerifier m a - -> WithVerifier m a -withFallbackVerifier newV h@WithVerifier{verifier_} = - h { verifier_ = verifier_ <> newV } +-- can use 'withPriorityAuthorizer'. +-- +-- If you need to perform effects to compute the authorizer (eg. to get the current date, +-- or to query a database), you can use 'withFallbackAuthorizerM' instead. +withFallbackAuthorizer :: Functor m + => Authorizer + -> WithAuthorizer m a + -> WithAuthorizer m a +withFallbackAuthorizer newV h@WithAuthorizer{authorizer_} = + h { authorizer_ = (<> newV) <$> authorizer_ } --- | Combines the provided 'Verifier' to the 'Verifier' attached to the wrapped --- handler. _facts_, _rules_ and _checked_ are unordered, but _policies_ have a --- specific order. 'withFallbackVerifier' puts the provided policies at the _top_ --- of the list (ie as _priority_ policies). +-- | 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/ +-- of the list (ie as /fallback/ policies): these policies will be tried /after/ +-- the policies declared through 'withPriorityAuthorizer' and after the policies +-- declared by the endpoints. +-- +-- If you want the policies to be tried before the ones of the wrapped handler, you +-- can use 'withPriorityAuthorizer'. +-- +-- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects, +-- you can use 'withFallbackAuthorizer' instead. +withFallbackAuthorizerM :: Applicative m + => m Authorizer + -> WithAuthorizer m a + -> WithAuthorizer m a +withFallbackAuthorizerM newV h@WithAuthorizer{authorizer_} = + h { authorizer_ = liftA2 (<>) authorizer_ newV } + +-- | 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 /top/ +-- of the list (ie as /priority/ policies): these policies will be tried /after/ +-- the policies declared through 'withPriorityAuthorizer' and after the policies +-- declared by the endpoints. +-- -- If you want the policies to be tried after the ones of the wrapped handler, you --- can use 'withFallbackVerifier'. -withPriorityVerifier :: Verifier - -> WithVerifier m a - -> WithVerifier m a -withPriorityVerifier newV h@WithVerifier{verifier_} = - h { verifier_ = newV <> verifier_ } +-- can use 'withFallbackAuthorizer'. +-- +-- If you need to perform effects to compute the authorizer (eg. to get the current date, +-- or to query a database), you can use 'withPriorityAuthorizerM' instead. +withPriorityAuthorizer :: Functor m + => Authorizer + -> WithAuthorizer m a + -> WithAuthorizer m a +withPriorityAuthorizer newV h@WithAuthorizer{authorizer_} = + h { authorizer_ = (newV <>) <$> authorizer_ } --- | Wraps an existing handler block, attaching a 'Verifier'. The handler has --- to be a 'ReaderT Biscuit' to be able to access the token. If you don't need --- to access the token from the handler block, you can use 'withVerifier_' --- instead. -withVerifier :: Monad m => Verifier -> ReaderT Biscuit m a -> WithVerifier m a -withVerifier verifier_ handler_ = - WithVerifier +-- | 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 /top/ +-- of the list (ie as /priority/ policies): these policies will be tried /after/ +-- the policies declared through 'withPriorityAuthorizer' and after the policies +-- declared by the endpoints. +-- +-- If you want the policies to be tried after the ones of the wrapped handler, you +-- can use 'withFallbackAuthorizer'. +-- +-- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects, +-- you can use 'withFallbackAuthorizer' instead. +withPriorityAuthorizerM :: Applicative m + => m Authorizer + -> WithAuthorizer m a + -> WithAuthorizer m a +withPriorityAuthorizerM newV h@WithAuthorizer{authorizer_} = + h { authorizer_ = liftA2 (<>) newV authorizer_ } + +-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler has +-- to be a @ReaderT (Biscuit OpenOrSealed Verified)' to be able to access the token. +-- If you don't need to access the token from the handler block, you can use +-- 'withAuthorizer_' instead. +-- +-- 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 +withAuthorizer v handler_ = + WithAuthorizer { handler_ - , verifier_ + , authorizer_ = pure v } --- | Wraps an existing handler block, attaching a 'Verifier'. The handler can be --- any monad, but won't be able to access the 'Biscuit'. If you want to read the --- biscuit token from the handler block, you can use 'withVerifier' instead. -withVerifier_ :: Monad m => Verifier -> m a -> WithVerifier m a -withVerifier_ v = withVerifier v . lift +-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler has +-- to be a @ReaderT (Biscuit OpenOrSealed Verified)@ to be able to access the token. +-- If you don't need to access the token from the handler block, you can use +-- 'withAuthorizer_' instead. +-- +-- 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 +withAuthorizerM authorizer_ handler_ = + WithAuthorizer + { handler_ + , authorizer_ + } --- | Wraps an existing handler block, attaching an empty 'Verifier'. The handler has --- to be a 'ReaderT Biscuit' to be able to access the token. If you don't need --- to access the token from the handler block, you can use 'noVerifier_' +-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler can be +-- any monad, but won't be able to access the biscuit. If you want to read the biscuit +-- token from the handler block, you can use 'withAuthorizer' instead. +-- +-- 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_ v = withAuthorizer v . lift + +-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler can be +-- any monad, but won't be able to access the 'Biscuit'. +-- +-- If you want to read the biscuit token from the handler block, you can use 'withAuthorizer' -- instead. -- --- This function can be used together with 'withFallbackVerifier' or 'withPriorityVerifier' --- to apply policies on several handlers at the same time (with 'hoistServer' for instance). -noVerifier :: Monad m => ReaderT Biscuit m a -> WithVerifier m a -noVerifier = withVerifier mempty +-- 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_ v = withAuthorizerM v . lift --- | Wraps an existing handler block, attaching an empty 'Verifier'. The handler can be --- any monad, but won't be able to access the 'Biscuit'. If you want to read the --- biscuit token from the handler block, you can use 'noVerifier' instead. +-- | Wraps an existing handler block, attaching an empty 'Authorizer'. The handler has +-- to be a @ReaderT (Biscuit OpenOrSealed Verified)@ to be able to access the token. If you don't need +-- to access the token from the handler block, you can use 'noAuthorizer_' +-- instead. -- --- This function can be used together with 'withFallbackVerifier' or 'withPriorityVerifier' --- to apply policies on several handlers at the same time (with 'hoistServer' for instance). -noVerifier_ :: Monad m => m a -> WithVerifier m a -noVerifier_ = noVerifier . lift +-- This function is useful when the endpoint does not have any specific authorizer +-- 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 :: Applicative m + => ReaderT (Biscuit OpenOrSealed Verified) m a + -> WithAuthorizer m a +noAuthorizer = withAuthorizer mempty +-- | Wraps an existing handler block, attaching an empty 'Authorizer'. The handler can be +-- any monad, but won't be able to access the biscuit. If you want to read the +-- biscuit token from the handler block, you can use 'noAuthorizer' instead. +-- +-- This function is useful when the endpoint does not have any specific authorizer +-- 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_ = noAuthorizer . lift + -- | Extracts a biscuit from an http request, assuming: -- -- - the biscuit is b64-encoded --- - prefixed with the `Bearer ` string --- - in the `Authorization` header -extractBiscuit :: Request -> Either String Biscuit -extractBiscuit req = do +-- - prefixed with the @Bearer @ string +-- - in the @Authorization@ header +extractBiscuit :: PublicKey + -> Request + -> Either String (Biscuit OpenOrSealed Verified) +extractBiscuit pk 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 b64Token + first (const "Not a B64-encoded biscuit") $ parseB64 pk b64Token -- | Servant authorization handler. This extracts the biscuit from the request, --- checks its signature (but not the datalog part) and returns a 'CheckedBiscuit' +-- checks its signature (but not the datalog part) and returns a 'Biscuit' -- upon success. -authHandler :: PublicKey -> AuthHandler Request CheckedBiscuit +authHandler :: PublicKey + -> AuthHandler Request (Biscuit OpenOrSealed Verified) authHandler publicKey = mkAuthHandler handler where authError s = err401 { errBody = LBS.fromStrict (C8.pack s) } orError = either (throwError . authError) pure - handler req = do - biscuit <- orError $ extractBiscuit req - result <- liftIO $ checkBiscuitSignature biscuit publicKey - case result of - False -> throwError $ authError "Invalid signature" - True -> pure $ CheckedBiscuit publicKey biscuit + handler req = + orError $ extractBiscuit publicKey req -- | Helper function generating a servant context containing the authorization -- handler. -genBiscuitCtx :: PublicKey -> Context '[AuthHandler Request CheckedBiscuit] +genBiscuitCtx :: PublicKey + -> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)] genBiscuitCtx pk = authHandler pk :. EmptyContext --- | Given a 'CheckedBiscuit' (provided by the servant authorization mechanism), --- verify its validity (with the provided 'Verifier'). If you don't want to pass --- the biscuit manually to all the endpoints or want to blanket apply verifiers on --- whole API trees, you can consider using 'withVerifier' (on endpoints), 'withFallbackVerifier' and --- 'withPriorityVerifier' (on API sub-trees) and 'handleBiscuit' (on the whole API). +-- | Given a biscuit (provided by the servant authorization mechanism), +-- verify its validity (with the provided 'Authorizer'). +-- +-- 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 '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). checkBiscuit :: (MonadIO m, MonadError ServerError m) - => CheckedBiscuit - -> Verifier + => Biscuit OpenOrSealed Verified + -> Authorizer -> m a -> m a -checkBiscuit (CheckedBiscuit pk b) v h = do - res <- liftIO $ verifyBiscuit b v pk +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 --- | Given a handler wrapped in a 'WithVerifier', use the attached 'Verifier' to +-- | Given a 'Biscuit' (provided by the servant authorization mechanism), +-- verify its validity (with the provided 'Authorizer', which can be effectful). +-- +-- If you don't need to run any effects in the verifying phase, 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). +checkBiscuitM :: (MonadIO m, MonadError ServerError m) + => Biscuit OpenOrSealed Verified + -> m Authorizer + -> m a + -> m a +checkBiscuitM 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 + +-- | Given a handler wrapped in a 'WithAuthorizer', use the attached 'Authorizer' to -- verify the provided biscuit and return an error as needed. -- -- For simpler use cases, consider using 'checkBiscuit' instead, which works on regular -- servant handlers. handleBiscuit :: (MonadIO m, MonadError ServerError m) - => CheckedBiscuit - -> WithVerifier m a + => Biscuit OpenOrSealed Verified + -> WithAuthorizer m a -> m a -handleBiscuit cb@(CheckedBiscuit _ b) WithVerifier{verifier_, handler_} = +handleBiscuit b WithAuthorizer{authorizer_, handler_} = let h = runReaderT handler_ b - in checkBiscuit cb verifier_ h - + in checkBiscuitM b authorizer_ h diff --git a/test/AppWithAuthorizer.hs b/test/AppWithAuthorizer.hs new file mode 100644 --- /dev/null +++ b/test/AppWithAuthorizer.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module AppWithAuthorizer where + +import Auth.Biscuit +import Auth.Biscuit.Servant +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time (getCurrentTime) +import Servant +import Servant.Client + +import ClientHelpers + +call1 :: Text -> ClientM Int +call1 b = + let (e1 :<|> _) = client @API Proxy (protect b) + in e1 + +call2 :: Text -> Int -> ClientM Int +call2 b = + let (_ :<|> e2 :<|> _) = client @API Proxy (protect b) + in e2 + +call3 :: Text -> ClientM Int +call3 b = + let (_ :<|> _ :<|> e3) = client @API Proxy (protect b) + in e3 + +type H = WithAuthorizer Handler +type API = RequireBiscuit :> ProtectedAPI +type ProtectedAPI = + "endpoint1" :> Get '[JSON] Int + :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int + :<|> "endpoint3" :> Get '[JSON] Int + +app :: PublicKey -> Application +app appPublicKey = + serveWithContext @API Proxy (genBiscuitCtx appPublicKey) server + +server :: Server API +server b = + let nowFact = do + now <- liftIO getCurrentTime + 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 + 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 + +handler3 :: H Int +handler3 = withAuthorizer [authorizer|deny if true;|] $ pure 3 diff --git a/test/AppWithVerifier.hs b/test/AppWithVerifier.hs deleted file mode 100644 --- a/test/AppWithVerifier.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module AppWithVerifier where - -import Auth.Biscuit -import Auth.Biscuit.Servant -import Data.Text (Text) -import Servant -import Servant.Client - -import ClientHelpers - -call1 :: Text -> ClientM Int -call1 b = - let (e1 :<|> _) = client @API Proxy (protect b) - in e1 - -call2 :: Text -> Int -> ClientM Int -call2 b = - let (_ :<|> e2 :<|> _) = client @API Proxy (protect b) - in e2 - -call3 :: Text -> ClientM Int -call3 b = - let (_ :<|> _ :<|> e3) = client @API Proxy (protect b) - in e3 - -type H = WithVerifier Handler -type API = RequireBiscuit :> ProtectedAPI -type ProtectedAPI = - "endpoint1" :> Get '[JSON] Int - :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int - :<|> "endpoint3" :> Get '[JSON] Int - -app :: PublicKey -> Application -app appPublicKey = - serveWithContext @API Proxy (genBiscuitCtx appPublicKey) server - -server :: Server API -server b = - let handleAuth :: WithVerifier Handler x -> Handler x - handleAuth = - handleBiscuit b - . withPriorityVerifier [verifier|allow if right(#authority, #admin);|] - . withFallbackVerifier [verifier|allow if right(#authority, #anon);|] - handlers = handler1 :<|> handler2 :<|> handler3 - in hoistServer @ProtectedAPI Proxy handleAuth handlers - -handler1 :: H Int -handler1 = withVerifier [verifier|allow if right(#authority, #one);|] $ pure 1 - -handler2 :: Int -> H Int -handler2 v = withVerifier [verifier|allow if right(#authority, #two, ${v});|] $ pure 2 - -handler3 :: H Int -handler3 = withVerifier [verifier|deny if true;|] $ pure 3 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,20 +10,24 @@ import Data.Maybe (fromJust) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) +import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Test.Hspec -import AppWithVerifier (app, call1, call2, call3) +import AppWithAuthorizer (app, call1, call2, call3) import ClientHelpers (runC, withApp) main :: IO () main = do - keypair <- fromPrivateKey appPrivateKey - let appPk = publicKey keypair - adminB <- toText <$> mkAdminBiscuit keypair - anonB <- toText <$> mkAnonBiscuit keypair - e1 <- toText <$> mkE1Biscuit keypair - e21 <- toText <$> mkE2Biscuit 1 keypair - e22 <- toText <$> mkE2Biscuit 2 keypair + let appPk = toPublic appSecretKey + later <- addUTCTime (60*5) <$> getCurrentTime + earlier <- addUTCTime (-60) <$> getCurrentTime + adminB <- toText <$> mkAdminBiscuit appSecretKey + anonB <- toText <$> mkAnonBiscuit appSecretKey + e1 <- toText <$> mkE1Biscuit appSecretKey + e21 <- toText <$> mkE2Biscuit 1 appSecretKey + e22 <- toText <$> mkE2Biscuit 2 appSecretKey + ttld <- toText <$> (addTtl later =<< mkAdminBiscuit appSecretKey) + expd <- toText <$> (addTtl earlier =<< mkAdminBiscuit appSecretKey) print adminB hspec $ around (withApp $ app appPk) $ @@ -41,21 +45,28 @@ runC port (call2 e21 1) `shouldReturn` Right 2 runC port (call2 e22 1) `shouldReturn` Left (Just "Biscuit failed checks") runC port (call3 anonB) `shouldReturn` Left (Just "Biscuit failed checks") + 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") -appPrivateKey :: PrivateKey -appPrivateKey = fromJust . parsePrivateKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209" +appSecretKey :: SecretKey +appSecretKey = fromJust . parseSecretKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209" -toText :: Biscuit -> Text +toText :: BiscuitProof p => Biscuit p Verified -> Text toText = decodeUtf8 . serializeB64 -mkAdminBiscuit :: Keypair -> IO Biscuit -mkAdminBiscuit kp = mkBiscuit kp [block|right(#authority, #admin);|] +mkAdminBiscuit :: SecretKey -> IO (Biscuit Open Verified) +mkAdminBiscuit sk = mkBiscuit sk [block|right("admin");|] -mkAnonBiscuit :: Keypair -> IO Biscuit -mkAnonBiscuit kp = mkBiscuit kp [block|right(#authority, #anon);|] +mkAnonBiscuit :: SecretKey -> IO (Biscuit Open Verified) +mkAnonBiscuit sk = mkBiscuit sk [block|right("anon");|] -mkE1Biscuit :: Keypair -> IO Biscuit -mkE1Biscuit kp = mkBiscuit kp [block|right(#authority, #one);|] +mkE1Biscuit :: SecretKey -> IO (Biscuit Open Verified) +mkE1Biscuit sk = mkBiscuit sk [block|right("one");|] -mkE2Biscuit :: Int -> Keypair -> IO Biscuit -mkE2Biscuit v kp = mkBiscuit kp [block|right(#authority, #two, ${v});|] +mkE2Biscuit :: Int -> SecretKey -> IO (Biscuit Open Verified) +mkE2Biscuit v sk = mkBiscuit sk [block|right("two", ${v});|] + +addTtl :: UTCTime -> Biscuit Open Verified -> IO (Biscuit Open Verified) +addTtl expiration = + addBlock [block|check if time($now), $now < ${expiration};|]