{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}
{-|
  Module      : Auth.Biscuit.Token
  Copyright   : © Clément Delafargue, 2021
  License     : MIT
  Maintainer  : clement@delafargue.name
  Module defining the main biscuit-related operations
-}
module Auth.Biscuit.Token
  ( Biscuit (..)
  , ParseError (..)
  , VerificationError (..)
  , ExistingBlock
  , mkBiscuit
  , addBlock
  , checkBiscuitSignature
  , parseBiscuit
  , serializeBiscuit
  , verifyBiscuit
  , verifyBiscuitWithLimits

  , BlockWithRevocationIds (..)
  , getRevocationIds
  ) where

import           Control.Monad                 (when)
import           Control.Monad.Except          (runExceptT, throwError)
import           Control.Monad.IO.Class        (liftIO)
import           Data.Bifunctor                (first)
import           Data.ByteString               (ByteString)
import           Data.List.NonEmpty            (NonEmpty ((:|)))
import qualified Data.List.NonEmpty            as NE

import           Auth.Biscuit.Datalog.AST      (Block, Query, Verifier)
import           Auth.Biscuit.Datalog.Executor (BlockWithRevocationIds (..),
                                                ExecutionError, Limits,
                                                defaultLimits,
                                                runVerifierWithLimits)
import qualified Auth.Biscuit.Proto            as PB
import           Auth.Biscuit.ProtoBufAdapter  (Symbols, blockToPb,
                                                commonSymbols, extractSymbols,
                                                pbToBlock)
import           Auth.Biscuit.Sel              (Keypair (publicKey), PublicKey,
                                                Signature (..), aggregate,
                                                hashBytes, newKeypair,
                                                parsePublicKey,
                                                serializePublicKey, signBlock,
                                                verifySignature)
import           Auth.Biscuit.Utils            (maybeToRight)

-- | Protobuf serialization does not have a guaranteed deterministic behaviour,
-- so we need to keep the initial serialized payload around in order to compute
-- a new signature when adding a block.
type ExistingBlock = (ByteString, Block)

-- | A parsed biscuit
data Biscuit
  = Biscuit
  { Biscuit -> Symbols
symbols   :: Symbols
  -- ^ The symbols already defined in the contained blocks
  , Biscuit -> (PublicKey, ExistingBlock)
authority :: (PublicKey, ExistingBlock)
  -- ^ The authority block, along with the associated public key. The public key
  -- is kept around since it's embedded in the serialized biscuit, but should not
  -- be used for verification. An externally provided public key should be used instead.
  , Biscuit -> [(PublicKey, ExistingBlock)]
blocks    :: [(PublicKey, ExistingBlock)]
  -- ^ The extra blocks, along with the public keys needed
  , Biscuit -> Signature
signature :: Signature
  }
  deriving (Biscuit -> Biscuit -> Bool
(Biscuit -> Biscuit -> Bool)
-> (Biscuit -> Biscuit -> Bool) -> Eq Biscuit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Biscuit -> Biscuit -> Bool
$c/= :: Biscuit -> Biscuit -> Bool
== :: Biscuit -> Biscuit -> Bool
$c== :: Biscuit -> Biscuit -> Bool
Eq, Int -> Biscuit -> ShowS
[Biscuit] -> ShowS
Biscuit -> String
(Int -> Biscuit -> ShowS)
-> (Biscuit -> String) -> ([Biscuit] -> ShowS) -> Show Biscuit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Biscuit] -> ShowS
$cshowList :: [Biscuit] -> ShowS
show :: Biscuit -> String
$cshow :: Biscuit -> String
showsPrec :: Int -> Biscuit -> ShowS
$cshowsPrec :: Int -> Biscuit -> ShowS
Show)

-- | Create a new biscuit with the provided authority block
mkBiscuit :: Keypair -> Block -> IO Biscuit
mkBiscuit :: Keypair -> Block -> IO Biscuit
mkBiscuit Keypair
keypair Block
authority = do
  let authorityPub :: PublicKey
authorityPub = Keypair -> PublicKey
publicKey Keypair
keypair
      (Symbols
s, ByteString
authoritySerialized) = Block -> ByteString
PB.encodeBlock (Block -> ByteString) -> (Symbols, Block) -> (Symbols, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbols -> Int -> Block -> (Symbols, Block)
blockToPb Symbols
commonSymbols Int
0 Block
authority
  Signature
signature <- Keypair -> ByteString -> IO Signature
signBlock Keypair
keypair ByteString
authoritySerialized
  Biscuit -> IO Biscuit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Biscuit -> IO Biscuit) -> Biscuit -> IO Biscuit
