biscuit-servant 0.1.1.0 → 0.2.0.0

raw patch · 6 files changed

+521/−186 lines, 6 filesdep +timedep ~biscuit-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: time

Dependency ranges changed: biscuit-haskell

API changes (from Hackage documentation)

Files

• README.md +53/−1
• biscuit-servant.cabal +4/−3
• src/Auth/Biscuit/Servant.hs +368/−103
• test/AppWithAuthorizer.hs +66/−0
• test/AppWithVerifier.hs +0/−60
• test/Spec.hs +30/−19

@@ -1,1 +1,53 @@-# Biscuit-based auth for servant apps+<img src="https://raw.githubusercontent.com/divarvel/biscuit-haskell/main/assets/biscuit-logo.png" align=right>++# 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

@@ -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 <https://github.com/divarvel/biscuit-haskell#readme>@@ -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

@@ -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

@@ -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

@@ -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

@@ -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};|]