From 2bcdda477f8d5cf13bc95a1522c6c31a936cd6e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 18 May 2023 12:50:39 +0200 Subject: [PATCH 1/6] wai: basic middleware for biscuit parsing and verification --- biscuit-wai/Setup.hs | 2 + biscuit-wai/biscuit-wai.cabal | 59 ++++++++++++++ .../src/Network/Wai/Middleware/Biscuit.hs | 53 +++++++++++++ biscuit-wai/test/Spec.hs | 77 +++++++++++++++++++ cabal.project | 1 + 5 files changed, 192 insertions(+) create mode 100644 biscuit-wai/Setup.hs create mode 100644 biscuit-wai/biscuit-wai.cabal create mode 100644 biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs create mode 100644 biscuit-wai/test/Spec.hs diff --git a/biscuit-wai/Setup.hs b/biscuit-wai/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/biscuit-wai/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/biscuit-wai/biscuit-wai.cabal b/biscuit-wai/biscuit-wai.cabal new file mode 100644 index 0000000..af77737 --- /dev/null +++ b/biscuit-wai/biscuit-wai.cabal @@ -0,0 +1,59 @@ +cabal-version: 2.0 + +name: biscuit-wai +version: 0.1.0.0 +category: Security +synopsis: WAI middleware for the Biscuit security token +description: Please see the README on GitHub at +homepage: https://github.com/biscuit-auth/biscuit-haskell#readme +bug-reports: https://github.com/biscuit-auth/biscuit-haskell/issues +author: Clément Delafargue +maintainer: clement@delafargue.name +copyright: 2021 Clément Delafargue +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: GHC ==8.10.7 || == 9.0.2 || == 9.2.4 +extra-source-files: + +source-repository head + type: git + location: https://github.com/biscuit-auth/biscuit-haskell + +library + exposed-modules: + Network.Wai.Middleware.Biscuit + other-modules: + Paths_biscuit_wai + autogen-modules: + Paths_biscuit_wai + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >= 4.7 && <5, + biscuit-haskell >= 0.3 && < 0.4, + bytestring >= 0.10 && <0.12, + http-types ^>= 0.12, + vault ^>= 0.3, + wai ^>= 3.2 + default-language: Haskell2010 + +test-suite biscuit-wai-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , biscuit-haskell + , biscuit-wai + , bytestring + , hspec + , http-client + , http-types + , 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 new file mode 100644 index 0000000..3a547c0 --- /dev/null +++ b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.Biscuit (parseBiscuit, getBiscuit) where + +import Auth.Biscuit (Biscuit, OpenOrSealed, ParseError, + PublicKey, Verified, parseB64) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.List as List +import qualified Data.Vault.Lazy as Vault +import GHC.IO (unsafePerformIO) +import Network.HTTP.Types (forbidden403, hAuthorization, + unauthorized401) +import Network.Wai (Middleware, Request (..), Response, + responseLBS) + +-- todo explain why +{-# NOINLINE biscuitKey #-} +biscuitKey :: Vault.Key (Biscuit OpenOrSealed Verified) +biscuitKey = unsafePerformIO Vault.newKey + +getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified) +getBiscuit = Vault.lookup biscuitKey . vault + +parseBiscuit :: PublicKey -> Middleware +parseBiscuit publicKey app req sendResponse = case defaultExtractToken req of + Nothing -> sendResponse =<< defaultHandleError NoToken + Just s -> case defaultParseToken publicKey s of + Left e -> sendResponse =<< defaultHandleError (ParseError e) + Right t -> do + let newVault = Vault.insert biscuitKey t (vault req) + app req { vault = newVault } sendResponse + +data BiscuitError + = NoToken + | ParseError ParseError + +defaultExtractToken :: Request -> Maybe ByteString +defaultExtractToken req = do + (_, authHeader) <- List.find ((== hAuthorization) . fst) $ requestHeaders req + BS.stripPrefix "Bearer " authHeader + +defaultParseToken :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified) +defaultParseToken = parseB64 + +defaultHandleError :: BiscuitError -> IO Response +defaultHandleError = \case + NoToken -> do + putStrLn "Missing biscuit token" + pure $ responseLBS unauthorized401 mempty mempty + ParseError e -> do + putStrLn $ "Parsing or verification error: " <> show e + pure $ responseLBS forbidden403 mempty mempty diff --git a/biscuit-wai/test/Spec.hs b/biscuit-wai/test/Spec.hs new file mode 100644 index 0000000..2735191 --- /dev/null +++ b/biscuit-wai/test/Spec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Auth.Biscuit (SecretKey, mkBiscuit, + parseSecretKeyHex, + serializeB64, toPublic) +import Data.Maybe (fromMaybe) +import Network.HTTP.Client (Response (responseStatus), + applyBearerAuth, + defaultManagerSettings, + httpLbs, newManager, + parseRequest) +import Network.HTTP.Types (Status (..), badRequest400, + ok200) +import Network.Wai (Application, + Request (pathInfo), ifRequest, + responseLBS) +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Middleware.Biscuit (getBiscuit, parseBiscuit) +import Test.Hspec (around, describe, hspec, it, + shouldBe) + +secretKey :: SecretKey +secretKey = fromMaybe (error "Failed parsing secret key") $ parseSecretKeyHex "ac40d48ac474b6d41a58cbb91facc6317e32afdc21edfe23b9967e9d07c039be" + +otherSecretKey :: SecretKey +otherSecretKey = fromMaybe (error "Failed parsing secret key") $ parseSecretKeyHex "1b53545e9ca6d1368bb222cb4c2183aac3304d8a3d0fea53173bca82f57b95a8" + +app :: Application +app = + let endpoint req sendResponse = case getBiscuit req of + Just _ -> sendResponse $ responseLBS ok200 mempty mempty + Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty + checkBiscuit = parseBiscuit (toPublic secretKey) + isProtected = (== ["protected"]) . take 1 . pathInfo + in ifRequest isProtected checkBiscuit endpoint + +withApp :: (Warp.Port -> IO ()) -> IO () +withApp = + --testWithApplication makes sure the action is executed after the server has + -- started and is being properly shutdown. + -- exceptions thrown by the app are bubbled up to the test suite. + Warp.testWithApplication (pure app) + +main :: IO () +main = do + manager <- newManager defaultManagerSettings + hspec $ + around withApp $ + describe "biscuit wai middleware" $ do + describe "on protected endpoints" $ do + it "rejects unauthenticated calls" $ \port -> do + req <- parseRequest $ "http://localhost:" <> show port <> "/protected" + res <- httpLbs req manager + statusCode (responseStatus res) `shouldBe` 401 + it "rejects gibberish tokens" $ \port -> do + req <- parseRequest $ "http://localhost:" <> show port <> "/protected" + 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" + 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" + 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 + res <- httpLbs req manager + statusCode (responseStatus res) `shouldBe` 400 diff --git a/cabal.project b/cabal.project index 9030d5b..71f2a23 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ packages: biscuit/ biscuit-servant/ + biscuit-wai/ tests: True documentation: True From 5c380fe36b85d0b219977226784debf85ca2512c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 18 May 2023 13:47:45 +0200 Subject: [PATCH 2/6] biscuit-wai: allow configuring parsing & extraction --- .../src/Network/Wai/Middleware/Biscuit.hs | 34 ++++++++++++++----- 1 file changed, 26 insertions(+), 8 deletions(-) diff --git a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs index 3a547c0..3b2ee29 100644 --- a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs +++ b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs @@ -1,9 +1,12 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Biscuit (parseBiscuit, getBiscuit) where import Auth.Biscuit (Biscuit, OpenOrSealed, ParseError, PublicKey, Verified, parseB64) +import Control.Monad ((<=<)) +import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.List as List @@ -23,26 +26,41 @@ getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified) getBiscuit = Vault.lookup biscuitKey . vault parseBiscuit :: PublicKey -> Middleware -parseBiscuit publicKey app req sendResponse = case defaultExtractToken req of - Nothing -> sendResponse =<< defaultHandleError NoToken - Just s -> case defaultParseToken publicKey s of - Left e -> sendResponse =<< defaultHandleError (ParseError e) - Right t -> do +parseBiscuit = parseBiscuitWith . defaultExtractionConfig + +parseBiscuitWith :: ExtractionConfig e -> Middleware +parseBiscuitWith config app req sendResponse = do + let ExtractionConfig{extractToken,parseToken,handleError} = config + onError = sendResponse <=< handleError + forward t = do let newVault = Vault.insert biscuitKey t (vault req) app req { vault = newVault } sendResponse + eBiscuit <- either (pure . Left) parseToken =<< extractToken req + either onError forward eBiscuit + +data ExtractionConfig e + = ExtractionConfig + { extractToken :: Request -> IO (Either e ByteString) + , parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified)) + , handleError :: e -> IO Response + } data BiscuitError = NoToken | ParseError ParseError +defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError +defaultExtractionConfig publicKey = ExtractionConfig + { extractToken = pure . maybe (Left NoToken) Right . defaultExtractToken + , parseToken = pure . Data.Bifunctor.first ParseError . parseB64 publicKey + , handleError = defaultHandleError + } + defaultExtractToken :: Request -> Maybe ByteString defaultExtractToken req = do (_, authHeader) <- List.find ((== hAuthorization) . fst) $ requestHeaders req BS.stripPrefix "Bearer " authHeader -defaultParseToken :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified) -defaultParseToken = parseB64 - defaultHandleError :: BiscuitError -> IO Response defaultHandleError = \case NoToken -> do From 33003ae698aa4f3c416ccbe201767cc2d5c7b934 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 3/6] 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 From c5de90eec31e3ac09e8369400ac6a586f8945107 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 18 May 2023 23:06:47 +0200 Subject: [PATCH 4/6] biscuit-wai: provide documentation --- .../src/Network/Wai/Middleware/Biscuit.hs | 126 +++++++++++++++++- 1 file changed, 122 insertions(+), 4 deletions(-) diff --git a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs index 8f41a55..f1a2a72 100644 --- a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs +++ b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs @@ -3,12 +3,22 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Biscuit - ( parseBiscuit + ( + -- * Biscuit parsing + parseBiscuit + , getBiscuit , parseBiscuitWith + , ExtractionConfig (..) + , defaultExtractionConfig + -- * Biscuit authorization , authorizeBiscuit' - , authorizeBiscuitWith - , getBiscuit , getAuthorizedBiscuit + , authorizeBiscuitWith + , AuthorizationConfig (..) + , defaultAuthorizationConfig + -- * Helpers + , defaultExtractToken + , defaultHandleError ) where import Auth.Biscuit (AuthorizedBiscuit, Authorizer, Biscuit, @@ -27,24 +37,64 @@ import Network.HTTP.Types (forbidden403, hAuthorization, import Network.Wai (Middleware, Request (..), Response, responseLBS) --- todo explain why +-- | Key where the verified biscuit is stored in the request context. The +-- `Vault` module is designed to make keys opaque and unique, hence the use of +-- `IO` for key generation. Here we don’t care about unicity, we want the token +-- to be easily accessible. Hence the call to `unsafePerformIO`. {-# NOINLINE biscuitKey #-} biscuitKey :: Vault.Key (Biscuit OpenOrSealed Verified) biscuitKey = unsafePerformIO Vault.newKey +-- | Key where the authorized biscuit is stored in the request context. The +-- `Vault` module is designed to make keys opaque and unique, hence the use of +-- `IO` for key generation. Here we don’t care about unicity, we want the token +-- to be easily accessible. Hence the call to `unsafePerformIO`. {-# NOINLINE authorizedBiscuitKey #-} authorizedBiscuitKey :: Vault.Key (AuthorizedBiscuit OpenOrSealed) authorizedBiscuitKey = unsafePerformIO Vault.newKey +-- | Retrieve the parsed token from the request context. It is meant to be used +-- in conjunction with the `parseBiscuit` (or `parseBiscuitWith`) middleware. +-- It will not be set by the `authorizeBiscuit'` (or `authorizeBiscuitWith`) +-- middleware. getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified) getBiscuit = Vault.lookup biscuitKey . vault +-- | Retrieve the result of the successful authorization from the request +-- context. It is meant to be used in conjunction with the `authorizeBiscuit'` +-- (or the `authorizeBiscuitWith`) middleware. getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed) getAuthorizedBiscuit = Vault.lookup authorizedBiscuitKey . vault +-- | Given a public key, generate a middleware that will extract a biscuit +-- token from incoming requests, parse it, and verify its signature. Requests +-- without a verified biscuit are rejected, and the verified biscuit is added +-- to the request context. __The token is not authorized, only parsed and has +-- its signature verified.__ Authorization is meant to be carried out in the +-- application itself. If you want to carry out authorization in the middleware, +-- have a look at `authorizeBiscuit'` (or `authorizeBiscuitWith`). +-- +-- The token is expected as a base64-encoded string, provided as a bearer token +-- in the @Authorization@ header. A missing header results in a bodyless 401 +-- HTTP response. An invalid token results in a bodyless 403 HTTP response. +-- Errors are logged to stdout. +-- +-- If you need custom extraction, parsing or error handling, have a look at +-- `parseBiscuitWith`. parseBiscuit :: PublicKey -> Middleware parseBiscuit = parseBiscuitWith . defaultExtractionConfig +-- | Given a way to extract a token from a request, parse it, and handle errors, +-- generate a middleware that will extract a biscuit token from incoming +-- requests, parse it, and verify its signature. Requests without a verified +-- biscuit are rejected, and the verified biscuit is added to the request +-- context. __The token is not authorized, only parsed and has its signature +-- verified. __Authorization is meant to be carried out in the application +-- itself. If you want to carry out authorization in the middleware, have a +-- look at `authorizeBiscuit'` (or `authorizeBiscuitWith`). +-- +-- If you don’t need custom extraction, parsing or error handling logic, have a +-- look at `parseBiscuit`. parseBiscuitWith :: ExtractionConfig e -> Middleware parseBiscuitWith config app req sendResponse = do let ExtractionConfig{extractToken,parseToken,handleError} = config @@ -55,9 +105,38 @@ parseBiscuitWith config app req sendResponse = do eBiscuit <- either (pure . Left) parseToken =<< extractToken req either onError forward eBiscuit +-- | Given a public key and a way to generate an authorizer from a request, +-- generate a middleware that will extract a biscuit token from incoming +-- requests, parse it, verify its signature and authorize it. Requests without +-- an authorized biscuit are rejected, and the authorized biscuit is added to +-- the request context. __The underlying application will only receive requests +-- where the whole authorization process succeeded.__ If you want to only parse +-- tokens and delegate actual authorization to the underlying application, have +-- a look at `parseBiscuit` (or `parseBiscuitWith`). +-- +-- The token is expected as a base64-encoded string, provided as a bearer token +-- in the @Authorization@ header. A missing header results in a bodyless 401 +-- HTTP response. An invalid token results in a bodyless 403 HTTP response. A +-- failed authorization process results in a bodyless 403 HTTP response. +-- Errors are logged to stdout. +-- +-- If you need custom extraction, parsing, authorization or error handling, +-- have a look at `authorizeBiscuitWith`. authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware authorizeBiscuit' publicKey = authorizeBiscuitWith . defaultAuthorizationConfig publicKey +-- | Given a way to extract a token from a request, parse it, authorized it and +-- handle errors, generate a middleware that will extract a biscuit token from +-- incoming requests, parse it, verify its signature and authorize it. +-- Requests without an authorized biscuit are rejected, and the authorized +-- biscuit is added to the request context. __The underlying application will +-- only receive requests where the whole authorization process succeeded. +-- __ If you want to only parse tokens and delegate actual authorization to the +-- underlying application, have a look at `parseBiscuit` (or +-- `parseBiscuitWith`). +-- +-- If you don’t need custom extraction, parsing, authorization, or error +-- handling logic, have a look at `authorizeBiscuit'`. authorizeBiscuitWith :: AuthorizationConfig e -> Middleware authorizeBiscuitWith config app req sendResponse = do let AuthorizationConfig{extractToken,parseToken,authorizeToken,handleError} = config @@ -69,26 +148,47 @@ authorizeBiscuitWith config app req sendResponse = do eResult <- either (pure . Left) (authorizeToken req) eBiscuit either onError forward eResult +-- | Configuration for `parseBiscuitWith`. data ExtractionConfig e = ExtractionConfig + -- | How to extract a token from a request { extractToken :: Request -> IO (Either e ByteString) + -- | How to parse a token from the extracted serialized bytestring , parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified)) + -- | How to handle errors (this does not allow recovery) , handleError :: e -> IO Response } +-- | Configuration for `authorizeBiscuitWith`. data AuthorizationConfig e = AuthorizationConfig + -- | How to extract a token from a request { extractToken :: Request -> IO (Either e ByteString) + -- | How to parse a token from the extracted serialized bytestring , parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified)) + -- | How to authorize a token , authorizeToken :: Request -> Biscuit OpenOrSealed Verified -> IO (Either e (AuthorizedBiscuit OpenOrSealed)) + -- | How to handle errors (this does not allow recovery) , handleError :: e -> IO Response } +-- | Errors that can happen during token authorization data BiscuitError + -- | No token was provided = NoToken + -- | The provided token could not be parsed or verified | ParseError ParseError + -- | The provided token was successfully parsed, but authorization failed | AuthorizationError ExecutionError +-- | Default behaviour for token extraction and parsing. +-- +-- - Extract the token as a bearer token from the @Authorization@ header; +-- - Parse the token as URL-safe base64 strings, using the provided public +-- key; +-- - Errors are logged to stdout; +-- - Missing tokens are rejected with a bodyless 401 HTTP response; +-- - Parsing errors are rejected with a bodyless 403 HTTP response. defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError defaultExtractionConfig publicKey = ExtractionConfig { extractToken = pure . maybe (Left NoToken) Right . defaultExtractToken @@ -96,6 +196,16 @@ defaultExtractionConfig publicKey = ExtractionConfig , handleError = defaultHandleError } +-- | Default behaviour for token extraction, parsing and authorization. +-- +-- - Extract the token as a bearer token from the @Authorization@ header; +-- - Parse the token as URL-safe base64 strings, using the provided public +-- key; +-- - Authorize the request with the generated authorizer; +-- - Errors are logged to stdout; +-- - Missing tokens are rejected with a bodyless 401 HTTP response; +-- - Parsing errors are rejected with a bodyless 403 HTTP response. +-- - Authorization errors are rejected with a bodyless 403 HTTP response. defaultAuthorizationConfig :: PublicKey -> (Request -> IO Authorizer) -> AuthorizationConfig BiscuitError defaultAuthorizationConfig publicKey mkAuthorizer = AuthorizationConfig { extractToken = pure . maybe (Left NoToken) Right . defaultExtractToken @@ -104,11 +214,19 @@ defaultAuthorizationConfig publicKey mkAuthorizer = AuthorizationConfig , handleError = defaultHandleError } +-- | Extract a token from the @Authorization@ header, stripping the @Bearer @ +-- prefix. defaultExtractToken :: Request -> Maybe ByteString defaultExtractToken req = do (_, authHeader) <- List.find ((== hAuthorization) . fst) $ requestHeaders req BS.stripPrefix "Bearer " authHeader +-- | Generate HTTP responses based on authorization errors. Errors are logged +-- to stdout. +-- +-- - Missing tokens result in a 401 bodyless response; +-- - Parsing errors result in a 403 bodyless response; +-- - Authorization errors result in a 403 bodyless response. defaultHandleError :: BiscuitError -> IO Response defaultHandleError = \case NoToken -> do From 5f25d50c338af4c0e2a33d53785ec36b1ff49804 Mon Sep 17 00:00:00 2001 From: Clement Delafargue Date: Thu, 18 May 2023 23:20:07 +0200 Subject: [PATCH 5/6] biscuit-wai: add License and top-level Makefile config --- Makefile | 4 ++++ biscuit-wai/LICENSE | 30 ++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) create mode 100644 Makefile create mode 100644 biscuit-wai/LICENSE diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..b3f86ad --- /dev/null +++ b/Makefile @@ -0,0 +1,4 @@ +.PHONY: bundle +bundle: + cabal v2-sdist biscuit-haskell biscuit-servant biscuit-wai + cabal v2-haddock --haddock-for-hackage --enable-documentation biscuit-haskell biscuit-servant biscuit-wai diff --git a/biscuit-wai/LICENSE b/biscuit-wai/LICENSE new file mode 100644 index 0000000..083128e --- /dev/null +++ b/biscuit-wai/LICENSE @@ -0,0 +1,30 @@ +Copyright Clément Delafargue (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. From 94ffc8b904f921253b58006659586070c5bef42b Mon Sep 17 00:00:00 2001 From: Clement Delafargue Date: Fri, 19 May 2023 00:11:54 +0200 Subject: [PATCH 6/6] biscuit-wai: haddock is fickle --- .../src/Network/Wai/Middleware/Biscuit.hs | 69 ++++++++++--------- 1 file changed, 36 insertions(+), 33 deletions(-) diff --git a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs index f1a2a72..fb67b5f 100644 --- a/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs +++ b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs @@ -38,41 +38,42 @@ import Network.Wai (Middleware, Request (..), Response, responseLBS) -- | Key where the verified biscuit is stored in the request context. The --- `Vault` module is designed to make keys opaque and unique, hence the use of --- `IO` for key generation. Here we don’t care about unicity, we want the token --- to be easily accessible. Hence the call to `unsafePerformIO`. +-- 'Vault' module is designed to make keys opaque and unique, hence the use of +-- 'IO' for key generation. Here we don’t care about unicity, we want the token +-- to be easily accessible. Hence the call to 'unsafePerformIO'. {-# NOINLINE biscuitKey #-} biscuitKey :: Vault.Key (Biscuit OpenOrSealed Verified) biscuitKey = unsafePerformIO Vault.newKey -- | Key where the authorized biscuit is stored in the request context. The --- `Vault` module is designed to make keys opaque and unique, hence the use of --- `IO` for key generation. Here we don’t care about unicity, we want the token --- to be easily accessible. Hence the call to `unsafePerformIO`. +-- 'Vault' module is designed to make keys opaque and unique, hence the use of +-- 'IO' for key generation. Here we don’t care about unicity, we want the token +-- to be easily accessible. Hence the call to 'unsafePerformIO'. {-# NOINLINE authorizedBiscuitKey #-} authorizedBiscuitKey :: Vault.Key (AuthorizedBiscuit OpenOrSealed) authorizedBiscuitKey = unsafePerformIO Vault.newKey -- | Retrieve the parsed token from the request context. It is meant to be used --- in conjunction with the `parseBiscuit` (or `parseBiscuitWith`) middleware. --- It will not be set by the `authorizeBiscuit'` (or `authorizeBiscuitWith`) +-- in conjunction with the 'parseBiscuit' (or 'parseBiscuitWith') middleware. +-- It will not be set by the 'authorizeBiscuit'' (or 'authorizeBiscuitWith') -- middleware. getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified) getBiscuit = Vault.lookup biscuitKey . vault -- | Retrieve the result of the successful authorization from the request --- context. It is meant to be used in conjunction with the `authorizeBiscuit'` --- (or the `authorizeBiscuitWith`) middleware. +-- context. It is meant to be used in conjunction with the 'authorizeBiscuit'' +-- (or the 'authorizeBiscuitWith') middleware. getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed) getAuthorizedBiscuit = Vault.lookup authorizedBiscuitKey . vault -- | Given a public key, generate a middleware that will extract a biscuit -- token from incoming requests, parse it, and verify its signature. Requests -- without a verified biscuit are rejected, and the verified biscuit is added --- to the request context. __The token is not authorized, only parsed and has --- its signature verified.__ Authorization is meant to be carried out in the --- application itself. If you want to carry out authorization in the middleware, --- have a look at `authorizeBiscuit'` (or `authorizeBiscuitWith`). +-- to the request context. +-- __The token is not authorized, only parsed and has its signature verified__. +-- Authorization is meant to be carried out in the application itself. If you +-- want to carry out authorization in the middleware, have a look at +-- 'authorizeBiscuit'' (or 'authorizeBiscuitWith'). -- -- The token is expected as a base64-encoded string, provided as a bearer token -- in the @Authorization@ header. A missing header results in a bodyless 401 @@ -80,7 +81,7 @@ getAuthorizedBiscuit = Vault.lookup authorizedBiscuitKey . vault -- Errors are logged to stdout. -- -- If you need custom extraction, parsing or error handling, have a look at --- `parseBiscuitWith`. +-- 'parseBiscuitWith'. parseBiscuit :: PublicKey -> Middleware parseBiscuit = parseBiscuitWith . defaultExtractionConfig @@ -88,13 +89,14 @@ parseBiscuit = parseBiscuitWith . defaultExtractionConfig -- generate a middleware that will extract a biscuit token from incoming -- requests, parse it, and verify its signature. Requests without a verified -- biscuit are rejected, and the verified biscuit is added to the request --- context. __The token is not authorized, only parsed and has its signature --- verified. __Authorization is meant to be carried out in the application --- itself. If you want to carry out authorization in the middleware, have a --- look at `authorizeBiscuit'` (or `authorizeBiscuitWith`). +-- context. +-- __The token is not authorized, only parsed and has its signature verified__. +-- Authorization is meant to be carried out in the application itself. If you +-- want to carry out authorization in the middleware, have a look at +-- 'authorizeBiscuit'' (or 'authorizeBiscuitWith'). -- -- If you don’t need custom extraction, parsing or error handling logic, have a --- look at `parseBiscuit`. +-- look at 'parseBiscuit'. parseBiscuitWith :: ExtractionConfig e -> Middleware parseBiscuitWith config app req sendResponse = do let ExtractionConfig{extractToken,parseToken,handleError} = config @@ -109,10 +111,11 @@ parseBiscuitWith config app req sendResponse = do -- generate a middleware that will extract a biscuit token from incoming -- requests, parse it, verify its signature and authorize it. Requests without -- an authorized biscuit are rejected, and the authorized biscuit is added to --- the request context. __The underlying application will only receive requests --- where the whole authorization process succeeded.__ If you want to only parse --- tokens and delegate actual authorization to the underlying application, have --- a look at `parseBiscuit` (or `parseBiscuitWith`). +-- the request context. +-- __The underlying application will only receive requests where the whole authorization process succeeded.__ +-- If you want to only parse tokens and delegate actual authorization to the +-- underlying application, have a look at 'parseBiscuit' +-- (or 'parseBiscuitWith'). -- -- The token is expected as a base64-encoded string, provided as a bearer token -- in the @Authorization@ header. A missing header results in a bodyless 401 @@ -121,7 +124,7 @@ parseBiscuitWith config app req sendResponse = do -- Errors are logged to stdout. -- -- If you need custom extraction, parsing, authorization or error handling, --- have a look at `authorizeBiscuitWith`. +-- have a look at 'authorizeBiscuitWith'. authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware authorizeBiscuit' publicKey = authorizeBiscuitWith . defaultAuthorizationConfig publicKey @@ -129,14 +132,14 @@ authorizeBiscuit' publicKey = authorizeBiscuitWith . defaultAuthorizationConfig -- handle errors, generate a middleware that will extract a biscuit token from -- incoming requests, parse it, verify its signature and authorize it. -- Requests without an authorized biscuit are rejected, and the authorized --- biscuit is added to the request context. __The underlying application will --- only receive requests where the whole authorization process succeeded. --- __ If you want to only parse tokens and delegate actual authorization to the --- underlying application, have a look at `parseBiscuit` (or --- `parseBiscuitWith`). +-- biscuit is added to the request context. +-- __The underlying application will only receive requests where the whole authorization process succeeded__. +-- If you want to only parse tokens and delegate actual authorization to the +-- underlying application, have a look at 'parseBiscuit' (or +-- 'parseBiscuitWith'). -- -- If you don’t need custom extraction, parsing, authorization, or error --- handling logic, have a look at `authorizeBiscuit'`. +-- handling logic, have a look at 'authorizeBiscuit''. authorizeBiscuitWith :: AuthorizationConfig e -> Middleware authorizeBiscuitWith config app req sendResponse = do let AuthorizationConfig{extractToken,parseToken,authorizeToken,handleError} = config @@ -148,7 +151,7 @@ authorizeBiscuitWith config app req sendResponse = do eResult <- either (pure . Left) (authorizeToken req) eBiscuit either onError forward eResult --- | Configuration for `parseBiscuitWith`. +-- | Configuration for 'parseBiscuitWith'. data ExtractionConfig e = ExtractionConfig -- | How to extract a token from a request @@ -159,7 +162,7 @@ data ExtractionConfig e , handleError :: e -> IO Response } --- | Configuration for `authorizeBiscuitWith`. +-- | Configuration for 'authorizeBiscuitWith'. data AuthorizationConfig e = AuthorizationConfig -- | How to extract a token from a request