forall a b. (a -> b) -> a -> b
$ Biscuit :: Symbols
-> (PublicKey, ExistingBlock)
-> [(PublicKey, ExistingBlock)]
-> Signature
-> Biscuit
Biscuit { authority :: (PublicKey, ExistingBlock)
authority = (PublicKey
authorityPub, (ByteString
authoritySerialized, Block
authority))
                 , blocks :: [(PublicKey, ExistingBlock)]
blocks = []
                 , symbols :: Symbols
symbols = Symbols
commonSymbols Symbols -> Symbols -> Symbols
forall a. Semigroup a => a -> a -> a
<> Symbols
s
                 , Signature
signature :: Signature
signature :: Signature
signature
                 }

-- | Add a block to an existing biscuit. The block will be signed
-- with a randomly-generated keypair
addBlock :: Block -> Biscuit -> IO Biscuit
addBlock :: Block -> Biscuit -> IO Biscuit
addBlock Block
newBlock b :: Biscuit
b@Biscuit{[(PublicKey, ExistingBlock)]
(PublicKey, ExistingBlock)
Symbols
Signature
signature :: Signature
blocks :: [(PublicKey, ExistingBlock)]
authority :: (PublicKey, ExistingBlock)
symbols :: Symbols
signature :: Biscuit -> Signature
blocks :: Biscuit -> [(PublicKey, ExistingBlock)]
authority :: Biscuit -> (PublicKey, ExistingBlock)
symbols :: Biscuit -> Symbols
..} = do
  let (Symbols
s, ByteString
newBlockSerialized) = Block -> ByteString
PB.encodeBlock (Block -> ByteString) -> (Symbols, Block) -> (Symbols, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbols -> Int -> Block -> (Symbols, Block)
blockToPb Symbols
symbols ([(PublicKey, ExistingBlock)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PublicKey, ExistingBlock)]
blocks) Block
newBlock
  Keypair
keypair <- IO Keypair
newKeypair
  Signature
newSig <- Keypair -> ByteString -> IO Signature
signBlock Keypair
keypair ByteString
newBlockSerialized
  Signature
endSig <- Signature -> Signature -> IO Signature
aggregate Signature
signature Signature
newSig
  Biscuit -> IO Biscuit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Biscuit -> IO Biscuit) -> Biscuit -> IO Biscuit
forall a b. (a -> b) -> a -> b
$ Biscuit
b { blocks :: [(PublicKey, ExistingBlock)]
blocks = [(PublicKey, ExistingBlock)]
blocks [(PublicKey, ExistingBlock)]
-> [(PublicKey, ExistingBlock)] -> [(PublicKey, ExistingBlock)]
forall a. Semigroup a => a -> a -> a
<> [(Keypair -> PublicKey
publicKey Keypair
keypair, (ByteString
newBlockSerialized, Block
newBlock))]
           , symbols :: Symbols
symbols = Symbols
symbols Symbols -> Symbols -> Symbols
forall a. Semigroup a => a -> a -> a
<> Symbols
s
           , signature :: Signature
signature = Signature
endSig
           }

-- | Only check a biscuit signature. This can be used to perform an early check, before
-- bothering with constructing a verifier.
checkBiscuitSignature :: Biscuit -> PublicKey -> IO Bool
checkBiscuitSignature :: Biscuit -> PublicKey -> IO Bool
checkBiscuitSignature Biscuit{[(PublicKey, ExistingBlock)]
(PublicKey, ExistingBlock)
Symbols
Signature
signature :: Signature
blocks :: [(PublicKey, ExistingBlock)]
authority :: (PublicKey, ExistingBlock)
symbols :: Symbols
signature :: Biscuit -> Signature
blocks :: Biscuit -> [(PublicKey, ExistingBlock)]
authority :: Biscuit -> (PublicKey, ExistingBlock)
symbols :: Biscuit -> Symbols
..} PublicKey
publicKey =
  let publicKeysAndMessages :: NonEmpty (PublicKey, ByteString)
