{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
  Module      : Auth.Biscuit
  Copyright   : © Clément Delafargue, 2021
  License     : MIT
  Maintainer  : clement@delafargue.name
  Haskell implementation for the Biscuit token.
-}
module Auth.Biscuit
  (
  -- * The biscuit auth token
  -- $biscuitOverview

  -- * Creating keypairs
  -- $keypairs
    newSecret
  , toPublic
  , SecretKey
  , PublicKey

  -- ** Parsing and serializing keypairs
  , serializeSecretKeyHex
  , serializePublicKeyHex
  , parseSecretKeyHex
  , parsePublicKeyHex
  , serializeSecretKey
  , serializePublicKey
  , parseSecretKey
  , parsePublicKey

  -- * Creating a biscuit
  -- $biscuitBlocks
  , mkBiscuit
  , block
  , blockContext
  , Biscuit
  , OpenOrSealed
  , Open
  , Sealed
  , Verified
  , Unverified
  , BiscuitProof
  , Block
  -- ** Parsing and serializing biscuits
  , parseB64
  , parse
  , parseWith
  , parseBiscuitUnverified
  , checkBiscuitSignatures
  , BiscuitEncoding (..)
  , ParserConfig (..)
  , fromRevocationList
  , serializeB64
  , serialize
  , fromHex
  -- ** Attenuating biscuits
  -- $attenuatingBiscuits
  , addBlock
  -- $sealedBiscuits
  , seal
  , fromOpen
  , fromSealed
  , asOpen
  , asSealed

  -- * Verifying a biscuit
  -- $verifying
  , authorizer
  , Authorizer
  , authorizeBiscuit
  , authorizeBiscuitWithLimits
  , Limits (..)
  , defaultLimits
  , ParseError (..)
  , ExecutionError (..)
  , AuthorizationSuccess (..)
  , MatchedQuery (..)
  , query
  , queryAuthorizerFacts
  , getBindings
  , getVariableValues
  , getSingleVariableValue
  , ToTerm (..)
  , FromValue (..)
  , Term
  , Term' (..)

  -- * Retrieving information from a biscuit
  , getRevocationIds
  , getVerifiedBiscuitPublicKey
  ) where

import           Control.Monad                       ((<=<))
import           Control.Monad.Identity              (runIdentity)
import           Data.ByteString                     (ByteString)
import qualified Data.ByteString.Base16              as Hex
import qualified Data.ByteString.Base64.URL          as B64
import           Data.Foldable                       (toList)
import           Data.Set                            (Set)
import qualified Data.Set                            as Set
import           Data.Text                           (Text)

import           Auth.Biscuit.Crypto                 (PublicKey, SecretKey,
                                                      convert,
                                                      generateSecretKey,
                                                      maybeCryptoError,
                                                      publicKey, secretKey,
                                                      toPublic)
import           Auth.Biscuit.Datalog.AST            (Authorizer, Block,
                                                      FromValue (..), Term,
                                                      Term' (..), ToTerm (..),
                                                      bContext)
import           Auth.Biscuit.Datalog.Executor       (ExecutionError (..),
                                                      Limits (..),
                                                      MatchedQuery (..),
                                                      defaultLimits)
import           Auth.Biscuit.Datalog.Parser         (authorizer, block, query)
import           Auth.Biscuit.Datalog.ScopedExecutor (AuthorizationSuccess (..),
                                                      getBindings,
                                                      getSingleVariableValue,
                                                      getVariableValues,
                                                      queryAuthorizerFacts)
import           Auth.Biscuit.Token                  (Biscuit,
                                                      BiscuitEncoding (..),
                                                      BiscuitProof (..), Open,
                                                      OpenOrSealed,
                                                      ParseError (..),
                                                      ParserConfig (..), Sealed,
                                                      Unverified, Verified,
                                                      addBlock, asOpen,
                                                      asSealed,
                                                      authorizeBiscuit,
                                                      authorizeBiscuitWithLimits,
                                                      checkBiscuitSignatures,
                                                      fromOpen, fromSealed,
                                                      getRevocationIds,
                                                      getVerifiedBiscuitPublicKey,
                                                      mkBiscuit,
                                                      parseBiscuitUnverified,
                                                      parseBiscuitWith, seal,
                                                      serializeBiscuit)


