packages feed

biscuit-servant (empty) → 0.1.1.0

raw patch · 9 files changed

+454/−0 lines, 9 filesdep +basedep +biscuit-haskelldep +biscuit-servantsetup-changed

Dependencies added: base, biscuit-haskell, biscuit-servant, bytestring, hspec, http-client, mtl, servant, servant-client, servant-client-core, servant-server, text, wai, warp

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for biscuit-servant++## 0.1.1.0++Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# Biscuit-based auth for servant apps
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ biscuit-servant.cabal view
@@ -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 <https://github.com/divarvel/biscuit-haskell#readme>+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
+ src/Auth/Biscuit/Servant.hs view
@@ -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+
+ test/AppWithVerifier.hs view
@@ -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
+ test/ClientHelpers.hs view
@@ -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
+ test/Spec.hs view
@@ -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});|]