publicKeysAndMessages = (PublicKey
publicKey, ExistingBlock -> ByteString
forall a b. (a, b) -> a
fst (ExistingBlock -> ByteString) -> ExistingBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ (PublicKey, ExistingBlock) -> ExistingBlock
forall a b. (a, b) -> b
snd (PublicKey, ExistingBlock)
authority) (PublicKey, ByteString)
-> [(PublicKey, ByteString)] -> NonEmpty (PublicKey, ByteString)
forall a. a -> [a] -> NonEmpty a
:| ((ExistingBlock -> ByteString)
-> (PublicKey, ExistingBlock) -> (PublicKey, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExistingBlock -> ByteString
forall a b. (a, b) -> a
fst ((PublicKey, ExistingBlock) -> (PublicKey, ByteString))
-> [(PublicKey, ExistingBlock)] -> [(PublicKey, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PublicKey, ExistingBlock)]
blocks)
   in NonEmpty (PublicKey, ByteString) -> Signature -> IO Bool
verifySignature NonEmpty (PublicKey, ByteString)
publicKeysAndMessages Signature
signature

-- | Errors that can happen when parsing a biscuit
data ParseError
  = InvalidHexEncoding
  -- ^ The provided ByteString is not hex-encoded
  | InvalidB64Encoding
  -- ^ The provided ByteString is not base64-encoded
  | InvalidProtobufSer String
  -- ^ The provided ByteString does not contain properly serialized protobuf values
  | InvalidProtobuf String
  -- ^ The bytestring was correctly deserialized from protobuf, but the values can't be turned into a proper biscuit
  deriving (ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)

-- | Parse a biscuit from a raw bytestring.
parseBiscuit :: ByteString -> Either ParseError Biscuit
parseBiscuit :: ByteString -> Either ParseError Biscuit
parseBiscuit ByteString
bs = do
  Biscuit
blockList <- (String -> ParseError)
-> Either String Biscuit -> Either ParseError Biscuit
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ParseError
InvalidProtobufSer (Either String Biscuit -> Either ParseError Biscuit)
-> Either String Biscuit -> Either ParseError Biscuit
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Biscuit
PB.decodeBlockList ByteString
bs
  let pbBlocks :: FieldType (Repeated 2 (Value ByteString))
pbBlocks    = Repeated 2 (Value ByteString)
-> FieldType (Repeated 2 (Value ByteString))
forall a. HasField a => a -> FieldType a
PB.getField (Repeated 2 (Value ByteString)
 -> FieldType (Repeated 2 (Value ByteString)))
-> Repeated 2 (Value ByteString)
-> FieldType (Repeated 2 (Value ByteString))
forall a b. (a -> b) -> a -> b
$ Biscuit -> Repeated 2 (Value ByteString)
PB.blocks    Biscuit
blockList
      pbKeys :: FieldType (Repeated 3 (Value ByteString))
pbKeys      = Repeated 3 (Value ByteString)
-> FieldType (Repeated 3 (Value ByteString))
forall a. HasField a => a -> FieldType a
PB.getField (Repeated 3 (Value ByteString)
 -> FieldType (Repeated 3 (Value ByteString)))
-> Repeated 3 (Value ByteString)
-> FieldType (Repeated 3 (Value ByteString))
forall a b. (a -> b) -> a -> b
$ Biscuit -> Repeated 3 (Value ByteString)
PB.keys      Biscuit
blockList
      pbAuthority :: FieldType (Field 1 (RequiredField (Always (Value ByteString))))
pbAuthority = Field 1 (RequiredField (Always (Value ByteString)))
-> FieldType (Field 1 (RequiredField (Always (Value ByteString))))
forall a. HasField a => a -> FieldType a
PB.getField (Field 1 (RequiredField (Always (Value ByteString)))
 -> FieldType (Field 1 (RequiredField (Always (Value ByteString)))))
-> Field 1 (RequiredField (Always (Value ByteString)))
-> FieldType (Field 1 (RequiredField (Always (Value ByteString))))
forall a b. (a -> b) -> a -> b
$ Biscuit -> Required 1 (Value ByteString)
PB.authority Biscuit
blockList
      pbSignature :: FieldType (Field 4 (RequiredField (Always (Message Signature))))
pbSignature = Field 4 (RequiredField (Always (Message Signature)))
-> FieldType (Field 4 (RequiredField (Always (Message Signature))))
forall a. HasField a => a -> FieldType a
PB.getField (Field 4 (RequiredField (Always (Message Signature)))
 -> FieldType
      (Field 4 (RequiredField (Always (Message Signature)))))
-> Field 4 (RequiredField (Always (Message Signature)))
-> FieldType (Field 4 (RequiredField (Always (Message Signature))))
forall a b. (a -> b) -> a -> b
$ Biscuit -> Required 4 (Message Signature)
PB.signature Biscuit
blockList
  Bool -> Either ParseError () -> Either ParseError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
pbBlocks Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
pbKeys) (Either ParseError () -> Either ParseError ())
-> Either ParseError () -> Either ParseError ()
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError ()
forall a b. a -> Either a b
Left (String -> ParseError
InvalidProtobufSer (String -> ParseError) -> String -> ParseError
forall a b. (a -> b) -> a -> b
$ String
"Length mismatch " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int, Int) -> String
forall a. Show a => a -> String
show ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
pbBlocks, [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
pbKeys))
  Block
