From 64fdeff8b040e648adcb18b97aed427ae704f196 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 18 May 2023 14:47:20 +0200 Subject: [PATCH] biscuit-wai: allow authorizing tokens within the middleware --- biscuit-wai/biscuit-wai.cabal | 1 + .../src/Network/Wai/Middleware/Biscuit.hs | 63 ++++++++++++-- biscuit-wai/test/Spec.hs | 85 ++++++++++++++----- 3 files changed, 123 insertions(+), 26 deletions(-) diff --git a/biscuit-wai/biscuit-wai.cabal b/biscuit-wai/biscuit-wai.cabal index af77737..2c8f94b 100644 --- a/biscuit-wai/biscuit-wai.cabal +++ b/biscuit-wai/biscuit-wai.cabal @@ -54,6 +54,7 @@ test-suite biscuit-wai-test , hspec , http-client , http-types + , text , wai , warp default-language: Haskell2010 diff --git a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs index 3b2ee29..8f41a55 100644 --- a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs +++ b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs @@ -1,10 +1,20 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.Biscuit (parseBiscuit, getBiscuit) where +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.Biscuit + ( parseBiscuit + , parseBiscuitWith + , authorizeBiscuit' + , authorizeBiscuitWith + , getBiscuit + , getAuthorizedBiscuit + ) where -import Auth.Biscuit (Biscuit, OpenOrSealed, ParseError, - PublicKey, Verified, parseB64) +import Auth.Biscuit (AuthorizedBiscuit, Authorizer, Biscuit, + ExecutionError, OpenOrSealed, ParseError, + PublicKey, Verified, authorizeBiscuit, + parseB64) import Control.Monad ((<=<)) import Data.Bifunctor (first) import Data.ByteString (ByteString) @@ -22,9 +32,16 @@ import Network.Wai (Middleware, Request (..), Response, biscuitKey :: Vault.Key (Biscuit OpenOrSealed Verified) biscuitKey = unsafePerformIO Vault.newKey +{-# NOINLINE authorizedBiscuitKey #-} +authorizedBiscuitKey :: Vault.Key (AuthorizedBiscuit OpenOrSealed) +authorizedBiscuitKey = unsafePerformIO Vault.newKey + getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified) getBiscuit = Vault.lookup biscuitKey . vault +getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed) +getAuthorizedBiscuit = Vault.lookup authorizedBiscuitKey . vault + parseBiscuit :: PublicKey -> Middleware parseBiscuit = parseBiscuitWith . defaultExtractionConfig @@ -38,6 +55,20 @@ parseBiscuitWith config app req sendResponse = do eBiscuit <- either (pure . Left) parseToken =<< extractToken req either onError forward eBiscuit +authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware +authorizeBiscuit' publicKey = authorizeBiscuitWith . defaultAuthorizationConfig publicKey + +authorizeBiscuitWith :: AuthorizationConfig e -> Middleware +authorizeBiscuitWith config app req sendResponse = do + let AuthorizationConfig{extractToken,parseToken,authorizeToken,handleError} = config + onError = sendResponse <=< handleError + forward t = do + let newVault = Vault.insert authorizedBiscuitKey t (vault req) + app req { vault = newVault } sendResponse + eBiscuit <- either (pure . Left) parseToken =<< extractToken req + eResult <- either (pure . Left) (authorizeToken req) eBiscuit + either onError forward eResult + data ExtractionConfig e = ExtractionConfig { extractToken :: Request -> IO (Either e ByteString) @@ -45,9 +76,18 @@ data ExtractionConfig e , handleError :: e -> IO Response } +data AuthorizationConfig e + = AuthorizationConfig + { extractToken :: Request -> IO (Either e ByteString) + , parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified)) + , authorizeToken :: Request -> Biscuit OpenOrSealed Verified -> IO (Either e (AuthorizedBiscuit OpenOrSealed)) + , handleError :: e -> IO Response + } + data BiscuitError = NoToken | ParseError ParseError + | AuthorizationError ExecutionError defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError defaultExtractionConfig publicKey = ExtractionConfig @@ -56,6 +96,14 @@ defaultExtractionConfig publicKey = ExtractionConfig , handleError = defaultHandleError } +defaultAuthorizationConfig :: PublicKey -> (Request -> IO Authorizer) -> AuthorizationConfig BiscuitError +defaultAuthorizationConfig publicKey mkAuthorizer = AuthorizationConfig + { extractToken = pure . maybe (Left NoToken) Right . defaultExtractToken + , parseToken = pure . Data.Bifunctor.first ParseError . parseB64 publicKey + , authorizeToken = \req token -> first AuthorizationError <$> (authorizeBiscuit token =<< mkAuthorizer req) + , handleError = defaultHandleError + } + defaultExtractToken :: Request -> Maybe ByteString defaultExtractToken req = do (_, authHeader) <- List.find ((== hAuthorization) . fst) $ requestHeaders req @@ -69,3 +117,6 @@ defaultHandleError = \case ParseError e -> do putStrLn $ "Parsing or verification error: " <> show e pure $ responseLBS forbidden403 mempty mempty + AuthorizationError e -> do + putStrLn $ "Authorization error: " <> show e + pure $ responseLBS forbidden403 mempty mempty diff --git a/biscuit-wai/test/Spec.hs b/biscuit-wai/test/Spec.hs index 2735191..46aaa68 100644 --- a/biscuit-wai/test/Spec.hs +++ b/biscuit-wai/test/Spec.hs @@ -1,22 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Main (main) where -import Auth.Biscuit (SecretKey, mkBiscuit, - parseSecretKeyHex, +import Auth.Biscuit (SecretKey, authorizer, block, + mkBiscuit, parseSecretKeyHex, serializeB64, toPublic) import Data.Maybe (fromMaybe) +import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Client (Response (responseStatus), applyBearerAuth, defaultManagerSettings, httpLbs, newManager, parseRequest) import Network.HTTP.Types (Status (..), badRequest400, - ok200) + notFound404, ok200) import Network.Wai (Application, - Request (pathInfo), ifRequest, - responseLBS) + Request (pathInfo, rawPathInfo), + ifRequest, responseLBS) import qualified Network.Wai.Handler.Warp as Warp -import Network.Wai.Middleware.Biscuit (getBiscuit, parseBiscuit) +import Network.Wai.Middleware.Biscuit (authorizeBiscuit', + getAuthorizedBiscuit, + getBiscuit, parseBiscuit) import Test.Hspec (around, describe, hspec, it, shouldBe) @@ -28,12 +32,25 @@ otherSecretKey = fromMaybe (error "Failed parsing secret key") $ parseSecretKeyH app :: Application app = - let endpoint req sendResponse = case getBiscuit req of - Just _ -> sendResponse $ responseLBS ok200 mempty mempty - Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty + let endpoint req sendResponse = case pathInfo req of + ["protected", "parsed"] -> + case getBiscuit req of + Just _ -> sendResponse $ responseLBS ok200 mempty mempty + Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty + ["protected", "authed"] -> + case getAuthorizedBiscuit req of + Just _ -> sendResponse $ responseLBS ok200 mempty mempty + Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty + [] -> sendResponse $ responseLBS ok200 mempty mempty + _ -> sendResponse $ responseLBS notFound404 mempty mempty checkBiscuit = parseBiscuit (toPublic secretKey) - isProtected = (== ["protected"]) . take 1 . pathInfo - in ifRequest isProtected checkBiscuit endpoint + checkBiscuit' = authorizeBiscuit' (toPublic secretKey) $ \req -> + let path = decodeUtf8 $ rawPathInfo req + in pure [authorizer|allow if right({path});|] + isProtectedParsed = (== ["protected", "parsed"]) . take 2 . pathInfo + isProtectedAuthed = (== ["protected", "authed"]) . take 2 . pathInfo + in ifRequest isProtectedParsed checkBiscuit $ + ifRequest isProtectedAuthed checkBiscuit' endpoint withApp :: (Warp.Port -> IO ()) -> IO () withApp = @@ -48,30 +65,58 @@ main = do hspec $ around withApp $ describe "biscuit wai middleware" $ do - describe "on protected endpoints" $ do + describe "on open endpoints" $ do + it "accepts unauthenticated calls" $ \port -> do + req <- parseRequest $ "http://localhost:" <> show port + res <- httpLbs req manager + statusCode (responseStatus res) `shouldBe` 200 + describe "on protected endpoints (parsing)" $ do it "rejects unauthenticated calls" $ \port -> do - req <- parseRequest $ "http://localhost:" <> show port <> "/protected" + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed" res <- httpLbs req manager statusCode (responseStatus res) `shouldBe` 401 it "rejects gibberish tokens" $ \port -> do - req <- parseRequest $ "http://localhost:" <> show port <> "/protected" + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed" let withAuth = applyBearerAuth "whatevs" req res <- httpLbs withAuth manager statusCode (responseStatus res) `shouldBe` 403 it "rejects tokens signed by the wrong keypair" $ \port -> do badToken <- mkBiscuit otherSecretKey mempty - req <- parseRequest $ "http://localhost:" <> show port <> "/protected" + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed" let withAuth = applyBearerAuth (serializeB64 badToken) req res <- httpLbs withAuth manager statusCode (responseStatus res) `shouldBe` 403 it "accepts properly signed tokens" $ \port -> do goodToken <- mkBiscuit secretKey mempty - req <- parseRequest $ "http://localhost:" <> show port <> "/protected" + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed" let withAuth = applyBearerAuth (serializeB64 goodToken) req res <- httpLbs withAuth manager statusCode (responseStatus res) `shouldBe` 200 - describe "on open endpoints" $ do - it "accepts unauthenticated calls, but doesn't provide a parsed token" $ \port -> do - req <- parseRequest $ "http://localhost:" <> show port + describe "on protected endpoints (auth)" $ do + it "rejects unauthenticated calls" $ \port -> do + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed" res <- httpLbs req manager - statusCode (responseStatus res) `shouldBe` 400 + statusCode (responseStatus res) `shouldBe` 401 + it "rejects gibberish tokens" $ \port -> do + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed" + let withAuth = applyBearerAuth "whatevs" req + res <- httpLbs withAuth manager + statusCode (responseStatus res) `shouldBe` 403 + it "rejects tokens signed by the wrong keypair" $ \port -> do + badToken <- mkBiscuit otherSecretKey mempty + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed" + let withAuth = applyBearerAuth (serializeB64 badToken) req + res <- httpLbs withAuth manager + statusCode (responseStatus res) `shouldBe` 403 + it "rejects properly signed tokens which fail authorization" $ \port -> do + badToken <- mkBiscuit secretKey mempty + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed" + let withAuth = applyBearerAuth (serializeB64 badToken) req + res <- httpLbs withAuth manager + statusCode (responseStatus res) `shouldBe` 403 + it "accepts properly signed tokens which succeed authorization" $ \port -> do + goodToken <- mkBiscuit secretKey [block|right("/protected/authed");|] + req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed" + let withAuth = applyBearerAuth (serializeB64 goodToken) req + res <- httpLbs withAuth manager + statusCode (responseStatus res) `shouldBe` 200