diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for biscuit-servant + +## 0.1.1.0 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# Biscuit-based auth for servant apps diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/biscuit-servant.cabal b/biscuit-servant.cabal new file mode 100644 --- /dev/null +++ b/biscuit-servant.cabal @@ -0,0 +1,66 @@ +cabal-version: 2.0 + +name: biscuit-servant +version: 0.1.1.0 +category: Security +synopsis: Servant support for the Biscuit security token +description: Please see the README on GitHub at +homepage: https://github.com/divarvel/biscuit-haskell#readme +bug-reports: https://github.com/divarvel/biscuit-haskell/issues +author: Clément Delafargue +maintainer: clement@delafargue.name +copyright: 2021 Clément Delafargue +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/divarvel/biscuit-haskell + +library + exposed-modules: + Auth.Biscuit.Servant + other-modules: + Paths_biscuit_servant + autogen-modules: + Paths_biscuit_servant + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >= 4.7 && <5, + biscuit-haskell ^>= 0.1, + bytestring ^>= 0.10, + mtl ^>= 2.2, + text ^>= 1.2, + servant-server ^>= 0.18, + wai ^>= 3.2 + default-language: Haskell2010 + +test-suite biscuit-servant-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + AppWithVerifier + ClientHelpers + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , biscuit-haskell + , biscuit-servant + , bytestring + , hspec + , http-client + , servant + , servant-server + , servant-client + , servant-client-core + , text + , warp + default-language: Haskell2010 diff --git a/src/Auth/Biscuit/Servant.hs b/src/Auth/Biscuit/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Auth/Biscuit/Servant.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Auth.Biscuit.Servant + ( + -- Servant Auth Handler + RequireBiscuit + , authHandler + , genBiscuitCtx + , checkBiscuit + -- Decorate regular handlers with composable verifiers + , WithVerifier (..) + , handleBiscuit + , withVerifier + , withVerifier_ + , noVerifier + , noVerifier_ + , withFallbackVerifier + , withPriorityVerifier + ) where + +import Auth.Biscuit (Biscuit, PublicKey, Verifier, + checkBiscuitSignature, + parseB64, verifyBiscuit) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT, lift, runReaderT) +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LBS +import Network.Wai +import Servant (AuthProtect) +import Servant.Server +import Servant.Server.Experimental.Auth + +-- | 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 +-- usually requires endpoint-specific information, and has to +-- 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 + +-- | Wrapper for a servant handler, equipped with a biscuit 'Verifier' +-- 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 + -- ^ the wrapped handler, in a 'ReaderT' to give easy access to the biscuit + , verifier_ :: Verifier + -- ^ the 'Verifier' 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). +-- 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 } + +-- | 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). +-- 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_ } + +-- | 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 + { handler_ + , verifier_ + } + +-- | 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 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_' +-- 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 + +-- | 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. +-- +-- 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 + +-- | 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 + 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 + +-- | Servant authorization handler. This extracts the biscuit from the request, +-- checks its signature (but not the datalog part) and returns a 'CheckedBiscuit' +-- upon success. +authHandler :: PublicKey -> AuthHandler Request CheckedBiscuit +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 + +-- | Helper function generating a servant context containing the authorization +-- handler. +genBiscuitCtx :: PublicKey -> Context '[AuthHandler Request CheckedBiscuit] +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). +checkBiscuit :: (MonadIO m, MonadError ServerError m) + => CheckedBiscuit + -> Verifier + -> m a + -> m a +checkBiscuit (CheckedBiscuit pk b) v h = do + res <- liftIO $ verifyBiscuit b v pk + 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 +-- 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 + -> m a +handleBiscuit cb@(CheckedBiscuit _ b) WithVerifier{verifier_, handler_} = + let h = runReaderT handler_ b + in checkBiscuit cb verifier_ h + diff --git a/test/AppWithVerifier.hs b/test/AppWithVerifier.hs new file mode 100644 --- /dev/null +++ b/test/AppWithVerifier.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module AppWithVerifier where + +import Auth.Biscuit +import Auth.Biscuit.Servant +import Data.Text (Text) +import Servant +import Servant.Client + +import ClientHelpers + +call1 :: Text -> ClientM Int +call1 b = + let (e1 :<|> _) = client @API Proxy (protect b) + in e1 + +call2 :: Text -> Int -> ClientM Int +call2 b = + let (_ :<|> e2 :<|> _) = client @API Proxy (protect b) + in e2 + +call3 :: Text -> ClientM Int +call3 b = + let (_ :<|> _ :<|> e3) = client @API Proxy (protect b) + in e3 + +type H = WithVerifier Handler +type API = RequireBiscuit :> ProtectedAPI +type ProtectedAPI = + "endpoint1" :> Get '[JSON] Int + :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int + :<|> "endpoint3" :> Get '[JSON] Int + +app :: PublicKey -> Application +app appPublicKey = + serveWithContext @API Proxy (genBiscuitCtx appPublicKey) server + +server :: Server API +server b = + let handleAuth :: WithVerifier Handler x -> Handler x + handleAuth = + handleBiscuit b + . withPriorityVerifier [verifier|allow if right(#authority, #admin);|] + . withFallbackVerifier [verifier|allow if right(#authority, #anon);|] + handlers = handler1 :<|> handler2 :<|> handler3 + in hoistServer @ProtectedAPI Proxy handleAuth handlers + +handler1 :: H Int +handler1 = withVerifier [verifier|allow if right(#authority, #one);|] $ pure 1 + +handler2 :: Int -> H Int +handler2 v = withVerifier [verifier|allow if right(#authority, #two, ${v});|] $ pure 2 + +handler3 :: H Int +handler3 = withVerifier [verifier|deny if true;|] $ pure 3 diff --git a/test/ClientHelpers.hs b/test/ClientHelpers.hs new file mode 100644 --- /dev/null +++ b/test/ClientHelpers.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module ClientHelpers where + +import Data.Bifunctor (first) +import Data.ByteString +import Data.ByteString.Lazy (toStrict) +import Data.Text (Text) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import qualified Network.Wai.Handler.Warp as Warp +import Servant +import Servant.Client +import Servant.Client.Core (AuthClientData, AuthenticatedRequest, + mkAuthenticatedRequest) +import qualified Servant.Client.Core as ClientCore + +protect :: Text -> AuthenticatedRequest (AuthProtect "biscuit") +protect b = mkAuthenticatedRequest b (ClientCore.addHeader "Authorization" . ("Bearer " <>)) + +type instance AuthClientData (AuthProtect "biscuit") = Text + +withApp :: Application -> (Warp.Port -> IO ()) -> IO () +withApp app = + --testWithApplication makes sure the action is executed after the server has + -- started and is being properly shutdown. + Warp.testWithApplication (pure app) + +runC :: Warp.Port -> ClientM a -> IO (Either (Maybe ByteString) a) +runC p c = do + baseUrl <- parseBaseUrl $ "http://localhost:" <> show p + manager <- newManager defaultManagerSettings + let clientEnv = mkClientEnv manager baseUrl + first extractBody <$> runClientM c clientEnv + +extractBody :: ClientError -> Maybe ByteString +extractBody (FailureResponse _ Response{responseBody}) = Just $ toStrict responseBody +extractBody _ = Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Main (main) where + +import Auth.Biscuit +import Data.Maybe (fromJust) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Test.Hspec + +import AppWithVerifier (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 + print adminB + hspec $ + around (withApp $ app appPk) $ + describe "Biscuit-protected servant app" $ do + it "Priority rules should apply everywhere" $ \port -> do + runC port (call1 adminB) `shouldReturn` Right 1 + runC port (call2 adminB 1) `shouldReturn` Right 2 + runC port (call3 adminB) `shouldReturn` Right 3 + it "Fallback rules should only apply after inner rules" $ \port -> do + runC port (call1 anonB) `shouldReturn` Right 1 + runC port (call2 anonB 1) `shouldReturn` Right 2 + runC port (call3 anonB) `shouldReturn` Left (Just "Biscuit failed checks") + it "Endpoint rules should be matched after priority rules and before fallback rules" $ \port -> do + runC port (call1 e1) `shouldReturn` Right 1 + 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") + +appPrivateKey :: PrivateKey +appPrivateKey = fromJust . parsePrivateKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209" + +toText :: Biscuit -> Text +toText = decodeUtf8 . serializeB64 + +mkAdminBiscuit :: Keypair -> IO Biscuit +mkAdminBiscuit kp = mkBiscuit kp [block|right(#authority, #admin);|] + +mkAnonBiscuit :: Keypair -> IO Biscuit +mkAnonBiscuit kp = mkBiscuit kp [block|right(#authority, #anon);|] + +mkE1Biscuit :: Keypair -> IO Biscuit +mkE1Biscuit kp = mkBiscuit kp [block|right(#authority, #one);|] + +mkE2Biscuit :: Int -> Keypair -> IO Biscuit +mkE2Biscuit v kp = mkBiscuit kp [block|right(#authority, #two, ${v});|]