rawAuthority <- (String -> ParseError)
-> Either String Block -> Either ParseError Block
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ParseError
InvalidProtobufSer (Either String Block -> Either ParseError Block)
-> Either String Block -> Either ParseError Block
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Block
PB.decodeBlock ByteString
pbAuthority
  [Block]
rawBlocks    <- (ByteString -> Either ParseError Block)
-> [ByteString] -> Either ParseError [Block]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((String -> ParseError)
-> Either String Block -> Either ParseError Block
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ParseError
InvalidProtobufSer (Either String Block -> Either ParseError Block)
-> (ByteString -> Either String Block)
-> ByteString
-> Either ParseError Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Block
PB.decodeBlock) [ByteString]
pbBlocks
  let s :: Symbols
s = Symbols -> [Block] -> Symbols
extractSymbols Symbols
commonSymbols ([Block] -> Symbols) -> [Block] -> Symbols
forall a b. (a -> b) -> a -> b
$ Block
rawAuthority Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
rawBlocks


  ExistingBlock
parsedAuthority <- (ByteString
pbAuthority,) (Block -> ExistingBlock)
-> Either ParseError Block -> Either ParseError ExistingBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbols -> Block -> Either ParseError Block
blockFromPB Symbols
s Block
rawAuthority
  [ExistingBlock]
parsedBlocks    <- [ByteString] -> [Block] -> [ExistingBlock]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
pbBlocks ([Block] -> [ExistingBlock])
-> Either ParseError [Block] -> Either ParseError [ExistingBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> Either ParseError Block)
-> [Block] -> Either ParseError [Block]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Symbols -> Block -> Either ParseError Block
blockFromPB Symbols
s) [Block]
rawBlocks
  [PublicKey]
parsedKeys      <- ParseError -> Maybe [PublicKey] -> Either ParseError [PublicKey]
forall b a. b -> Maybe a -> Either b a
maybeToRight (String -> ParseError
InvalidProtobufSer String
"Invalid pubkeys") (Maybe [PublicKey] -> Either ParseError [PublicKey])
-> Maybe [PublicKey] -> Either ParseError [PublicKey]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe PublicKey)
-> [ByteString] -> Maybe [PublicKey]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ByteString -> Maybe PublicKey
parsePublicKey [ByteString]
pbKeys
  let blocks :: [(PublicKey, ExistingBlock)]
blocks = [PublicKey] -> [ExistingBlock] -> [(PublicKey, ExistingBlock)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [PublicKey] -> [PublicKey]
forall a. Int -> [a] -> [a]
drop Int
1 [PublicKey]
parsedKeys) [ExistingBlock]
parsedBlocks
      authority :: (PublicKey, ExistingBlock)
authority = ([PublicKey] -> PublicKey
forall a. [a] -> a
head [PublicKey]
parsedKeys, ExistingBlock
parsedAuthority)
      symbols :: Symbols
symbols = Symbols
s
      signature :: Signature
signature = Signature :: [ByteString] -> ByteString -> Signature
Signature { parameters :: [ByteString]
parameters = Repeated 1 (Value ByteString)
-> FieldType (Repeated 1 (Value ByteString))
forall a. HasField a => a -> FieldType a
PB.getField (Repeated 1 (Value ByteString)
 -> FieldType (Repeated 1 (Value ByteString)))
-> Repeated 1 (Value ByteString)
-> FieldType (Repeated 1 (Value ByteString))
forall a b. (a -> b) -> a -> b
$ Signature -> Repeated 1 (Value ByteString)
PB.parameters Signature
pbSignature
                            , z :: ByteString
z = Field 2 (RequiredField (Always (Value ByteString)))
-> FieldType (Field 2 (RequiredField (Always (Value ByteString))))
forall a. HasField a => a -> FieldType a
PB.getField (Field 2 (RequiredField (Always (Value ByteString)))
 -> FieldType (Field 2 (RequiredField (Always (Value ByteString)))))
-> Field 2 (RequiredField (Always (Value ByteString)))
-> FieldType (Field 2 (RequiredField (Always (Value ByteString))))
forall a b. (a -> b) -> a -> b
$ Signature -> Required 2 (Value ByteString)
PB.z Signature
pbSignature
                            }
  Biscuit -> Either ParseError Biscuit