-- $biscuitOverview
--
-- <https://github.com/CleverCloud/biscuit/blob/master/SUMMARY.md Biscuit> is a /bearer token/,
-- allowing /offline attenuation/ (meaning that anyone having a token can craft a new, more
-- restricted token),
-- and /'PublicKey' verification/. Token rights and attenuation are expressed using a logic
-- language, derived from <todo datalog>. Such a language can describe facts (things we know
-- about the world), rules (describing how to derive new facts from existing ones) and checks
-- (ensuring that facts hold). Facts and checks let you describe access control rules, while
-- rules make them modular. /Authorizer policies/ lets the verifying party ensure that a
-- provided biscuit grants access to the required operations.
--
-- Here's how to create a biscuit token:
--
-- > -- Biscuit Open Verified means the token has valid signatures
-- > -- and is open to further restriction
-- > buildToken :: Keypair -> IO (Biscuit Open Verified)
-- > buildToken keypair =
-- >   -- the logic language has its own syntax, which can be typed directly in haskell
-- >   -- source code thanks to QuasiQuotes. The datalog snippets are parsed at compile
-- >   -- time, so a datalog error results in a compilation error, not a runtime error
-- >   mkBiscuit keypair [block|
-- >       // the two first lines describe facts:
-- >       // the token holder is identified as `user_1234`
-- >       user("user_1234");
-- >       // the token holder is granted access to resource `file1`
-- >       resource("file1");
-- >       // this last line defines a restriction: properties that need
-- >       // to be verified for the token to be verified:
-- >       // the token can only be used before a specified date
-- >       check if time($time), $time < 2021-05-08T00:00:00Z;
-- >    |]
--
-- Here's how to attenuate a biscuit token:
--
-- > restrictToken :: Biscuit Open Verified -> IO Biscuit Open Verified
-- > restrictToken =
-- >   addBlock [block|
-- >       // restrict the token to local use only
-- >       check if user_ip_address("127.0.0.1");
-- >    |]
--
-- To verify a biscuit token, we need two things:
--
--  - a public key, that will let us verify the token has been emitted by
--    a trusted authority
--  - an authorizer, that will make sure all the checks declared in the token are fulfilled,
--    as well as providing its own checks, and policies which decide if the token is
--    verified or not
--
-- Here's how to verify a base64-serialized biscuit token:
--
-- > verifyToken :: PublicKey -> ByteString -> IO Bool
-- > verifyToken publicKey token = do
-- >   -- complete parsing is only attempted if signatures can be verified,
-- >   -- that's the reason why 'parseB64' takes a public key as a parameter
-- >   parseResult <- parseB64 publicKey token
-- >   case parseResult of
-- >     Left e -> print e $> False
-- >     Right biscuit -> do
-- >       now <- getCurrentTime
-- >       let verif = [authorizer|
-- >                // the datalog snippets can reference haskell variables
-- >                // with the ${variableName} syntax
-- >                time(${now});
-- >
-- >                // policies are tried in order. The first matching policy
-- >                // will decide if the token is valid or not. If no policies
-- >                // match, the token will fail validation
-- >                allow if resource("file1");
-- >                // catch-all policy if the previous ones did not match
-- >                deny if true;
-- >             |]
-- >       result <- authorizeBiscuit biscuit [authorizer|current_time()|]
-- >       case result of
-- >         Left e -> print e $> False
-- >         Right _ -> pure True

-- | Build a block containing an explicit context value.
-- The context of a block can't be parsed from datalog currently,
-- so you'll need an explicit call to `blockContext` to add it
--
-- >     [block|check if time($t), $t < 2021-01-01;|]
-- >  <> blockContext "ttl-check"
blockContext :: Text -> Block
blockContext :: Text -> Block
blockContext Text
c = Block
forall a. Monoid a => a
mempty { bContext :: Maybe Text
bContext = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c }

