├── .cabal.project.local ├── .git-blame-ignore-revs ├── .github └── workflows │ ├── github-actions.yml │ └── setup_ci_env.sh ├── .gitignore ├── README.md ├── assets └── logo-black-white-bg.png ├── biscuit-servant ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── biscuit-servant.cabal ├── src │ └── Auth │ │ └── Biscuit │ │ └── Servant.hs └── test │ ├── AppWithAuthorizer.hs │ ├── ClientHelpers.hs │ └── Spec.hs ├── biscuit ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── benchmarks │ └── Bench.hs ├── biscuit-haskell.cabal ├── src │ └── Auth │ │ ├── Biscuit.hs │ │ └── Biscuit │ │ ├── Crypto.hs │ │ ├── Datalog │ │ ├── AST.hs │ │ ├── Executor.hs │ │ ├── Parser.hs │ │ └── ScopedExecutor.hs │ │ ├── Example.hs │ │ ├── Proto.hs │ │ ├── ProtoBufAdapter.hs │ │ ├── Symbols.hs │ │ ├── Timer.hs │ │ ├── Token.hs │ │ └── Utils.hs └── test │ ├── Spec.hs │ ├── Spec │ ├── Executor.hs │ ├── NewCrypto.hs │ ├── Parser.hs │ ├── Quasiquoter.hs │ ├── Roundtrip.hs │ ├── SampleReader.hs │ ├── ScopedExecutor.hs │ └── Verification.hs │ └── samples │ └── current │ ├── README.md │ ├── samples.json │ ├── test001_basic.bc │ ├── test002_different_root_key.bc │ ├── test003_invalid_signature_format.bc │ ├── test004_random_block.bc │ ├── test005_invalid_signature.bc │ ├── test006_reordered_blocks.bc │ ├── test007_scoped_rules.bc │ ├── test008_scoped_checks.bc │ ├── test009_expired_token.bc │ ├── test010_authorizer_scope.bc │ ├── test011_authorizer_authority_caveats.bc │ ├── test012_authority_caveats.bc │ ├── test013_block_rules.bc │ ├── test014_regex_constraint.bc │ ├── test015_multi_queries_caveats.bc │ ├── test016_caveat_head_name.bc │ ├── test017_expressions.bc │ ├── test018_unbound_variables_in_rule.bc │ ├── test019_generating_ambient_from_variables.bc │ ├── test020_sealed.bc │ ├── test021_parsing.bc │ ├── test022_default_symbols.bc │ ├── test023_execution_scope.bc │ ├── test024_third_party.bc │ ├── test025_check_all.bc │ ├── test026_public_keys_interning.bc │ ├── test027_integer_wraparound.bc │ └── test028_expressions_v4.bc ├── cabal.project ├── publish.sh └── shell.nix /.cabal.project.local: -------------------------------------------------------------------------------- 1 | package biscuit-haskell 2 | ghc-options: -Werror 3 | 4 | package biscuit-servant 5 | ghc-options: -Werror 6 | -------------------------------------------------------------------------------- /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | # add copyright headers 2 | 69d4fe624890c8194eccd5a21348081a8466fd93 3 | -------------------------------------------------------------------------------- /.github/workflows/github-actions.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the main branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: 8 | - main 9 | 10 | jobs: 11 | cabal: 12 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | matrix: 16 | os: [ubuntu-latest] 17 | cabal: ["3.10.3.0"] 18 | ghc: ["9.2.4", "9.4.8", "9.6.5", "9.8.2"] 19 | 20 | steps: 21 | - uses: actions/checkout@v3 22 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' 23 | 24 | - uses: haskell-actions/setup@v2 25 | id: setup-haskell-cabal 26 | name: Setup Haskell 27 | with: 28 | ghc-version: ${{ matrix.ghc }} 29 | cabal-version: ${{ matrix.cabal }} 30 | - name: Prepare environment 31 | run: .github/workflows/setup_ci_env.sh 32 | 33 | - name: Freeze 34 | run: | 35 | cabal freeze 36 | 37 | - uses: actions/cache@v3 38 | name: Cache ~/.cabal/store and .ghcup 39 | with: 40 | path: | 41 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 42 | .ghcup 43 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 44 | 45 | - name: Build 46 | run: | 47 | cp .cabal.project.local cabal.project.local 48 | cabal configure --enable-tests --test-show-details=direct --disable-optimization 49 | cabal build all 50 | - name: Test 51 | run: | 52 | cabal test all 53 | -------------------------------------------------------------------------------- /.github/workflows/setup_ci_env.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | CI_OS=$(uname -s) 6 | 7 | install_deps_linux() { 8 | echo "Setting up the environment for linux" 9 | echo "${HOME}/.ghcup/bin" >> "$GITHUB_PATH" 10 | echo "${HOME}/.cabal/bin" >> "$GITHUB_PATH" 11 | echo "${HOME}/.local/bin" >> "$GITHUB_PATH" 12 | } 13 | 14 | install_deps_darwin() { 15 | echo "Setting up the environment for macOS" 16 | } 17 | 18 | case $CI_OS in 19 | Linux) install_deps_linux;; 20 | Darwin) install_deps_darwin;; 21 | esac 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist-newstyle/ 3 | *~ 4 | cabal.project.local 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Biscuit [![CI-badge][CI-badge]][CI-url] [![Hackage][hackage]][hackage-url] 2 | 3 | 4 | 5 | This is the repository for a collection of haskell libraries providing support for the [Biscuit][biscuit] auth toolkit, created by [Geoffroy Couprie][gcouprie]. 6 | 7 | You will find below the main lib and its companions: 8 | 9 | * [biscuit](./biscuit/) — Main library, providing minting and signature verification of biscuit tokens, as well as a datalog engine allowing to compute the validity of a token in a given context 10 | * [biscuit-servant](./biscuit-servant) — Servant combinators, for a smooth integration in your API 11 | 12 | ## Supported biscuit versions 13 | 14 | The core library supports [`v3` and `v4` biscuits][spec] (both open and sealed). 15 | 16 | [CI-badge]: https://img.shields.io/github/actions/workflow/status/biscuit-auth/biscuit-haskell/github-actions.yml?style=flat-square&branch=main 17 | [CI-url]: https://github.com/biscuit-auth/biscuit-haskell/actions 18 | [Hackage]: https://img.shields.io/hackage/v/biscuit-haskell?color=purple&style=flat-square 19 | [hackage-url]: https://hackage.haskell.org/package/biscuit-haskell 20 | [gcouprie]: https://github.com/geal 21 | [biscuit]: https://biscuitsec.org 22 | [spec]: https://github.com/biscuit-auth/biscuit/blob/master/SPECIFICATIONS.md 23 | -------------------------------------------------------------------------------- /assets/logo-black-white-bg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/assets/logo-black-white-bg.png -------------------------------------------------------------------------------- /biscuit-servant/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for biscuit-servant 2 | 3 | ## 0.4.0.0 4 | 5 | - use biscuit-haskell 0.4.0.0 6 | 7 | ## 0.3.0.1 8 | 9 | - use biscuit-haskell 0.3.0.1 10 | - GHC 9.6 and 9.8 support 11 | - Generalize type for `withPriorityAuthorizer` 12 | 13 | ## 0.3.0.0 14 | 15 | - use biscuit-haskell 0.3.0.0 16 | - GHC 9.2 support 17 | - custom error handlers and token post-processing 18 | 19 | ## 0.2.1.0 20 | 21 | - use biscuit-haskell 0.2.1.0 22 | 23 | ## 0.2.0.1 24 | 25 | - use biscuit-haskell 0.2.0.1 26 | 27 | ## 0.2.0.0 28 | 29 | - use biscuit-haskell 0.2.0.0 30 | - allow effectful verification 31 | 32 | ## 0.1.1.0 33 | 34 | Initial release 35 | -------------------------------------------------------------------------------- /biscuit-servant/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Clément Delafargue (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /biscuit-servant/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: ghcid 2 | ghcid: 3 | ghcid -l -c 'cabal repl' 4 | 5 | .PHONY: ghcid-tests 6 | ghcid-tests: 7 | ghcid -l -c 'cabal repl biscuit-servant-test' -T main 8 | 9 | .PHONY: configure 10 | configure: 11 | cabal configure --enable-tests --test-show-details=direct --disable-optimization 12 | 13 | .PHONY: build 14 | build: 15 | cabal build -j all 16 | -------------------------------------------------------------------------------- /biscuit-servant/README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # biscuit-servant 🤖 [![Hackage][hackage]][hackage-url] 4 | 5 | > **Servant combinators to enable biscuit validation in your API trees** 6 | 7 | ## Usage 8 | 9 | ```Haskell 10 | type AppM = WithAuthorizer Handler 11 | type API = RequireBiscuit :> ProtectedAPI 12 | 13 | -- /users 14 | -- /users/:userId 15 | type ProtectedAPI = 16 | "users" :> ( Get '[JSON] [User] 17 | :<|> Capture "userId" Int :> Get '[JSON] User 18 | ) 19 | app :: PublicKey -> Application 20 | app pk = serveWithContext @API Proxy (genBiscuitCtx pk) server 21 | 22 | server :: Server API 23 | server biscuit = 24 | let handlers = userListHandler :<|> singleUserHandler 25 | handleAuth = 26 | handleBiscuit biscuit 27 | -- `allow if right("admin");` will be the first policy 28 | -- for every endpoint. 29 | -- Policies added by endpoints (or sub-apis) will tried after this one. 30 | . withPriorityAuthorizer [authorizer|allow if right("admin");|] 31 | -- `deny if true;` will be the last policy for every endpoint. 32 | -- Policies added by endpoints (or sub-apis) will tried before this one. 33 | . withFallbackAuthorizer [authorizer|deny if true;|] 34 | in hoistServer @ProtectedAPI Proxy handleAuth handlers 35 | 36 | allUsers :: [User] 37 | allUsers = [ User 1 "Danielle" "George" 38 | , User 2 "Albert" "Einstein" 39 | ] 40 | 41 | userListHandler :: AppM [User] 42 | userListHandler = withAuthorizer [authorizer|allow if right("userList")|] 43 | $ pure allUsers 44 | 45 | singleUserHandler :: Int -> AppM User 46 | singleUserHandler uid = 47 | withAuthorizer [authorizer|allow if right("getUser", {uid})|] $ 48 | let user = find (\user -> userId user == uid) allUsers 49 | in maybe (throwError error404) (\user -> pure user) user 50 | ``` 51 | 52 | [Hackage]: https://img.shields.io/hackage/v/biscuit-haskell?color=purple&style=flat-square 53 | [hackage-url]: https://hackage.haskell.org/package/biscuit-servant 54 | -------------------------------------------------------------------------------- /biscuit-servant/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /biscuit-servant/biscuit-servant.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | name: biscuit-servant 4 | version: 0.4.0.0 5 | category: Security 6 | synopsis: Servant support for the Biscuit security token 7 | description: Please see the README on GitHub at 8 | homepage: https://github.com/biscuit-auth/biscuit-haskell#readme 9 | bug-reports: https://github.com/biscuit-auth/biscuit-haskell/issues 10 | author: Clément Delafargue 11 | maintainer: clement@delafargue.name 12 | copyright: 2021 Clément Delafargue 13 | license: BSD3 14 | license-file: LICENSE 15 | build-type: Simple 16 | tested-with: GHC ==9.0.2 || ==9.2.4 || ==9.6.5 || ==9.8.2 17 | extra-source-files: 18 | README.md 19 | ChangeLog.md 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/biscuit-auth/biscuit-haskell 24 | 25 | library 26 | exposed-modules: 27 | Auth.Biscuit.Servant 28 | other-modules: 29 | Paths_biscuit_servant 30 | autogen-modules: 31 | Paths_biscuit_servant 32 | hs-source-dirs: 33 | src 34 | ghc-options: -Wall 35 | build-depends: 36 | base >= 4.7 && <5, 37 | biscuit-haskell >= 0.4 && < 0.5, 38 | bytestring >= 0.10 && <0.12, 39 | mtl >= 2.2 && < 2.4, 40 | text >= 1.2 && <3, 41 | servant-server >= 0.18 && < 0.21, 42 | wai ^>= 3.2 43 | default-language: Haskell2010 44 | 45 | test-suite biscuit-servant-test 46 | type: exitcode-stdio-1.0 47 | main-is: Spec.hs 48 | other-modules: 49 | AppWithAuthorizer 50 | ClientHelpers 51 | hs-source-dirs: 52 | test 53 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 54 | build-depends: 55 | base >=4.7 && <5 56 | , biscuit-haskell 57 | , biscuit-servant 58 | , bytestring 59 | , hspec 60 | , http-client 61 | , mtl 62 | , servant 63 | , servant-server 64 | , servant-client 65 | , servant-client-core 66 | , text 67 | , time 68 | , warp 69 | default-language: Haskell2010 70 | -------------------------------------------------------------------------------- /biscuit-servant/test/AppWithAuthorizer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {- 9 | Copyright : © Clément Delafargue, 2021 10 | License : BSD-3-Clause 11 | -} 12 | module AppWithAuthorizer where 13 | 14 | import Auth.Biscuit 15 | import Auth.Biscuit.Servant 16 | import Control.Monad.IO.Class (liftIO) 17 | import Control.Monad.Reader (ask) 18 | import Data.Text (Text) 19 | import Data.Time (getCurrentTime) 20 | import Servant 21 | import Servant.Client 22 | 23 | import ClientHelpers 24 | 25 | call1 :: Text -> ClientM Int 26 | call1 b = 27 | let (e1 :<|> _) = client @API Proxy (protect b) 28 | in e1 29 | 30 | call2 :: Text -> Int -> ClientM Int 31 | call2 b = 32 | let (_ :<|> e2 :<|> _) = client @API Proxy (protect b) 33 | in e2 34 | 35 | call3 :: Text -> ClientM Int 36 | call3 b = 37 | let (_ :<|> _ :<|> e3 :<|> _) = client @API Proxy (protect b) 38 | in e3 39 | 40 | call4 :: Text -> ClientM Int 41 | call4 b = 42 | let (_ :<|> _ :<|> _ :<|> e4) = client @API Proxy (protect b) 43 | in e4 44 | 45 | type H = WithAuthorizer Handler 46 | type H' = WithAuthorizer' Int Handler 47 | type API = RequireBiscuit :> ProtectedAPI 48 | type ProtectedAPI = 49 | "endpoint1" :> Get '[JSON] Int 50 | :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int 51 | :<|> "endpoint3" :> Get '[JSON] Int 52 | :<|> "endpoint4" :> Get '[JSON] Int 53 | 54 | app :: PublicKey -> Application 55 | app appPublicKey = 56 | serveWithContext @API Proxy (genBiscuitCtx appPublicKey) server 57 | 58 | server :: Server API 59 | server b = 60 | let nowFact = do 61 | now <- liftIO getCurrentTime 62 | pure [authorizer|time({now});|] 63 | handleAuth :: WithAuthorizer Handler x -> Handler x 64 | handleAuth = 65 | handleBiscuit b 66 | . withPriorityAuthorizerM nowFact 67 | . withPriorityAuthorizer [authorizer|allow if right("admin");|] 68 | . withFallbackAuthorizer [authorizer|allow if right("anon");|] 69 | handlers = handler1 :<|> handler2 :<|> handler3 :<|> handler4 70 | in hoistServer @ProtectedAPI Proxy handleAuth handlers 71 | 72 | handler1 :: H Int 73 | handler1 = withAuthorizer [authorizer|allow if right("one");|] $ pure 1 74 | 75 | handler2 :: Int -> H Int 76 | handler2 v = withAuthorizer [authorizer|allow if right("two", {v});|] $ pure 2 77 | 78 | handler3 :: H Int 79 | handler3 = withAuthorizer [authorizer|deny if true;|] $ pure 3 80 | 81 | handler4 :: H Int 82 | handler4 = withTransformation extractUserId $ 83 | withAuthorizer [authorizer|allow if user($user_id); |] $ do 84 | ask 85 | 86 | extractUserId :: AuthorizedBiscuit OpenOrSealed -> Handler Int 87 | extractUserId AuthorizedBiscuit{authorizationSuccess} = do 88 | let b = getBindings authorizationSuccess 89 | in maybe (throwError err403) pure $ getSingleVariableValue b "user_id" 90 | -------------------------------------------------------------------------------- /biscuit-servant/test/ClientHelpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {- 6 | Copyright : © Clément Delafargue, 2021 7 | License : BSD-3-Clause 8 | -} 9 | module ClientHelpers where 10 | 11 | import Data.Bifunctor (first) 12 | import Data.ByteString (ByteString) 13 | import Data.ByteString.Lazy (toStrict) 14 | import Data.Text (Text) 15 | import Network.HTTP.Client (defaultManagerSettings, newManager) 16 | import qualified Network.Wai.Handler.Warp as Warp 17 | import Servant 18 | import Servant.Client 19 | import qualified Servant.Client.Core as ClientCore 20 | import Servant.Client.Core (AuthClientData, AuthenticatedRequest, 21 | mkAuthenticatedRequest) 22 | 23 | protect :: Text -> AuthenticatedRequest (AuthProtect "biscuit") 24 | protect b = mkAuthenticatedRequest b (ClientCore.addHeader "Authorization" . ("Bearer " <>)) 25 | 26 | type instance AuthClientData (AuthProtect "biscuit") = Text 27 | 28 | withApp :: Application -> (Warp.Port -> IO ()) -> IO () 29 | withApp app = 30 | --testWithApplication makes sure the action is executed after the server has 31 | -- started and is being properly shutdown. 32 | Warp.testWithApplication (pure app) 33 | 34 | runC :: Warp.Port -> ClientM a -> IO (Either (Maybe ByteString) a) 35 | runC p c = do 36 | baseUrl <- parseBaseUrl $ "http://localhost:" <> show p 37 | manager <- newManager defaultManagerSettings 38 | let clientEnv = mkClientEnv manager baseUrl 39 | first extractBody <$> runClientM c clientEnv 40 | 41 | extractBody :: ClientError -> Maybe ByteString 42 | extractBody (FailureResponse _ Response{responseBody}) = Just $ toStrict responseBody 43 | extractBody _ = Nothing 44 | -------------------------------------------------------------------------------- /biscuit-servant/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {- 8 | Copyright : © Clément Delafargue, 2021 9 | License : BSD-3-Clause 10 | -} 11 | module Main (main) where 12 | 13 | import Auth.Biscuit 14 | import Data.Maybe (fromJust) 15 | import Data.Text (Text) 16 | import Data.Text.Encoding (decodeUtf8) 17 | import Data.Time (UTCTime, addUTCTime, getCurrentTime) 18 | import Test.Hspec 19 | 20 | import AppWithAuthorizer (app, call1, call2, call3, call4) 21 | import ClientHelpers (runC, withApp) 22 | 23 | main :: IO () 24 | main = do 25 | let appPk = toPublic appSecretKey 26 | later <- addUTCTime (60*5) <$> getCurrentTime 27 | earlier <- addUTCTime (-60) <$> getCurrentTime 28 | adminB <- toText <$> mkAdminBiscuit appSecretKey 29 | anonB <- toText <$> mkAnonBiscuit appSecretKey 30 | e1 <- toText <$> mkE1Biscuit appSecretKey 31 | e21 <- toText <$> mkE2Biscuit 1 appSecretKey 32 | e22 <- toText <$> mkE2Biscuit 2 appSecretKey 33 | ttld <- toText <$> (addTtl later =<< mkAdminBiscuit appSecretKey) 34 | expd <- toText <$> (addTtl earlier =<< mkAdminBiscuit appSecretKey) 35 | e4 <- toText <$> mkE4Biscuit 42 appSecretKey 36 | print adminB 37 | hspec $ 38 | around (withApp $ app appPk) $ 39 | describe "Biscuit-protected servant app" $ do 40 | it "Priority rules should apply everywhere" $ \port -> do 41 | runC port (call1 adminB) `shouldReturn` Right 1 42 | runC port (call2 adminB 1) `shouldReturn` Right 2 43 | runC port (call3 adminB) `shouldReturn` Right 3 44 | it "Fallback rules should only apply after inner rules" $ \port -> do 45 | runC port (call1 anonB) `shouldReturn` Right 1 46 | runC port (call2 anonB 1) `shouldReturn` Right 2 47 | runC port (call3 anonB) `shouldReturn` Left (Just "Biscuit failed checks") 48 | it "Endpoint rules should be matched after priority rules and before fallback rules" $ \port -> do 49 | runC port (call1 e1) `shouldReturn` Right 1 50 | runC port (call2 e21 1) `shouldReturn` Right 2 51 | runC port (call2 e22 1) `shouldReturn` Left (Just "Biscuit failed checks") 52 | runC port (call3 anonB) `shouldReturn` Left (Just "Biscuit failed checks") 53 | it "Effectful verification should work as expected" $ \port -> do 54 | runC port (call1 ttld) `shouldReturn` Right 1 55 | runC port (call1 expd) `shouldReturn` Left (Just "Biscuit failed checks") 56 | it "Token post-processing should work as expected" $ \port -> do 57 | runC port (call4 e4) `shouldReturn` Right 42 58 | 59 | appSecretKey :: SecretKey 60 | appSecretKey = fromJust . parseSecretKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209" 61 | 62 | toText :: BiscuitProof p => Biscuit p Verified -> Text 63 | toText = decodeUtf8 . serializeB64 64 | 65 | mkAdminBiscuit :: SecretKey -> IO (Biscuit Open Verified) 66 | mkAdminBiscuit sk = mkBiscuit sk [block|right("admin");|] 67 | 68 | mkAnonBiscuit :: SecretKey -> IO (Biscuit Open Verified) 69 | mkAnonBiscuit sk = mkBiscuit sk [block|right("anon");|] 70 | 71 | mkE1Biscuit :: SecretKey -> IO (Biscuit Open Verified) 72 | mkE1Biscuit sk = mkBiscuit sk [block|right("one");|] 73 | 74 | mkE2Biscuit :: Int -> SecretKey -> IO (Biscuit Open Verified) 75 | mkE2Biscuit v sk = mkBiscuit sk [block|right("two", {v});|] 76 | 77 | mkE4Biscuit :: Int -> SecretKey -> IO (Biscuit Open Verified) 78 | mkE4Biscuit v sk = mkBiscuit sk [block|user({v});|] 79 | 80 | addTtl :: UTCTime -> Biscuit Open Verified -> IO (Biscuit Open Verified) 81 | addTtl expiration = 82 | addBlock [block|check if time($now), $now < {expiration};|] 83 | -------------------------------------------------------------------------------- /biscuit/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for biscuit-haskell 2 | 3 | ## 0.4.0.0 4 | 5 | - abort authorization on evaluation error as mandated by the spec 6 | - use utf8 byte count in `{string}.length()` as mandated by the spec 7 | - fix security issue with third-party blocks public key interning, see [advisory](https://github.com/biscuit-auth/biscuit/security/advisories/GHSA-rgqv-mwc3-c78m) 8 | 9 | ## 0.3.0.1 10 | 11 | - GHC 9.6 and 9.8 support 12 | - Support for `!=` 13 | - Fixed-sized arithmetic and overflow detection 14 | - Allow parsing chained method calls 15 | 16 | ## 0.3.0.0 17 | 18 | - GHC 9.2 support 19 | - support for `v4` blocks: 20 | - support for third-party blocks & scope annotations 21 | - support for `check all` 22 | - support for bitwise operations in datalog 23 | - support for scoped queries after authorization 24 | - new datalog parser with better error reporting 25 | - forbid unbound variables during datalog parsing and 26 | token deserialization 27 | - update parameters syntax: `${name}` is now `{name}` 28 | - support for runtime datalog parsing 29 | - support for pre-authorization queries 30 | 31 | ## 0.2.1.0 32 | 33 | - support for string concatenation in datalog 34 | - support for `.contains()` on strings in datalog 35 | - update default symbol table 36 | 37 | ## 0.2.0.1 38 | 39 | - rename `verifier` to `authorizer` 40 | - keep track of the public key used to verify a biscuit 41 | - check revocation id during parsing 42 | - support for sealing biscuits 43 | - support for querying facts after authorization 44 | 45 | ## 0.2.0.0 46 | 47 | - support for v2 biscuits 48 | 49 | ## 0.1.1.0 50 | 51 | Bugfix for `serializeB64` and `serializeHex`. 52 | 53 | ## 0.1.0.0 54 | 55 | Basic biscuit support. 56 | -------------------------------------------------------------------------------- /biscuit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Clément Delafargue (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /biscuit/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: ghcid 2 | ghcid: 3 | ghcid -l -c 'cabal repl' 4 | 5 | .PHONY: ghcid-tests 6 | ghcid-tests: 7 | ghcid -l -c 'cabal repl biscuit-haskell-test' -T main 8 | 9 | .PHONY: configure 10 | configure: 11 | cabal configure --enable-tests --test-show-details=direct --disable-optimization 12 | 13 | .PHONY: build 14 | build: 15 | cabal build -j all 16 | 17 | .PHONY: test 18 | test: 19 | cabal test all 20 | -------------------------------------------------------------------------------- /biscuit/README.md: -------------------------------------------------------------------------------- 1 | # biscuit-haskell [![CI-badge][CI-badge]][CI-url] [![Hackage][hackage]][hackage-url] 2 | 3 | 4 | 5 | Main library for biscuit tokens support, providing minting and signature verification of biscuit tokens, as well as a datalog engine allowing to compute the validity of a token in a given context. 6 | 7 | ## Supported biscuit versions 8 | 9 | The core library supports [`v2` biscuits][v2spec] (both open and sealed). 10 | 11 | ## How to use this library 12 | 13 | This library was designed with the use of [`QuasiQuotes`][quasiquotes] in mind. 14 | 15 | A [minimal example][biscuitexample] is provided in the library itself, and the [package documentation][packagedoc] contains comprehensive examples and explanations for all the library features. 16 | 17 | Familiarity with biscuit tokens will make the examples easier to follow. 18 | Reading the [biscuit presentation][biscuit] and the [biscuit tutorial][biscuittutorial] is advised. 19 | 20 | ### Checking a biscuit token 21 | 22 | To make sure a biscuit token is valid, two checks have to take place: 23 | 24 | - a signature check with a public key, making sure the token is authentic 25 | - a datalog check making sure the token is authorized for the given context 26 | 27 | ```haskell 28 | -- public keys are typically serialized as hex-encoded strings. 29 | -- In most cases they will be read from a config file or an environment 30 | -- variable 31 | publicKey' :: PublicKey 32 | publicKey' = case parsePublicKeyHex "todo" of 33 | Nothing -> error "Error parsing public key" 34 | Just k -> k 35 | 36 | -- this function takes a base64-encoded biscuit in a bytestring, parses it, 37 | -- checks it signature and its validity. Here the provided context is just 38 | -- the current time (useful for TTL checks). In most cases, the provided context 39 | -- will carry a permissions check for the endpoint being accessed. 40 | verification :: ByteString -> IO Bool 41 | verification serialized = do 42 | now <- getCurrentTime 43 | -- biscuits are typically serialized as base64 bytestrings. The publicKey is needed 44 | -- to check the biscuit integrity before completely deserializing it 45 | biscuit <- either (fail . show) pure $ parseB64 publicKey' serialized 46 | -- the verifier can carry facts (like here), but also checks or policies. 47 | -- verifiers are defined inline, directly in datalog, through the `verifier` 48 | -- quasiquoter. datalog parsing and validation happens at compile time, but 49 | -- can still reference haskell variables. 50 | let authorizer' = [authorizer|time({now}); 51 | allow if true; 52 | |] 53 | -- `authorizeBiscuit` only works on valid biscuits, and runs the datalog verifications 54 | -- ensuring the biscuit is authorized in a given context 55 | result <- authorizeBiscuit biscuit authorizer' 56 | case result of 57 | Left e -> print e $> False 58 | Right _ -> pure True 59 | ``` 60 | 61 | ### Creating (and attenuating) biscuit tokens 62 | 63 | Biscuit tokens are created from a secret key, and can be attenuated without it. 64 | 65 | ```haskell 66 | -- secret keys are typically serialized as hex-encoded strings. 67 | -- In most cases they will be read from a config file or an environment 68 | -- variable (env vars or another secret management system are favored, 69 | -- since the secret key is sensitive information). 70 | -- A random secret key can be generated with `generateSecretKey` 71 | secretKey' :: SecretKey 72 | secretKey' = case parseSecretPrivateKeyHex "todo" of 73 | Nothing -> error "Error parsing secret key" 74 | Just k -> k 75 | 76 | creation :: IO ByteString 77 | creation = do 78 | -- biscuit tokens carry an authority block, which contents are guaranteed by the 79 | -- secret key. 80 | -- Blocks are defined inline, directly in datalog, through the `block` 81 | -- quasiquoter. datalog parsing and validation happens at compile time, but 82 | -- can still reference haskell variables. 83 | let authority = [block| 84 | // toto 85 | resource("file1"); 86 | |] 87 | biscuit <- mkBiscuit secretKey authority 88 | -- biscuits can be attenuated with blocks. blocks are not guaranteed by the secret key and 89 | -- should only restrict the token use. This property is guaranteed by the datalog evaluation: 90 | -- facts and rules declared in a block cannot interact with previous blocks. 91 | -- Here, the block only adds a TTL check. 92 | let block1 = [block|check if time($time), $time < 2021-05-08T00:00:00Z;|] 93 | -- `addBlock` only takes a block and a biscuit, the secret key is not needed: 94 | -- any biscuit can be attenuated by its holder. 95 | newBiscuit <- addBlock block1 biscuit 96 | pure $ serializeB64 newBiscuit 97 | ``` 98 | 99 | [CI-badge]: https://img.shields.io/github/actions/workflow/status/biscuit-auth/biscuit-haskell/github-actions.yml?style=flat-square&branch=main 100 | [CI-url]: https://github.com/biscuit-auth/biscuit-haskell/actions 101 | [Hackage]: https://img.shields.io/hackage/v/biscuit-haskell?color=purple&style=flat-square 102 | [hackage-url]: https://hackage.haskell.org/package/biscuit-haskell 103 | [gcouprie]: https://github.com/geal 104 | [biscuit]: https://www.clever-cloud.com/blog/engineering/2021/04/12/introduction-to-biscuit/ 105 | [biscuittutorial]: https://www.clever-cloud.com/blog/engineering/2021/04/15/biscuit-tutorial/ 106 | [v2spec]: https://github.com/CleverCloud/biscuit/blob/2.0/SPECIFICATIONS.md 107 | [quasiquotes]: https://wiki.haskell.org/Quasiquotation 108 | [biscuitexample]: https://github.com/biscuit-auth/biscuit-haskell/blob/main/biscuit/src/Auth/Biscuit/Example.hs 109 | [packagedoc]: https://hackage.haskell.org/package/biscuit-haskell-0.1.0.0/docs/Auth-Biscuit.html 110 | -------------------------------------------------------------------------------- /biscuit/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /biscuit/benchmarks/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | import Criterion.Main 3 | 4 | import Auth.Biscuit 5 | import Data.Maybe (fromJust) 6 | 7 | buildToken :: SecretKey -> IO (Biscuit Open Verified) 8 | buildToken sk = do 9 | mkBiscuit sk [block|user_id("user_1234");|] 10 | 11 | -- Our benchmark harness. 12 | main = do 13 | sk <- newSecret 14 | biscuit <- buildToken sk 15 | let pk = toPublic sk 16 | let biscuitBs = serialize biscuit 17 | defaultMain [ 18 | bgroup "biscuit" [ bench "mkBiscuit" $ whnfIO (buildToken sk) 19 | , bench "parse" $ whnf (parse pk) biscuitBs 20 | , bench "serialize" $ whnf serialize biscuit 21 | , bench "verify" $ whnfIO (authorizeBiscuit biscuit [authorizer|allow if user_id("user_1234");|]) 22 | ] 23 | ] 24 | -------------------------------------------------------------------------------- /biscuit/biscuit-haskell.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | name: biscuit-haskell 4 | version: 0.4.0.0 5 | category: Security 6 | synopsis: Library support for the Biscuit security token 7 | description: Please see the README on GitHub at 8 | homepage: https://github.com/biscuit-auth/biscuit-haskell#readme 9 | bug-reports: https://github.com/biscuit-auth/biscuit-haskell/issues 10 | author: Clément Delafargue 11 | maintainer: clement@delafargue.name 12 | copyright: 2021 Clément Delafargue 13 | license: BSD3 14 | license-file: LICENSE 15 | build-type: Simple 16 | tested-with: GHC ==9.0.2 || ==9.2.4 || ==9.6.5 || ==9.8.2 17 | extra-source-files: 18 | README.md 19 | ChangeLog.md 20 | test/samples/current/samples.json 21 | test/samples/current/*.bc 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/biscuit-auth/biscuit-haskell 26 | 27 | library 28 | exposed-modules: 29 | Auth.Biscuit 30 | Auth.Biscuit.Symbols 31 | Auth.Biscuit.Utils 32 | Auth.Biscuit.Crypto 33 | Auth.Biscuit.Datalog.AST 34 | Auth.Biscuit.Datalog.Executor 35 | Auth.Biscuit.Datalog.Parser 36 | Auth.Biscuit.Datalog.ScopedExecutor 37 | Auth.Biscuit.Example 38 | Auth.Biscuit.Proto 39 | Auth.Biscuit.ProtoBufAdapter 40 | Auth.Biscuit.Timer 41 | Auth.Biscuit.Token 42 | other-modules: 43 | Paths_biscuit_haskell 44 | autogen-modules: 45 | Paths_biscuit_haskell 46 | hs-source-dirs: 47 | src 48 | ghc-options: -Wall 49 | build-depends: 50 | base >= 4.7 && <5, 51 | async ^>= 2.2, 52 | base16 >= 0.3 && <2.0, 53 | bytestring >= 0.10 && <0.12, 54 | text >= 1.2 && <3, 55 | containers ^>= 0.6, 56 | cryptonite >= 0.27 && < 0.31, 57 | memory >= 0.15 && < 0.19, 58 | template-haskell >= 2.16 && < 2.22, 59 | base64 ^>= 0.4, 60 | cereal ^>= 0.5, 61 | mtl >= 2.2 && < 2.4, 62 | parser-combinators >= 1.2 && < 1.4, 63 | protobuf ^>= 0.2, 64 | random >= 1.0 && < 1.3, 65 | regex-tdfa ^>= 1.3, 66 | th-lift-instances ^>= 0.1, 67 | time ^>= 1.9, 68 | validation-selective >= 0.1 && < 0.3, 69 | megaparsec >= 9.2 && < 9.7 70 | default-language: Haskell2010 71 | 72 | test-suite biscuit-haskell-test 73 | type: exitcode-stdio-1.0 74 | main-is: Spec.hs 75 | other-modules: 76 | Spec.NewCrypto 77 | Spec.Executor 78 | Spec.Parser 79 | Spec.Quasiquoter 80 | Spec.Roundtrip 81 | Spec.SampleReader 82 | Spec.ScopedExecutor 83 | Spec.Verification 84 | Paths_biscuit_haskell 85 | hs-source-dirs: 86 | test 87 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 88 | build-depends: 89 | async 90 | , aeson 91 | , base >=4.7 && <5 92 | , base16 >=0.3 && <2.0 93 | , base64 94 | , biscuit-haskell 95 | , bytestring 96 | , cereal 97 | , containers 98 | , cryptonite 99 | , lens 100 | , lens-aeson 101 | , megaparsec 102 | , mtl 103 | , parser-combinators 104 | , protobuf 105 | , random 106 | , tasty 107 | , tasty-hunit 108 | , template-haskell 109 | , text 110 | , th-lift-instances 111 | , time 112 | , validation-selective 113 | default-language: Haskell2010 114 | 115 | benchmark biscuit-bench 116 | type: exitcode-stdio-1.0 117 | main-is: Bench.hs 118 | hs-source-dirs: benchmarks 119 | default-language: Haskell2010 120 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T 121 | build-depends: base 122 | , criterion 123 | , biscuit-haskell 124 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyDataDeriving #-} 3 | {-| 4 | Module : Auth.Biscuit 5 | Copyright : © Clément Delafargue, 2021 6 | License : BSD-3-Clause 7 | Maintainer : clement@delafargue.name 8 | Haskell implementation for the Biscuit token. 9 | -} 10 | module Auth.Biscuit 11 | ( 12 | -- * The biscuit auth token 13 | -- $biscuitOverview 14 | 15 | -- * Creating key pairs 16 | -- $keypairs 17 | newSecret 18 | , toPublic 19 | , SecretKey 20 | , PublicKey 21 | 22 | -- ** Parsing and serializing key pairs 23 | , serializeSecretKeyHex 24 | , serializePublicKeyHex 25 | , parseSecretKeyHex 26 | , parsePublicKeyHex 27 | , serializeSecretKey 28 | , serializePublicKey 29 | , parseSecretKey 30 | , parsePublicKey 31 | 32 | -- * Creating a biscuit 33 | -- $biscuitBlocks 34 | , mkBiscuit 35 | , mkBiscuitWith 36 | , block 37 | , blockContext 38 | , Biscuit 39 | , OpenOrSealed 40 | , Open 41 | , Sealed 42 | , Verified 43 | , Unverified 44 | , BiscuitProof 45 | , Block 46 | -- ** Parsing and serializing biscuits 47 | , parseB64 48 | , parse 49 | , parseWith 50 | , parseBiscuitUnverified 51 | , checkBiscuitSignatures 52 | , BiscuitEncoding (..) 53 | , ParserConfig (..) 54 | , fromRevocationList 55 | , serializeB64 56 | , serialize 57 | , fromHex 58 | -- ** Attenuating biscuits 59 | -- $attenuatingBiscuits 60 | , addBlock 61 | -- ** Third-party blocks 62 | -- $thirdPartyBlocks 63 | , addSignedBlock 64 | , mkThirdPartyBlockReq 65 | , mkThirdPartyBlockReqB64 66 | , mkThirdPartyBlock 67 | , mkThirdPartyBlockB64 68 | , applyThirdPartyBlock 69 | , applyThirdPartyBlockB64 70 | -- ** Sealing biscuits 71 | -- $sealedBiscuits 72 | , seal 73 | , fromOpen 74 | , fromSealed 75 | , asOpen 76 | , asSealed 77 | 78 | -- * Verifying a biscuit 79 | -- $verifying 80 | , authorizer 81 | , Authorizer 82 | , authorizeBiscuit 83 | , authorizeBiscuitWithLimits 84 | , Limits (..) 85 | , defaultLimits 86 | , ParseError (..) 87 | , ExecutionError (..) 88 | , AuthorizedBiscuit (..) 89 | , AuthorizationSuccess (..) 90 | , MatchedQuery (..) 91 | , getBindings 92 | , ToTerm (..) 93 | , FromValue (..) 94 | , Term 95 | , Term' (..) 96 | 97 | -- * Retrieving information from a biscuit 98 | , queryAuthorizerFacts 99 | , queryRawBiscuitFacts 100 | , getVariableValues 101 | , getSingleVariableValue 102 | , query 103 | , getRevocationIds 104 | , getVerifiedBiscuitPublicKey 105 | ) where 106 | 107 | import Control.Monad ((<=<)) 108 | import Control.Monad.Identity (runIdentity) 109 | import Data.Bifunctor (first) 110 | import Data.ByteString (ByteString) 111 | import qualified Data.ByteString.Base64.URL as B64 112 | import Data.Foldable (toList) 113 | import Data.Set (Set) 114 | import qualified Data.Set as Set 115 | import Data.Text (Text, unpack) 116 | 117 | import Auth.Biscuit.Crypto (PublicKey, SecretKey, 118 | generateSecretKey, 119 | pkBytes, 120 | readEd25519PublicKey, 121 | readEd25519SecretKey, 122 | skBytes, toPublic) 123 | import Auth.Biscuit.Datalog.AST (Authorizer, Block, 124 | FromValue (..), Term, 125 | Term' (..), ToTerm (..), 126 | bContext) 127 | import Auth.Biscuit.Datalog.Executor (ExecutionError (..), 128 | Limits (..), 129 | MatchedQuery (..), 130 | defaultLimits) 131 | import Auth.Biscuit.Datalog.Parser (authorizer, block, query) 132 | import Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess (..), 133 | getBindings, 134 | getSingleVariableValue, 135 | getVariableValues) 136 | import Auth.Biscuit.Token (AuthorizedBiscuit (..), 137 | Biscuit, 138 | BiscuitEncoding (..), 139 | BiscuitProof (..), Open, 140 | OpenOrSealed, 141 | ParseError (..), 142 | ParserConfig (..), Sealed, 143 | Unverified, Verified, 144 | addBlock, addSignedBlock, 145 | applyThirdPartyBlock, 146 | asOpen, asSealed, 147 | authorizeBiscuit, 148 | authorizeBiscuitWithLimits, 149 | checkBiscuitSignatures, 150 | fromOpen, fromSealed, 151 | getRevocationIds, 152 | getVerifiedBiscuitPublicKey, 153 | mkBiscuit, mkBiscuitWith, 154 | mkThirdPartyBlock, 155 | mkThirdPartyBlockReq, 156 | parseBiscuitUnverified, 157 | parseBiscuitWith, 158 | queryAuthorizerFacts, 159 | queryRawBiscuitFacts, 160 | seal, serializeBiscuit) 161 | import Auth.Biscuit.Utils (decodeHex, encodeHex') 162 | import qualified Data.Text as Text 163 | 164 | 165 | -- $biscuitOverview 166 | -- 167 | -- is a /bearer token/, 168 | -- allowing /offline attenuation/ (meaning that anyone having a token can craft a new, more 169 | -- restricted token), 170 | -- and /'PublicKey' verification/. Token rights and attenuation are expressed using a logic 171 | -- language, derived from . Such a language can describe facts (things we know 172 | -- about the world), rules (describing how to derive new facts from existing ones) and checks 173 | -- (ensuring that facts hold). Facts and checks let you describe access control rules, while 174 | -- rules make them modular. /Authorizer policies/ lets the verifying party ensure that a 175 | -- provided biscuit grants access to the required operations. 176 | -- 177 | -- Here's how to create a biscuit token: 178 | -- 179 | -- > -- Biscuit Open Verified means the token has valid signatures 180 | -- > -- and is open to further restriction 181 | -- > buildToken :: SecretKey -> IO (Biscuit Open Verified) 182 | -- > buildToken secret = 183 | -- > -- the logic language has its own syntax, which can be typed directly in haskell 184 | -- > -- source code thanks to QuasiQuotes. The datalog snippets are parsed at compile 185 | -- > -- time, so a datalog error results in a compilation error, not a runtime error 186 | -- > mkBiscuit secret [block| 187 | -- > // the two first lines describe facts: 188 | -- > // the token holder is identified as `user_1234` 189 | -- > user("user_1234"); 190 | -- > // the token holder is granted access to resource `file1` 191 | -- > resource("file1"); 192 | -- > // this last line defines a restriction: properties that need 193 | -- > // to be verified for the token to be verified: 194 | -- > // the token can only be used before a specified date 195 | -- > check if time($time), $time < 2021-05-08T00:00:00Z; 196 | -- > |] 197 | -- 198 | -- Here's how to attenuate a biscuit token: 199 | -- 200 | -- > restrictToken :: Biscuit Open Verified -> IO Biscuit Open Verified 201 | -- > restrictToken = 202 | -- > addBlock [block| 203 | -- > // restrict the token to local use only 204 | -- > check if user_ip_address("127.0.0.1"); 205 | -- > |] 206 | -- 207 | -- To verify a biscuit token, we need two things: 208 | -- 209 | -- - a public key, that will let us verify the token has been emitted by 210 | -- a trusted authority 211 | -- - an authorizer, that will make sure all the checks declared in the token are fulfilled, 212 | -- as well as providing its own checks, and policies which decide if the token is 213 | -- verified or not 214 | -- 215 | -- Here's how to verify a base64-serialized biscuit token: 216 | -- 217 | -- > verifyToken :: PublicKey -> ByteString -> IO Bool 218 | -- > verifyToken publicKey token = do 219 | -- > -- complete parsing is only attempted if signatures can be verified, 220 | -- > -- that's the reason why 'parseB64' takes a public key as a parameter 221 | -- > parseResult <- parseB64 publicKey token 222 | -- > case parseResult of 223 | -- > Left e -> print e $> False 224 | -- > Right biscuit -> do 225 | -- > now <- getCurrentTime 226 | -- > let authorizer' = [authorizer| 227 | -- > // the datalog snippets can reference haskell variables 228 | -- > // with the {variableName} syntax 229 | -- > time({now}); 230 | -- > 231 | -- > // policies are tried in order. The first matching policy 232 | -- > // will decide if the token is valid or not. If no policies 233 | -- > // match, the token will fail validation 234 | -- > allow if resource("file1"); 235 | -- > |] 236 | -- > result <- authorizeBiscuit biscuit authorizer' 237 | -- > case result of 238 | -- > Left e -> print e $> False 239 | -- > Right _ -> pure True 240 | 241 | -- | Build a block containing an explicit freeform context value. 242 | -- The context of a block can't be parsed from datalog, 243 | -- so you'll need an explicit call to `blockContext` to add it 244 | -- 245 | -- > [block|check if time($t), $t < 2021-01-01;|] 246 | -- > <> blockContext "ttl-check" 247 | blockContext :: Text -> Block 248 | blockContext c = mempty { bContext = Just c } 249 | 250 | -- | Decode a base16-encoded bytestring, reporting errors via `MonadFail` 251 | fromHex :: MonadFail m => ByteString -> m ByteString 252 | fromHex = either (fail . Text.unpack) pure . decodeHex 253 | 254 | -- $keypairs 255 | -- 256 | -- Biscuits rely on public key cryptography: biscuits are signed with a secret key only known 257 | -- to the party which emits it. Verifying a biscuit, on the other hand, can be done with a 258 | -- public key that can be widely distributed. A private key and its corresponding public key 259 | -- is called a key pair, but since a public key can be deterministically computed from a 260 | -- private key, owning a private key is the same as owning a key pair. 261 | 262 | -- | Generate a new random 'SecretKey' 263 | newSecret :: IO SecretKey 264 | newSecret = generateSecretKey 265 | 266 | -- | Serialize a 'SecretKey' to raw bytes, without any encoding 267 | serializeSecretKey :: SecretKey -> ByteString 268 | serializeSecretKey = skBytes 269 | 270 | -- | Serialize a 'PublicKey' to raw bytes, without any encoding 271 | serializePublicKey :: PublicKey -> ByteString 272 | serializePublicKey = pkBytes 273 | 274 | -- | Serialize a 'SecretKey' to a hex-encoded bytestring 275 | serializeSecretKeyHex :: SecretKey -> ByteString 276 | serializeSecretKeyHex = encodeHex' . skBytes 277 | 278 | -- | Serialize a 'PublicKey' to a hex-encoded bytestring 279 | serializePublicKeyHex :: PublicKey -> ByteString 280 | serializePublicKeyHex = encodeHex' . pkBytes 281 | 282 | -- | Read a 'SecretKey' from raw bytes 283 | parseSecretKey :: ByteString -> Maybe SecretKey 284 | parseSecretKey = readEd25519SecretKey 285 | 286 | -- | Read a 'SecretKey' from an hex bytestring 287 | parseSecretKeyHex :: ByteString -> Maybe SecretKey 288 | parseSecretKeyHex = parseSecretKey <=< fromHex 289 | 290 | -- | Read a 'PublicKey' from raw bytes 291 | parsePublicKey :: ByteString -> Maybe PublicKey 292 | parsePublicKey = readEd25519PublicKey 293 | 294 | -- | Read a 'PublicKey' from an hex bytestring 295 | parsePublicKeyHex :: ByteString -> Maybe PublicKey 296 | parsePublicKeyHex = parsePublicKey <=< fromHex 297 | 298 | -- | Parse a biscuit from a raw bytestring. If you want to parse 299 | -- from a URL-compatible base 64 bytestring, consider using `parseB64` 300 | -- instead. 301 | -- The biscuit signature is verified with the provided 'PublicKey' before 302 | -- completely decoding blocks 303 | -- The revocation ids are /not/ verified before completely decoding blocks. 304 | -- If you need to check revocation ids before decoding blocks, use 'parseWith' 305 | -- (or 'parseB64With' instead). 306 | parse :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified) 307 | parse pk = runIdentity . parseBiscuitWith ParserConfig 308 | { encoding = RawBytes 309 | , isRevoked = const $ pure False 310 | , getPublicKey = pure pk 311 | } 312 | 313 | -- | Parse a biscuit from a URL-compatible base 64 encoded bytestring 314 | parseB64 :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified) 315 | parseB64 pk = runIdentity . parseBiscuitWith ParserConfig 316 | { encoding = UrlBase64 317 | , isRevoked = const $ pure False 318 | , getPublicKey = pure pk 319 | } 320 | 321 | -- | Parse a biscuit, with explicitly supplied parsing options: 322 | -- 323 | -- - encoding ('RawBytes' or 'UrlBase64') 324 | -- - revocation check 325 | -- - public key (based on the token's @rootKeyId@ field) 326 | -- 327 | -- If you don't need dynamic public key selection or revocation checks, you can use 328 | -- 'parse' or 'parseB64' instead. 329 | -- 330 | -- The biscuit signature is verified with the selected 'PublicKey' before 331 | -- completely decoding blocks 332 | parseWith :: Applicative m 333 | => ParserConfig m 334 | -> ByteString 335 | -> m (Either ParseError (Biscuit OpenOrSealed Verified)) 336 | parseWith = parseBiscuitWith 337 | 338 | -- | Helper for building a revocation check from a static list, suitable for use with 339 | -- 'parseWith' and 'ParserConfig'. 340 | fromRevocationList :: (Applicative m, Foldable t) 341 | => t ByteString 342 | -> Set ByteString 343 | -> m Bool 344 | fromRevocationList revokedIds tokenIds = 345 | pure . not . null $ Set.intersection (Set.fromList $ toList revokedIds) tokenIds 346 | 347 | -- | Serialize a biscuit to a binary format. If you intend to send 348 | -- the biscuit over a text channel, consider using `serializeB64` instead 349 | serialize :: BiscuitProof p => Biscuit p Verified -> ByteString 350 | serialize = serializeBiscuit 351 | 352 | -- | Serialize a biscuit to URL-compatible base 64, as recommended by the spec 353 | serializeB64 :: BiscuitProof p => Biscuit p Verified -> ByteString 354 | serializeB64 = B64.encodeBase64' . serialize 355 | 356 | -- | Generate a base64-encoded third-party block request. It can be used in 357 | -- conjunction with 'mkThirdPartyBlockB64' to generate a base64-encoded 358 | -- third-party block, which can be then appended to a token with 359 | -- 'applyThirdPartyBlockB64'. 360 | mkThirdPartyBlockReqB64 :: Biscuit Open c -> ByteString 361 | mkThirdPartyBlockReqB64 = B64.encodeBase64' . mkThirdPartyBlockReq 362 | 363 | -- | Given a base64-encoded third-party block request, generate a base64-encoded 364 | -- third-party block, which can be then appended to a token with 365 | -- 'applyThirdPartyBlockB64'. 366 | mkThirdPartyBlockB64 :: SecretKey -> ByteString -> Block -> Either String ByteString 367 | mkThirdPartyBlockB64 sk reqB64 b = do 368 | req <- first unpack $ B64.decodeBase64 reqB64 369 | contents <- mkThirdPartyBlock sk req b 370 | pure $ B64.encodeBase64' contents 371 | 372 | -- | Given a base64-encoded third-party block, append it to a token. 373 | applyThirdPartyBlockB64 :: Biscuit Open check -> ByteString -> Either String (IO (Biscuit Open check)) 374 | applyThirdPartyBlockB64 b contentsB64 = do 375 | contents <- first unpack $ B64.decodeBase64 contentsB64 376 | applyThirdPartyBlock b contents 377 | 378 | -- $biscuitBlocks 379 | -- 380 | -- The core of a biscuit is its authority block. This block declares facts and rules and 381 | -- is signed by its creator with a secret key. In addition to this trusted, authority 382 | -- block, a biscuit may carry extra blocks that can only restrict what it can do. By 383 | -- default, biscuits can be restricted, but it's possible to seal a biscuit and prevent 384 | -- further modifications. 385 | -- 386 | -- Blocks are defined with a logic language (datalog) that can be used directly from haskell 387 | -- with the `QuasiQuotes` extension. 388 | 389 | -- $attenuatingBiscuits 390 | -- 391 | -- By default, biscuits can be /attenuated/. It means that any party that holds a biscuit can 392 | -- craft a new biscuit with fewer rights. A common example is taking a long-lived biscuit and 393 | -- adding a short TTL right before sending it over the wire. 394 | 395 | -- $thirdPartyBlocks 396 | -- 397 | -- Regular blocks can be added by anyone and as such can only /attenuate/ a token: the facts 398 | -- they carry are not visible outside themselves, only their checks are evaluated. 399 | -- 400 | -- Third-party blocks lift this limitation by carrying an extra signature, crafted with a 401 | -- dedicated key pair. This way, the token authorizer (as well as blocks themselves) can 402 | -- opt-in to trust facts coming from third-party blocks signed with specific key pairs. 403 | -- 404 | -- For instance, adding `check if group("admin") trusting {publicKey};` to a token will 405 | -- make it usable only if it carries a third party-block signed by the corresponding key pair, 406 | -- and carrying a `group("admin")` fact. 407 | -- 408 | -- Since it is not desirable to share the token with the external entity providing the third-party 409 | -- block, a request mechanism is available: 410 | -- 411 | -- - the token holder generates a /third-party block request/ from the token (it contains technical 412 | -- information needed to generate a third-party block) with 'mkThirdPartyBlockReq'; 413 | -- - the token holder forwards this request to the external entity; 414 | -- - the external entity uses this request, a 'Block' value, and a 'SecretKey' to generate a third-party 415 | -- block, with 'mkThirdPartyBlock'; 416 | -- - the external entity sends this block back to the token holder; 417 | -- - the token holder can now add the block to the token with 'applyThirdPartyBlock'. 418 | -- 419 | -- In some cases, the party holding the token is also the one who's adding the third-party block. It 420 | -- is then possible to directly use 'addSignedBlock' to append a third-party block to the token without 421 | -- having to go through generating a third-party block request. 422 | 423 | -- $sealedBiscuits 424 | -- 425 | -- An 'Open' biscuit can be turned into a 'Sealed' one, meaning it won't be possible 426 | -- to attenuate it further. 427 | -- 428 | -- 'mkBiscuit' creates 'Open' biscuits, while 'parse' returns an 'OpenOrSealed' biscuit (since 429 | -- when you're verifying a biscuit, you're not caring about whether it can be extended further 430 | -- or not). 'authorizeBiscuit' does not care whether a biscuit is 'Open' or 'Sealed' and can be 431 | -- used with both. 'addBlock' and 'seal' only work with 'Open' biscuits. 432 | 433 | -- $verifying 434 | -- 435 | -- Verifying a biscuit requires providing a list of policies (/allow/ or /deny/), which will 436 | -- decide if the biscuit is accepted. Policies are tried in order, and the first one to match 437 | -- decides whether the biscuit is accepted. 438 | -- 439 | -- In addition to policies, an authorizer typically provides facts (such as the current time) so 440 | -- that checks and policies can be verified. 441 | -- 442 | -- The authorizer checks and policies only see the content of the authority (first) block. Extra 443 | -- blocks can only carry restrictions and cannot interfere with the authority facts. 444 | 445 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Crypto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-| 9 | Module : Auth.Biscuit.Crypto 10 | Copyright : © Clément Delafargue, 2021 11 | License : BSD-3-Clause 12 | Maintainer : clement@delafargue.name 13 | Cryptographic helpers for biscuit signatures 14 | -} 15 | module Auth.Biscuit.Crypto 16 | ( SignedBlock 17 | , Blocks 18 | , signBlock 19 | , signExternalBlock 20 | , sign3rdPartyBlock 21 | , verifyBlocks 22 | , verifySecretProof 23 | , verifySignatureProof 24 | , getSignatureProof 25 | , verifyExternalSig 26 | , PublicKey 27 | , pkBytes 28 | , readEd25519PublicKey 29 | , SecretKey 30 | , skBytes 31 | , readEd25519SecretKey 32 | , Signature 33 | , sigBytes 34 | , signature 35 | , generateSecretKey 36 | , toPublic 37 | , sign 38 | ) where 39 | 40 | import Control.Arrow ((&&&)) 41 | import Crypto.Error (maybeCryptoError) 42 | import qualified Crypto.PubKey.Ed25519 as Ed25519 43 | import Data.ByteArray (convert) 44 | import Data.ByteString (ByteString) 45 | import Data.Function (on) 46 | import Data.Int (Int32) 47 | import Data.List.NonEmpty (NonEmpty (..)) 48 | import qualified Data.List.NonEmpty as NE 49 | import Data.Maybe (catMaybes, fromJust) 50 | import Instances.TH.Lift () 51 | import Language.Haskell.TH.Syntax 52 | 53 | import qualified Auth.Biscuit.Proto as PB 54 | import qualified Data.Serialize as PB 55 | 56 | newtype PublicKey = PublicKey Ed25519.PublicKey 57 | deriving newtype (Eq, Show) 58 | 59 | instance Ord PublicKey where 60 | compare = compare `on` serializePublicKey 61 | 62 | instance Lift PublicKey where 63 | lift pk = [| fromJust $ readEd25519PublicKey $(lift $ pkBytes pk) |] 64 | #if MIN_VERSION_template_haskell(2,17,0) 65 | liftTyped = liftCode . unsafeTExpCoerce . lift 66 | #else 67 | liftTyped = unsafeTExpCoerce . lift 68 | #endif 69 | 70 | newtype SecretKey = SecretKey Ed25519.SecretKey 71 | deriving newtype (Eq, Show) 72 | newtype Signature = Signature ByteString 73 | deriving newtype (Eq, Show) 74 | 75 | signature :: ByteString -> Signature 76 | signature = Signature 77 | 78 | sigBytes :: Signature -> ByteString 79 | sigBytes (Signature b) = b 80 | 81 | readEd25519PublicKey :: ByteString -> Maybe PublicKey 82 | readEd25519PublicKey bs = PublicKey <$> maybeCryptoError (Ed25519.publicKey bs) 83 | 84 | readEd25519SecretKey :: ByteString -> Maybe SecretKey 85 | readEd25519SecretKey bs = SecretKey <$> maybeCryptoError (Ed25519.secretKey bs) 86 | 87 | readEd25519Signature :: Signature -> Maybe Ed25519.Signature 88 | readEd25519Signature (Signature bs) = maybeCryptoError (Ed25519.signature bs) 89 | 90 | -- | Generate a public key from a secret key 91 | toPublic :: SecretKey -> PublicKey 92 | toPublic (SecretKey sk) = PublicKey $ Ed25519.toPublic sk 93 | 94 | generateSecretKey :: IO SecretKey 95 | generateSecretKey = SecretKey <$> Ed25519.generateSecretKey 96 | 97 | sign :: SecretKey -> PublicKey -> ByteString -> Signature 98 | sign (SecretKey sk) (PublicKey pk) payload = 99 | Signature . convert $ Ed25519.sign sk pk payload 100 | 101 | verify :: PublicKey -> ByteString -> Signature -> Bool 102 | verify (PublicKey pk) payload sig = 103 | case readEd25519Signature sig of 104 | Just sig' -> Ed25519.verify pk payload sig' 105 | Nothing -> False 106 | 107 | pkBytes :: PublicKey -> ByteString 108 | pkBytes (PublicKey pk) = convert pk 109 | 110 | skBytes :: SecretKey -> ByteString 111 | skBytes (SecretKey sk) = convert sk 112 | 113 | type SignedBlock = (ByteString, Signature, PublicKey, Maybe (Signature, PublicKey)) 114 | type Blocks = NonEmpty SignedBlock 115 | 116 | -- | Biscuit 2.0 allows multiple signature algorithms. 117 | -- For now this lib only supports Ed25519, but the spec mandates flagging 118 | -- each publicKey with an algorithm identifier when serializing it. The 119 | -- serializing itself is handled by protobuf, but we still need to manually 120 | -- serialize keys when we include them in something we want sign (block 121 | -- signatures, and the final signature for sealed tokens). 122 | serializePublicKey :: PublicKey -> ByteString 123 | serializePublicKey pk = 124 | let keyBytes = pkBytes pk 125 | algId :: Int32 126 | algId = fromIntegral $ fromEnum PB.Ed25519 127 | -- The spec mandates that we serialize the algorithm id as a little-endian int32 128 | algBytes = PB.runPut $ PB.putInt32le algId 129 | in algBytes <> keyBytes 130 | 131 | signBlock :: SecretKey 132 | -> ByteString 133 | -> Maybe (Signature, PublicKey) 134 | -> IO (SignedBlock, SecretKey) 135 | signBlock sk payload eSig = do 136 | let pk = toPublic sk 137 | (nextPk, nextSk) <- (toPublic &&& id) <$> generateSecretKey 138 | let toSign = getToSig (payload, (), nextPk, eSig) 139 | sig = sign sk pk toSign 140 | pure ((payload, sig, nextPk, eSig), nextSk) 141 | 142 | signExternalBlock :: SecretKey 143 | -> SecretKey 144 | -> PublicKey 145 | -> ByteString 146 | -> IO (SignedBlock, SecretKey) 147 | signExternalBlock sk eSk pk payload = 148 | let eSig = sign3rdPartyBlock eSk pk payload 149 | in signBlock sk payload (Just eSig) 150 | 151 | sign3rdPartyBlock :: SecretKey 152 | -> PublicKey 153 | -> ByteString 154 | -> (Signature, PublicKey) 155 | sign3rdPartyBlock eSk nextPk payload = 156 | let toSign = payload <> serializePublicKey nextPk 157 | ePk = toPublic eSk 158 | eSig = sign eSk ePk toSign 159 | in (eSig, ePk) 160 | 161 | getSignatureProof :: SignedBlock -> SecretKey -> Signature 162 | getSignatureProof (lastPayload, Signature lastSig, lastPk, _todo) nextSecret = 163 | let sk = nextSecret 164 | pk = toPublic nextSecret 165 | toSign = lastPayload <> serializePublicKey lastPk <> lastSig 166 | in sign sk pk toSign 167 | 168 | getToSig :: (ByteString, a, PublicKey, Maybe (Signature, PublicKey)) -> ByteString 169 | getToSig (p, _, nextPk, ePk) = 170 | p <> foldMap (sigBytes . fst) ePk <> serializePublicKey nextPk 171 | 172 | getSignature :: SignedBlock -> Signature 173 | getSignature (_, sig, _, _) = sig 174 | 175 | getPublicKey :: SignedBlock -> PublicKey 176 | getPublicKey (_, _, pk, _) = pk 177 | 178 | -- | The data signed by the external key is the payload for the current block + the public key from 179 | -- the previous block: this prevents signature reuse (the external signature cannot be used on another 180 | -- token) 181 | getExternalSigPayload :: PublicKey -> SignedBlock -> Maybe (PublicKey, ByteString, Signature) 182 | getExternalSigPayload pkN (payload, _, _, Just (eSig, ePk)) = Just (ePk, payload <> serializePublicKey pkN, eSig) 183 | getExternalSigPayload _ _ = Nothing 184 | 185 | -- | When adding a pre-signed third-party block to a token, we make sure the third-party block is correctly 186 | -- signed (pk-signature match, and the third-party block is pinned to the last biscuit block) 187 | verifyExternalSig :: PublicKey -> (ByteString, Signature, PublicKey) -> Bool 188 | verifyExternalSig previousPk (payload, eSig, ePk) = 189 | verify ePk (payload <> serializePublicKey previousPk) eSig 190 | 191 | verifyBlocks :: Blocks 192 | -> PublicKey 193 | -> Bool 194 | verifyBlocks blocks rootPk = 195 | let attachKey pk (payload, sig) = (pk, payload, sig) 196 | uncurry3 f (a, b, c) = f a b c 197 | sigs = getSignature <$> blocks 198 | toSigs = getToSig <$> blocks 199 | -- key for block 0 is the root key 200 | -- key for block n is the key from block (n - 1) 201 | keys = pure rootPk <> (getPublicKey <$> blocks) 202 | keysPayloadsSigs = NE.zipWith attachKey keys (NE.zip toSigs sigs) 203 | 204 | -- external_signature(block_n) = sign(external_key_n, payload_n <> public_key_n-1) 205 | -- so we need to pair each block with the public key carried by the previous block 206 | -- (the authority block can't have an external signature) 207 | previousKeys = getPublicKey <$> NE.init blocks 208 | blocksAfterAuthority = NE.tail blocks 209 | eKeysPayloadsESigs = catMaybes $ zipWith getExternalSigPayload previousKeys blocksAfterAuthority 210 | in all (uncurry3 verify) keysPayloadsSigs 211 | && all (uncurry3 verify) eKeysPayloadsESigs 212 | 213 | verifySecretProof :: SecretKey 214 | -> SignedBlock 215 | -> Bool 216 | verifySecretProof nextSecret (_, _, lastPk, _) = 217 | lastPk == toPublic nextSecret 218 | 219 | verifySignatureProof :: Signature 220 | -> SignedBlock 221 | -> Bool 222 | verifySignatureProof extraSig (lastPayload, Signature lastSig, lastPk, _) = 223 | let toSign = lastPayload <> serializePublicKey lastPk <> lastSig 224 | in verify lastPk toSign extraSig 225 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Datalog/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskellQuotes #-} 10 | {-# LANGUAGE TupleSections #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-| 13 | Module : Auth.Biscuit.Datalog.AST 14 | Copyright : © Clément Delafargue, 2021 15 | License : BSD-3-Clause 16 | Maintainer : clement@delafargue.name 17 | Parser for the authorization language 18 | -} 19 | module Auth.Biscuit.Datalog.Parser 20 | where 21 | 22 | import Auth.Biscuit.Crypto (PublicKey, 23 | readEd25519PublicKey) 24 | import Auth.Biscuit.Datalog.AST 25 | import Auth.Biscuit.Utils (decodeHex) 26 | import Control.Monad (join) 27 | import qualified Control.Monad.Combinators.Expr as Expr 28 | import Data.Bifunctor 29 | import Data.ByteString (ByteString) 30 | import qualified Data.ByteString.Char8 as C8 31 | import Data.Char 32 | import Data.Either (partitionEithers) 33 | import Data.Function ((&)) 34 | import Data.Int (Int64) 35 | import Data.List.NonEmpty (NonEmpty) 36 | import qualified Data.List.NonEmpty as NE 37 | import Data.Map.Strict (Map) 38 | import Data.Maybe (isJust) 39 | import Data.Set (Set) 40 | import qualified Data.Set as Set 41 | import Data.Text (Text) 42 | import qualified Data.Text as T 43 | import Data.Time (UTCTime, defaultTimeLocale, 44 | parseTimeM) 45 | import Instances.TH.Lift () 46 | import Language.Haskell.TH 47 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 48 | import Language.Haskell.TH.Syntax (Lift) 49 | import Text.Megaparsec 50 | import qualified Text.Megaparsec.Char as C 51 | import qualified Text.Megaparsec.Char.Lexer as L 52 | import Validation (Validation (..), 53 | validationToEither) 54 | 55 | type Parser = Parsec SemanticError Text 56 | 57 | type Span = (Int, Int) 58 | 59 | data SemanticError = 60 | VarInFact Span 61 | | VarInSet Span 62 | | NestedSet Span 63 | | InvalidBs Text Span 64 | | InvalidPublicKey Text Span 65 | | UnboundVariables (NonEmpty Text) Span 66 | | PreviousInAuthorizer Span 67 | deriving stock (Eq, Ord) 68 | 69 | instance ShowErrorComponent SemanticError where 70 | showErrorComponent = \case 71 | VarInFact _ -> "Variables can't appear in a fact" 72 | VarInSet _ -> "Variables can't appear in a set" 73 | NestedSet _ -> "Sets cannot be nested" 74 | InvalidBs e _ -> "Invalid bytestring literal: " <> T.unpack e 75 | InvalidPublicKey e _ -> "Invalid public key: " <> T.unpack e 76 | UnboundVariables e _ -> "Unbound variables: " <> T.unpack (T.intercalate ", " $ NE.toList e) 77 | PreviousInAuthorizer _ -> "'previous' can't appear in an authorizer scope" 78 | 79 | run :: Parser a -> Text -> Either String a 80 | run p = first errorBundlePretty . runParser (l (pure ()) *> l p <* eof) "" 81 | 82 | l :: Parser a -> Parser a 83 | l = L.lexeme $ L.space C.space1 (L.skipLineComment "//") empty 84 | 85 | getSpan :: Parser a -> Parser (Span, a) 86 | getSpan p = do 87 | begin <- getOffset 88 | a <- p 89 | end <- getOffset 90 | pure ((begin, end), a) 91 | 92 | registerError :: (Span -> SemanticError) -> Span -> Parser a 93 | registerError mkError sp = do 94 | let err = FancyError (fst sp) (Set.singleton (ErrorCustom $ mkError sp)) 95 | registerParseError err 96 | pure $ error "delayed parsing error" 97 | 98 | forbid :: (Span -> SemanticError) -> Parser a -> Parser b 99 | forbid mkError p = do 100 | (sp, _) <- getSpan p 101 | registerError mkError sp 102 | 103 | variableParser :: Parser Text 104 | variableParser = 105 | C.char '$' *> takeWhile1P (Just "_, :, or any alphanumeric char") (\c -> c == '_' || c == ':' || isAlphaNum c) 106 | 107 | haskellVariableParser :: Parser Text 108 | haskellVariableParser = l $ do 109 | _ <- chunk "{" 110 | leadingUS <- optional $ C.char '_' 111 | x <- if isJust leadingUS then C.letterChar else C.lowerChar 112 | xs <- takeWhileP (Just "_, ', or any alphanumeric char") (\c -> c == '_' || c == '\'' || isAlphaNum c) 113 | _ <- C.char '}' 114 | pure . maybe id T.cons leadingUS $ T.cons x xs 115 | 116 | setParser :: Parser (Set (Term' 'WithinSet 'InFact 'WithSlices)) 117 | setParser = do 118 | _ <- l $ C.char '[' 119 | ts <- sepBy (termParser (forbid VarInSet variableParser) (forbid NestedSet setParser)) (l $ C.char ',') 120 | _ <- l $ C.char ']' 121 | pure $ Set.fromList ts 122 | 123 | factTermParser :: Parser (Term' 'NotWithinSet 'InFact 'WithSlices) 124 | factTermParser = termParser (forbid VarInFact variableParser) 125 | setParser 126 | 127 | predicateTermParser :: Parser (Term' 'NotWithinSet 'InPredicate 'WithSlices) 128 | predicateTermParser = termParser variableParser 129 | setParser 130 | 131 | termParser :: Parser (VariableType inSet pof) 132 | -> Parser (SetType inSet 'WithSlices) 133 | -> Parser (Term' inSet pof 'WithSlices) 134 | termParser parseVar parseSet = l $ choice 135 | [ Antiquote . Slice <$> haskellVariableParser "parameter (eg. {paramName})" 136 | , Variable <$> parseVar "datalog variable (eg. $variable)" 137 | , TermSet <$> parseSet "set (eg. [1,2,3])" 138 | , LBytes <$> (chunk "hex:" *> hexParser) "hex-encoded bytestring (eg. hex:00ff99)" 139 | , LDate <$> rfc3339DateParser "RFC3339-formatted timestamp (eg. 2022-11-29T00:00:00Z)" 140 | , LInteger <$> intParser "(signed) integer" 141 | , LString . T.pack <$> (C.char '"' *> manyTill L.charLiteral (C.char '"')) "string literal" 142 | , LBool <$> choice [ True <$ chunk "true" 143 | , False <$ chunk "false" 144 | ] 145 | "boolean value (eg. true or false)" 146 | ] 147 | 148 | intParser :: Parser Int64 149 | intParser = do 150 | integer :: Integer <- L.signed C.space L.decimal "(signed) integer" 151 | if integer < fromIntegral (minBound @Int64) 152 | || integer > fromIntegral (maxBound @Int64) 153 | then fail "integer literals must fit in the int64 range" 154 | else pure $ fromIntegral integer 155 | 156 | hexParser :: Parser ByteString 157 | hexParser = do 158 | (sp, hexStr) <- getSpan $ C8.pack <$> some C.hexDigitChar 159 | case decodeHex hexStr of 160 | Left e -> registerError (InvalidBs e) sp 161 | Right bs -> pure bs 162 | 163 | publicKeyParser :: Parser PublicKey 164 | publicKeyParser = do 165 | (sp, hexStr) <- getSpan $ C8.pack <$> (chunk "ed25519/" *> some C.hexDigitChar) 166 | case decodeHex hexStr of 167 | Left e -> registerError (InvalidPublicKey e) sp 168 | Right bs -> case readEd25519PublicKey bs of 169 | Nothing -> registerError (InvalidPublicKey "Invalid ed25519 public key") sp 170 | Just pk -> pure pk 171 | 172 | rfc3339DateParser :: Parser UTCTime 173 | rfc3339DateParser = do 174 | let parseDate = parseTimeM False defaultTimeLocale "%FT%T%Q%EZ" 175 | input <- sequenceA [ 176 | try (sequenceA [ 177 | C.digitChar, 178 | C.digitChar, 179 | C.digitChar, 180 | C.digitChar, 181 | C.char '-', 182 | C.digitChar, 183 | C.digitChar, 184 | C.char '-', 185 | C.digitChar, 186 | C.digitChar, 187 | C.char 'T' 188 | ]), 189 | pure <$> C.digitChar, 190 | pure <$> C.digitChar, 191 | pure <$> C.char ':', 192 | pure <$> C.digitChar, 193 | pure <$> C.digitChar, 194 | pure <$> C.char ':', 195 | pure <$> C.digitChar, 196 | pure <$> C.digitChar, 197 | foldMap join <$> optional (sequenceA [ 198 | pure <$> C.char '.', 199 | some C.digitChar 200 | ]), 201 | choice [ 202 | pure <$> C.char 'Z', 203 | sequenceA [ 204 | choice [C.char '+', C.char '-'], 205 | C.digitChar, 206 | C.digitChar, 207 | C.char ':', 208 | C.digitChar, 209 | C.digitChar 210 | ] 211 | ] 212 | ] 213 | parseDate $ join input 214 | 215 | predicateParser' :: Parser (Term' 'NotWithinSet pof 'WithSlices) 216 | -> Parser (Predicate' pof 'WithSlices) 217 | predicateParser' parseTerm = l $ do 218 | name <- try . ( "predicate name") $ do 219 | x <- C.letterChar 220 | xs <- takeWhileP (Just "_, :, or any alphanumeric char") (\c -> c == '_' || c == ':' || isAlphaNum c) 221 | _ <- l $ C.char '(' 222 | pure $ T.cons x xs 223 | terms <- sepBy1 parseTerm (l $ C.char ',') 224 | _ <- l $ C.char ')' 225 | pure Predicate { 226 | name, 227 | terms 228 | } 229 | 230 | factParser :: Parser (Predicate' 'InFact 'WithSlices) 231 | factParser = predicateParser' factTermParser 232 | 233 | predicateParser :: Parser (Predicate' 'InPredicate 'WithSlices) 234 | predicateParser = predicateParser' predicateTermParser 235 | 236 | expressionParser :: Parser (Expression' 'WithSlices) 237 | expressionParser = 238 | let base = choice [ try methodsParser 239 | , exprTerm 240 | ] 241 | in Expr.makeExprParser base table 242 | 243 | table :: [[Expr.Operator Parser (Expression' 'WithSlices)]] 244 | table = 245 | let infixL name op = Expr.InfixL (EBinary op <$ l (chunk name) "infix operator") 246 | infixN name op = Expr.InfixN (EBinary op <$ l (chunk name) "infix operator") 247 | prefix name op = Expr.Prefix (EUnary op <$ l (chunk name) "prefix operator") 248 | in [ [ prefix "!" Negate] 249 | , [ infixL "*" Mul 250 | , infixL "/" Div 251 | ] 252 | , [ infixL "+" Add 253 | , infixL "-" Sub 254 | ] 255 | -- TODO find a better way to avoid eager parsing 256 | -- of && and || by the bitwise operators 257 | , [ infixL "& " BitwiseAnd ] 258 | , [ infixL "| " BitwiseOr ] 259 | , [ infixL "^" BitwiseXor ] 260 | , [ infixN "<=" LessOrEqual 261 | , infixN ">=" GreaterOrEqual 262 | , infixN "<" LessThan 263 | , infixN ">" GreaterThan 264 | , infixN "==" Equal 265 | , infixN "!=" NotEqual 266 | ] 267 | , [ infixL "&&" And ] 268 | , [ infixL "||" Or ] 269 | ] 270 | 271 | binaryMethodParser :: Parser (Expression' 'WithSlices -> Expression' 'WithSlices) 272 | binaryMethodParser = do 273 | _ <- C.char '.' 274 | method <- choice 275 | [ Contains <$ chunk "contains" 276 | , Intersection <$ chunk "intersection" 277 | , Union <$ chunk "union" 278 | , Prefix <$ chunk "starts_with" 279 | , Suffix <$ chunk "ends_with" 280 | , Regex <$ chunk "matches" 281 | ] 282 | _ <- l $ C.char '(' 283 | e2 <- l expressionParser 284 | _ <- l $ C.char ')' 285 | pure $ \e1 -> EBinary method e1 e2 286 | 287 | unaryMethodParser :: Parser (Expression' 'WithSlices -> Expression' 'WithSlices) 288 | unaryMethodParser = do 289 | _ <- C.char '.' 290 | method <- Length <$ chunk "length" 291 | _ <- l $ chunk "()" 292 | pure $ EUnary method 293 | 294 | methodsParser :: Parser (Expression' 'WithSlices) 295 | methodsParser = do 296 | e1 <- exprTerm 297 | methods <- some (try binaryMethodParser <|> unaryMethodParser) 298 | pure $ foldl (&) e1 methods 299 | 300 | unaryParens :: Parser (Expression' 'WithSlices) 301 | unaryParens = do 302 | _ <- l $ C.char '(' 303 | e <- l expressionParser 304 | _ <- l $ C.char ')' 305 | pure $ EUnary Parens e 306 | 307 | exprTerm :: Parser (Expression' 'WithSlices) 308 | exprTerm = choice 309 | [ unaryParens "parens" 310 | , EValue <$> predicateTermParser 311 | ] 312 | 313 | ruleParser :: Bool -> Parser (Rule' 'Repr 'WithSlices) 314 | ruleParser inAuthorizer = do 315 | begin <- getOffset 316 | rhead <- try $ l predicateParser <* l (chunk "<-") 317 | (body, expressions, scope) <- ruleBodyParser inAuthorizer 318 | end <- getOffset 319 | case makeRule rhead body expressions scope of 320 | Failure vs -> registerError (UnboundVariables vs) (begin, end) 321 | Success r -> pure r 322 | 323 | ruleBodyParser :: Bool -> Parser ([Predicate' 'InPredicate 'WithSlices], [Expression' 'WithSlices], Set.Set (RuleScope' 'Repr 'WithSlices)) 324 | ruleBodyParser inAuthorizer = do 325 | let predicateOrExprParser = 326 | Left <$> (predicateParser "predicate") 327 | <|> Right <$> (expressionParser "expression") 328 | elems <- l $ sepBy1 (l predicateOrExprParser) 329 | (l $ C.char ',') 330 | scope <- option Set.empty $ scopeParser inAuthorizer 331 | let (predicates, expressions) = partitionEithers elems 332 | pure (predicates, expressions, scope) 333 | 334 | scopeParser :: Bool -> Parser (Set.Set (RuleScope' 'Repr 'WithSlices)) 335 | scopeParser inAuthorizer = ( "scope annotation") $ do 336 | _ <- l $ chunk "trusting " 337 | let elemParser = do 338 | (sp, s) <- getSpan $ choice [ OnlyAuthority <$ chunk "authority" 339 | , Previous <$ chunk "previous" 340 | , BlockId <$> 341 | choice [ PkSlice <$> haskellVariableParser "parameter (eg. {paramName})" 342 | , Pk <$> publicKeyParser "public key (eg. ed25519/00ff99)" 343 | ] 344 | ] 345 | if inAuthorizer && s == Previous 346 | then registerError PreviousInAuthorizer sp 347 | else pure s 348 | Set.fromList <$> sepBy1 (l elemParser) 349 | (l $ C.char ',') 350 | 351 | queryItemParser :: Bool -> Parser (QueryItem' 'Repr 'WithSlices) 352 | queryItemParser inAuthorizer = do 353 | (sp, (predicates, expressions, scope)) <- getSpan $ ruleBodyParser inAuthorizer 354 | case makeQueryItem predicates expressions scope of 355 | Failure e -> registerError (UnboundVariables e) sp 356 | Success qi -> pure qi 357 | 358 | queryParser :: Bool -> Parser [QueryItem' 'Repr 'WithSlices] 359 | queryParser inAuthorizer = 360 | sepBy1 (queryItemParser inAuthorizer) (l $ C.string' "or" <* C.space) 361 | "datalog query" 362 | 363 | checkParser :: Bool -> Parser (Check' 'Repr 'WithSlices) 364 | checkParser inAuthorizer = do 365 | cKind <- l $ choice [ One <$ chunk "check if" 366 | , All <$ chunk "check all" 367 | ] 368 | cQueries <- queryParser inAuthorizer 369 | pure Check{..} 370 | 371 | policyParser :: Parser (Policy' 'Repr 'WithSlices) 372 | policyParser = do 373 | policy <- l $ choice [ Allow <$ chunk "allow if" 374 | , Deny <$ chunk "deny if" 375 | ] 376 | (policy, ) <$> queryParser True 377 | 378 | blockElementParser :: Bool -> Parser (BlockElement' 'Repr 'WithSlices) 379 | blockElementParser inAuthorizer = choice 380 | [ BlockCheck <$> checkParser inAuthorizer <* C.char ';' "check" 381 | , BlockRule <$> ruleParser inAuthorizer <* C.char ';' "rule" 382 | , BlockFact <$> factParser <* C.char ';' "fact" 383 | ] 384 | 385 | authorizerElementParser :: Parser (AuthorizerElement' 'Repr 'WithSlices) 386 | authorizerElementParser = choice 387 | [ AuthorizerPolicy <$> policyParser <* C.char ';' "policy" 388 | , BlockElement <$> blockElementParser True 389 | ] 390 | 391 | blockParser :: Parser (Block' 'Repr 'WithSlices) 392 | blockParser = do 393 | bScope <- option Set.empty $ l (scopeParser False <* C.char ';' "scope annotation") 394 | elems <- many $ l $ blockElementParser False 395 | pure $ (foldMap elementToBlock elems) { bScope = bScope } 396 | 397 | authorizerParser :: Parser (Authorizer' 'Repr 'WithSlices) 398 | authorizerParser = do 399 | bScope <- option Set.empty $ l (scopeParser True <* C.char ';' "scope annotation") 400 | elems <- many $ l authorizerElementParser 401 | let addScope a = a { vBlock = (vBlock a) { bScope = bScope } } 402 | pure $ addScope $ foldMap elementToAuthorizer elems 403 | 404 | parseWithParams :: Parser (a 'WithSlices) 405 | -> (Map Text Value -> Map Text PublicKey -> a 'WithSlices -> Validation (NonEmpty Text) (a 'Representation)) 406 | -> Text 407 | -> Map Text Value -> Map Text PublicKey 408 | -> Either (NonEmpty Text) (a 'Representation) 409 | parseWithParams parser substitute input termMapping keyMapping = do 410 | withSlices <- first (pure . T.pack) $ run parser input 411 | validationToEither $ substitute termMapping keyMapping withSlices 412 | 413 | parseBlock :: Text -> Map Text Value -> Map Text PublicKey 414 | -> Either (NonEmpty Text) Block 415 | parseBlock = parseWithParams blockParser substituteBlock 416 | 417 | parseAuthorizer :: Text -> Map Text Value -> Map Text PublicKey 418 | -> Either (NonEmpty Text) Authorizer 419 | parseAuthorizer = parseWithParams authorizerParser substituteAuthorizer 420 | 421 | compileParser :: Lift a => Parser a -> (a -> Q Exp) -> String -> Q Exp 422 | compileParser p build = 423 | either fail build . run p . T.pack 424 | 425 | -- | Quasiquoter for a rule expression. You can reference haskell variables 426 | -- like this: @{variableName}@. 427 | -- 428 | -- You most likely want to directly use 'block' or 'authorizer' instead. 429 | rule :: QuasiQuoter 430 | rule = QuasiQuoter 431 | { quoteExp = compileParser (ruleParser False) $ \result -> [| result :: Rule |] 432 | , quotePat = error "not supported" 433 | , quoteType = error "not supported" 434 | , quoteDec = error "not supported" 435 | } 436 | 437 | -- | Quasiquoter for a predicate expression. You can reference haskell variables 438 | -- like this: @{variableName}@. 439 | -- 440 | -- You most likely want to directly use 'block' or 'authorizer' instead. 441 | predicate :: QuasiQuoter 442 | predicate = QuasiQuoter 443 | { quoteExp = compileParser predicateParser $ \result -> [| result :: Predicate |] 444 | , quotePat = error "not supported" 445 | , quoteType = error "not supported" 446 | , quoteDec = error "not supported" 447 | } 448 | 449 | -- | Quasiquoter for a fact expression. You can reference haskell variables 450 | -- like this: @{variableName}@. 451 | -- 452 | -- You most likely want to directly use 'block' or 'authorizer' instead. 453 | fact :: QuasiQuoter 454 | fact = QuasiQuoter 455 | { quoteExp = compileParser factParser $ \result -> [| result :: Fact |] 456 | , quotePat = error "not supported" 457 | , quoteType = error "not supported" 458 | , quoteDec = error "not supported" 459 | } 460 | 461 | -- | Quasiquoter for a check expression. You can reference haskell variables 462 | -- like this: @{variableName}@. 463 | -- 464 | -- You most likely want to directly use 'block' or 'authorizer' instead. 465 | check :: QuasiQuoter 466 | check = QuasiQuoter 467 | { quoteExp = compileParser (checkParser False) $ \result -> [| result :: Check |] 468 | , quotePat = error "not supported" 469 | , quoteType = error "not supported" 470 | , quoteDec = error "not supported" 471 | } 472 | 473 | -- | Compile-time parser for a block expression, intended to be used with the 474 | -- @QuasiQuotes@ extension. 475 | -- 476 | -- A typical use of 'block' looks like this: 477 | -- 478 | -- > let fileName = "data.pdf" 479 | -- > in [block| 480 | -- > // datalog can reference haskell variables with {variableName} 481 | -- > resource({fileName}); 482 | -- > rule($variable) <- fact($value), other_fact($value); 483 | -- > check if operation("read"); 484 | -- > |] 485 | block :: QuasiQuoter 486 | block = QuasiQuoter 487 | { quoteExp = compileParser blockParser $ \result -> [| result :: Block |] 488 | , quotePat = error "not supported" 489 | , quoteType = error "not supported" 490 | , quoteDec = error "not supported" 491 | } 492 | 493 | -- | Compile-time parser for an authorizer expression, intended to be used with the 494 | -- @QuasiQuotes@ extension. 495 | -- 496 | -- A typical use of 'authorizer' looks like this: 497 | -- 498 | -- > do 499 | -- > now <- getCurrentTime 500 | -- > pure [authorizer| 501 | -- > // datalog can reference haskell variables with {variableName} 502 | -- > current_time({now}); 503 | -- > // authorizers can contain facts, rules and checks like blocks, but 504 | -- > // also declare policies. While every check has to pass for a biscuit to 505 | -- > // be valid, policies are tried in order. The first one to match decides 506 | -- > // if the token is valid or not 507 | -- > allow if resource("file1"); 508 | -- > deny if true; 509 | -- > |] 510 | authorizer :: QuasiQuoter 511 | authorizer = QuasiQuoter 512 | { quoteExp = compileParser authorizerParser $ \result -> [| result :: Authorizer |] 513 | , quotePat = error "not supported" 514 | , quoteType = error "not supported" 515 | , quoteDec = error "not supported" 516 | } 517 | 518 | -- | Compile-time parser for a query expression, intended to be used with the 519 | -- @QuasiQuotes@ extension. 520 | -- 521 | -- A typical use of 'query' looks like this: 522 | -- 523 | -- > [query|user($user_id) or group($group_id)|] 524 | query :: QuasiQuoter 525 | query = QuasiQuoter 526 | { quoteExp = compileParser (queryParser False) $ \result -> [| result :: Query |] 527 | , quotePat = error "not supported" 528 | , quoteType = error "not supported" 529 | , quoteDec = error "not supported" 530 | } 531 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Datalog/ScopedExecutor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE TupleSections #-} 11 | {-| 12 | Module : Auth.Biscuit.Datalog.Executor 13 | Copyright : © Clément Delafargue, 2021 14 | License : BSD-3-Clause 15 | Maintainer : clement@delafargue.name 16 | Wrapper for the executor engine that makes sure facts are properly scoped 17 | -} 18 | module Auth.Biscuit.Datalog.ScopedExecutor 19 | ( BlockWithRevocationId 20 | , runAuthorizer 21 | , runAuthorizerWithLimits 22 | , runAuthorizerNoTimeout 23 | , runFactGeneration 24 | , PureExecError (..) 25 | , AuthorizationSuccess (..) 26 | , getBindings 27 | , queryGeneratedFacts 28 | , queryAvailableFacts 29 | , getVariableValues 30 | , getSingleVariableValue 31 | , FactGroup (..) 32 | , collectWorld 33 | ) where 34 | 35 | import Control.Monad (unless, when) 36 | import Control.Monad.State (StateT (..), evalStateT, get, 37 | gets, lift, put) 38 | import Data.Bifunctor (first) 39 | import Data.ByteString (ByteString) 40 | import Data.Foldable (sequenceA_) 41 | import Data.List (genericLength) 42 | import Data.List.NonEmpty (NonEmpty) 43 | import qualified Data.List.NonEmpty as NE 44 | import Data.Map (Map) 45 | import qualified Data.Map as Map 46 | import Data.Map.Strict ((!?)) 47 | import Data.Set (Set) 48 | import qualified Data.Set as Set 49 | import Data.Text (Text) 50 | import Numeric.Natural (Natural) 51 | import Validation (Validation (..)) 52 | 53 | import Auth.Biscuit.Crypto (PublicKey) 54 | import Auth.Biscuit.Datalog.AST 55 | import Auth.Biscuit.Datalog.Executor (Bindings, ExecutionError (..), 56 | FactGroup (..), Limits (..), 57 | MatchedQuery (..), 58 | ResultError (..), Scoped, 59 | checkCheck, checkPolicy, 60 | countFacts, defaultLimits, 61 | fromScopedFacts, 62 | getBindingsForRuleBody, 63 | getFactsForRule, 64 | keepAuthorized', toScopedFacts) 65 | import Auth.Biscuit.Datalog.Parser (fact) 66 | import Auth.Biscuit.Timer (timer) 67 | import Auth.Biscuit.Utils (foldMapM, mapMaybeM) 68 | import Data.Bitraversable (bisequence) 69 | 70 | type BlockWithRevocationId = (Block, ByteString, Maybe PublicKey) 71 | 72 | -- | A subset of 'ExecutionError' that can only happen during fact generation 73 | data PureExecError = Facts | Iterations | BadRule | BadExpression String 74 | deriving (Eq, Show) 75 | 76 | -- | Proof that a biscuit was authorized successfully. In addition to the matched 77 | -- @allow query@, the generated facts are kept around for further querying. 78 | -- Since only authority facts can be trusted, they are kept separate. 79 | data AuthorizationSuccess 80 | = AuthorizationSuccess 81 | { matchedAllowQuery :: MatchedQuery 82 | -- ^ The allow query that matched 83 | , allFacts :: FactGroup 84 | -- ^ All the facts that were generated by the biscuit, grouped by their origin 85 | , limits :: Limits 86 | -- ^ Limits used when running datalog. It is kept around to allow further 87 | -- datalog computation when querying facts 88 | } 89 | deriving (Eq, Show) 90 | 91 | -- | Get the matched variables from the @allow@ query used to authorize the biscuit. 92 | -- This can be used in conjuction with 'getVariableValues' or 'getSingleVariableValue' 93 | -- to extract the actual values 94 | getBindings :: AuthorizationSuccess -> Set Bindings 95 | getBindings AuthorizationSuccess{matchedAllowQuery=MatchedQuery{bindings}} = bindings 96 | 97 | -- | Given a series of blocks and an authorizer, ensure that all 98 | -- the checks and policies match 99 | runAuthorizer :: BlockWithRevocationId 100 | -- ^ The authority block 101 | -> [BlockWithRevocationId] 102 | -- ^ The extra blocks 103 | -> Authorizer 104 | -- ^ A authorizer 105 | -> IO (Either ExecutionError AuthorizationSuccess) 106 | runAuthorizer = runAuthorizerWithLimits defaultLimits 107 | 108 | -- | Given a series of blocks and an authorizer, ensure that all 109 | -- the checks and policies match, with provided execution 110 | -- constraints 111 | runAuthorizerWithLimits :: Limits 112 | -- ^ custom limits 113 | -> BlockWithRevocationId 114 | -- ^ The authority block 115 | -> [BlockWithRevocationId] 116 | -- ^ The extra blocks 117 | -> Authorizer 118 | -- ^ A authorizer 119 | -> IO (Either ExecutionError AuthorizationSuccess) 120 | runAuthorizerWithLimits l@Limits{..} authority blocks v = do 121 | resultOrTimeout <- timer maxTime $ pure $ runAuthorizerNoTimeout l authority blocks v 122 | pure $ case resultOrTimeout of 123 | Nothing -> Left Timeout 124 | Just r -> r 125 | 126 | 127 | mkRevocationIdFacts :: BlockWithRevocationId -> [BlockWithRevocationId] 128 | -> Set Fact 129 | mkRevocationIdFacts authority blocks = 130 | let allIds :: [(Int, ByteString)] 131 | allIds = zip [0..] $ snd' <$> authority : blocks 132 | snd' (_,b,_) = b 133 | mkFact (index, rid) = [fact|revocation_id({index}, {rid})|] 134 | in Set.fromList $ mkFact <$> allIds 135 | 136 | data ComputeState 137 | = ComputeState 138 | { sLimits :: Limits -- readonly 139 | , sRules :: Map Natural (Set EvalRule) -- readonly 140 | , sBlockCount :: Natural 141 | -- state 142 | , sIterations :: Int -- elapsed iterations 143 | , sFacts :: FactGroup -- facts generated so far 144 | } 145 | deriving (Eq, Show) 146 | 147 | mkInitState :: Limits -> BlockWithRevocationId -> [BlockWithRevocationId] -> Authorizer -> ComputeState 148 | mkInitState limits authority blocks authorizer = 149 | let fst' (a,_,_) = a 150 | trd' (_,_,c) = c 151 | sBlockCount = 1 + genericLength blocks 152 | externalKeys = Nothing : (trd' <$> blocks) 153 | revocationWorld = (mempty, FactGroup $ Map.singleton (Set.singleton sBlockCount) $ mkRevocationIdFacts authority blocks) 154 | firstBlock = fst' authority 155 | otherBlocks = fst' <$> blocks 156 | allBlocks = zip [0..] (firstBlock : otherBlocks) <> [(sBlockCount, vBlock authorizer)] 157 | (sRules, sFacts) = revocationWorld <> foldMap (uncurry collectWorld . fmap (toEvaluation externalKeys)) allBlocks 158 | in ComputeState 159 | { sLimits = limits 160 | , sRules 161 | , sBlockCount 162 | , sIterations = 0 163 | , sFacts 164 | } 165 | 166 | runAuthorizerNoTimeout :: Limits 167 | -> BlockWithRevocationId 168 | -> [BlockWithRevocationId] 169 | -> Authorizer 170 | -> Either ExecutionError AuthorizationSuccess 171 | runAuthorizerNoTimeout limits authority blocks authorizer = do 172 | let fst' (a,_,_) = a 173 | trd' (_,_,c) = c 174 | blockCount = 1 + genericLength blocks 175 | externalKeys = Nothing : (trd' <$> blocks) 176 | (<$$>) = fmap . fmap 177 | (<$$$>) = fmap . fmap . fmap 178 | initState = mkInitState limits authority blocks authorizer 179 | toExecutionError = \case 180 | Facts -> TooManyFacts 181 | Iterations -> TooManyIterations 182 | BadRule -> InvalidRule 183 | BadExpression e -> EvaluationError e 184 | allFacts <- first toExecutionError $ computeAllFacts initState 185 | let checks = bChecks <$$> ( zip [0..] (fst' <$> authority : blocks) 186 | <> [(blockCount,vBlock authorizer)] 187 | ) 188 | policies = vPolicies authorizer 189 | checkResults = checkChecks limits blockCount allFacts (checkToEvaluation externalKeys <$$$> checks) 190 | policyResults = checkPolicies limits blockCount allFacts (policyToEvaluation externalKeys <$> policies) 191 | case bisequence (checkResults, policyResults) of 192 | Left e -> Left $ EvaluationError e 193 | Right (Success (), Left Nothing) -> Left $ ResultError $ NoPoliciesMatched [] 194 | Right (Success (), Left (Just p)) -> Left $ ResultError $ DenyRuleMatched [] p 195 | Right (Failure cs, Left Nothing) -> Left $ ResultError $ NoPoliciesMatched (NE.toList cs) 196 | Right (Failure cs, Left (Just p)) -> Left $ ResultError $ DenyRuleMatched (NE.toList cs) p 197 | Right (Failure cs, Right _) -> Left $ ResultError $ FailedChecks cs 198 | Right (Success (), Right p) -> Right $ AuthorizationSuccess { matchedAllowQuery = p 199 | , allFacts 200 | , limits 201 | } 202 | 203 | runStep :: StateT ComputeState (Either PureExecError) Int 204 | runStep = do 205 | state@ComputeState{sLimits,sFacts,sRules,sBlockCount,sIterations} <- get 206 | let Limits{maxFacts, maxIterations} = sLimits 207 | previousCount = countFacts sFacts 208 | generatedFacts :: Either PureExecError FactGroup 209 | generatedFacts = first BadExpression $ extend sLimits sBlockCount sRules sFacts 210 | newFacts <- (sFacts <>) <$> lift generatedFacts 211 | let newCount = countFacts newFacts 212 | -- counting the facts returned by `extend` is not equivalent to 213 | -- comparing complete counts, as `extend` may return facts that 214 | -- are already present in `sFacts` 215 | addedFactsCount = newCount - previousCount 216 | when (newCount >= maxFacts) $ lift $ Left Facts 217 | when (sIterations >= maxIterations) $ lift $ Left Iterations 218 | put $ state { sIterations = sIterations + 1 219 | , sFacts = newFacts 220 | } 221 | pure addedFactsCount 222 | 223 | -- | Check if every variable from the head is present in the body 224 | checkRuleHead :: EvalRule -> Bool 225 | checkRuleHead Rule{rhead, body} = 226 | let headVars = extractVariables [rhead] 227 | bodyVars = extractVariables body 228 | in headVars `Set.isSubsetOf` bodyVars 229 | 230 | -- | Repeatedly generate new facts until it converges (no new 231 | -- facts are generated) 232 | computeAllFacts :: ComputeState -> Either PureExecError FactGroup 233 | computeAllFacts initState@ComputeState{sRules} = do 234 | let checkRules = all (all checkRuleHead) sRules 235 | go = do 236 | newFacts <- runStep 237 | if newFacts > 0 then go else gets sFacts 238 | 239 | unless checkRules $ Left BadRule 240 | evalStateT go initState 241 | 242 | -- | Small helper used in tests to directly provide rules and facts without creating 243 | -- a biscuit token 244 | runFactGeneration :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> Either PureExecError FactGroup 245 | runFactGeneration sLimits sBlockCount sRules sFacts = 246 | let initState = ComputeState{sIterations = 0, ..} 247 | in computeAllFacts initState 248 | 249 | checkChecks :: Limits -> Natural -> FactGroup -> [(Natural, [EvalCheck])] -> Either String (Validation (NonEmpty Check) ()) 250 | checkChecks limits blockCount allFacts = 251 | fmap sequenceA_ . traverse (uncurry $ checkChecksForGroup limits blockCount allFacts) 252 | 253 | checkChecksForGroup :: Limits -> Natural -> FactGroup -> Natural -> [EvalCheck] -> Either String (Validation (NonEmpty Check) ()) 254 | checkChecksForGroup limits blockCount allFacts checksBlockId = 255 | fmap sequenceA_ . traverse (checkCheck limits blockCount checksBlockId allFacts) 256 | 257 | checkPolicies :: Limits -> Natural -> FactGroup -> [EvalPolicy] -> Either String (Either (Maybe MatchedQuery) MatchedQuery) 258 | checkPolicies limits blockCount allFacts policies = do 259 | results <- mapMaybeM (checkPolicy limits blockCount allFacts) policies 260 | pure $ case results of 261 | p : _ -> first Just p 262 | [] -> Left Nothing 263 | 264 | -- | Generate new facts by applying rules on existing facts 265 | extend :: Limits -> Natural -> Map Natural (Set EvalRule) -> FactGroup -> Either String FactGroup 266 | extend l blockCount rules facts = 267 | let buildFacts :: Natural -> Set EvalRule -> FactGroup -> Either String (Set (Scoped Fact)) 268 | buildFacts ruleBlockId ruleGroup factGroup = 269 | let extendRule :: EvalRule -> Either String (Set (Scoped Fact)) 270 | extendRule r@Rule{scope} = getFactsForRule l (toScopedFacts $ keepAuthorized' False blockCount factGroup scope ruleBlockId) r 271 | in foldMapM extendRule ruleGroup 272 | 273 | extendRuleGroup :: Natural -> Set EvalRule -> Either String FactGroup 274 | extendRuleGroup ruleBlockId ruleGroup = 275 | -- todo pre-filter facts based on the weakest rule scope to avoid passing too many facts 276 | -- to buildFacts 277 | let authorizedFacts = facts -- test $ keepAuthorized facts $ Set.fromList [0..ruleBlockId] 278 | addRuleOrigin = FactGroup . Map.mapKeysWith (<>) (Set.insert ruleBlockId) . getFactGroup 279 | in addRuleOrigin . fromScopedFacts <$> buildFacts ruleBlockId ruleGroup authorizedFacts 280 | 281 | in foldMapM (uncurry extendRuleGroup) $ Map.toList rules 282 | 283 | 284 | collectWorld :: Natural -> EvalBlock -> (Map Natural (Set EvalRule), FactGroup) 285 | collectWorld blockId Block{..} = 286 | let -- a block can define a default scope for its rule 287 | -- which is used unless the rule itself has defined a scope 288 | applyScope r@Rule{scope} = r { scope = if null scope then bScope else scope } 289 | in ( Map.singleton blockId $ Set.map applyScope $ Set.fromList bRules 290 | , FactGroup $ Map.singleton (Set.singleton blockId) $ Set.fromList bFacts 291 | ) 292 | 293 | queryGeneratedFacts :: [Maybe PublicKey] -> AuthorizationSuccess -> Query -> Either String (Set Bindings) 294 | queryGeneratedFacts ePks AuthorizationSuccess{allFacts, limits} = 295 | queryAvailableFacts ePks allFacts limits 296 | 297 | queryAvailableFacts :: [Maybe PublicKey] -> FactGroup -> Limits -> Query -> Either String (Set Bindings) 298 | queryAvailableFacts ePks allFacts limits q = 299 | let blockCount = genericLength ePks 300 | getBindingsForQueryItem QueryItem{qBody,qExpressions,qScope} = 301 | let facts = toScopedFacts $ keepAuthorized' True blockCount allFacts qScope blockCount 302 | in Set.map snd <$> 303 | getBindingsForRuleBody limits facts qBody qExpressions 304 | in foldMapM (getBindingsForQueryItem . toEvaluation ePks) q 305 | 306 | -- | Extract a set of values from a matched variable for a specific type. 307 | -- Returning @Set Value@ allows to get all values, whatever their type. 308 | getVariableValues :: (Ord t, FromValue t) 309 | => Set Bindings 310 | -> Text 311 | -> Set t 312 | getVariableValues bindings variableName = 313 | let mapMaybeS f = foldMap (foldMap Set.singleton . f) 314 | getVar vars = fromValue =<< vars !? variableName 315 | in mapMaybeS getVar bindings 316 | 317 | -- | Extract exactly one value from a matched variable. If the variable has 0 318 | -- matches or more than one match, 'Nothing' will be returned 319 | getSingleVariableValue :: (Ord t, FromValue t) 320 | => Set Bindings 321 | -> Text 322 | -> Maybe t 323 | getSingleVariableValue bindings variableName = 324 | let values = getVariableValues bindings variableName 325 | in case Set.toList values of 326 | [v] -> Just v 327 | _ -> Nothing 328 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-| 4 | Module : Auth.Biscuit.Example 5 | Copyright : © Clément Delafargue, 2021 6 | License : BSD-3-Clause 7 | Maintainer : clement@delafargue.name 8 | Working examples of biscuit-haskell 9 | -} 10 | module Auth.Biscuit.Example where 11 | 12 | import Data.ByteString (ByteString) 13 | import Data.Functor (($>)) 14 | import Data.Maybe (fromMaybe) 15 | import Data.Text (Text) 16 | import Data.Time (getCurrentTime) 17 | 18 | import Auth.Biscuit 19 | 20 | privateKey' :: SecretKey 21 | privateKey' = fromMaybe (error "Error parsing private key") $ parseSecretKeyHex "a2c4ead323536b925f3488ee83e0888b79c2761405ca7c0c9a018c7c1905eecc" 22 | 23 | publicKey' :: PublicKey 24 | publicKey' = fromMaybe (error "Error parsing public key") $ parsePublicKeyHex "24afd8171d2c0107ec6d5656aa36f8409184c2567649e0a7f66e629cc3dbfd70" 25 | 26 | creation :: IO ByteString 27 | creation = do 28 | let allowedOperations = ["read", "write"] :: [Text] 29 | networkLocal = "192.168.0.1" :: Text 30 | let authority = [block| 31 | // this is a comment 32 | right("file1", {allowedOperations}); 33 | check if source_ip($source_ip), ["127.0.0.1", {networkLocal}].contains($source_ip); 34 | |] 35 | biscuit <- mkBiscuit privateKey' authority 36 | let block1 = [block|check if time($time), $time < 2025-05-08T00:00:00Z;|] 37 | newBiscuit <- addBlock block1 biscuit 38 | pure $ serializeB64 newBiscuit 39 | 40 | verification :: ByteString -> IO Bool 41 | verification serialized = do 42 | now <- getCurrentTime 43 | biscuit <- either (fail . show) pure $ parseB64 publicKey' serialized 44 | let authorizer' = [authorizer| 45 | time({now}); 46 | source_ip("127.0.0.1"); 47 | allow if right("file1", $ops), $ops.contains("read"); 48 | |] 49 | result <- authorizeBiscuit biscuit authorizer' 50 | case result of 51 | Left e -> print e $> False 52 | Right _ -> pure True 53 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Proto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DuplicateRecordFields #-} 6 | {-| 7 | Module : Auth.Biscuit.Proto 8 | Copyright : © Clément Delafargue, 2021 9 | License : BSD-3-Clause 10 | Maintainer : clement@delafargue.name 11 | Haskell data structures mapping the biscuit protobuf definitions 12 | -} 13 | 14 | module Auth.Biscuit.Proto 15 | ( Biscuit (..) 16 | , SignedBlock (..) 17 | , PublicKey (..) 18 | , Algorithm (..) 19 | , ExternalSig (..) 20 | , Proof (..) 21 | , Block (..) 22 | , Scope (..) 23 | , ScopeType (..) 24 | , FactV2 (..) 25 | , RuleV2 (..) 26 | , CheckKind (..) 27 | , CheckV2 (..) 28 | , PredicateV2 (..) 29 | , TermV2 (..) 30 | , ExpressionV2 (..) 31 | , TermSet (..) 32 | , Op (..) 33 | , OpUnary (..) 34 | , UnaryKind (..) 35 | , OpBinary (..) 36 | , BinaryKind (..) 37 | , OpTernary (..) 38 | , TernaryKind (..) 39 | , ThirdPartyBlockContents (..) 40 | , ThirdPartyBlockRequest (..) 41 | , getField 42 | , putField 43 | , decodeBlockList 44 | , decodeBlock 45 | , encodeBlockList 46 | , encodeBlock 47 | , decodeThirdPartyBlockRequest 48 | , decodeThirdPartyBlockContents 49 | , encodeThirdPartyBlockRequest 50 | , encodeThirdPartyBlockContents 51 | ) where 52 | 53 | import Data.ByteString (ByteString) 54 | import Data.Int 55 | import Data.ProtocolBuffers 56 | import Data.Serialize 57 | import Data.Text 58 | import GHC.Generics (Generic) 59 | 60 | data Biscuit = Biscuit 61 | { rootKeyId :: Optional 1 (Value Int32) 62 | , authority :: Required 2 (Message SignedBlock) 63 | , blocks :: Repeated 3 (Message SignedBlock) 64 | , proof :: Required 4 (Message Proof) 65 | } deriving (Generic, Show) 66 | deriving anyclass (Decode, Encode) 67 | 68 | data Proof = 69 | ProofSecret (Required 1 (Value ByteString)) 70 | | ProofSignature (Required 2 (Value ByteString)) 71 | deriving (Generic, Show) 72 | deriving anyclass (Decode, Encode) 73 | 74 | data ExternalSig = ExternalSig 75 | { signature :: Required 1 (Value ByteString) 76 | , publicKey :: Required 2 (Message PublicKey) 77 | } 78 | deriving (Generic, Show) 79 | deriving anyclass (Decode, Encode) 80 | 81 | data SignedBlock = SignedBlock 82 | { block :: Required 1 (Value ByteString) 83 | , nextKey :: Required 2 (Message PublicKey) 84 | , signature :: Required 3 (Value ByteString) 85 | , externalSig :: Optional 4 (Message ExternalSig) 86 | } 87 | deriving (Generic, Show) 88 | deriving anyclass (Decode, Encode) 89 | 90 | data Algorithm = Ed25519 91 | deriving stock (Show, Enum, Bounded) 92 | 93 | data PublicKey = PublicKey 94 | { algorithm :: Required 1 (Enumeration Algorithm) 95 | , key :: Required 2 (Value ByteString) 96 | } 97 | deriving (Generic, Show) 98 | deriving anyclass (Decode, Encode) 99 | 100 | data Block = Block { 101 | symbols :: Repeated 1 (Value Text) 102 | , context :: Optional 2 (Value Text) 103 | , version :: Optional 3 (Value Int32) 104 | , facts_v2 :: Repeated 4 (Message FactV2) 105 | , rules_v2 :: Repeated 5 (Message RuleV2) 106 | , checks_v2 :: Repeated 6 (Message CheckV2) 107 | , scope :: Repeated 7 (Message Scope) 108 | , pksTable :: Repeated 8 (Message PublicKey) 109 | } deriving stock (Generic, Show) 110 | deriving anyclass (Decode, Encode) 111 | 112 | data ScopeType = 113 | ScopeAuthority 114 | | ScopePrevious 115 | deriving stock (Show, Enum, Bounded) 116 | 117 | data Scope = 118 | ScType (Required 1 (Enumeration ScopeType)) 119 | | ScBlock (Required 2 (Value Int64)) 120 | deriving stock (Generic, Show) 121 | deriving anyclass (Decode, Encode) 122 | 123 | newtype FactV2 = FactV2 124 | { predicate :: Required 1 (Message PredicateV2) 125 | } deriving stock (Generic, Show) 126 | deriving anyclass (Decode, Encode) 127 | 128 | data RuleV2 = RuleV2 129 | { head :: Required 1 (Message PredicateV2) 130 | , body :: Repeated 2 (Message PredicateV2) 131 | , expressions :: Repeated 3 (Message ExpressionV2) 132 | , scope :: Repeated 4 (Message Scope) 133 | } deriving stock (Generic, Show) 134 | deriving anyclass (Decode, Encode) 135 | 136 | data CheckKind = 137 | One 138 | | All 139 | deriving stock (Show, Enum, Bounded) 140 | 141 | data CheckV2 = CheckV2 142 | { queries :: Repeated 1 (Message RuleV2) 143 | , kind :: Optional 2 (Enumeration CheckKind) 144 | } deriving stock (Generic, Show) 145 | deriving anyclass (Decode, Encode) 146 | 147 | data PredicateV2 = PredicateV2 148 | { name :: Required 1 (Value Int64) 149 | , terms :: Repeated 2 (Message TermV2) 150 | } deriving stock (Generic, Show) 151 | deriving anyclass (Decode, Encode) 152 | 153 | data TermV2 = 154 | TermVariable (Required 1 (Value Int64)) 155 | | TermInteger (Required 2 (Value Int64)) 156 | | TermString (Required 3 (Value Int64)) 157 | | TermDate (Required 4 (Value Int64)) 158 | | TermBytes (Required 5 (Value ByteString)) 159 | | TermBool (Required 6 (Value Bool)) 160 | | TermTermSet (Required 7 (Message TermSet)) 161 | deriving stock (Generic, Show) 162 | deriving anyclass (Decode, Encode) 163 | 164 | 165 | newtype TermSet = TermSet 166 | { set :: Repeated 1 (Message TermV2) 167 | } deriving stock (Generic, Show) 168 | deriving anyclass (Decode, Encode) 169 | 170 | newtype ExpressionV2 = ExpressionV2 171 | { ops :: Repeated 1 (Message Op) 172 | } deriving stock (Generic, Show) 173 | deriving anyclass (Decode, Encode) 174 | 175 | data Op = 176 | OpVValue (Required 1 (Message TermV2)) 177 | | OpVUnary (Required 2 (Message OpUnary)) 178 | | OpVBinary (Required 3 (Message OpBinary)) 179 | deriving stock (Generic, Show) 180 | deriving anyclass (Decode, Encode) 181 | 182 | data UnaryKind = Negate | Parens | Length 183 | deriving stock (Show, Enum, Bounded) 184 | 185 | newtype OpUnary = OpUnary 186 | { kind :: Required 1 (Enumeration UnaryKind) 187 | } deriving stock (Generic, Show) 188 | deriving anyclass (Decode, Encode) 189 | 190 | data BinaryKind = 191 | LessThan 192 | | GreaterThan 193 | | LessOrEqual 194 | | GreaterOrEqual 195 | | Equal 196 | | Contains 197 | | Prefix 198 | | Suffix 199 | | Regex 200 | | Add 201 | | Sub 202 | | Mul 203 | | Div 204 | | And 205 | | Or 206 | | Intersection 207 | | Union 208 | | BitwiseAnd 209 | | BitwiseOr 210 | | BitwiseXor 211 | | NotEqual 212 | deriving stock (Show, Enum, Bounded) 213 | 214 | newtype OpBinary = OpBinary 215 | { kind :: Required 1 (Enumeration BinaryKind) 216 | } deriving stock (Generic, Show) 217 | deriving anyclass (Decode, Encode) 218 | 219 | data TernaryKind = 220 | VerifyEd25519Signature 221 | deriving stock (Show, Enum, Bounded) 222 | 223 | newtype OpTernary = OpTernary 224 | { kind :: Required 1 (Enumeration TernaryKind) 225 | } deriving stock (Generic, Show) 226 | deriving anyclass (Decode, Encode) 227 | 228 | decodeBlockList :: ByteString 229 | -> Either String Biscuit 230 | decodeBlockList = runGet decodeMessage 231 | 232 | decodeBlock :: ByteString 233 | -> Either String Block 234 | decodeBlock = runGet decodeMessage 235 | 236 | encodeBlockList :: Biscuit -> ByteString 237 | encodeBlockList = runPut . encodeMessage 238 | 239 | encodeBlock :: Block -> ByteString 240 | encodeBlock = runPut . encodeMessage 241 | 242 | encodeThirdPartyBlockRequest :: ThirdPartyBlockRequest -> ByteString 243 | encodeThirdPartyBlockRequest = runPut . encodeMessage 244 | 245 | encodeThirdPartyBlockContents :: ThirdPartyBlockContents -> ByteString 246 | encodeThirdPartyBlockContents = runPut . encodeMessage 247 | 248 | decodeThirdPartyBlockRequest :: ByteString -> Either String ThirdPartyBlockRequest 249 | decodeThirdPartyBlockRequest = runGet decodeMessage 250 | 251 | decodeThirdPartyBlockContents :: ByteString -> Either String ThirdPartyBlockContents 252 | decodeThirdPartyBlockContents = runGet decodeMessage 253 | 254 | data ThirdPartyBlockRequest 255 | = ThirdPartyBlockRequest 256 | { previousPk :: Required 1 (Message PublicKey) 257 | , pkTable :: Repeated 2 (Message PublicKey) 258 | } deriving stock (Generic, Show) 259 | deriving anyclass (Decode, Encode) 260 | 261 | data ThirdPartyBlockContents 262 | = ThirdPartyBlockContents 263 | { payload :: Required 1 (Value ByteString) 264 | , externalSig :: Required 2 (Message ExternalSig) 265 | } deriving stock (Generic, Show) 266 | deriving anyclass (Decode, Encode) 267 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-| 9 | Module : Auth.Biscuit.Utils 10 | Copyright : © Clément Delafargue, 2021 11 | License : BSD-3-Clause 12 | Maintainer : clement@delafargue.name 13 | Conversion functions between biscuit components and protobuf-encoded components 14 | -} 15 | module Auth.Biscuit.ProtoBufAdapter 16 | ( Symbols 17 | , buildSymbolTable 18 | , pbToBlock 19 | , blockToPb 20 | , pbToSignedBlock 21 | , signedBlockToPb 22 | , pbToProof 23 | , pbToThirdPartyBlockRequest 24 | , thirdPartyBlockRequestToPb 25 | , pbToThirdPartyBlockContents 26 | , thirdPartyBlockContentsToPb 27 | ) where 28 | 29 | import Control.Monad (unless, when) 30 | import Control.Monad.State (StateT, get, lift, modify) 31 | import Data.ByteString (ByteString) 32 | import Data.Int (Int64) 33 | import qualified Data.List.NonEmpty as NE 34 | import Data.Maybe (isJust, isNothing) 35 | import qualified Data.Set as Set 36 | import qualified Data.Text as T 37 | import Data.Time (UTCTime) 38 | import Data.Time.Clock.POSIX (posixSecondsToUTCTime, 39 | utcTimeToPOSIXSeconds) 40 | import Data.Void (absurd) 41 | import GHC.Records (getField) 42 | import Validation (Validation (..)) 43 | 44 | import qualified Auth.Biscuit.Crypto as Crypto 45 | import Auth.Biscuit.Datalog.AST 46 | import qualified Auth.Biscuit.Proto as PB 47 | import Auth.Biscuit.Symbols 48 | import Auth.Biscuit.Utils (maybeToRight) 49 | 50 | buildSymbolTable :: Symbols -> Block -> BlockSymbols 51 | buildSymbolTable existingSymbols block = 52 | let allSymbols = listSymbolsInBlock block 53 | allKeys = listPublicKeysInBlock block 54 | in addSymbols existingSymbols allSymbols allKeys 55 | 56 | pbToPublicKey :: PB.PublicKey -> Either String Crypto.PublicKey 57 | pbToPublicKey PB.PublicKey{..} = 58 | let keyBytes = PB.getField key 59 | parseKey = Crypto.readEd25519PublicKey 60 | in case PB.getField algorithm of 61 | PB.Ed25519 -> maybeToRight "Invalid ed25519 public key" $ parseKey keyBytes 62 | 63 | pbToOptionalSignature :: PB.ExternalSig -> Either String (Crypto.Signature, Crypto.PublicKey) 64 | pbToOptionalSignature PB.ExternalSig{..} = do 65 | let sig = Crypto.signature $ PB.getField signature 66 | pk <- pbToPublicKey $ PB.getField publicKey 67 | pure (sig, pk) 68 | 69 | -- | Parse a protobuf signed block into a signed biscuit block 70 | pbToSignedBlock :: PB.SignedBlock -> Either String Crypto.SignedBlock 71 | pbToSignedBlock PB.SignedBlock{..} = do 72 | let sig = Crypto.signature $ PB.getField signature 73 | mSig <- traverse pbToOptionalSignature $ PB.getField externalSig 74 | pk <- pbToPublicKey $ PB.getField nextKey 75 | pure ( PB.getField block 76 | , sig 77 | , pk 78 | , mSig 79 | ) 80 | 81 | publicKeyToPb :: Crypto.PublicKey -> PB.PublicKey 82 | publicKeyToPb pk = PB.PublicKey 83 | { algorithm = PB.putField PB.Ed25519 84 | , key = PB.putField $ Crypto.pkBytes pk 85 | } 86 | 87 | externalSigToPb :: (Crypto.Signature, Crypto.PublicKey) -> PB.ExternalSig 88 | externalSigToPb (sig, pk) = PB.ExternalSig 89 | { signature = PB.putField $ Crypto.sigBytes sig 90 | , publicKey = PB.putField $ publicKeyToPb pk 91 | } 92 | 93 | signedBlockToPb :: Crypto.SignedBlock -> PB.SignedBlock 94 | signedBlockToPb (block, sig, pk, eSig) = PB.SignedBlock 95 | { block = PB.putField block 96 | , signature = PB.putField $ Crypto.sigBytes sig 97 | , nextKey = PB.putField $ publicKeyToPb pk 98 | , externalSig = PB.putField $ externalSigToPb <$> eSig 99 | } 100 | 101 | pbToProof :: PB.Proof -> Either String (Either Crypto.Signature Crypto.SecretKey) 102 | pbToProof (PB.ProofSignature rawSig) = Left <$> Right (Crypto.signature $ PB.getField rawSig) 103 | pbToProof (PB.ProofSecret rawPk) = Right <$> maybeToRight "Invalid public key proof" (Crypto.readEd25519SecretKey $ PB.getField rawPk) 104 | 105 | pbToBlock :: Maybe Crypto.PublicKey -> PB.Block -> StateT Symbols (Either String) Block 106 | pbToBlock ePk PB.Block{..} = do 107 | blockPks <- lift $ traverse pbToPublicKey $ PB.getField pksTable 108 | let blockSymbols = PB.getField symbols 109 | -- third party blocks use an isolated symbol table, 110 | -- but use the global public keys table: 111 | -- symbols defined in 3rd party blocks are not visible 112 | -- to following blocks, but public keys are 113 | when (isNothing ePk) $ do 114 | modify (registerNewSymbols blockSymbols) 115 | modify (registerNewPublicKeys blockPks) 116 | currentSymbols <- get 117 | 118 | let symbolsForCurrentBlock = 119 | -- third party blocks use an isolated symbol and public keys table, 120 | -- 3rd party blocks don't see previously defined 121 | -- symbols or public keys 122 | if isNothing ePk then currentSymbols 123 | else registerNewPublicKeys blockPks $ registerNewSymbols blockSymbols newSymbolTable 124 | let bContext = PB.getField context 125 | bVersion = PB.getField version 126 | lift $ do 127 | let s = symbolsForCurrentBlock 128 | bFacts <- traverse (pbToFact s) $ PB.getField facts_v2 129 | bRules <- traverse (pbToRule s) $ PB.getField rules_v2 130 | bChecks <- traverse (pbToCheck s) $ PB.getField checks_v2 131 | bScope <- Set.fromList <$> traverse (pbToScope s) (PB.getField scope) 132 | let v5Plus = isJust ePk 133 | v4Plus = not $ and 134 | [ Set.null bScope 135 | , all ruleHasNoScope bRules 136 | , all (queryHasNoScope . cQueries) bChecks 137 | , all isCheckOne bChecks 138 | , all ruleHasNoV4Operators bRules 139 | , all (queryHasNoV4Operators . cQueries) bChecks 140 | ] 141 | case (bVersion, v4Plus, v5Plus) of 142 | (Just 5, _, _) -> pure Block {..} 143 | (Just 4, _, False) -> pure Block {..} 144 | (Just 4, _, True) -> 145 | Left "Biscuit v5 features are present, but the block version is 4." 146 | (Just 3, False, False) -> pure Block {..} 147 | (Just 3, True, False) -> 148 | Left "Biscuit v4 features are present, but the block version is 3." 149 | (Just 3, _, True) -> 150 | Left "Biscuit v5 features are present, but the block version is 3." 151 | _ -> 152 | Left $ "Unsupported biscuit version: " <> maybe "0" show bVersion <> ". Only versions 3 and 4 are supported" 153 | 154 | -- | Turn a biscuit block into a protobuf block, for serialization, 155 | -- along with the newly defined symbols 156 | blockToPb :: Bool -> Symbols -> Block -> (BlockSymbols, PB.Block) 157 | blockToPb hasExternalPk existingSymbols b@Block{..} = 158 | let v4Plus = not $ and 159 | [Set.null bScope 160 | , all ruleHasNoScope bRules 161 | , all (queryHasNoScope . cQueries) bChecks 162 | , all isCheckOne bChecks 163 | , all ruleHasNoV4Operators bRules 164 | , all (queryHasNoV4Operators . cQueries) bChecks 165 | ] 166 | v5Plus = hasExternalPk 167 | bSymbols = buildSymbolTable existingSymbols b 168 | s = reverseSymbols $ addFromBlock existingSymbols bSymbols 169 | symbols = PB.putField $ getSymbolList bSymbols 170 | context = PB.putField bContext 171 | facts_v2 = PB.putField $ factToPb s <$> bFacts 172 | rules_v2 = PB.putField $ ruleToPb s <$> bRules 173 | checks_v2 = PB.putField $ checkToPb s <$> bChecks 174 | scope = PB.putField $ scopeToPb s <$> Set.toList bScope 175 | pksTable = PB.putField $ publicKeyToPb <$> getPkList bSymbols 176 | version = PB.putField $ if | v5Plus -> Just 5 177 | | v4Plus -> Just 4 178 | | otherwise -> Just 3 179 | in (bSymbols, PB.Block {..}) 180 | 181 | pbToFact :: Symbols -> PB.FactV2 -> Either String Fact 182 | pbToFact s PB.FactV2{predicate} = do 183 | let pbName = PB.getField $ PB.name $ PB.getField predicate 184 | pbTerms = PB.getField $ PB.terms $ PB.getField predicate 185 | name <- getSymbol s $ SymbolRef pbName 186 | terms <- traverse (pbToValue s) pbTerms 187 | pure Predicate{..} 188 | 189 | factToPb :: ReverseSymbols -> Fact -> PB.FactV2 190 | factToPb s Predicate{..} = 191 | let 192 | predicate = PB.PredicateV2 193 | { name = PB.putField $ getSymbolRef $ getSymbolCode s name 194 | , terms = PB.putField $ valueToPb s <$> terms 195 | } 196 | in PB.FactV2{predicate = PB.putField predicate} 197 | 198 | pbToRule :: Symbols -> PB.RuleV2 -> Either String Rule 199 | pbToRule s pbRule = do 200 | let pbHead = PB.getField $ PB.head pbRule 201 | pbBody = PB.getField $ PB.body pbRule 202 | pbExpressions = PB.getField $ PB.expressions pbRule 203 | pbScope = PB.getField $ getField @"scope" pbRule 204 | rhead <- pbToPredicate s pbHead 205 | body <- traverse (pbToPredicate s) pbBody 206 | expressions <- traverse (pbToExpression s) pbExpressions 207 | scope <- Set.fromList <$> traverse (pbToScope s) pbScope 208 | case makeRule rhead body expressions scope of 209 | Failure vs -> Left $ "Unbound variables in rule: " <> T.unpack (T.intercalate ", " $ NE.toList vs) 210 | Success r -> pure r 211 | 212 | ruleToPb :: ReverseSymbols -> Rule -> PB.RuleV2 213 | ruleToPb s Rule{..} = 214 | PB.RuleV2 215 | { head = PB.putField $ predicateToPb s rhead 216 | , body = PB.putField $ predicateToPb s <$> body 217 | , expressions = PB.putField $ expressionToPb s <$> expressions 218 | , scope = PB.putField $ scopeToPb s <$> Set.toList scope 219 | } 220 | 221 | pbToCheck :: Symbols -> PB.CheckV2 -> Either String Check 222 | pbToCheck s PB.CheckV2{queries,kind} = do 223 | let toCheck Rule{body,expressions,scope} = QueryItem{qBody = body, qExpressions = expressions, qScope = scope} 224 | rules <- traverse (pbToRule s) $ PB.getField queries 225 | let cQueries = toCheck <$> rules 226 | let cKind = case PB.getField kind of 227 | Just PB.All -> All 228 | Just PB.One -> One 229 | Nothing -> One 230 | pure Check{..} 231 | 232 | checkToPb :: ReverseSymbols -> Check -> PB.CheckV2 233 | checkToPb s Check{..} = 234 | let dummyHead = Predicate "query" [] 235 | toQuery QueryItem{..} = 236 | ruleToPb s $ Rule { rhead = dummyHead 237 | , body = qBody 238 | , expressions = qExpressions 239 | , scope = qScope 240 | } 241 | pbKind = case cKind of 242 | One -> Nothing 243 | All -> Just PB.All 244 | in PB.CheckV2 { queries = PB.putField $ toQuery <$> cQueries 245 | , kind = PB.putField pbKind 246 | } 247 | 248 | pbToScope :: Symbols -> PB.Scope -> Either String RuleScope 249 | pbToScope s = \case 250 | PB.ScType e -> case PB.getField e of 251 | PB.ScopeAuthority -> Right OnlyAuthority 252 | PB.ScopePrevious -> Right Previous 253 | PB.ScBlock pkRef -> 254 | BlockId <$> getPublicKey' s (PublicKeyRef $ PB.getField pkRef) 255 | 256 | scopeToPb :: ReverseSymbols -> RuleScope -> PB.Scope 257 | scopeToPb s = \case 258 | OnlyAuthority -> PB.ScType $ PB.putField PB.ScopeAuthority 259 | Previous -> PB.ScType $ PB.putField PB.ScopePrevious 260 | BlockId pk -> PB.ScBlock $ PB.putField $ getPublicKeyCode s pk 261 | 262 | pbToPredicate :: Symbols -> PB.PredicateV2 -> Either String (Predicate' 'InPredicate 'Representation) 263 | pbToPredicate s pbPredicate = do 264 | let pbName = PB.getField $ PB.name pbPredicate 265 | pbTerms = PB.getField $ PB.terms pbPredicate 266 | name <- getSymbol s $ SymbolRef pbName 267 | terms <- traverse (pbToTerm s) pbTerms 268 | pure Predicate{..} 269 | 270 | predicateToPb :: ReverseSymbols -> Predicate -> PB.PredicateV2 271 | predicateToPb s Predicate{..} = 272 | PB.PredicateV2 273 | { name = PB.putField $ getSymbolRef $ getSymbolCode s name 274 | , terms = PB.putField $ termToPb s <$> terms 275 | } 276 | 277 | pbTimeToUtcTime :: Int64 -> UTCTime 278 | pbTimeToUtcTime = posixSecondsToUTCTime . fromIntegral 279 | 280 | pbToTerm :: Symbols -> PB.TermV2 -> Either String Term 281 | pbToTerm s = \case 282 | PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f 283 | PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) 284 | PB.TermDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f 285 | PB.TermBytes f -> pure $ LBytes $ PB.getField f 286 | PB.TermBool f -> pure $ LBool $ PB.getField f 287 | PB.TermVariable f -> Variable <$> getSymbol s (SymbolRef $ PB.getField f) 288 | PB.TermTermSet f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f) 289 | 290 | termToPb :: ReverseSymbols -> Term -> PB.TermV2 291 | termToPb s = \case 292 | Variable n -> PB.TermVariable $ PB.putField $ getSymbolRef $ getSymbolCode s n 293 | LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v 294 | LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v 295 | LDate v -> PB.TermDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v 296 | LBytes v -> PB.TermBytes $ PB.putField v 297 | LBool v -> PB.TermBool $ PB.putField v 298 | TermSet vs -> PB.TermTermSet $ PB.putField $ PB.TermSet $ PB.putField $ setValueToPb s <$> Set.toList vs 299 | 300 | Antiquote v -> absurd v 301 | 302 | pbToValue :: Symbols -> PB.TermV2 -> Either String Value 303 | pbToValue s = \case 304 | PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f 305 | PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) 306 | PB.TermDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f 307 | PB.TermBytes f -> pure $ LBytes $ PB.getField f 308 | PB.TermBool f -> pure $ LBool $ PB.getField f 309 | PB.TermVariable _ -> Left "Variables can't appear in facts" 310 | PB.TermTermSet f -> TermSet . Set.fromList <$> traverse (pbToSetValue s) (PB.getField . PB.set $ PB.getField f) 311 | 312 | valueToPb :: ReverseSymbols -> Value -> PB.TermV2 313 | valueToPb s = \case 314 | LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v 315 | LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v 316 | LDate v -> PB.TermDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v 317 | LBytes v -> PB.TermBytes $ PB.putField v 318 | LBool v -> PB.TermBool $ PB.putField v 319 | TermSet vs -> PB.TermTermSet $ PB.putField $ PB.TermSet $ PB.putField $ setValueToPb s <$> Set.toList vs 320 | 321 | Variable v -> absurd v 322 | Antiquote v -> absurd v 323 | 324 | pbToSetValue :: Symbols -> PB.TermV2 -> Either String (Term' 'WithinSet 'InFact 'Representation) 325 | pbToSetValue s = \case 326 | PB.TermInteger f -> pure $ LInteger $ fromIntegral $ PB.getField f 327 | PB.TermString f -> LString <$> getSymbol s (SymbolRef $ PB.getField f) 328 | PB.TermDate f -> pure $ LDate $ pbTimeToUtcTime $ PB.getField f 329 | PB.TermBytes f -> pure $ LBytes $ PB.getField f 330 | PB.TermBool f -> pure $ LBool $ PB.getField f 331 | PB.TermVariable _ -> Left "Variables can't appear in facts or sets" 332 | PB.TermTermSet _ -> Left "Sets can't be nested" 333 | 334 | setValueToPb :: ReverseSymbols -> Term' 'WithinSet 'InFact 'Representation -> PB.TermV2 335 | setValueToPb s = \case 336 | LInteger v -> PB.TermInteger $ PB.putField $ fromIntegral v 337 | LString v -> PB.TermString $ PB.putField $ getSymbolRef $ getSymbolCode s v 338 | LDate v -> PB.TermDate $ PB.putField $ round $ utcTimeToPOSIXSeconds v 339 | LBytes v -> PB.TermBytes $ PB.putField v 340 | LBool v -> PB.TermBool $ PB.putField v 341 | 342 | TermSet v -> absurd v 343 | Variable v -> absurd v 344 | Antiquote v -> absurd v 345 | 346 | pbToExpression :: Symbols -> PB.ExpressionV2 -> Either String Expression 347 | pbToExpression s PB.ExpressionV2{ops} = do 348 | parsedOps <- traverse (pbToOp s) $ PB.getField ops 349 | fromStack parsedOps 350 | 351 | expressionToPb :: ReverseSymbols -> Expression -> PB.ExpressionV2 352 | expressionToPb s e = 353 | let ops = opToPb s <$> toStack e 354 | in PB.ExpressionV2 { ops = PB.putField ops } 355 | 356 | pbToOp :: Symbols -> PB.Op -> Either String Op 357 | pbToOp s = \case 358 | PB.OpVValue v -> VOp <$> pbToTerm s (PB.getField v) 359 | PB.OpVUnary v -> pure . UOp . pbToUnary $ PB.getField v 360 | PB.OpVBinary v -> pure . BOp . pbToBinary $ PB.getField v 361 | 362 | opToPb :: ReverseSymbols -> Op -> PB.Op 363 | opToPb s = \case 364 | VOp t -> PB.OpVValue $ PB.putField $ termToPb s t 365 | UOp o -> PB.OpVUnary $ PB.putField $ unaryToPb o 366 | BOp o -> PB.OpVBinary $ PB.putField $ binaryToPb o 367 | 368 | pbToUnary :: PB.OpUnary -> Unary 369 | pbToUnary PB.OpUnary{kind} = case PB.getField kind of 370 | PB.Negate -> Negate 371 | PB.Parens -> Parens 372 | PB.Length -> Length 373 | 374 | unaryToPb :: Unary -> PB.OpUnary 375 | unaryToPb = PB.OpUnary . PB.putField . \case 376 | Negate -> PB.Negate 377 | Parens -> PB.Parens 378 | Length -> PB.Length 379 | 380 | pbToBinary :: PB.OpBinary -> Binary 381 | pbToBinary PB.OpBinary{kind} = case PB.getField kind of 382 | PB.LessThan -> LessThan 383 | PB.GreaterThan -> GreaterThan 384 | PB.LessOrEqual -> LessOrEqual 385 | PB.GreaterOrEqual -> GreaterOrEqual 386 | PB.Equal -> Equal 387 | PB.Contains -> Contains 388 | PB.Prefix -> Prefix 389 | PB.Suffix -> Suffix 390 | PB.Regex -> Regex 391 | PB.Add -> Add 392 | PB.Sub -> Sub 393 | PB.Mul -> Mul 394 | PB.Div -> Div 395 | PB.And -> And 396 | PB.Or -> Or 397 | PB.Intersection -> Intersection 398 | PB.Union -> Union 399 | PB.BitwiseAnd -> BitwiseAnd 400 | PB.BitwiseOr -> BitwiseOr 401 | PB.BitwiseXor -> BitwiseXor 402 | PB.NotEqual -> NotEqual 403 | 404 | binaryToPb :: Binary -> PB.OpBinary 405 | binaryToPb = PB.OpBinary . PB.putField . \case 406 | LessThan -> PB.LessThan 407 | GreaterThan -> PB.GreaterThan 408 | LessOrEqual -> PB.LessOrEqual 409 | GreaterOrEqual -> PB.GreaterOrEqual 410 | Equal -> PB.Equal 411 | Contains -> PB.Contains 412 | Prefix -> PB.Prefix 413 | Suffix -> PB.Suffix 414 | Regex -> PB.Regex 415 | Add -> PB.Add 416 | Sub -> PB.Sub 417 | Mul -> PB.Mul 418 | Div -> PB.Div 419 | And -> PB.And 420 | Or -> PB.Or 421 | Intersection -> PB.Intersection 422 | Union -> PB.Union 423 | BitwiseAnd -> PB.BitwiseAnd 424 | BitwiseOr -> PB.BitwiseOr 425 | BitwiseXor -> PB.BitwiseXor 426 | NotEqual -> PB.NotEqual 427 | 428 | pbToThirdPartyBlockRequest :: PB.ThirdPartyBlockRequest -> Either String Crypto.PublicKey 429 | pbToThirdPartyBlockRequest PB.ThirdPartyBlockRequest{previousPk, pkTable} = do 430 | unless (null $ PB.getField pkTable) $ Left "Public key table provided in third-party block request" 431 | pbToPublicKey $ PB.getField previousPk 432 | 433 | thirdPartyBlockRequestToPb :: Crypto.PublicKey -> PB.ThirdPartyBlockRequest 434 | thirdPartyBlockRequestToPb previousPk = PB.ThirdPartyBlockRequest 435 | { previousPk = PB.putField $ publicKeyToPb previousPk 436 | , pkTable = PB.putField [] 437 | } 438 | 439 | pbToThirdPartyBlockContents :: PB.ThirdPartyBlockContents -> Either String (ByteString, Crypto.Signature, Crypto.PublicKey) 440 | pbToThirdPartyBlockContents PB.ThirdPartyBlockContents{payload,externalSig} = do 441 | (sig, pk) <- pbToOptionalSignature $ PB.getField externalSig 442 | pure ( PB.getField payload 443 | , sig 444 | , pk 445 | ) 446 | 447 | thirdPartyBlockContentsToPb :: (ByteString, Crypto.Signature, Crypto.PublicKey) -> PB.ThirdPartyBlockContents 448 | thirdPartyBlockContentsToPb (payload, sig, pk) = PB.ThirdPartyBlockContents 449 | { PB.payload = PB.putField payload 450 | , PB.externalSig = PB.putField $ externalSigToPb (sig, pk) 451 | } 452 | 453 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Symbols.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedLists #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-| 7 | Module : Auth.Biscuit.Symbols 8 | Copyright : © Clément Delafargue, 2021 9 | License : BSD-3-Clause 10 | Maintainer : clement@delafargue.name 11 | Symbol management logic for biscuit serialization 12 | -} 13 | module Auth.Biscuit.Symbols 14 | ( Symbols 15 | , BlockSymbols 16 | , ReverseSymbols 17 | , SymbolRef (..) 18 | , PublicKeyRef (..) 19 | , getSymbol 20 | , getPublicKey' 21 | , addSymbols 22 | , addFromBlock 23 | , registerNewSymbols 24 | , registerNewPublicKeys 25 | , reverseSymbols 26 | , getSymbolList 27 | , getPkList 28 | , getPkTable 29 | , getSymbolCode 30 | , getPublicKeyCode 31 | , newSymbolTable 32 | ) where 33 | 34 | import Auth.Biscuit.Crypto (PublicKey) 35 | import Data.Int (Int64) 36 | import Data.List ((\\)) 37 | import Data.Map (Map, elems, (!?)) 38 | import qualified Data.Map as Map 39 | import Data.Set (Set, difference, union) 40 | import qualified Data.Set as Set 41 | import Data.Text (Text) 42 | 43 | import Auth.Biscuit.Utils (maybeToRight) 44 | 45 | newtype SymbolRef = SymbolRef { getSymbolRef :: Int64 } 46 | deriving stock (Eq, Ord) 47 | deriving newtype (Enum) 48 | 49 | instance Show SymbolRef where 50 | show = ("#" <>) . show . getSymbolRef 51 | 52 | newtype PublicKeyRef = PublicKeyRef { getPublicKeyRef :: Int64 } 53 | deriving stock (Eq, Ord) 54 | deriving newtype (Enum) 55 | 56 | instance Show PublicKeyRef where 57 | show = ("#" <>) . show . getPublicKeyRef 58 | 59 | data Symbols = Symbols 60 | { symbols :: Map SymbolRef Text 61 | , publicKeys :: Map PublicKeyRef PublicKey 62 | } deriving stock (Eq, Show) 63 | 64 | data BlockSymbols = BlockSymbols 65 | { blockSymbols :: Map SymbolRef Text 66 | , blockPublicKeys :: Map PublicKeyRef PublicKey 67 | } deriving stock (Eq, Show) 68 | 69 | instance Semigroup BlockSymbols where 70 | b <> b' = BlockSymbols 71 | { blockSymbols = blockSymbols b <> blockSymbols b' 72 | , blockPublicKeys = blockPublicKeys b <> blockPublicKeys b' 73 | } 74 | 75 | data ReverseSymbols = ReverseSymbols 76 | { reverseSymbolMap :: Map Text SymbolRef 77 | , reversePublicKeyMap :: Map PublicKey PublicKeyRef 78 | } 79 | deriving stock (Eq, Show) 80 | 81 | instance Semigroup ReverseSymbols where 82 | b <> b' = ReverseSymbols 83 | { reverseSymbolMap = reverseSymbolMap b <> reverseSymbolMap b' 84 | , reversePublicKeyMap = reversePublicKeyMap b <> reversePublicKeyMap b' 85 | } 86 | 87 | getNextOffset :: Symbols -> SymbolRef 88 | getNextOffset (Symbols m _) = 89 | SymbolRef $ fromIntegral $ 1024 + (Map.size m - Map.size commonSymbols) 90 | 91 | getNextPublicKeyOffset :: Symbols -> PublicKeyRef 92 | getNextPublicKeyOffset (Symbols _ m) = 93 | PublicKeyRef $ fromIntegral $ Map.size m 94 | 95 | getSymbol :: Symbols -> SymbolRef -> Either String Text 96 | getSymbol (Symbols m _) i = 97 | maybeToRight ("Missing symbol at id " <> show i) $ m !? i 98 | 99 | getPublicKey' :: Symbols -> PublicKeyRef -> Either String PublicKey 100 | getPublicKey' (Symbols _ m) i = 101 | maybeToRight ("Missing symbol at id " <> show i) $ m !? i 102 | 103 | -- | Given already existing symbols and a set of symbols used in a block, 104 | -- compute the symbol table carried by this specific block 105 | addSymbols :: Symbols -> Set Text -> Set PublicKey -> BlockSymbols 106 | addSymbols s@(Symbols sm pkm) bSymbols pks = 107 | let existingSymbols = Set.fromList (elems commonSymbols) `union` Set.fromList (elems sm) 108 | newSymbols = Set.toList $ bSymbols `difference` existingSymbols 109 | starting = getNextOffset s 110 | existingPks = Set.fromList (elems pkm) 111 | newPks = Set.toList $ pks `difference` existingPks 112 | startingPk = getNextPublicKeyOffset s 113 | in BlockSymbols 114 | { blockSymbols = Map.fromList (zip [starting..] newSymbols) 115 | , blockPublicKeys = Map.fromList (zip [startingPk..] newPks) 116 | } 117 | 118 | getSymbolList :: BlockSymbols -> [Text] 119 | getSymbolList (BlockSymbols m _) = Map.elems m 120 | 121 | getPkList :: BlockSymbols -> [PublicKey] 122 | getPkList (BlockSymbols _ m) = Map.elems m 123 | 124 | getPkTable :: Symbols -> [PublicKey] 125 | getPkTable (Symbols _ m) = Map.elems m 126 | 127 | newSymbolTable :: Symbols 128 | newSymbolTable = Symbols commonSymbols Map.empty 129 | 130 | -- | Given the symbol table of a protobuf block, update the provided symbol table 131 | addFromBlock :: Symbols -> BlockSymbols -> Symbols 132 | addFromBlock (Symbols sm pkm) (BlockSymbols bsm bpkm) = 133 | Symbols 134 | { symbols = sm <> bsm 135 | , publicKeys = pkm <> bpkm 136 | } 137 | 138 | registerNewSymbols :: [Text] -> Symbols -> Symbols 139 | registerNewSymbols newSymbols s@Symbols{symbols} = 140 | let newSymbolsMap = Map.fromList $ zip [getNextOffset s..] newSymbols 141 | in s { symbols = symbols <> newSymbolsMap } 142 | 143 | registerNewPublicKeys :: [PublicKey] -> Symbols -> Symbols 144 | registerNewPublicKeys newPks s@Symbols{publicKeys} = 145 | let newPkMap = Map.fromList $ zip [getNextPublicKeyOffset s..] (newPks \\ elems publicKeys) 146 | in s { publicKeys = publicKeys <> newPkMap } 147 | 148 | -- | Reverse a symbol table 149 | reverseSymbols :: Symbols -> ReverseSymbols 150 | reverseSymbols (Symbols sm pkm) = 151 | let swap (a,b) = (b,a) 152 | reverseMap :: (Ord a, Ord b) => Map a b -> Map b a 153 | reverseMap = Map.fromList . fmap swap . Map.toList 154 | in ReverseSymbols 155 | { reverseSymbolMap = reverseMap sm 156 | , reversePublicKeyMap = reverseMap pkm 157 | } 158 | 159 | -- | Given a reverse symbol table (symbol refs indexed by their textual 160 | -- representation), turn textual representations into symbol refs. 161 | -- This function is partial, the reverse table is guaranteed to 162 | -- contain the expected textual symbols. 163 | getSymbolCode :: ReverseSymbols -> Text -> SymbolRef 164 | getSymbolCode (ReverseSymbols rm _) t = rm Map.! t 165 | 166 | getPublicKeyCode :: ReverseSymbols -> PublicKey -> Int64 167 | getPublicKeyCode (ReverseSymbols _ rm) t = getPublicKeyRef $ rm Map.! t 168 | 169 | -- | The common symbols defined in the biscuit spec 170 | commonSymbols :: Map SymbolRef Text 171 | commonSymbols = Map.fromList $ zip [SymbolRef 0..] 172 | [ "read" 173 | , "write" 174 | , "resource" 175 | , "operation" 176 | , "right" 177 | , "time" 178 | , "role" 179 | , "owner" 180 | , "tenant" 181 | , "namespace" 182 | , "user" 183 | , "team" 184 | , "service" 185 | , "admin" 186 | , "email" 187 | , "group" 188 | , "member" 189 | , "ip_address" 190 | , "client" 191 | , "client_ip" 192 | , "domain" 193 | , "path" 194 | , "version" 195 | , "cluster" 196 | , "node" 197 | , "hostname" 198 | , "nonce" 199 | , "query" 200 | ] 201 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Timer.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Auth.Biscuit.Timer 3 | Copyright : © Clément Delafargue, 2021 4 | License : BSD-3-Clause 5 | Maintainer : clement@delafargue.name 6 | Helper function making sure an IO action runs in an alloted time 7 | -} 8 | module Auth.Biscuit.Timer 9 | ( timer 10 | ) where 11 | 12 | import Control.Concurrent (threadDelay) 13 | import Control.Concurrent.Async (race) 14 | 15 | -- | Given a maximum execution time, run the provide action, and 16 | -- fail (by returning `Nothing`) if it takes too much time. 17 | -- Else, the action result is returned in a `Just` 18 | timer :: Int 19 | -> IO a 20 | -> IO (Maybe a) 21 | timer timeout job = do 22 | let watchDog = threadDelay timeout 23 | result <- race watchDog job 24 | pure $ case result of 25 | Left _ -> Nothing 26 | Right a -> Just a 27 | 28 | -------------------------------------------------------------------------------- /biscuit/src/Auth/Biscuit/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | 4 | -- Module : Auth.Biscuit.Utils 5 | -- Copyright : © Clément Delafargue, 2021 6 | -- License : BSD-3-Clause 7 | -- Maintainer : clement@delafargue.name 8 | module Auth.Biscuit.Utils 9 | ( maybeToRight, 10 | rightToMaybe, 11 | encodeHex, 12 | encodeHex', 13 | decodeHex, 14 | anyM, 15 | allM, 16 | setFilterM, 17 | foldMapM, 18 | mapMaybeM, 19 | ) 20 | where 21 | 22 | #if MIN_VERSION_base16(1,0,0) 23 | import qualified Data.Base16.Types as Hex 24 | #endif 25 | import Data.Bool (bool) 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString.Base16 as Hex 28 | import Data.Maybe (maybeToList) 29 | import Data.Monoid (All (..), Any (..)) 30 | import Data.Set (Set) 31 | import qualified Data.Set as Set 32 | import Data.Text (Text) 33 | 34 | encodeHex :: ByteString -> Text 35 | #if MIN_VERSION_base16(1,0,0) 36 | encodeHex = Hex.extractBase16 . Hex.encodeBase16 37 | #else 38 | encodeHex = Hex.encodeBase16 39 | #endif 40 | 41 | encodeHex' :: ByteString -> ByteString 42 | #if MIN_VERSION_base16(1,0,0) 43 | encodeHex' = Hex.extractBase16 . Hex.encodeBase16' 44 | #else 45 | encodeHex' = Hex.encodeBase16' 46 | #endif 47 | 48 | decodeHex :: ByteString -> Either Text ByteString 49 | #if MIN_VERSION_base16(1,0,0) 50 | decodeHex = Hex.decodeBase16Untyped 51 | #else 52 | decodeHex = Hex.decodeBase16 53 | #endif 54 | 55 | -- | Exactly like `maybeToRight` from the `either` package, 56 | -- but without the dependency footprint 57 | maybeToRight :: b -> Maybe a -> Either b a 58 | maybeToRight b = maybe (Left b) Right 59 | 60 | -- | Exactly like `rightToMaybe` from the `either` package, 61 | -- but without the dependency footprint 62 | rightToMaybe :: Either b a -> Maybe a 63 | rightToMaybe = either (const Nothing) Just 64 | 65 | anyM :: (Foldable t, Monad m) => (a -> m Bool) -> t a -> m Bool 66 | anyM f = fmap getAny . foldMapM (fmap Any . f) 67 | 68 | allM :: (Foldable t, Monad m) => (a -> m Bool) -> t a -> m Bool 69 | allM f = fmap getAll . foldMapM (fmap All . f) 70 | 71 | setFilterM :: (Ord a, Monad m) => (a -> m Bool) -> Set a -> m (Set a) 72 | setFilterM p = foldMapM (\a -> bool mempty (Set.singleton a) <$> p a) 73 | 74 | -- from Relude 75 | foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b 76 | foldMapM f xs = foldr step return xs mempty 77 | where 78 | step x r z = f x >>= \y -> r $! z `mappend` y 79 | {-# INLINE foldMapM #-} 80 | 81 | mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] 82 | mapMaybeM f = foldMapM (fmap maybeToList . f) 83 | -------------------------------------------------------------------------------- /biscuit/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : © Clément Delafargue, 2021 3 | License : BSD-3-Clause 4 | -} 5 | module Main (main) where 6 | 7 | import Test.Tasty 8 | 9 | import qualified Spec.Executor as Executor 10 | import qualified Spec.NewCrypto as NewCrypto 11 | import qualified Spec.Parser as Parser 12 | import qualified Spec.Quasiquoter as Quasiquoter 13 | import qualified Spec.Roundtrip as Roundtrip 14 | import qualified Spec.SampleReader as SampleReader 15 | import qualified Spec.ScopedExecutor as ScopedExecutor 16 | import qualified Spec.Verification as Verification 17 | 18 | main :: IO () 19 | main = do 20 | sampleReader <- SampleReader.getSpecs 21 | defaultMain $ testGroup "biscuit-haskell" 22 | [ 23 | NewCrypto.specs 24 | , Executor.specs 25 | , Parser.specs 26 | , Quasiquoter.specs 27 | , Roundtrip.specs 28 | , Verification.specs 29 | , ScopedExecutor.specs 30 | , sampleReader 31 | ] 32 | -------------------------------------------------------------------------------- /biscuit/test/Spec/Executor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {- 5 | Copyright : © Clément Delafargue, 2021 6 | License : BSD-3-Clause 7 | -} 8 | module Spec.Executor (specs) where 9 | 10 | import Data.Map.Strict as Map 11 | import Data.Set as Set 12 | import Data.Text (Text, unpack) 13 | import Numeric.Natural (Natural) 14 | import Test.Tasty 15 | import Test.Tasty.HUnit 16 | 17 | import Auth.Biscuit.Datalog.AST 18 | import Auth.Biscuit.Datalog.Executor (ExecutionError (..), 19 | Limits (..), 20 | defaultLimits, 21 | evaluateExpression) 22 | import Auth.Biscuit.Datalog.Parser (expressionParser, fact, 23 | rule) 24 | import Auth.Biscuit.Datalog.ScopedExecutor hiding (limits) 25 | import Spec.Parser (parseExpression) 26 | 27 | specs :: TestTree 28 | specs = testGroup "Datalog evaluation" 29 | [ grandparent 30 | , ancestor 31 | , scopedRules 32 | , exprEval 33 | , exprEvalError 34 | , rulesWithConstraints 35 | , ruleHeadWithNoVars 36 | , limits 37 | , overflow 38 | ] 39 | 40 | authGroup :: Set Fact -> FactGroup 41 | authGroup = FactGroup . Map.singleton (Set.singleton 0) 42 | 43 | authRulesGroup :: Set Rule -> Map Natural (Set EvalRule) 44 | authRulesGroup = Map.singleton 0 . adaptRules 45 | 46 | adaptRules :: Set Rule -> Set EvalRule 47 | adaptRules = Set.map (toEvaluation []) 48 | 49 | grandparent :: TestTree 50 | grandparent = testCase "Basic grandparent rule" $ 51 | let rules = authRulesGroup $ Set.fromList 52 | [ [rule|grandparent($a,$b) <- parent($a,$c), parent($c,$b)|] 53 | ] 54 | facts = authGroup $ Set.fromList 55 | [ [fact|parent("alice", "bob")|] 56 | , [fact|parent("bob", "jean-pierre")|] 57 | , [fact|parent("alice", "toto")|] 58 | ] 59 | in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList 60 | [ [fact|parent("alice", "bob")|] 61 | , [fact|parent("bob", "jean-pierre")|] 62 | , [fact|parent("alice", "toto")|] 63 | , [fact|grandparent("alice", "jean-pierre")|] 64 | ]) 65 | 66 | ancestor :: TestTree 67 | ancestor = testCase "Ancestor rule" $ 68 | let rules = authRulesGroup $ Set.fromList 69 | [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] 70 | , [rule|ancestor($a,$b) <- parent($a,$b)|] 71 | ] 72 | facts = authGroup $ Set.fromList 73 | [ [fact|parent("alice", "bob")|] 74 | , [fact|parent("bob", "jean-pierre")|] 75 | , [fact|parent("alice", "toto")|] 76 | ] 77 | in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList 78 | [ [fact|parent("alice", "bob")|] 79 | , [fact|parent("bob", "jean-pierre")|] 80 | , [fact|parent("alice", "toto")|] 81 | , [fact|ancestor("alice", "bob")|] 82 | , [fact|ancestor("bob", "jean-pierre")|] 83 | , [fact|ancestor("alice", "toto")|] 84 | , [fact|ancestor("alice", "jean-pierre")|] 85 | ]) 86 | 87 | expr :: Text -> Expression 88 | expr = either error id . parseExpression 89 | 90 | exprEval :: TestTree 91 | exprEval = do 92 | let bindings = Map.fromList 93 | [ ("var1", LInteger 0) 94 | , ("topDomain", LString "example.com") 95 | , ("domain", LString "test.example.com") 96 | ] 97 | eval (e, r) = testCase (unpack e) $ 98 | evaluateExpression defaultLimits bindings (expr e) @?= Right r 99 | 100 | -- ("1 / 0") @?= Left "Divide by 0" 101 | testGroup "Expressions evaluation" $ eval <$> 102 | [ ("!(1 < $var1)", LBool True) 103 | , ("[0].contains($var1)", LBool True) 104 | , ("1 + 2 * 3", LInteger 7) 105 | , ("!(1 + 2 * 3 > 4)", LBool False) 106 | , ("!true", LBool False) 107 | , ("!false", LBool True) 108 | , ("(true)", LBool True) 109 | , ("\"test\".length()", LInteger 4) 110 | , ("\"é\".length()", LInteger 2) 111 | , ("hex:ababab.length()", LInteger 3) 112 | , ("[].length()", LInteger 0) 113 | , ("[\"test\", \"test\"].length()", LInteger 1) 114 | , ("1 == 1", LBool True) 115 | , ("2 == 1", LBool False) 116 | , ("\"toto\" == \"toto\"", LBool True) 117 | , ("\"toto\" == \"truc\"", LBool False) 118 | , ("\"toto\".matches(\"to(to)?\")", LBool True) 119 | , ("\"toto\".matches(\"^to$\")", LBool False) 120 | , ("2021-05-07T18:00:00Z == 2021-05-07T18:00:00Z", LBool True) 121 | , ("2021-05-07T18:00:00Z == 2021-05-07T19:00:00Z", LBool False) 122 | , ("hex:ababab == hex:ababab", LBool True) 123 | , ("hex:ababab == hex:ababac", LBool False) 124 | , ("true == true", LBool True) 125 | , ("true == false", LBool False) 126 | , ("[1,2,3] == [1,2,3]", LBool True) 127 | , ("[1,2,3] == [1,2,4]", LBool False) 128 | , ("1 < 2", LBool True) 129 | , ("2 < 1", LBool False) 130 | , ("2021-05-07T18:00:00Z < 2021-05-07T19:00:00Z", LBool True) 131 | , ("2021-05-07T19:00:00Z < 2021-05-07T18:00:00Z", LBool False) 132 | , ("2 > 1", LBool True) 133 | , ("1 > 2", LBool False) 134 | , ("2021-05-07T19:00:00Z > 2021-05-07T18:00:00Z", LBool True) 135 | , ("2021-05-07T18:00:00Z > 2021-05-07T19:00:00Z", LBool False) 136 | , ("1 <= 2", LBool True) 137 | , ("1 <= 1", LBool True) 138 | , ("2 <= 1", LBool False) 139 | , ("2021-05-07T18:00:00Z <= 2021-05-07T19:00:00Z", LBool True) 140 | , ("2021-05-07T18:00:00Z <= 2021-05-07T18:00:00Z", LBool True) 141 | , ("2021-05-07T19:00:00Z <= 2021-05-07T18:00:00Z", LBool False) 142 | , ("2 >= 1", LBool True) 143 | , ("2 >= 2", LBool True) 144 | , ("1 >= 2", LBool False) 145 | , ("2021-05-07T19:00:00Z >= 2021-05-07T18:00:00Z", LBool True) 146 | , ("2021-05-07T18:00:00Z >= 2021-05-07T18:00:00Z", LBool True) 147 | , ("2021-05-07T18:00:00Z >= 2021-05-07T19:00:00Z", LBool False) 148 | , ("\"my string\".starts_with(\"my\")", LBool True) 149 | , ("\"my string\".starts_with(\"string\")", LBool False) 150 | , ("\"my string\".ends_with(\"string\")", LBool True) 151 | , ("\"my string\".ends_with(\"my\")", LBool False) 152 | , ("$domain.ends_with(\".\" + $topDomain)", LBool True) 153 | , ("2 + 1", LInteger 3) 154 | , ("2 - 1", LInteger 1) 155 | , ("5 / 2", LInteger 2) 156 | , ("2 * 1", LInteger 2) 157 | , ("true && true", LBool True) 158 | , ("true && false", LBool False) 159 | , ("false && true", LBool False) 160 | , ("false && false", LBool False) 161 | , ("true || true", LBool True) 162 | , ("true || false", LBool True) 163 | , ("false || true", LBool True) 164 | , ("false || false", LBool False) 165 | , ("[1].contains([1])", LBool True) 166 | , ("[1].contains(1)", LBool True) 167 | , ("[].contains(1)", LBool False) 168 | , ("[\"test\"].contains(2)", LBool False) 169 | , ("[1].intersection([1])", TermSet (Set.fromList [LInteger 1])) 170 | , ("[1].intersection([\"test\"])", TermSet (Set.fromList [])) 171 | , ("[1].union([1])", TermSet (Set.fromList [LInteger 1])) 172 | , ("[1].union([\"test\"])", TermSet (Set.fromList [LInteger 1, LString "test"])) 173 | ] 174 | 175 | exprEvalError :: TestTree 176 | exprEvalError = do 177 | let bindings = Map.fromList 178 | [ ("var1", LInteger 0) 179 | ] 180 | l = defaultLimits { allowRegexes = False } 181 | evalFail (e, r) = testCase (unpack e) $ 182 | evaluateExpression l bindings (expr e) @?= Left r 183 | 184 | testGroup "Expressions evaluation (expected errors)" $ evalFail <$> 185 | [ ("1 / 0", "Divide by 0") 186 | , ("\"toto\".matches(\"to\")", "Regex evaluation is disabled") 187 | , ("9223372036854775807 + 1", "integer overflow") 188 | , ("-9223372036854775808 - 1", "integer underflow") 189 | ] 190 | 191 | rulesWithConstraints :: TestTree 192 | rulesWithConstraints = testCase "Rule with constraints" $ 193 | let rules = authRulesGroup $ Set.fromList 194 | [ [rule|valid_date("file1") <- time($0), resource("file1"), $0 <= 2019-12-04T09:46:41+00:00|] 195 | , [rule|valid_date("file2") <- time($0), resource("file2"), $0 <= 2010-12-04T09:46:41+00:00|] 196 | ] 197 | facts = authGroup $ Set.fromList 198 | [ [fact|time(2019-12-04T01:00:00Z)|] 199 | , [fact|resource("file1")|] 200 | , [fact|resource("file2")|] 201 | ] 202 | in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList 203 | [ [fact|time(2019-12-04T01:00:00Z)|] 204 | , [fact|resource("file1")|] 205 | , [fact|resource("file2")|] 206 | , [fact|valid_date("file1")|] 207 | ]) 208 | 209 | ruleHeadWithNoVars :: TestTree 210 | ruleHeadWithNoVars = testCase "Rule head with no variables" $ 211 | let rules = authRulesGroup $ Set.fromList 212 | [ [rule|operation("authority", "read") <- test($yolo, "nothing")|] 213 | ] 214 | facts = authGroup $ Set.fromList 215 | [ [fact|test("whatever", "notNothing")|] 216 | ] 217 | in runFactGeneration defaultLimits 1 rules facts @?= Right (authGroup $ Set.fromList 218 | [ [fact|test("whatever", "notNothing")|] 219 | ]) 220 | 221 | limits :: TestTree 222 | limits = 223 | let rules = authRulesGroup $ Set.fromList 224 | [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] 225 | , [rule|ancestor($a,$b) <- parent($a,$b)|] 226 | ] 227 | facts = authGroup $ Set.fromList 228 | [ [fact|parent("alice", "bob")|] 229 | , [fact|parent("bob", "jean-pierre")|] 230 | , [fact|parent("bob", "marielle")|] 231 | , [fact|parent("alice", "toto")|] 232 | ] 233 | factLimits = defaultLimits { maxFacts = 10 } 234 | iterLimits = defaultLimits { maxIterations = 2 } 235 | in testGroup "Facts generation limits" 236 | [ testCase "max facts" $ 237 | runFactGeneration factLimits 1 rules facts @?= Left Facts 238 | , testCase "max iterations" $ 239 | runFactGeneration iterLimits 1 rules facts @?= Left Iterations 240 | ] 241 | 242 | scopedRules :: TestTree 243 | scopedRules = testGroup "Rules and facts in different scopes" 244 | [ testCase "with default scoping for rules" $ 245 | let rules :: Map Natural (Set Rule) 246 | rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b)|] ]) 247 | , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b)|] ]) 248 | ] 249 | facts :: FactGroup 250 | facts = FactGroup 251 | [ ([0], [ [fact|parent("alice", "bob")|] 252 | , [fact|parent("bob", "trudy")|] 253 | ]) 254 | , ([1], [ [fact|parent("bob", "jean-pierre")|] 255 | ]) 256 | , ([2], [ [fact|parent("toto", "toto")|] 257 | ]) 258 | ] 259 | in runFactGeneration defaultLimits 3 (adaptRules <$> rules) facts @?= Right (FactGroup 260 | [ ([0], [ [fact|parent("alice", "bob")|] 261 | , [fact|ancestor("alice", "bob")|] 262 | , [fact|parent("bob", "trudy")|] 263 | , [fact|ancestor("bob", "trudy")|] 264 | ]) 265 | , ([1], [ [fact|parent("bob", "jean-pierre")|] 266 | ]) 267 | , ([0,1], [ [fact|ancestor("alice", "trudy")|] 268 | ]) 269 | , ([2], [ [fact|parent("toto", "toto")|] ]) 270 | ]) 271 | , testCase "with explicit scoping for rules (authority)" $ 272 | let rules :: Map Natural (Set Rule) 273 | rules = [ (0, [ [rule|ancestor($a,$b) <- parent($a,$b) trusting authority |] ]) 274 | , (1, [ [rule|ancestor($a,$b) <- parent($a,$c), ancestor($c,$b) trusting authority |] ]) 275 | , (2, [ [rule|family($a,$b) <- parent($a,$b) trusting authority |] ]) 276 | ] 277 | facts :: FactGroup 278 | facts = FactGroup 279 | [ ([0], [ [fact|parent("alice", "bob")|] 280 | , [fact|parent("bob", "trudy")|] 281 | ]) 282 | , ([1], [ [fact|parent("bob", "jean-pierre")|] 283 | ]) 284 | , ([2], [ [fact|parent("toto", "toto")|] 285 | ]) 286 | ] 287 | in runFactGeneration defaultLimits 3 (adaptRules <$> rules) facts @?= Right (FactGroup 288 | [ ([0], [ [fact|parent("alice", "bob")|] 289 | , [fact|ancestor("alice", "bob")|] 290 | , [fact|parent("bob", "trudy")|] 291 | , [fact|ancestor("bob", "trudy")|] 292 | ]) 293 | , ([1], [ [fact|parent("bob", "jean-pierre")|] 294 | ]) 295 | , ([0,1], [ [fact|ancestor("alice", "trudy")|] 296 | ]) 297 | , ([2], [ [fact|parent("toto", "toto")|] 298 | , [fact|family("toto", "toto")|] 299 | ]) 300 | , ([0,2], [ [fact|family("alice", "bob")|] 301 | , [fact|family("bob", "trudy")|] 302 | ]) 303 | ]) 304 | ] 305 | 306 | overflow :: TestTree 307 | overflow = 308 | let subtraction = authRulesGroup $ Set.singleton 309 | [rule|test(true) <- -9223372036854775808 - 1 != 0|] 310 | multiplication = authRulesGroup $ Set.singleton 311 | [rule|test(true) <- 10000000000 * 10000000000 != 0|] 312 | addition = authRulesGroup $ Set.singleton 313 | [rule|test(true) <- 9223372036854775807 + 1 != 0|] 314 | in testGroup "Arithmetic overflow" 315 | [ testCase "subtraction" $ 316 | runFactGeneration defaultLimits 1 subtraction mempty @?= Left (BadExpression "integer underflow") 317 | , testCase "multiplication" $ 318 | runFactGeneration defaultLimits 1 multiplication mempty @?= Left (BadExpression "integer overflow") 319 | , testCase "addition" $ 320 | runFactGeneration defaultLimits 1 addition mempty @?= Left (BadExpression "integer overflow") 321 | ] 322 | -------------------------------------------------------------------------------- /biscuit/test/Spec/NewCrypto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {- HLINT ignore "Reduce duplication" -} 6 | {- 7 | Copyright : © Clément Delafargue, 2021 8 | License : BSD-3-Clause 9 | -} 10 | module Spec.NewCrypto (specs) where 11 | 12 | import Data.ByteString (ByteString) 13 | import Data.List.NonEmpty (NonEmpty ((:|))) 14 | import qualified Data.List.NonEmpty as NE 15 | import Data.Maybe (isJust) 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | 19 | import Auth.Biscuit.Crypto 20 | 21 | -- This test module is only there to test the crypto layer of biscuits, 22 | -- so we define a custom token type that only cares about the envelope, 23 | -- not the actual payload 24 | data Token = Token 25 | { payload :: Blocks 26 | , privKey :: SecretKey 27 | } 28 | 29 | data SealedToken = SealedToken 30 | { payload :: Blocks 31 | , sig :: Signature 32 | } 33 | 34 | signToken :: ByteString -> SecretKey -> IO Token 35 | signToken p sk = do 36 | (signedBlock, privKey) <- signBlock sk p Nothing 37 | pure Token 38 | { payload = pure signedBlock 39 | , privKey 40 | } 41 | 42 | snocNE :: NonEmpty a -> a -> NonEmpty a 43 | snocNE (h :| t) e = h :| (t <> [e]) 44 | 45 | append :: Token -> ByteString -> IO Token 46 | append t@Token{payload} p = do 47 | (signedBlock, privKey) <- signBlock (privKey t) p Nothing 48 | pure Token 49 | { payload = snocNE payload signedBlock 50 | , privKey 51 | } 52 | 53 | appendSigned :: Token -> SecretKey -> ByteString -> IO Token 54 | appendSigned t@Token{payload} eSk p = do 55 | let (_, _, lastPk, _) = NE.last payload 56 | (signedBlock, privKey) <- signExternalBlock (privKey t) eSk lastPk p 57 | pure Token 58 | { payload = snocNE payload signedBlock 59 | , privKey 60 | } 61 | 62 | seal :: Token -> SealedToken 63 | seal Token{payload,privKey} = 64 | let lastBlock = NE.last payload 65 | in SealedToken 66 | { sig = getSignatureProof lastBlock privKey 67 | , payload 68 | } 69 | 70 | verifyToken :: Token 71 | -> PublicKey 72 | -> Bool 73 | verifyToken Token{payload, privKey} rootPk = 74 | let blocks = payload 75 | sigChecks = verifyBlocks blocks rootPk 76 | lastCheck = verifySecretProof privKey (NE.last payload) 77 | in sigChecks && lastCheck 78 | 79 | verifySealedToken :: SealedToken 80 | -> PublicKey 81 | -> Bool 82 | verifySealedToken SealedToken{payload, sig} rootPk = 83 | let blocks = payload 84 | sigChecks = verifyBlocks blocks rootPk 85 | lastCheck = verifySignatureProof sig (NE.last payload) 86 | in sigChecks && lastCheck 87 | 88 | specs :: TestTree 89 | specs = testGroup "new biscuit crypto" 90 | [ testGroup "signature algorithm - normal" 91 | [ singleBlockRoundtrip 92 | , multiBlockRoundtrip 93 | , tamperedAuthority 94 | , tamperedBlock 95 | , removedBlock 96 | ] 97 | , testGroup "signature algorithm - sealed" 98 | [ singleBlockRoundtripSealed 99 | , multiBlockRoundtripSealed 100 | , tamperedAuthoritySealed 101 | , tamperedBlockSealed 102 | , removedBlockSealed 103 | ] 104 | , testGroup "external signatures" 105 | [ multiBlockRoundtripWithExternal 106 | , invalidExternalSig 107 | ] 108 | ] 109 | 110 | singleBlockRoundtrip :: TestTree 111 | singleBlockRoundtrip = testCase "Single block roundtrip" $ do 112 | sk <- generateSecretKey 113 | let pk = toPublic sk 114 | content = "content" 115 | token <- signToken content sk 116 | let res = verifyToken token pk 117 | res @?= True 118 | 119 | multiBlockRoundtrip :: TestTree 120 | multiBlockRoundtrip = testCase "Multi block roundtrip" $ do 121 | sk <- generateSecretKey 122 | let pk = toPublic sk 123 | content = "content" 124 | token <- signToken content sk 125 | attenuated <- append token "block1" 126 | let res = verifyToken attenuated pk 127 | res @?= True 128 | 129 | multiBlockRoundtripWithExternal :: TestTree 130 | multiBlockRoundtripWithExternal = testCase "Multi block with external signatures roundtrip" $ do 131 | sk <- generateSecretKey 132 | eSk <- generateSecretKey 133 | let pk = toPublic sk 134 | content = "content" 135 | token <- signToken content sk 136 | attenuated <- appendSigned token eSk "block1" 137 | let res = verifyToken attenuated pk 138 | res @?= True 139 | 140 | invalidExternalSig :: TestTree 141 | invalidExternalSig = testCase "Invalid external signature" $ do 142 | sk <- generateSecretKey 143 | eSk <- generateSecretKey 144 | let pk = toPublic sk 145 | ePk = toPublic eSk 146 | content = "content" 147 | token <- signToken content sk 148 | attenuated <- appendSigned token eSk "block1" 149 | let bogusSignature = sign eSk ePk ("yolo yolo" :: ByteString) 150 | replaceExternalSig :: SignedBlock -> SignedBlock 151 | replaceExternalSig (p, s, pk, Just (_, ePk)) = (p, s, pk, Just (bogusSignature, ePk)) 152 | replaceExternalSig sb = sb 153 | tamper :: Blocks -> Blocks 154 | tamper = fmap replaceExternalSig 155 | tampered = alterPayload tamper attenuated 156 | let res = verifyToken tampered pk 157 | res @?= False 158 | 159 | alterPayload :: (Blocks -> Blocks) 160 | -> Token 161 | -> Token 162 | alterPayload f Token{..} = Token { payload = f payload, ..} 163 | 164 | tamperedAuthority :: TestTree 165 | tamperedAuthority = testCase "Tampered authority" $ do 166 | sk <- generateSecretKey 167 | let pk = toPublic sk 168 | content = "content" 169 | token <- signToken content sk 170 | attenuated <- append token "block1" 171 | let tamper ((_, s, pk, eS) :| o) = ("tampered", s, pk, eS) :| o 172 | tampered = alterPayload tamper attenuated 173 | let res = verifyToken tampered pk 174 | res @?= False 175 | 176 | tamperedBlock :: TestTree 177 | tamperedBlock = testCase "Tampered block" $ do 178 | sk <- generateSecretKey 179 | let pk = toPublic sk 180 | content = "content" 181 | token <- signToken content sk 182 | attenuated <- append token "block1" 183 | let tamper (h :| ((_, s, pk, eS): t)) = h :| (("tampered", s, pk, eS) : t) 184 | tampered = alterPayload tamper attenuated 185 | let res = verifyToken tampered pk 186 | res @?= False 187 | 188 | removedBlock :: TestTree 189 | removedBlock = testCase "Removed block" $ do 190 | sk <- generateSecretKey 191 | let pk = toPublic sk 192 | content = "content" 193 | token <- signToken content sk 194 | attenuated <- append token "block1" 195 | let tamper (h :| _) = h :| [] 196 | tampered = alterPayload tamper attenuated 197 | let res = verifyToken tampered pk 198 | res @?= False 199 | 200 | singleBlockRoundtripSealed :: TestTree 201 | singleBlockRoundtripSealed = testCase "Single block roundtrip" $ do 202 | sk <- generateSecretKey 203 | let pk = toPublic sk 204 | content = "content" 205 | token <- seal <$> signToken content sk 206 | let res = verifySealedToken token pk 207 | res @?= True 208 | 209 | multiBlockRoundtripSealed :: TestTree 210 | multiBlockRoundtripSealed = testCase "Multi block roundtrip" $ do 211 | sk <- generateSecretKey 212 | let pk = toPublic sk 213 | content = "content" 214 | token <- signToken content sk 215 | attenuated <- seal <$> append token "block1" 216 | let res = verifySealedToken attenuated pk 217 | res @?= True 218 | 219 | alterPayloadSealed :: (Blocks -> Blocks) 220 | -> SealedToken 221 | -> SealedToken 222 | alterPayloadSealed f SealedToken{..} = SealedToken { payload = f payload, ..} 223 | 224 | tamperedAuthoritySealed :: TestTree 225 | tamperedAuthoritySealed = testCase "Tampered authority" $ do 226 | sk <- generateSecretKey 227 | let pk = toPublic sk 228 | content = "content" 229 | token <- signToken content sk 230 | attenuated <- seal <$> append token "block1" 231 | let tamper ((_, s, pk, eS) :| o) = ("tampered", s, pk, eS) :| o 232 | tampered = alterPayloadSealed tamper attenuated 233 | let res = verifySealedToken tampered pk 234 | res @?= False 235 | 236 | tamperedBlockSealed :: TestTree 237 | tamperedBlockSealed = testCase "Tampered block" $ do 238 | sk <- generateSecretKey 239 | let pk = toPublic sk 240 | content = "content" 241 | token <- signToken content sk 242 | attenuated <- seal <$> append token "block1" 243 | let tamper (h :| ((_, s, pk, eS): t)) = h :| (("tampered", s, pk, eS) : t) 244 | tampered = alterPayloadSealed tamper attenuated 245 | let res = verifySealedToken tampered pk 246 | res @?= False 247 | 248 | removedBlockSealed :: TestTree 249 | removedBlockSealed = testCase "Removed block" $ do 250 | sk <- generateSecretKey 251 | let pk = toPublic sk 252 | content = "content" 253 | token <- signToken content sk 254 | attenuated <- seal <$> append token "block1" 255 | let tamper (h :| _) = h :| [] 256 | tampered = alterPayloadSealed tamper attenuated 257 | let res = verifySealedToken tampered pk 258 | res @?= False 259 | -------------------------------------------------------------------------------- /biscuit/test/Spec/Quasiquoter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {- 5 | Copyright : © Clément Delafargue, 2021 6 | License : BSD-3-Clause 7 | -} 8 | module Spec.Quasiquoter (specs) where 9 | 10 | import Data.Text (Text) 11 | import Test.Tasty 12 | import Test.Tasty.HUnit 13 | 14 | import Auth.Biscuit.Datalog.AST 15 | import Auth.Biscuit.Datalog.Parser (fact, rule) 16 | 17 | specs :: TestTree 18 | specs = testGroup "Datalog quasiquoter" 19 | [ basicFact 20 | , basicRule 21 | , antiquotedFact 22 | , antiquotedRule 23 | ] 24 | 25 | basicFact :: TestTree 26 | basicFact = testCase "Basic fact" $ 27 | let actual :: Fact 28 | actual = [fact|right("file1", "read")|] 29 | in actual @?= 30 | Predicate "right" [ LString "file1" 31 | , LString "read" 32 | ] 33 | 34 | basicRule :: TestTree 35 | basicRule = testCase "Basic rule" $ 36 | let actual :: Rule 37 | actual = [rule|right($0, "read") <- resource( $0), operation("read")|] 38 | in actual @?= 39 | Rule (Predicate "right" [Variable "0", LString "read"]) 40 | [ Predicate "resource" [Variable "0"] 41 | , Predicate "operation" [LString "read"] 42 | ] [] [] 43 | 44 | antiquotedFact :: TestTree 45 | antiquotedFact = testCase "Sliced fact" $ 46 | let toto2' :: Text 47 | toto2' = "test" 48 | actual :: Fact 49 | actual = [fact|right({toto2'}, "read")|] 50 | in actual @?= 51 | Predicate "right" [ LString "test" 52 | , LString "read" 53 | ] 54 | 55 | antiquotedRule :: TestTree 56 | antiquotedRule = testCase "Sliced rule" $ 57 | let toto :: Text 58 | toto = "test" 59 | actual :: Rule 60 | actual = [rule|right($0, "read") <- resource( $0), operation("read", {toto})|] 61 | in actual @?= 62 | Rule (Predicate "right" [Variable "0", LString "read"]) 63 | [ Predicate "resource" [Variable "0"] 64 | , Predicate "operation" [LString "read", LString "test"] 65 | ] [] [] 66 | -------------------------------------------------------------------------------- /biscuit/test/Spec/Roundtrip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {- 7 | Copyright : © Clément Delafargue, 2021 8 | License : BSD-3-Clause 9 | -} 10 | module Spec.Roundtrip 11 | ( specs 12 | ) where 13 | 14 | import Control.Arrow ((&&&)) 15 | import Data.ByteString (ByteString) 16 | import Data.List.NonEmpty (NonEmpty ((:|))) 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | 20 | import Auth.Biscuit hiding (Biscuit, ParseError, PublicKey, 21 | addBlock, mkBiscuit, publicKey) 22 | import Auth.Biscuit.Crypto 23 | import Auth.Biscuit.Token 24 | 25 | specs :: TestTree 26 | specs = testGroup "Serde roundtrips" 27 | [ testGroup "Raw serde" 28 | [ singleBlock (serialize, parse) 29 | , multipleBlocks (serialize, parse) 30 | , thirdPartyBlocks (serialize, parse) 31 | ] 32 | , testGroup "B64 serde" 33 | [ singleBlock (serializeB64, parseB64) 34 | , multipleBlocks (serializeB64, parseB64) 35 | ] 36 | , testGroup "Keys serde" 37 | [ secret 38 | , public 39 | ] 40 | ] 41 | 42 | type Roundtrip = ( Biscuit Open Verified -> ByteString 43 | , PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified) 44 | ) 45 | 46 | roundtrip :: Roundtrip 47 | -> NonEmpty Block 48 | -> Assertion 49 | roundtrip r bs = roundtrip' r $ (Nothing,) <$> bs 50 | 51 | roundtrip' :: Roundtrip 52 | -> NonEmpty (Maybe SecretKey, Block) 53 | -> Assertion 54 | roundtrip' (s,p) i@(authority' :| blocks') = do 55 | let addBlocks bs biscuit = case bs of 56 | ((Just sk, b):rest) -> addBlocks rest =<< addSignedBlock sk b biscuit 57 | ((Nothing, b):rest) -> addBlocks rest =<< addBlock b biscuit 58 | [] -> pure biscuit 59 | sk <- generateSecretKey 60 | let pk = toPublic sk 61 | init' <- mkBiscuitWith (Just 1) sk (snd authority') 62 | final <- addBlocks blocks' init' 63 | let serialized = s final 64 | parsed = p pk serialized 65 | getBlock ((_, b), _, _, _) = b 66 | getBlocks b = getBlock <$> authority b :| blocks b 67 | getBlocks <$> parsed @?= Right (snd <$> i) 68 | rootKeyId <$> parsed @?= Right (Just 1) 69 | 70 | roundtrip'' :: Bool 71 | -> Roundtrip 72 | -> NonEmpty (Maybe SecretKey, Block) 73 | -> Assertion 74 | roundtrip'' direct (s,p) i@(authority' :| blocks') = do 75 | let addSignedBlock' :: SecretKey -> Block -> Biscuit Open check -> IO (Biscuit Open check) 76 | addSignedBlock' sk block biscuit = do 77 | if direct 78 | then 79 | addSignedBlock sk block biscuit 80 | else do 81 | let req = mkThirdPartyBlockReq biscuit 82 | thirdPartyBlock <- either (fail . ("req " <>)) pure $ mkThirdPartyBlock sk req block 83 | either (fail . ("apply " <>)) id $ applyThirdPartyBlock biscuit thirdPartyBlock 84 | addBlocks bs biscuit = case bs of 85 | ((Just sk, b):rest) -> addBlocks rest =<< addSignedBlock' sk b biscuit 86 | ((Nothing, b):rest) -> addBlocks rest =<< addBlock b biscuit 87 | [] -> pure biscuit 88 | sk <- generateSecretKey 89 | let pk = toPublic sk 90 | init' <- mkBiscuitWith (Just 1) sk (snd authority') 91 | final <- addBlocks blocks' init' 92 | let serialized = s final 93 | parsed = p pk serialized 94 | getBlock ((_, b), _, _, _) = b 95 | getBlocks b = getBlock <$> authority b :| blocks b 96 | getBlocks <$> parsed @?= Right (snd <$> i) 97 | rootKeyId <$> parsed @?= Right (Just 1) 98 | 99 | singleBlock :: Roundtrip -> TestTree 100 | singleBlock r = testCase "Single block" $ roundtrip r $ pure 101 | [block| 102 | right("file1", "read"); 103 | right("file2", "read"); 104 | right("file1", "write"); 105 | |] 106 | 107 | multipleBlocks :: Roundtrip -> TestTree 108 | multipleBlocks r = testCase "Multiple block" $ roundtrip r $ 109 | [block| 110 | right("file1", "read"); 111 | right("file2", "read"); 112 | right("file1", "write"); 113 | |] :| 114 | [ [block| 115 | valid_date("file1") <- time($0), resource("file1"), $0 <= 2030-12-31T12:59:59+00:00; 116 | valid_date($1) <- time($0), resource($1), $0 <= 1999-12-31T12:59:59+00:00, !["file1"].contains($1); 117 | check if valid_date($0), resource($0); 118 | |] 119 | , [block| 120 | check if true; 121 | check if !false; 122 | check if !false; 123 | check if false or true; 124 | check if 1 < 2; 125 | check if 2 > 1; 126 | check if 1 <= 2; 127 | check if 1 <= 1; 128 | check if 2 >= 1; 129 | check if 2 >= 2; 130 | check if 3 == 3; 131 | check if 1 + 2 * 3 - 4 / 2 == 5; 132 | check if "hello world".starts_with("hello") && "hello world".ends_with("world"); 133 | check if "aaabde".matches("a*c?.e"); 134 | check if "abcD12" == "abcD12"; 135 | check if 2019-12-04T09:46:41+00:00 < 2020-12-04T09:46:41+00:00; 136 | check if 2020-12-04T09:46:41+00:00 > 2019-12-04T09:46:41+00:00; 137 | check if 2019-12-04T09:46:41+00:00 <= 2020-12-04T09:46:41+00:00; 138 | check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00; 139 | check if 2020-12-04T09:46:41+00:00 >= 2019-12-04T09:46:41+00:00; 140 | check if 2020-12-04T09:46:41+00:00 >= 2020-12-04T09:46:41+00:00; 141 | check if 2020-12-04T09:46:41+00:00 == 2020-12-04T09:46:41+00:00; 142 | check if hex:12ab == hex:12ab; 143 | check if [1, 2].contains(2); 144 | check if [2019-12-04T09:46:41+00:00, 2020-12-04T09:46:41+00:00].contains(2020-12-04T09:46:41+00:00); 145 | check if [false, true].contains(true); 146 | check if ["abc", "def"].contains("abc"); 147 | check if [hex:12ab, hex:34de].contains(hex:34de); 148 | check if ["hello", "world"].contains("hello"); 149 | |] 150 | , [block| 151 | check if 152 | resource($0), 153 | operation("read"), 154 | right($0, "read"); 155 | |] 156 | , [block| 157 | check if resource("file1"); 158 | check if time($date), $date <= 2018-12-20T00:00:00+00:00; 159 | |] 160 | ] 161 | 162 | thirdPartyBlocks :: Roundtrip -> TestTree 163 | thirdPartyBlocks r = 164 | let mkBlocks = do 165 | (sk1, pkOne) <- (id &&& toPublic) <$> generateSecretKey 166 | (sk2, pkTwo) <- (id &&& toPublic) <$> generateSecretKey 167 | (sk3, pkThree) <- (id &&& toPublic) <$> generateSecretKey 168 | pure $ (Nothing, [block| 169 | query("authority"); 170 | right("file1", "read"); 171 | right("file2", "read"); 172 | right("file1", "write"); 173 | check if true trusting previous, {pkOne}; 174 | |]) :| 175 | [ (Just sk1, [block| 176 | query("block1"); 177 | check if right("file2", "read") trusting {pkTwo}; 178 | check if right("file3", "read") trusting {pkOne}; 179 | |]) 180 | , (Just sk2, [block| 181 | query("block2"); 182 | check if right("file2", "read") trusting {pkTwo}; 183 | check if right("file3", "read") trusting {pkOne}; 184 | |]) 185 | , (Nothing, [block| 186 | query("block3"); 187 | check if right("file2", "read") trusting {pkTwo}; 188 | check if right("file3", "read") trusting {pkThree}; 189 | |]) 190 | ] 191 | in testGroup "Third party blocks" 192 | [ testCase "Direct append" $ roundtrip'' True r =<< mkBlocks 193 | , testCase "Indirect append" $ roundtrip'' False r =<< mkBlocks 194 | ] 195 | 196 | secret :: TestTree 197 | secret = testGroup "Secret key serde" 198 | [ testCase "Raw bytes" $ do 199 | sk <- newSecret 200 | parseSecretKey (serializeSecretKey sk) @?= Just sk 201 | , testCase "Hex encoding" $ do 202 | sk <- newSecret 203 | parseSecretKeyHex (serializeSecretKeyHex sk) @?= Just sk 204 | ] 205 | 206 | public :: TestTree 207 | public = testGroup "Public key serde" 208 | [ testCase "Raw bytes" $ do 209 | pk <- toPublic <$> newSecret 210 | parsePublicKey (serializePublicKey pk) @?= Just pk 211 | , testCase "Hex encoding" $ do 212 | pk <- toPublic <$> newSecret 213 | parsePublicKeyHex (serializePublicKeyHex pk) @?= Just pk 214 | ] 215 | -------------------------------------------------------------------------------- /biscuit/test/Spec/SampleReader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DuplicateRecordFields #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {- 14 | Copyright : © Clément Delafargue, 2021 15 | License : BSD-3-Clause 16 | -} 17 | module Spec.SampleReader where 18 | 19 | import Control.Arrow ((&&&)) 20 | import Control.Lens ((^?)) 21 | import Control.Monad (join, void, when) 22 | import Data.Aeson 23 | import Data.Aeson.Lens (key) 24 | import Data.Aeson.Types (typeMismatch, unexpected) 25 | import Data.Bifunctor (Bifunctor (..)) 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString as BS 28 | import qualified Data.ByteString.Base16 as Hex 29 | import qualified Data.ByteString.Lazy as LBS 30 | import Data.Foldable (fold, traverse_) 31 | import Data.List.NonEmpty (NonEmpty (..), toList) 32 | import Data.Map.Strict (Map) 33 | import qualified Data.Map.Strict as Map 34 | import Data.Maybe (fromJust, isJust, isNothing) 35 | import Data.Text (Text, pack, unpack) 36 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 37 | import Data.Traversable (for) 38 | import GHC.Generics (Generic) 39 | import GHC.Records (HasField (getField)) 40 | 41 | import Test.Tasty hiding (Timeout) 42 | import Test.Tasty.HUnit 43 | 44 | import Auth.Biscuit 45 | import Auth.Biscuit.Datalog.AST (renderAuthorizer, renderBlock) 46 | import Auth.Biscuit.Datalog.Executor (ExecutionError (..), 47 | ResultError (..)) 48 | import Auth.Biscuit.Datalog.Parser (authorizerParser, blockParser) 49 | import Auth.Biscuit.Token 50 | import Auth.Biscuit.Utils (encodeHex) 51 | 52 | import Spec.Parser (parseAuthorizer, parseBlock) 53 | 54 | getB :: ParsedSignedBlock -> Block 55 | getB ((_, b), _, _, _) = b 56 | 57 | getAuthority :: Biscuit p Verified -> Block 58 | getAuthority = getB . authority 59 | 60 | getBlocks :: Biscuit p Verified -> [Block] 61 | getBlocks = fmap getB . blocks 62 | 63 | instance FromJSON SecretKey where 64 | parseJSON = withText "Ed25519 secret key" $ \t -> do 65 | let bs = encodeUtf8 t 66 | res = parseSecretKeyHex bs 67 | notSk = typeMismatch "Ed25519 secret key" (String t) 68 | maybe notSk pure res 69 | 70 | instance ToJSON SecretKey where 71 | toJSON = toJSON . decodeUtf8 . serializeSecretKeyHex 72 | 73 | instance FromJSON PublicKey where 74 | parseJSON = withText "Ed25519 public key" $ \t -> do 75 | let bs = encodeUtf8 t 76 | res = parsePublicKeyHex bs 77 | notPk = typeMismatch "Ed25519 public key" (String t) 78 | maybe notPk pure res 79 | 80 | instance ToJSON PublicKey where 81 | toJSON = toJSON . decodeUtf8 . serializePublicKeyHex 82 | 83 | instance FromJSON Authorizer where 84 | parseJSON = withText "authorizer" $ \t -> do 85 | let res = parseAuthorizer t 86 | notAuthorizer e = typeMismatch e (String t) 87 | either notAuthorizer pure res 88 | 89 | instance ToJSON Authorizer where 90 | toJSON = toJSON . renderAuthorizer 91 | 92 | data SampleFile a 93 | = SampleFile 94 | { root_private_key :: SecretKey 95 | , root_public_key :: PublicKey 96 | , testcases :: [TestCase a] 97 | } 98 | deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) 99 | deriving anyclass (FromJSON, ToJSON) 100 | 101 | data RustResult e a 102 | = Err e 103 | | Ok a 104 | deriving stock (Generic, Eq, Show, Functor) 105 | 106 | instance Bifunctor RustResult where 107 | bimap f g = \case 108 | Err e -> Err $ f e 109 | Ok a -> Ok $ g a 110 | 111 | instance (FromJSON e, FromJSON a) => FromJSON (RustResult e a) where 112 | parseJSON = genericParseJSON $ 113 | defaultOptions { sumEncoding = ObjectWithSingleField } 114 | 115 | instance (ToJSON e, ToJSON a) => ToJSON (RustResult e a) where 116 | toJSON = genericToJSON $ 117 | defaultOptions { sumEncoding = ObjectWithSingleField } 118 | 119 | type RustError = Value 120 | 121 | data ValidationR 122 | = ValidationR 123 | { world :: Maybe WorldDesc 124 | , result :: RustResult RustError Int 125 | , authorizer_code :: Authorizer 126 | , revocation_ids :: [Text] 127 | } deriving stock (Eq, Show, Generic) 128 | deriving anyclass (FromJSON, ToJSON) 129 | 130 | checkResult :: Show a 131 | => (a -> RustError -> Assertion) 132 | -> RustResult RustError Int 133 | -> Either a b 134 | -> Assertion 135 | checkResult f r e = case (r, e) of 136 | (Err es, Right _) -> assertFailure $ "Got success, but expected failure: " <> show es 137 | (Ok _, Left e) -> assertFailure $ "Expected success, but got failure: " <> show e 138 | (Err es, Left e) -> f e es 139 | _ -> pure () 140 | 141 | 142 | data TestCase a 143 | = TestCase 144 | { title :: String 145 | , filename :: a 146 | , token :: NonEmpty BlockDesc 147 | , validations :: Map String ValidationR 148 | } 149 | deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) 150 | deriving anyclass (FromJSON, ToJSON) 151 | 152 | data BlockDesc 153 | = BlockDesc 154 | { symbols :: [Text] 155 | , code :: Text 156 | } 157 | deriving stock (Eq, Show, Generic) 158 | deriving anyclass (FromJSON, ToJSON) 159 | 160 | data FactSet 161 | = FactSet 162 | { origin :: [Maybe Integer] 163 | , facts :: [Text] 164 | } 165 | deriving stock (Eq, Show, Generic) 166 | deriving anyclass (FromJSON, ToJSON) 167 | 168 | data RuleSet 169 | = RuleSet 170 | { origin :: Maybe Integer 171 | , rules :: [Text] 172 | } 173 | deriving stock (Eq, Show, Generic) 174 | deriving anyclass (FromJSON, ToJSON) 175 | 176 | data CheckSet 177 | = CheckSet 178 | { origin :: Maybe Integer 179 | , checks :: [Text] 180 | } 181 | deriving stock (Eq, Show, Generic) 182 | deriving anyclass (FromJSON, ToJSON) 183 | 184 | data WorldDesc 185 | = WorldDesc 186 | { facts :: [FactSet] 187 | , rules :: [RuleSet] 188 | , checks :: [CheckSet] 189 | , policies :: [Text] 190 | } 191 | deriving stock (Eq, Show, Generic) 192 | deriving anyclass (FromJSON, ToJSON) 193 | 194 | instance Semigroup WorldDesc where 195 | a <> b = WorldDesc 196 | { facts = getField @"facts" a <> getField @"facts" b 197 | , rules = getField @"rules" a <> getField @"rules" b 198 | , checks = getField @"checks" a <> getField @"checks" b 199 | , policies = policies a <> policies b 200 | } 201 | 202 | instance Monoid WorldDesc where 203 | mempty = WorldDesc [] [] [] [] 204 | 205 | readBiscuits :: SampleFile FilePath -> IO (SampleFile (FilePath, ByteString)) 206 | readBiscuits = 207 | traverse $ traverse (BS.readFile . ("test/samples/current/" <>)) . join (&&&) id 208 | 209 | readSamplesFile :: IO (SampleFile (FilePath, ByteString)) 210 | readSamplesFile = do 211 | f <- either fail pure =<< eitherDecodeFileStrict' "test/samples/current/samples.json" 212 | readBiscuits f 213 | 214 | checkTokenBlocks :: (String -> IO ()) 215 | -> Biscuit OpenOrSealed Verified 216 | -> NonEmpty BlockDesc 217 | -> Assertion 218 | checkTokenBlocks step b blockDescs = do 219 | step "Checking blocks" 220 | let bs = getAuthority b :| getBlocks b 221 | expected = traverse (parseBlock . code) blockDescs 222 | expected @?= Right bs 223 | 224 | processTestCase :: (String -> IO ()) 225 | -> PublicKey -> TestCase (FilePath, ByteString) 226 | -> Assertion 227 | processTestCase step rootPk TestCase{..} = 228 | if fst filename == "test018_unbound_variables_in_rule.bc" 229 | then 230 | step "Skipping for now (unbound variables are now caught before evaluation)" 231 | else do 232 | step "Parsing " 233 | let vList = Map.toList validations 234 | case parse rootPk (snd filename) of 235 | Left parseError -> traverse_ (processFailedValidation step parseError) vList 236 | Right biscuit -> do 237 | checkTokenBlocks step biscuit token 238 | traverse_ (processValidation step biscuit) vList 239 | 240 | compareParseErrors :: ParseError -> RustError -> Assertion 241 | compareParseErrors pe re = 242 | let mustMatch p = assertBool (show (re,pe)) $ isJust $ re ^? p 243 | mustMatchEither ps = assertBool (show (re, pe)) $ any (isJust . (re ^?)) ps 244 | in case pe of 245 | InvalidHexEncoding -> 246 | assertFailure $ "InvalidHexEncoding can't appear here " <> show re 247 | InvalidB64Encoding -> 248 | mustMatch $ key "Base64" 249 | InvalidProtobufSer True s -> 250 | mustMatch $ key "Format" . key "DeserializationError" 251 | InvalidProtobuf True s -> 252 | mustMatch $ key "Format" . key "DeserializationError" 253 | InvalidProtobufSer False s -> 254 | mustMatch $ key "Format" . key "BlockDeserializationError" 255 | InvalidProtobuf False s -> 256 | mustMatch $ key "Format" . key "BlockDeserializationError" 257 | -- the signature size is now verified just before verifying the 258 | -- signature itself, not at deserialization time, since we want 259 | -- to interpret signatures only relative to the verifying public 260 | -- key. 261 | InvalidSignatures -> 262 | mustMatchEither 263 | [ key "Format" . key "Signature" . key "InvalidSignature" 264 | , key "Format" . key "InvalidSignatureSize" 265 | ] 266 | InvalidProof -> 267 | assertFailure $ "InvalidProof can't appear here " <> show re 268 | RevokedBiscuit -> 269 | assertFailure $ "RevokedBiscuit can't appear here " <> show re 270 | 271 | compareExecErrors :: ExecutionError -> RustError -> Assertion 272 | compareExecErrors ee re = 273 | let errorMessage = "ExecutionError mismatch: " <> show ee <> " " <> unpack (decodeUtf8 . LBS.toStrict $ encode re) 274 | mustMatch p = assertBool errorMessage $ isJust $ re ^? p 275 | -- todo compare `Unauthorized` contents 276 | in case ee of 277 | Timeout -> mustMatch $ key "RunLimit" . key "Timeout" 278 | TooManyFacts -> mustMatch $ key "RunLimit" . key "TooManyFacts" 279 | TooManyIterations -> mustMatch $ key "RunLimit" . key "TooManyIterations" 280 | InvalidRule -> mustMatch $ key "FailedLogic" . key "InvalidBlockRule" 281 | EvaluationError _ -> mustMatch $ key "Execution" 282 | ResultError (NoPoliciesMatched cs) -> mustMatch $ key "FailedLogic" . key "Unauthorized" 283 | ResultError (FailedChecks cs) -> mustMatch $ key "FailedLogic" . key "Unauthorized" 284 | ResultError (DenyRuleMatched cs q) -> mustMatch $ key "FailedLogic" . key "Unauthorized" 285 | 286 | processFailedValidation :: (String -> IO ()) 287 | -> ParseError 288 | -> (String, ValidationR) 289 | -> Assertion 290 | processFailedValidation step e (name, ValidationR{result}) = do 291 | step $ "Checking validation " <> name 292 | checkResult compareParseErrors result (Left e) 293 | 294 | processValidation :: (String -> IO ()) 295 | -> Biscuit OpenOrSealed Verified 296 | -> (String, ValidationR) 297 | -> Assertion 298 | processValidation step b (name, ValidationR{..}) = do 299 | when (name /= "") $ step ("Checking " <> name) 300 | let w = fold world 301 | pols <- either (assertFailure . show) pure $ parseAuthorizer $ foldMap (<> ";") (policies w) 302 | res <- authorizeBiscuit b (authorizer_code <> pols) 303 | checkResult compareExecErrors result res 304 | let revocationIds = encodeHex <$> toList (getRevocationIds b) 305 | step "Comparing revocation ids" 306 | revocation_ids @?= revocationIds 307 | 308 | 309 | runTests :: (String -> IO ()) 310 | -> Assertion 311 | runTests step = do 312 | step "Parsing sample file" 313 | SampleFile{..} <- readSamplesFile 314 | traverse_ (processTestCase step root_public_key) testcases 315 | 316 | mkTestCase :: PublicKey -> TestCase (FilePath, ByteString) -> TestTree 317 | mkTestCase root_public_key tc@TestCase{filename} = 318 | testCaseSteps (fst filename) (\step -> processTestCase step root_public_key tc) 319 | 320 | getSpecs :: IO TestTree 321 | getSpecs = do 322 | SampleFile{..} <- readSamplesFile 323 | pure $ testGroup "Biscuit samples - compliance checks" 324 | $ mkTestCase root_public_key <$> testcases 325 | mkTestCaseFromBiscuit 326 | :: String 327 | -> FilePath 328 | -> Biscuit Open Verified 329 | -> [(String, Authorizer)] 330 | -> IO (TestCase FilePath) 331 | mkTestCaseFromBiscuit title filename biscuit authorizers = do 332 | let mkBlockDesc :: Block -> BlockDesc 333 | mkBlockDesc b = BlockDesc 334 | { code = renderBlock b 335 | , symbols = [] 336 | } 337 | mkValidation :: Authorizer -> IO ValidationR 338 | mkValidation authorizer = do 339 | Right success <- authorizeBiscuit biscuit authorizer 340 | pure ValidationR 341 | { world = Just mempty 342 | , result = Ok 0 343 | , authorizer_code = authorizer 344 | , revocation_ids = encodeHex <$> toList (getRevocationIds biscuit) 345 | } 346 | BS.writeFile ("test/samples/current/" <> filename) (serialize biscuit) 347 | let token = mkBlockDesc <$> getAuthority biscuit :| getBlocks biscuit 348 | validations <- Map.fromList <$> traverse (traverse mkValidation) authorizers 349 | 350 | pure TestCase{..} 351 | -------------------------------------------------------------------------------- /biscuit/test/Spec/ScopedExecutor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {- HLINT ignore "Reduce duplication" -} 4 | {- 5 | Copyright : © Clément Delafargue, 2021 6 | License : BSD-3-Clause 7 | -} 8 | module Spec.ScopedExecutor (specs) where 9 | 10 | import Control.Arrow ((&&&)) 11 | import Data.Either (isRight) 12 | import Data.Map.Strict as Map 13 | import Data.Set as Set 14 | import Data.Text (Text, unpack) 15 | import Test.Tasty 16 | import Test.Tasty.HUnit 17 | 18 | import Auth.Biscuit (addBlock, addSignedBlock, 19 | authorizeBiscuit, 20 | mkBiscuit, newSecret, 21 | queryAuthorizerFacts, 22 | queryRawBiscuitFacts) 23 | import Auth.Biscuit.Crypto 24 | import Auth.Biscuit.Datalog.AST 25 | import Auth.Biscuit.Datalog.Executor (ExecutionError (..), 26 | Limits (..), 27 | ResultError (..), 28 | defaultLimits) 29 | import Auth.Biscuit.Datalog.Parser (authorizer, block, check, 30 | query, run) 31 | import Auth.Biscuit.Datalog.ScopedExecutor 32 | 33 | specs :: TestTree 34 | specs = testGroup "Block-scoped Datalog Evaluation" 35 | [ authorizerOnlySeesAuthority 36 | , authorityOnlySeesItselfAndAuthorizer 37 | , block1OnlySeesAuthorityAndAuthorizer 38 | , block2OnlySeesAuthorityAndAuthorizer 39 | , block1SeesAuthorityAndAuthorizer 40 | , thirdPartyBlocks 41 | , iterationCountWorks 42 | , maxFactsCountWorks 43 | , allChecksAreCollected 44 | , revocationIdsAreInjected 45 | , authorizerFactsAreQueried 46 | , biscuitFactsAreQueried 47 | ] 48 | 49 | authorizerOnlySeesAuthority :: TestTree 50 | authorizerOnlySeesAuthority = testCase "Authorizer only accesses facts from authority" $ do 51 | let authority = 52 | [block| 53 | user(1234); 54 | |] 55 | block1 = 56 | [block| 57 | is_allowed(1234, "file1", "write"); 58 | |] 59 | verif = 60 | [authorizer| 61 | allow if is_allowed(1234, "file1", "write"); 62 | |] 63 | runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError (NoPoliciesMatched [])) 64 | 65 | authorityOnlySeesItselfAndAuthorizer :: TestTree 66 | authorityOnlySeesItselfAndAuthorizer = testCase "Authority rules only see authority and authorizer facts" $ do 67 | let authority = 68 | [block| 69 | user(1234); 70 | is_allowed($user, $resource) <- right($user, $resource, "read"); 71 | |] 72 | block1 = 73 | [block| 74 | right(1234, "file1", "read"); 75 | |] 76 | verif = 77 | [authorizer| 78 | allow if is_allowed(1234, "file1"); 79 | |] 80 | runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError (NoPoliciesMatched [])) 81 | 82 | block1OnlySeesAuthorityAndAuthorizer :: TestTree 83 | block1OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do 84 | let authority = 85 | [block| 86 | user(1234); 87 | |] 88 | block1 = 89 | [block| 90 | is_allowed($user, $resource) <- right($user, $resource, "read"); 91 | check if is_allowed(1234, "file1"); 92 | |] 93 | block2 = 94 | [block| 95 | right(1234, "file1", "read"); 96 | |] 97 | verif = 98 | [authorizer| 99 | allow if true; 100 | |] 101 | runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) 102 | 103 | block1SeesAuthorityAndAuthorizer :: TestTree 104 | block1SeesAuthorityAndAuthorizer = testCase "Arbitrary blocks see previous blocks" $ do 105 | let authority = 106 | [block| 107 | user(1234); 108 | |] 109 | block1 = 110 | [block| 111 | is_allowed($user, $resource) <- user($user), right($user, $resource, "read"); 112 | right(1234, "file1", "read"); 113 | check if is_allowed(1234, "file1"); 114 | |] 115 | verif = 116 | [authorizer| allow if false; 117 | |] 118 | runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched []) 119 | 120 | block2OnlySeesAuthorityAndAuthorizer :: TestTree 121 | block2OnlySeesAuthorityAndAuthorizer = testCase "Arbitrary blocks only see previous blocks" $ do 122 | let authority = 123 | [block| 124 | user(1234); 125 | |] 126 | block1 = 127 | [block| 128 | right(1234, "file1", "read"); 129 | |] 130 | block2 = 131 | [block| 132 | is_allowed($user, $resource) <- right($user, $resource, "read"); 133 | check if is_allowed(1234, "file1"); 134 | |] 135 | verif = 136 | [authorizer| 137 | allow if true; 138 | |] 139 | runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError (FailedChecks $ pure [check|check if is_allowed(1234, "file1") |])) 140 | 141 | thirdPartyBlocks :: TestTree 142 | thirdPartyBlocks = testCase "Third party blocks are correctly scoped" $ do 143 | (sk1, pkOne) <- (id &&& toPublic) <$> generateSecretKey 144 | let authority = 145 | [block| 146 | user(1234); 147 | check if from3rd(1, true) trusting {pkOne}; 148 | check if from3rd(2, true) trusting {pkOne}; 149 | |] 150 | block1 = 151 | [block| 152 | from3rd(1, true); 153 | |] 154 | block2 = 155 | [block| 156 | from3rd(2, true); 157 | |] 158 | verif = 159 | [authorizer| 160 | deny if from3rd(1, true); 161 | allow if from3rd(1, true), from3rd(2, true) trusting {pkOne}; 162 | |] 163 | let result = runAuthorizerNoTimeout defaultLimits 164 | (authority, "", Nothing) 165 | [ (block1, "", Just pkOne) 166 | , (block2, "", Just pkOne) 167 | ] 168 | verif 169 | isRight result @?= True 170 | 171 | iterationCountWorks :: TestTree 172 | iterationCountWorks = testCase "ScopedExecutions stops when hitting the iterations threshold" $ do 173 | let limits = defaultLimits { maxIterations = 8 } 174 | authority = 175 | [block| 176 | a("yolo"); 177 | b($a) <- a($a); 178 | c($b) <- b($b); 179 | d($c) <- c($c); 180 | e($d) <- d($d); 181 | f($e) <- e($e); 182 | g($f) <- f($f); 183 | |] 184 | block1 = 185 | [block| 186 | h($g) <- g($g); 187 | i($h) <- h($h); 188 | j($i) <- i($i); 189 | k($j) <- j($j); 190 | l($k) <- k($k); 191 | m($l) <- l($l); 192 | |] 193 | verif = 194 | [authorizer| 195 | allow if true; 196 | |] 197 | runAuthorizerNoTimeout limits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left TooManyIterations 198 | 199 | maxFactsCountWorks :: TestTree 200 | maxFactsCountWorks = testCase "ScopedExecutions stops when hitting the facts threshold" $ do 201 | let limits = defaultLimits { maxFacts = 8 } 202 | authority = 203 | [block| 204 | a("yolo"); 205 | b($a) <- a($a); 206 | c($b) <- b($b); 207 | d($c) <- c($c); 208 | e($d) <- d($d); 209 | f($e) <- e($e); 210 | g($f) <- f($f); 211 | |] 212 | block1 = 213 | [block| 214 | h($g) <- g($g); 215 | i($h) <- h($h); 216 | j($i) <- i($i); 217 | k($j) <- j($j); 218 | l($k) <- k($k); 219 | m($l) <- l($l); 220 | |] 221 | verif = 222 | [authorizer| 223 | allow if true; 224 | |] 225 | runAuthorizerNoTimeout limits (authority, "", Nothing) [(block1, "", Nothing)] verif @?= Left TooManyFacts 226 | 227 | allChecksAreCollected :: TestTree 228 | allChecksAreCollected = testCase "ScopedExecutions collects all facts results even after a failure" $ do 229 | let authority = 230 | [block| 231 | user(1234); 232 | |] 233 | block1 = 234 | [block| 235 | check if false; 236 | |] 237 | block2 = 238 | [block| 239 | check if false; 240 | |] 241 | verif = 242 | [authorizer| 243 | allow if user(4567); 244 | |] 245 | runAuthorizerNoTimeout defaultLimits (authority, "", Nothing) [(block1, "", Nothing), (block2, "", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched [[check|check if false|], [check|check if false|]]) 246 | 247 | revocationIdsAreInjected :: TestTree 248 | revocationIdsAreInjected = testCase "ScopedExecutions injects revocation ids" $ do 249 | let authority = 250 | [block| 251 | user(1234); 252 | |] 253 | block1 = 254 | [block|yolo("block1");|] 255 | block2 = 256 | [block|yolo("block2");|] 257 | verif = 258 | [authorizer| 259 | check if revocation_id(0, hex:61), 260 | revocation_id(1, hex:62), 261 | revocation_id(2, hex:63); 262 | |] 263 | runAuthorizerNoTimeout defaultLimits (authority, "a", Nothing) [(block1, "b", Nothing), (block2, "c", Nothing)] verif @?= Left (ResultError $ NoPoliciesMatched []) 264 | 265 | authorizerFactsAreQueried :: TestTree 266 | authorizerFactsAreQueried = testGroup "AuthorizedBiscuit can be queried" 267 | [ testCase "Attenuation blocks are ignored" $ do 268 | (p,s) <- (toPublic &&& id) <$> newSecret 269 | b <- mkBiscuit s [block|user(1234);|] 270 | b1 <- addBlock [block|user("tampered value");|] b 271 | result <- authorizeBiscuit b1 [authorizer|allow if true;|] 272 | let getUser s = queryAuthorizerFacts s [query|user($user)|] 273 | expected = Set.singleton $ Map.fromList 274 | [ ("user", LInteger 1234) 275 | ] 276 | getUser <$> result @?= Right (Right expected) 277 | , testCase "Attenuation blocks can be accessed if asked nicely" $ do 278 | (p,s) <- (toPublic &&& id) <$> newSecret 279 | b <- mkBiscuit s [block|user(1234);|] 280 | b1 <- addBlock [block|user("tampered value");|] b 281 | result <- authorizeBiscuit b1 [authorizer|allow if true;|] 282 | let getUser s = queryAuthorizerFacts s [query|user($user) trusting previous|] 283 | expected = Set.fromList 284 | [ Map.fromList [("user", LInteger 1234)] 285 | , Map.fromList [("user", LString "tampered value")] 286 | ] 287 | getUser <$> result @?= Right (Right expected) 288 | , testCase "Signed blocks can be accessed if asked nicely" $ do 289 | (p,s) <- (toPublic &&& id) <$> newSecret 290 | (p1,s1) <- (toPublic &&& id) <$> newSecret 291 | b <- mkBiscuit s [block|user(1234);|] 292 | b1 <- addBlock [block|user("tampered value");|] b 293 | b2 <- addSignedBlock s1 [block|user("from signed");|] b1 294 | result <- authorizeBiscuit b2 [authorizer|allow if true;|] 295 | let getUser s = queryAuthorizerFacts s [query|user($user) trusting authority, {p1}|] 296 | expected = Set.fromList 297 | [ Map.fromList [("user", LInteger 1234)] 298 | , Map.fromList [("user", LString "from signed")] 299 | ] 300 | getUser <$> result @?= Right (Right expected) 301 | ] 302 | 303 | biscuitFactsAreQueried :: TestTree 304 | biscuitFactsAreQueried = testGroup "Biscuit can be queried" 305 | [ testCase "Attenuation blocks are ignored" $ do 306 | (p,s) <- (toPublic &&& id) <$> newSecret 307 | b <- mkBiscuit s [block|user(1234);|] 308 | b1 <- addBlock [block|user("tampered value");|] b 309 | let user = queryRawBiscuitFacts b1 [query|user($user)|] 310 | expected = Set.singleton $ Map.fromList 311 | [ ("user", LInteger 1234) 312 | ] 313 | user @?= Right expected 314 | , testCase "Attenuation blocks can be accessed if asked nicely" $ do 315 | (p,s) <- (toPublic &&& id) <$> newSecret 316 | b <- mkBiscuit s [block|user(1234);|] 317 | b1 <- addBlock [block|user("tampered value");|] b 318 | let user = queryRawBiscuitFacts b1 [query|user($user) trusting previous|] 319 | expected = Set.fromList 320 | [ Map.fromList [("user", LInteger 1234)] 321 | , Map.fromList [("user", LString "tampered value")] 322 | ] 323 | user @?= Right expected 324 | , testCase "Signed blocks can be accessed if asked nicely" $ do 325 | (p,s) <- (toPublic &&& id) <$> newSecret 326 | (p1,s1) <- (toPublic &&& id) <$> newSecret 327 | b <- mkBiscuit s [block|user(1234);|] 328 | b1 <- addBlock [block|user("tampered value");|] b 329 | b2 <- addSignedBlock s1 [block|user("from signed");|] b1 330 | let user = queryRawBiscuitFacts b2 [query|user($user) trusting authority, {p1}|] 331 | expected = Set.fromList 332 | [ Map.fromList [("user", LInteger 1234)] 333 | , Map.fromList [("user", LString "from signed")] 334 | ] 335 | user @?= Right expected 336 | ] 337 | -------------------------------------------------------------------------------- /biscuit/test/Spec/Verification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {- 5 | Copyright : © Clément Delafargue, 2021 6 | License : BSD-3-Clause 7 | -} 8 | module Spec.Verification 9 | ( specs 10 | ) where 11 | 12 | import Data.List.NonEmpty (NonEmpty ((:|))) 13 | import qualified Data.Set as Set 14 | import Test.Tasty 15 | import Test.Tasty.HUnit 16 | 17 | import Auth.Biscuit 18 | import Auth.Biscuit.Datalog.AST (Block' (..), Check, Check' (..), 19 | CheckKind (..), 20 | Expression' (..), 21 | Predicate' (..), Query, 22 | QueryItem' (..), Rule' (..), 23 | Term' (..)) 24 | import Auth.Biscuit.Datalog.Executor (MatchedQuery (..), 25 | ResultError (..)) 26 | import qualified Auth.Biscuit.Datalog.Executor as Executor 27 | import Auth.Biscuit.Datalog.Parser (check, fact, query) 28 | 29 | specs :: TestTree 30 | specs = testGroup "Datalog checks" 31 | [ singleBlock 32 | , checkAll 33 | , errorAccumulation 34 | , unboundVarRule 35 | , symbolRestrictions 36 | ] 37 | 38 | ifTrue :: MatchedQuery 39 | ifTrue = MatchedQuery 40 | { matchedQuery = [query|true|] 41 | , bindings = Set.singleton mempty 42 | } 43 | 44 | ifFalse :: MatchedQuery 45 | ifFalse = MatchedQuery 46 | { matchedQuery = [query|false|] 47 | , bindings = Set.singleton mempty 48 | } 49 | 50 | ifFalse' :: Check 51 | ifFalse' = Check 52 | { cQueries = matchedQuery ifFalse 53 | , cKind = One 54 | } 55 | 56 | checkAll' :: Check 57 | checkAll' = [check|check all fact($value), $value|] 58 | 59 | singleBlock :: TestTree 60 | singleBlock = testCase "Single block" $ do 61 | secret <- newSecret 62 | biscuit <- mkBiscuit secret [block|right("file1", "read");|] 63 | res <- authorizeBiscuit biscuit [authorizer|check if right("file1", "read");allow if true;|] 64 | matchedAllowQuery . authorizationSuccess <$> res @?= Right ifTrue 65 | 66 | checkAll :: TestTree 67 | checkAll = testCase "Check all" $ do 68 | secret <- newSecret 69 | biscuit <- mkBiscuit secret [block|fact(true); fact(false);|] 70 | res <- authorizeBiscuit biscuit [authorizer|check all fact($value), $value;allow if true;|] 71 | res @?= Left (ResultError $ FailedChecks $ pure checkAll') 72 | 73 | errorAccumulation :: TestTree 74 | errorAccumulation = testGroup "Error accumulation" 75 | [ testCase "Only checks" $ do 76 | secret <- newSecret 77 | biscuit <- mkBiscuit secret[block|check if false; check if false;|] 78 | res <- authorizeBiscuit biscuit [authorizer|allow if true;|] 79 | res @?= Left (ResultError $ FailedChecks $ ifFalse' :| [ifFalse']) 80 | , testCase "Checks and deny policies" $ do 81 | secret <- newSecret 82 | biscuit <- mkBiscuit secret [block|check if false; check if false;|] 83 | res <- authorizeBiscuit biscuit [authorizer|deny if true;|] 84 | res @?= Left(ResultError $ DenyRuleMatched [ifFalse', ifFalse'] ifTrue) 85 | , testCase "Checks and no policies matched" $ do 86 | secret <- newSecret 87 | biscuit <- mkBiscuit secret [block|check if false; check if false;|] 88 | res <- authorizeBiscuit biscuit [authorizer|allow if false;|] 89 | res @?= Left (ResultError $ NoPoliciesMatched [ifFalse', ifFalse']) 90 | ] 91 | 92 | unboundVarRule :: TestTree 93 | unboundVarRule = testCase "Rule with unbound variable" $ do 94 | secret <- newSecret 95 | b1 <- mkBiscuit secret [block|check if operation("read");|] 96 | -- rules with unbound variables don't parse, so we have 97 | -- to manually construct a broken rule 98 | let brokenRuleBlock = Block { 99 | bRules = [Rule{ 100 | rhead = Predicate{ 101 | name = "operation", 102 | terms = [Variable"unbound", LString "read"] 103 | }, 104 | body = [Predicate{ 105 | name = "operation", 106 | terms = Variable <$> ["any1", "any2"] 107 | }], 108 | expressions = mempty, 109 | scope = mempty 110 | }], 111 | bFacts = mempty, 112 | bChecks = mempty, 113 | bScope = mempty, 114 | bContext = mempty 115 | } 116 | b2 <- addBlock brokenRuleBlock b1 117 | res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|] 118 | res @?= Left InvalidRule 119 | 120 | symbolRestrictions :: TestTree 121 | symbolRestrictions = testGroup "Restricted symbols in blocks" 122 | [ testCase "In facts" $ do 123 | secret <- newSecret 124 | b1 <- mkBiscuit secret [block|check if operation("read");|] 125 | b2 <- addBlock [block|operation("read");|] b1 126 | res <- authorizeBiscuit b2 [authorizer|allow if true;|] 127 | res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|]) 128 | , testCase "In rules" $ do 129 | secret <- newSecret 130 | b1 <- mkBiscuit secret [block|check if operation("read");|] 131 | b2 <- addBlock [block|operation($ambient, "read") <- operation($ambient, $any);|] b1 132 | res <- authorizeBiscuit b2 [authorizer|operation("write");allow if true;|] 133 | res @?= Left (Executor.ResultError $ Executor.FailedChecks $ pure [check|check if operation("read")|]) 134 | ] 135 | -------------------------------------------------------------------------------- /biscuit/test/samples/current/test001_basic.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test001_basic.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test002_different_root_key.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test002_different_root_key.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test003_invalid_signature_format.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test003_invalid_signature_format.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test004_random_block.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test004_random_block.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test005_invalid_signature.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test005_invalid_signature.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test006_reordered_blocks.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test006_reordered_blocks.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test007_scoped_rules.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test007_scoped_rules.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test008_scoped_checks.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test008_scoped_checks.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test009_expired_token.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test009_expired_token.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test010_authorizer_scope.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test010_authorizer_scope.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test011_authorizer_authority_caveats.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test011_authorizer_authority_caveats.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test012_authority_caveats.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test012_authority_caveats.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test013_block_rules.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test013_block_rules.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test014_regex_constraint.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test014_regex_constraint.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test015_multi_queries_caveats.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test015_multi_queries_caveats.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test016_caveat_head_name.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test016_caveat_head_name.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test017_expressions.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test017_expressions.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test018_unbound_variables_in_rule.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test018_unbound_variables_in_rule.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test019_generating_ambient_from_variables.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test019_generating_ambient_from_variables.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test020_sealed.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test020_sealed.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test021_parsing.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test021_parsing.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test022_default_symbols.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test022_default_symbols.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test023_execution_scope.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test023_execution_scope.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test024_third_party.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test024_third_party.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test025_check_all.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test025_check_all.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test026_public_keys_interning.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test026_public_keys_interning.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test027_integer_wraparound.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test027_integer_wraparound.bc -------------------------------------------------------------------------------- /biscuit/test/samples/current/test028_expressions_v4.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eclipse-biscuit/biscuit-haskell/37fd06abdcc1d87bdd2db24c8e4aae65614c0c5b/biscuit/test/samples/current/test028_expressions_v4.bc -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | biscuit/ 3 | biscuit-servant/ 4 | 5 | tests: True 6 | documentation: True 7 | -------------------------------------------------------------------------------- /publish.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | echo -n "Release official package? y/N> " 4 | read CANDIDATE 5 | 6 | case "$CANDIDATE" in 7 | y) echo "Releasing official version"; CANDIDATE="--publish";; 8 | *) echo "Releasing candidate version"; CANDIDATE="";; 9 | esac 10 | 11 | echo -n "Release version> " 12 | read VERSION 13 | 14 | cabal upload "./dist-newstyle/sdist/biscuit-haskell-${VERSION}.tar.gz" ${CANDIDATE} 15 | cabal upload "./dist-newstyle/biscuit-haskell-${VERSION}-docs.tar.gz" --documentation ${CANDIDATE} 16 | cabal upload "./dist-newstyle/sdist/biscuit-servant-${VERSION}.tar.gz" ${CANDIDATE} 17 | cabal upload "./dist-newstyle/biscuit-servant-${VERSION}-docs.tar.gz" --documentation ${CANDIDATE} 18 | # cabal upload -u clementd -P 'pass show hackage' "./dist-newstyle/sdist/biscuit-wai-${VERSION}.tar.gz" ${CANDIDATE} 19 | # cabal upload -u clementd -P 'pass show hackage' "./dist-newstyle/biscuit-wai-${VERSION}-docs.tar.gz" --documentation ${CANDIDATE} 20 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: with pkgs; 2 | 3 | mkShell { 4 | buildInputs = [ 5 | haskell.compiler.ghc94 6 | haskell-language-server 7 | pkg-config 8 | libsodium 9 | zlib 10 | haskellPackages.hlint 11 | haskellPackages.stylish-haskell 12 | cabal-install 13 | ghcid 14 | ]; 15 | } 16 | --------------------------------------------------------------------------------