forall (f :: * -> *) a. Applicative f => a -> f a
pure Biscuit :: Symbols
-> (PublicKey, ExistingBlock)
-> [(PublicKey, ExistingBlock)]
-> Signature
-> Biscuit
Biscuit{[(PublicKey, ExistingBlock)]
(PublicKey, ExistingBlock)
Symbols
Signature
signature :: Signature
symbols :: Symbols
authority :: (PublicKey, ExistingBlock)
blocks :: [(PublicKey, ExistingBlock)]
signature :: Signature
blocks :: [(PublicKey, ExistingBlock)]
authority :: (PublicKey, ExistingBlock)
symbols :: Symbols
..}

-- | Serialize a biscuit to a raw bytestring
serializeBiscuit :: Biscuit -> ByteString
serializeBiscuit :: Biscuit -> ByteString
serializeBiscuit Biscuit{[(PublicKey, ExistingBlock)]
(PublicKey, ExistingBlock)
Symbols
Signature
signature :: Signature
blocks :: [(PublicKey, ExistingBlock)]
authority :: (PublicKey, ExistingBlock)
symbols :: Symbols
signature :: Biscuit -> Signature
blocks :: Biscuit -> [(PublicKey, ExistingBlock)]
authority :: Biscuit -> (PublicKey, ExistingBlock)
symbols :: Biscuit -> Symbols
..} =
  let authorityBs :: ByteString
authorityBs = ExistingBlock -> ByteString
forall a b. (a, b) -> a
fst (ExistingBlock -> ByteString) -> ExistingBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ (PublicKey, ExistingBlock) -> ExistingBlock
forall a b. (a, b) -> b
snd (PublicKey, ExistingBlock)
authority
      blocksBs :: [ByteString]
blocksBs = ExistingBlock -> ByteString
forall a b. (a, b) -> a
fst (ExistingBlock -> ByteString)
-> ((PublicKey, ExistingBlock) -> ExistingBlock)
-> (PublicKey, ExistingBlock)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PublicKey, ExistingBlock) -> ExistingBlock
forall a b. (a, b) -> b
snd ((PublicKey, ExistingBlock) -> ByteString)
-> [(PublicKey, ExistingBlock)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PublicKey, ExistingBlock)]
blocks
      keys :: [ByteString]
keys = PublicKey -> ByteString
serializePublicKey (PublicKey -> ByteString)
-> ((PublicKey, ExistingBlock) -> PublicKey)
-> (PublicKey, ExistingBlock)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PublicKey, ExistingBlock) -> PublicKey
forall a b. (a, b) -> a
fst ((PublicKey, ExistingBlock) -> ByteString)
-> [(PublicKey, ExistingBlock)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PublicKey, ExistingBlock)
authority (PublicKey, ExistingBlock)
-> [(PublicKey, ExistingBlock)] -> [(PublicKey, ExistingBlock)]
forall a. a -> [a] -> [a]
: [(PublicKey, ExistingBlock)]
blocks
      Signature{[ByteString]
ByteString
z :: ByteString
parameters :: [ByteString]
z :: Signature -> ByteString
parameters :: Signature -> [ByteString]
..} = Signature
signature
      sigPb :: Signature
sigPb = Signature :: Repeated 1 (Value ByteString)
-> Required 2 (Value ByteString) -> Signature
PB.Signature
                { $sel:parameters:Signature :: Repeated 1 (Value ByteString)
parameters = FieldType (Repeated 1 (Value ByteString))
-> Repeated 1 (Value ByteString)
forall a. HasField a => FieldType a -> a
PB.putField [ByteString]
FieldType (Repeated 1 (Value ByteString))
parameters
                , $sel:z:Signature :: Required 2 (Value ByteString)
z = FieldType (Field 2 (RequiredField (Always (Value ByteString))))
-> Field 2 (RequiredField (Always (Value ByteString)))
forall a. HasField a => FieldType a -> a
PB.putField ByteString
FieldType (Field 2 (RequiredField (Always (Value ByteString))))
z
                }
   in Biscuit -> ByteString