-- | Decode a base16-encoded bytestring, reporting errors via `MonadFail`
fromHex :: MonadFail m => ByteString -> m ByteString
fromHex :: ByteString -> m ByteString
fromHex = (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> m ByteString)
-> (ByteString -> Either String ByteString)
-> ByteString
-> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Hex.decode

-- $keypairs
--
-- Biscuits rely on public key cryptography: biscuits are signed with a secret key only known
-- to the party which emits it. Verifying a biscuit, on the other hand, can be done with a
-- public key that can be widely distributed. A private key and its corresponding public key
-- is called a keypair, but since a public key can be deterministically computed from a
-- private key, owning a private key is the same as owning a keypair.

-- | Generate a new random 'SecretKey'
newSecret :: IO SecretKey
newSecret :: IO SecretKey
newSecret = IO SecretKey
forall (m :: * -> *). MonadRandom m => m SecretKey
generateSecretKey

-- | Serialize a 'SecretKey' to raw bytes, without any encoding
serializeSecretKey :: SecretKey -> ByteString
serializeSecretKey :: SecretKey -> ByteString
serializeSecretKey = SecretKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert

-- | Serialize a 'PublicKey' to raw bytes, without any encoding
serializePublicKey :: PublicKey -> ByteString
serializePublicKey :: PublicKey -> ByteString
serializePublicKey = PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert

-- | Serialize a 'SecretKey' to a hex-encoded bytestring
serializeSecretKeyHex :: SecretKey -> ByteString
serializeSecretKeyHex :: SecretKey -> ByteString
serializeSecretKeyHex = ByteString -> ByteString
Hex.encode (ByteString -> ByteString)
-> (SecretKey -> ByteString) -> SecretKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert

-- | Serialize a 'PublicKey' to a hex-encoded bytestring
serializePublicKeyHex :: PublicKey -> ByteString
serializePublicKeyHex :: PublicKey -> ByteString
serializePublicKeyHex = ByteString -> ByteString
Hex.encode (ByteString -> ByteString)
-> (PublicKey -> ByteString) -> PublicKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert

-- | Read a 'SecretKey' from raw bytes
parseSecretKey :: ByteString -> Maybe SecretKey
parseSecretKey :: ByteString -> Maybe SecretKey
parseSecretKey = CryptoFailable SecretKey -> Maybe SecretKey
forall a. CryptoFailable a -> Maybe a
maybeCryptoError (CryptoFailable SecretKey -> Maybe SecretKey)
-> (ByteString -> CryptoFailable SecretKey)
-> ByteString
-> Maybe SecretKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CryptoFailable SecretKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
secretKey

-- | Read a 'SecretKey' from an hex bytestring
parseSecretKeyHex :: ByteString -> Maybe SecretKey
parseSecretKeyHex :: ByteString -> Maybe SecretKey
parseSecretKeyHex = ByteString -> Maybe SecretKey
parseSecretKey (ByteString -> Maybe SecretKey)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Maybe SecretKey
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Maybe ByteString
forall (m :: * -> *). MonadFail m => ByteString -> m ByteString
fromHex

-- | Read a 'PublicKey' from raw bytes
parsePublicKey :: ByteString -> Maybe PublicKey
parsePublicKey :: ByteString -> Maybe PublicKey
parsePublicKey = CryptoFailable PublicKey -> Maybe PublicKey
forall a. CryptoFailable a -> Maybe a
maybeCryptoError (CryptoFailable PublicKey -> Maybe PublicKey)
-> (ByteString -> CryptoFailable PublicKey)
-> ByteString
-> Maybe PublicKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
publicKey

