{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-|
  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
  , mkBiscuitWith
  , 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
  -- ** Third-party blocks
  -- $thirdPartyBlocks
  , addSignedBlock
  , mkThirdPartyBlockReq
  , mkThirdPartyBlockReqB64
  , mkThirdPartyBlock
  , mkThirdPartyBlockB64
  , applyThirdPartyBlock
  , applyThirdPartyBlockB64
  -- ** Sealing biscuits
  -- $sealedBiscuits
  , seal
  , fromOpen
  , fromSealed
  , asOpen
  , asSealed

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

  -- * Retrieving information from a biscuit
  , queryAuthorizerFacts
  , queryRawBiscuitFacts
  , getVariableValues
  , getSingleVariableValue
  , query
  , getRevocationIds
  , getVerifiedBiscuitPublicKey
  ) where

import           Control.Monad                       ((<=<))
import           Control.Monad.Identity              (runIdentity)
import           Data.Bifunctor                      (first)
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, unpack)

import           Auth.Biscuit.Crypto                 (PublicKey, SecretKey,
                                                      generateSecretKey,
                                                      pkBytes,
                                                      readEd25519PublicKey,
                                                      readEd25519SecretKey,
                                                      skBytes, 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)
import           Auth.Biscuit.Token                  (AuthorizedBiscuit (..),
                                                      Biscuit,
                                                      BiscuitEncoding (..),
                                                      BiscuitProof (..), Open,
                                                      OpenOrSealed,
                                                      ParseError (..),
                                                      ParserConfig (..), Sealed,
                                                      Unverified, Verified,
                                                      addBlock, addSignedBlock,
                                                      applyThirdPartyBlock,
                                                      asOpen, asSealed,
                                                      authorizeBiscuit,
                                                      authorizeBiscuitWithLimits,
                                                      checkBiscuitSignatures,
                                                      fromOpen, fromSealed,
                                                      getRevocationIds,
                                                      getVerifiedBiscuitPublicKey,
                                                      mkBiscuit, mkBiscuitWith,
                                                      mkThirdPartyBlock,
                                                      mkThirdPartyBlockReq,
                                                      parseBiscuitUnverified,
                                                      parseBiscuitWith,
                                                      queryAuthorizerFacts,
                                                      queryRawBiscuitFacts,
                                                      seal, serializeBiscuit)
import qualified Data.Text                           as Text


-- $biscuitOverview
--
-- <https://github.com/biscuit-auth/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 authorizer' = [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");
-- >             |]
-- >       result <- authorizeBiscuit biscuit authorizer'
-- >       case result of
-- >         Left e -> print e $> False
-- >         Right _ -> pure True

-- | Build a block containing an explicit freeform context value.
-- The context of a block can't be parsed from datalog,
-- 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' 'Repr 'Representation
blockContext Text
c = forall a. Monoid a => a
mempty { bContext :: Maybe Text
bContext = forall a. a -> Maybe a
Just Text
c }

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

-- $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
generateSecretKey

-- | Serialize a 'SecretKey' to raw bytes, without any encoding
serializeSecretKey :: SecretKey -> ByteString
serializeSecretKey :: SecretKey -> ByteString
serializeSecretKey = SecretKey -> ByteString
skBytes

-- | Serialize a 'PublicKey' to raw bytes, without any encoding
serializePublicKey :: PublicKey -> ByteString
serializePublicKey :: PublicKey -> ByteString
serializePublicKey = PublicKey -> ByteString
pkBytes

-- | Serialize a 'SecretKey' to a hex-encoded bytestring
serializeSecretKeyHex :: SecretKey -> ByteString
serializeSecretKeyHex :: SecretKey -> ByteString
serializeSecretKeyHex = ByteString -> ByteString
Hex.encodeBase16' forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretKey -> ByteString
skBytes

-- | Serialize a 'PublicKey' to a hex-encoded bytestring
serializePublicKeyHex :: PublicKey -> ByteString
serializePublicKeyHex :: PublicKey -> ByteString
serializePublicKeyHex = ByteString -> ByteString
Hex.encodeBase16' forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> ByteString
pkBytes

-- | Read a 'SecretKey' from raw bytes
parseSecretKey :: ByteString -> Maybe SecretKey
parseSecretKey :: ByteString -> Maybe SecretKey
parseSecretKey = ByteString -> Maybe SecretKey
readEd25519SecretKey

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

-- | Read a 'PublicKey' from raw bytes
parsePublicKey :: ByteString -> Maybe PublicKey
parsePublicKey :: ByteString -> Maybe PublicKey
parsePublicKey = ByteString -> Maybe PublicKey
readEd25519PublicKey