PB.encodeBlockList Biscuit :: Required 1 (Value ByteString)
-> Repeated 2 (Value ByteString)
-> Repeated 3 (Value ByteString)
-> Required 4 (Message Signature)
-> Biscuit
PB.Biscuit
       { $sel:authority:Biscuit :: Required 1 (Value ByteString)
authority = FieldType (Field 1 (RequiredField (Always (Value ByteString))))
-> Field 1 (RequiredField (Always (Value ByteString)))
forall a. HasField a => FieldType a -> a
PB.putField ByteString
FieldType (Field 1 (RequiredField (Always (Value ByteString))))
authorityBs
       , $sel:blocks:Biscuit :: Repeated 2 (Value ByteString)
blocks    = FieldType (Repeated 2 (Value ByteString))
-> Repeated 2 (Value ByteString)
forall a. HasField a => FieldType a -> a
PB.putField [ByteString]
FieldType (Repeated 2 (Value ByteString))
blocksBs
       , $sel:keys:Biscuit :: Repeated 3 (Value ByteString)
keys      = FieldType (Repeated 3 (Value ByteString))
-> Repeated 3 (Value ByteString)
forall a. HasField a => FieldType a -> a
PB.putField [ByteString]
FieldType (Repeated 3 (Value ByteString))
keys
       , $sel:signature:Biscuit :: Required 4 (Message Signature)
signature = FieldType (Field 4 (RequiredField (Always (Message Signature))))
-> Field 4 (RequiredField (Always (Message Signature)))
forall a. HasField a => FieldType a -> a
PB.putField FieldType (Field 4 (RequiredField (Always (Message Signature))))
Signature
sigPb
       }

-- | Parse a single block from a protobuf value
blockFromPB :: Symbols -> PB.Block -> Either ParseError Block
blockFromPB :: Symbols -> Block -> Either ParseError Block
blockFromPB Symbols
s Block
pbBlock  = (String -> ParseError)
-> Either String Block -> Either ParseError Block
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ParseError
InvalidProtobuf (Either String Block -> Either ParseError Block)
-> Either String Block -> Either ParseError Block
forall a b. (a -> b) -> a -> b
$ Symbols -> Block -> Either String Block
pbToBlock Symbols
s Block
pbBlock

-- | An error that can happen when verifying a biscuit
data VerificationError
  = SignatureError
  -- ^ The signature is invalid
  | DatalogError ExecutionError
  -- ^ The checks and policies could not be verified
  deriving (VerificationError -> VerificationError -> Bool
(VerificationError -> VerificationError -> Bool)
-> (VerificationError -> VerificationError -> Bool)
-> Eq VerificationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VerificationError -> VerificationError -> Bool
$c/= :: VerificationError -> VerificationError -> Bool
== :: VerificationError -> VerificationError -> Bool
$c== :: VerificationError -> VerificationError -> Bool
Eq, Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> String
(Int -> VerificationError -> ShowS)
-> (VerificationError -> String)
-> ([VerificationError] -> ShowS)
-> Show VerificationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationError] -> ShowS
$cshowList :: [VerificationError] -> ShowS
show :: VerificationError -> String
$cshow :: VerificationError -> String
showsPrec :: Int -> VerificationError -> ShowS
$cshowsPrec :: Int -> VerificationError -> ShowS
Show)

-- | Given a provided verifier (a set of facts, rules, checks and policies),
-- and a public key, verify a biscuit:
--
-- - make sure the biscuit has been signed with the private key associated to the public key
-- - make sure the biscuit is valid for the provided verifier
verifyBiscuitWithLimits :: Limits -> Biscuit -> Verifier -> PublicKey -> IO (Either VerificationError Query)
verifyBiscuitWithLimits :: Limits
-> Biscuit
-> Verifier
-> PublicKey
-> IO (Either VerificationError Query)
verifyBiscuitWithLimits Limits
l Biscuit
b Verifier
verifier PublicKey
pub = ExceptT VerificationError IO Query
-> IO (Either VerificationError Query)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT VerificationError IO Query
 -> IO (Either VerificationError Query))