-- | Read a 'PublicKey' from an hex bytestring
parsePublicKeyHex :: ByteString -> Maybe PublicKey
parsePublicKeyHex :: ByteString -> Maybe PublicKey
parsePublicKeyHex = ByteString -> Maybe PublicKey
parsePublicKey (ByteString -> Maybe PublicKey)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Maybe PublicKey
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Maybe ByteString
forall (m :: * -> *). MonadFail m => ByteString -> m ByteString
fromHex

-- | Parse a biscuit from a raw bytestring. If you want to parse
-- from a URL-compatible base 64 bytestring, consider using `parseB64`
-- instead.
-- The biscuit signature is verified with the provided 'PublicKey' before
-- completely decoding blocks
-- The revocation ids are /not/ verified before completely decoding blocks.
-- If you need to check revocation ids before decoding blocks, use 'parseWith'
-- (or 'parseB64With' instead).
parse :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parse :: PublicKey
-> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parse PublicKey
pk = Identity (Either ParseError (Biscuit OpenOrSealed Verified))
-> Either ParseError (Biscuit OpenOrSealed Verified)
forall a. Identity a -> a
runIdentity (Identity (Either ParseError (Biscuit OpenOrSealed Verified))
 -> Either ParseError (Biscuit OpenOrSealed Verified))
-> (ByteString
    -> Identity (Either ParseError (Biscuit OpenOrSealed Verified)))
-> ByteString
-> Either ParseError (Biscuit OpenOrSealed Verified)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserConfig Identity
-> ByteString
-> Identity (Either ParseError (Biscuit OpenOrSealed Verified))
forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseBiscuitWith ParserConfig :: forall (m :: * -> *).
BiscuitEncoding
-> (Set ByteString -> m Bool)
-> (Maybe Int -> PublicKey)
-> ParserConfig m
ParserConfig
  { encoding :: BiscuitEncoding
encoding = BiscuitEncoding
RawBytes
  , isRevoked :: Set ByteString -> Identity Bool
isRevoked = Identity Bool -> Set ByteString -> Identity Bool
forall a b. a -> b -> a
const (Identity Bool -> Set ByteString -> Identity Bool)
-> Identity Bool -> Set ByteString -> Identity Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , getPublicKey :: Maybe Int -> PublicKey
getPublicKey = PublicKey -> Maybe Int -> PublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKey
pk
  }

-- | Parse a biscuit from a URL-compatible base 64 encoded bytestring
parseB64 :: PublicKey -> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parseB64 :: PublicKey
-> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parseB64 PublicKey
pk = Identity (Either ParseError (Biscuit OpenOrSealed Verified))
-> Either ParseError (Biscuit OpenOrSealed Verified)
forall a. Identity a -> a
runIdentity (Identity (Either ParseError (Biscuit OpenOrSealed Verified))
 -> Either ParseError (Biscuit OpenOrSealed Verified))
-> (ByteString
    -> Identity (Either ParseError (Biscuit OpenOrSealed Verified)))
-> ByteString
-> Either ParseError (Biscuit OpenOrSealed Verified)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserConfig Identity
-> ByteString
-> Identity (Either ParseError (Biscuit OpenOrSealed Verified))
forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseBiscuitWith ParserConfig :: forall (m :: * -> *).
BiscuitEncoding
-> (Set ByteString -> m Bool)
-> (Maybe Int -> PublicKey)
-> ParserConfig m
ParserConfig
  { encoding :: BiscuitEncoding
encoding = BiscuitEncoding
UrlBase64
  , isRevoked :: Set ByteString -> Identity Bool
isRevoked = Identity Bool -> Set ByteString -> Identity Bool
forall a b. a -> b -> a
const (Identity Bool -> Set ByteString -> Identity Bool)
-> Identity Bool -> Set ByteString -> Identity Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , getPublicKey :: Maybe Int -> PublicKey
getPublicKey = PublicKey -> Maybe Int -> PublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKey
pk
  }

