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. 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..2c8f94b --- /dev/null +++ b/biscuit-wai/biscuit-wai.cabal @@ -0,0 +1,60 @@ +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 + , 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 new file mode 100644 index 0000000..fb67b5f --- /dev/null +++ b/biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.Biscuit + ( + -- * Biscuit parsing + parseBiscuit + , getBiscuit + , parseBiscuitWith + , ExtractionConfig (..) + , defaultExtractionConfig + -- * Biscuit authorization + , authorizeBiscuit' + , getAuthorizedBiscuit + , authorizeBiscuitWith + , AuthorizationConfig (..) + , defaultAuthorizationConfig + -- * Helpers + , defaultExtractToken + , defaultHandleError + ) where + +import Auth.Biscuit (AuthorizedBiscuit, Authorizer, Biscuit, + ExecutionError, OpenOrSealed, ParseError, + PublicKey, Verified, authorizeBiscuit, + parseB64) +import Control.Monad ((<=<)) +import Data.Bifunctor (first) +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) + +-- | 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 + 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 + +-- | 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 + 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 + +-- | 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 + , parseToken = pure . Data.Bifunctor.first ParseError . parseB64 publicKey + , 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 + , parseToken = pure . Data.Bifunctor.first ParseError . parseB64 publicKey + , authorizeToken = \req token -> first AuthorizationError <$> (authorizeBiscuit token =<< mkAuthorizer req) + , 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 + putStrLn "Missing biscuit token" + pure $ responseLBS unauthorized401 mempty mempty + 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 new file mode 100644 index 0000000..46aaa68 --- /dev/null +++ b/biscuit-wai/test/Spec.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +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, + notFound404, ok200) +import Network.Wai (Application, + Request (pathInfo, rawPathInfo), + ifRequest, responseLBS) +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Middleware.Biscuit (authorizeBiscuit', + getAuthorizedBiscuit, + 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 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) + 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 = + --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 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/parsed" + res <- httpLbs req manager + statusCode (responseStatus res) `shouldBe` 401 + it "rejects gibberish tokens" $ \port -> do + 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/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/parsed" + let withAuth = applyBearerAuth (serializeB64 goodToken) req + res <- httpLbs withAuth manager + statusCode (responseStatus res) `shouldBe` 200 + 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` 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 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