-> ExceptT VerificationError IO Query
-> IO (Either VerificationError Query)
forall a b. (a -> b) -> a -> b
$ do
  Bool
sigCheck <- IO Bool -> ExceptT VerificationError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT VerificationError IO Bool)
-> IO Bool -> ExceptT VerificationError IO Bool
forall a b. (a -> b) -> a -> b
$ Biscuit -> PublicKey -> IO Bool
checkBiscuitSignature Biscuit
b PublicKey
pub
  Bool
-> ExceptT VerificationError IO ()
-> ExceptT VerificationError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
sigCheck) (ExceptT VerificationError IO ()
 -> ExceptT VerificationError IO ())
-> ExceptT VerificationError IO ()
-> ExceptT VerificationError IO ()
forall a b. (a -> b) -> a -> b
$ VerificationError -> ExceptT VerificationError IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError VerificationError
SignatureError
  BlockWithRevocationIds
authorityBlock :| [BlockWithRevocationIds]
attBlocks <- IO (NonEmpty BlockWithRevocationIds)
-> ExceptT VerificationError IO (NonEmpty BlockWithRevocationIds)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (NonEmpty BlockWithRevocationIds)
 -> ExceptT VerificationError IO (NonEmpty BlockWithRevocationIds))
-> IO (NonEmpty BlockWithRevocationIds)
-> ExceptT VerificationError IO (NonEmpty BlockWithRevocationIds)
forall a b. (a -> b) -> a -> b
$ Biscuit -> IO (NonEmpty BlockWithRevocationIds)
getRevocationIds Biscuit
b
  Either ExecutionError Query
verifResult <- IO (Either ExecutionError Query)
-> ExceptT VerificationError IO (Either ExecutionError Query)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ExecutionError Query)
 -> ExceptT VerificationError IO (Either ExecutionError Query))
-> IO (Either ExecutionError Query)
-> ExceptT VerificationError IO (Either ExecutionError Query)
forall a b. (a -> b) -> a -> b
$ Limits
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> Verifier
-> IO (Either ExecutionError Query)
runVerifierWithLimits Limits
l BlockWithRevocationIds
authorityBlock [BlockWithRevocationIds]
attBlocks Verifier
verifier
  case Either ExecutionError Query
verifResult of
    Left ExecutionError
e  -> VerificationError -> ExceptT VerificationError IO Query
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerificationError -> ExceptT VerificationError IO Query)
-> VerificationError -> ExceptT VerificationError IO Query
forall a b. (a -> b) -> a -> b
$ ExecutionError -> VerificationError
DatalogError ExecutionError
e
    Right Query
p -> Query -> ExceptT VerificationError IO Query
forall (f :: * -> *) a. Applicative f => a -> f a
pure Query
p

-- | Same as `verifyBiscuitWithLimits`, but with default limits (1ms timeout, max 1000 facts, max 100 iterations)
verifyBiscuit :: Biscuit -> Verifier -> PublicKey -> IO (Either VerificationError Query)
verifyBiscuit :: Biscuit
-> Verifier -> PublicKey -> IO (Either VerificationError Query)
verifyBiscuit = Limits
-> Biscuit
-> Verifier
-> PublicKey
-> IO (Either VerificationError Query)
verifyBiscuitWithLimits Limits
defaultLimits

-- | Get the components needed to compute revocation ids
getRidComponents :: (PublicKey, ExistingBlock) -> ByteString
                 -> ((ByteString, ByteString), Block)
getRidComponents :: (PublicKey, ExistingBlock)
-> ByteString -> ((ByteString, ByteString), Block)
getRidComponents (PublicKey
pub, (ByteString
blockBs, Block
block)) ByteString
param =
  ( ( ByteString
blockBs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
pub
    , ByteString
blockBs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
pub ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
param
    )
  , Block
block
  )

-- | Given revocation ids components and a block, compute the revocation ids
-- and attach them to the block
mkBRID :: ((ByteString, ByteString), Block) -> IO BlockWithRevocationIds
mkBRID :: ((ByteString, ByteString), Block) -> IO BlockWithRevocationIds
mkBRID ((ByteString
g,ByteString
u), Block
bBlock) = do
  ByteString
genericRevocationId <- ByteString -> IO ByteString
hashBytes ByteString
g
  ByteString