-- | Parse a biscuit, with explicitly supplied parsing options:
--
--   - encoding ('RawBytes' or 'UrlBase64')
--   - revocation check
--   - public key (based on the token's @rootKeyId@ field)
--
-- If you don't need dynamic public key selection or revocation checks, you can use
-- 'parse' or 'parseB64' instead.
--
-- The biscuit signature is verified with the selected 'PublicKey' before
-- completely decoding blocks
parseWith :: Applicative m
          => ParserConfig m
          -> ByteString
          -> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseWith :: ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseWith = ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseBiscuitWith

-- | Helper for building a revocation check from a static list, suitable for use with
-- 'parseWith' and 'ParserConfig'.
fromRevocationList :: (Applicative m, Foldable t)
                   => t ByteString
                   -> Set ByteString
                   -> m Bool
fromRevocationList :: t ByteString -> Set ByteString -> m Bool
fromRevocationList t ByteString
revokedIds Set ByteString
tokenIds =
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool)
-> (Set ByteString -> Bool) -> Set ByteString -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool)
-> (Set ByteString -> Bool) -> Set ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ByteString -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set ByteString -> m Bool) -> Set ByteString -> m Bool
forall a b. (a -> b) -> a -> b
$ Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ([ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString) -> [ByteString] -> Set ByteString
forall a b. (a -> b) -> a -> b
$ t ByteString -> [ByteString]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t ByteString
revokedIds) Set ByteString
tokenIds

-- | Serialize a biscuit to a binary format. If you intend to send
-- the biscuit over a text channel, consider using `serializeB64` instead
serialize :: BiscuitProof p => Biscuit p Verified -> ByteString
serialize :: Biscuit p Verified -> ByteString
serialize = Biscuit p Verified -> ByteString
forall p. BiscuitProof p => Biscuit p Verified -> ByteString
serializeBiscuit

-- | Serialize a biscuit to URL-compatible base 64, as recommended by the spec
serializeB64 :: BiscuitProof p => Biscuit p Verified -> ByteString
serializeB64 :: Biscuit p Verified -> ByteString
serializeB64 = ByteString -> ByteString
B64.encodeBase64' (ByteString -> ByteString)
-> (Biscuit p Verified -> ByteString)
-> Biscuit p Verified
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Biscuit p Verified -> ByteString
forall p. BiscuitProof p => Biscuit p Verified -> ByteString
serialize

-- $biscuitBlocks
--
-- The core of a biscuit is its authority block. This block declares facts and rules and
-- is signed by its creator with a secret key. In addition to this trusted, authority
-- block, a biscuit may carry extra blocks that can only restrict what it can do. By
-- default, biscuits can be restricted, but it's possible to seal a biscuit and prevent
-- further modifications.
--
-- Blocks are defined with a logic language (datalog) that can be used directly from haskell
-- with the `QuasiQuotes` extension.

-- $attenuatingBiscuits
--
-- By default, biscuits can be /attenuated/. It means that any party that holds a biscuit can
-- craft a new biscuit with fewer rights. A common example is taking a long-lived biscuit and
-- adding a short TTL right before sending it over the wire.

-- $sealedBiscuits
--
-- An 'Open' biscuit can be turned into a 'Sealed' one, meaning it won't be possible
-- to attenuate it further.
--
-- 'mkBiscuit' creates 'Open' biscuits, while 'parse' returns an 'OpenOrSealed' biscuit (since
-- when you're verifying a biscuit, you're not caring about whether it can be extended further
-- or not). 'authorizeBiscuit' does not care whether a biscuit is 'Open' or 'Sealed' and can be
-- used with both. 'addBlock' and 'seal' only work with 'Open' biscuits.

-- $verifying
--
-- Verifying a biscuit requires providing a list of policies (/allow/ or /deny/), which will
-- decide if the biscuit is accepted. Policies are tried in order, and the first one to match
-- decides whether the biscuit is accepted.
--
-- In addition to policies, an authorizer typically provides facts (such as the current time) so
-- that checks and policies can be verified.
--
-- The authorizer checks and policies only see the content of the authority (first) block. Extra
-- blocks can only carry restrictions and cannot interfere with the authority facts.