-- | Read a 'PublicKey' from an hex bytestring
parsePublicKeyHex :: ByteString -> Maybe PublicKey
parsePublicKeyHex :: ByteString -> Maybe PublicKey
parsePublicKeyHex = ByteString -> Maybe PublicKey
parsePublicKey forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseBiscuitWith ParserConfig
  { encoding :: BiscuitEncoding
encoding = BiscuitEncoding
RawBytes
  , isRevoked :: Set ByteString -> Identity Bool
isRevoked = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , getPublicKey :: Maybe Int -> PublicKey
getPublicKey = 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 = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseBiscuitWith ParserConfig
  { encoding :: BiscuitEncoding
encoding = BiscuitEncoding
UrlBase64
  , isRevoked :: Set ByteString -> Identity Bool
isRevoked = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , getPublicKey :: Maybe Int -> PublicKey
getPublicKey = 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 :: forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseWith = 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 :: forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t ByteString -> Set ByteString -> m Bool
fromRevocationList t ByteString
revokedIds Set ByteString
tokenIds =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ 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 :: forall p. BiscuitProof p => Biscuit p Verified -> ByteString
serialize = 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 :: forall p. BiscuitProof p => Biscuit p Verified -> ByteString
serializeB64 = ByteString -> ByteString
B64.encodeBase64' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. BiscuitProof p => Biscuit p Verified -> ByteString
serialize

-- | Generate a base64-encoded third-party block request. It can be used in
-- conjunction with 'mkThirdPartyBlockB64' to generate a base64-encoded
-- third-party block, which can be then appended to a token with
-- 'applyThirdPartyBlockB64'.
mkThirdPartyBlockReqB64 :: Biscuit Open c -> ByteString
mkThirdPartyBlockReqB64 :: forall c. Biscuit Open c -> ByteString
mkThirdPartyBlockReqB64 = ByteString -> ByteString
B64.encodeBase64' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall proof check. Biscuit proof check -> ByteString
mkThirdPartyBlockReq

-- | Given a base64-encoded third-party block request, generate a base64-encoded
-- third-party block, which can be then appended to a token with
-- 'applyThirdPartyBlockB64'.
mkThirdPartyBlockB64 :: SecretKey -> ByteString -> Block -> Either String ByteString
mkThirdPartyBlockB64 :: SecretKey
-> ByteString
-> Block' 'Repr 'Representation
-> Either String ByteString
mkThirdPartyBlockB64 SecretKey
sk ByteString
reqB64 Block' 'Repr 'Representation
b = do
  ByteString
req <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> String
unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
B64.decodeBase64 ByteString
reqB64
  ByteString
contents <- SecretKey
-> ByteString
-> Block' 'Repr 'Representation
-> Either String ByteString
mkThirdPartyBlock SecretKey
sk ByteString
req Block' 'Repr 'Representation
b
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encodeBase64' ByteString
contents

-- | Given a base64-encoded third-party block, append it to a token.
applyThirdPartyBlockB64 :: Biscuit Open check -> ByteString -> Either String (IO (Biscuit Open check))
applyThirdPartyBlockB64 :: forall check.
Biscuit Open check
-> ByteString -> Either String (IO (Biscuit Open check))
applyThirdPartyBlockB64 Biscuit Open check
b ByteString
contentsB64 = do
  ByteString
contents <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> String
unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
B64.decodeBase64 ByteString
contentsB64
  forall check.
Biscuit Open check
-> ByteString -> Either String (IO (Biscuit Open check))
applyThirdPartyBlock Biscuit Open check
b ByteString
contents

-- $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.

-- $thirdPartyBlocks
--
-- Regular blocks can be added by anyone and as such can only /attenuate/ a token: the facts
-- they carry are not visible outside themselves, only their checks are evaluated.
--
-- Third-party blocks lift this limitation by carrying an extra signature, crafted with a
-- dedicated keypair. This way, the token authorizer (as well as blocks themselves) can
-- opt-in to trust facts coming from third-party blocks signed with specific keypairs.
--
-- For instance, adding `check if group("admin") trusting {publicKey};` to a token will
-- make it usable only if it carries a third party-block signed by the corresponding keypair,
-- and carrying a `group("admin")` fact.
--
-- Since it is not desirable to share the token with the external entity providing the third-party
-- block, a request mechanism is available:
--
-- - the token holder generates a /third-party block request/ from the token (it contains technical
--   information needed to generate a third-party block) with 'mkThirdPartyBlockReq';
-- - the token holder forwards this request to the external entity;
-- - the external entity uses this request, a 'Block' value, and a 'SecretKey' to generate a third-party
--   block, with 'mkThirdPartyBlock';
-- - the external entity sends this block back to the token holder;
-- - the token holder can now add the block to the token with 'applyThirdPartyBlock'.
--
-- In some cases, the party holding the token is also the one who's adding the third-party block. It
-- is then possible to directly use 'addSignedBlock' to append a third-party block to the token without
-- having to go through generating a third-party block request.

-- $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.