uniqueRevocationId  <- ByteString -> IO ByteString
hashBytes ByteString
u
  BlockWithRevocationIds -> IO BlockWithRevocationIds
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockWithRevocationIds :: Block -> ByteString -> ByteString -> BlockWithRevocationIds
BlockWithRevocationIds{ByteString
Block
uniqueRevocationId :: ByteString
genericRevocationId :: ByteString
bBlock :: Block
uniqueRevocationId :: ByteString
genericRevocationId :: ByteString
bBlock :: Block
..}

-- | Compute the revocation ids for a given biscuit
getRevocationIds :: Biscuit -> IO (NonEmpty BlockWithRevocationIds)
getRevocationIds :: Biscuit -> IO (NonEmpty BlockWithRevocationIds)
getRevocationIds Biscuit{[(PublicKey, ExistingBlock)]
(PublicKey, ExistingBlock)
Symbols
Signature
signature :: Signature
blocks :: [(PublicKey, ExistingBlock)]
authority :: (PublicKey, ExistingBlock)
symbols :: Symbols
signature :: Biscuit -> Signature
blocks :: Biscuit -> [(PublicKey, ExistingBlock)]
authority :: Biscuit -> (PublicKey, ExistingBlock)
symbols :: Biscuit -> Symbols
..} = do
   NonEmpty ByteString
params <- IO (NonEmpty ByteString)
-> (NonEmpty ByteString -> IO (NonEmpty ByteString))
-> Maybe (NonEmpty ByteString)
-> IO (NonEmpty ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (NonEmpty ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"") NonEmpty ByteString -> IO (NonEmpty ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmpty ByteString) -> IO (NonEmpty ByteString))
-> ([ByteString] -> Maybe (NonEmpty ByteString))
-> [ByteString]
-> IO (NonEmpty ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Maybe (NonEmpty ByteString)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([ByteString] -> IO (NonEmpty ByteString))
-> [ByteString] -> IO (NonEmpty ByteString)
forall a b. (a -> b) -> a -> b
$ Signature -> [ByteString]
parameters Signature
signature
   let allBlocks :: NonEmpty (PublicKey, ExistingBlock)
allBlocks = (PublicKey, ExistingBlock)
authority (PublicKey, ExistingBlock)
-> [(PublicKey, ExistingBlock)]
-> NonEmpty (PublicKey, ExistingBlock)
forall a. a -> [a] -> NonEmpty a
:| [(PublicKey, ExistingBlock)]
blocks
       blocksAndParams :: NonEmpty ((ByteString, ByteString), Block)
blocksAndParams = ((PublicKey, ExistingBlock)
 -> ByteString -> ((ByteString, ByteString), Block))
-> NonEmpty (PublicKey, ExistingBlock)
-> NonEmpty ByteString
-> NonEmpty ((ByteString, ByteString), Block)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (PublicKey, ExistingBlock)
-> ByteString -> ((ByteString, ByteString), Block)
getRidComponents NonEmpty (PublicKey, ExistingBlock)
allBlocks NonEmpty ByteString
params
       conc :: ((a, b), b) -> ((a, b), b) -> ((a, b), b)
conc ((a
g1, b
u1), b
_) ((a
g2, b
u2), b
b) = ((a
g1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
g2, b
u1 b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
u2), b
b)
       withPreviousBlocks :: NonEmpty ((ByteString, ByteString), Block)
       withPreviousBlocks :: NonEmpty ((ByteString, ByteString), Block)
withPreviousBlocks = (((ByteString, ByteString), Block)
 -> ((ByteString, ByteString), Block)
 -> ((ByteString, ByteString), Block))
-> NonEmpty ((ByteString, ByteString), Block)
-> NonEmpty ((ByteString, ByteString), Block)
forall a. (a -> a -> a) -> NonEmpty a -> NonEmpty a
NE.scanl1 ((ByteString, ByteString), Block)
-> ((ByteString, ByteString), Block)
-> ((ByteString, ByteString), Block)
forall a b b b.
(Semigroup a, Semigroup b) =>
((a, b), b) -> ((a, b), b) -> ((a, b), b)
conc NonEmpty ((ByteString, ByteString), Block)
blocksAndParams
   (((ByteString, ByteString), Block) -> IO BlockWithRevocationIds)
-> NonEmpty ((ByteString, ByteString), Block)
-> IO (NonEmpty BlockWithRevocationIds)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ByteString, ByteString), Block) -> IO BlockWithRevocationIds
mkBRID NonEmpty ((ByteString, ByteString), Block)
withPreviousBlocks