{-# 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
    newKeypair
  , fromPrivateKey
  , PrivateKey
  , PublicKey
  , Keypair (..)

  -- ** Parsing and serializing keypairs
  , serializePrivateKeyHex
  , serializePublicKeyHex
  , parsePrivateKeyHex
  , parsePublicKeyHex
  , serializePrivateKey
  , serializePublicKey
  , parsePrivateKey
  , parsePublicKey

  -- * Creating a biscuit
  , block
  , blockContext
  , mkBiscuit
  , addBlock
  , Biscuit
  , Block
  -- ** Parsing and serializing biscuits
  , serializeB64
  , parseB64
  , parse
  , serialize
  , parseHex
  , serializeHex

  -- * Verifying a biscuit
  , verifier
  , verifyBiscuit
  , verifyBiscuitWithLimits
  , checkBiscuitSignature
  , defaultLimits
  , Verifier
  , ParseError (..)
  , VerificationError (..)
  , ExecutionError (..)
  , Limits (..)
  ) where

import           Control.Monad                 ((<=<))
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.Text                     (Text)

import           Auth.Biscuit.Datalog.AST      (Block, Verifier, bContext)
import           Auth.Biscuit.Datalog.Executor (ExecutionError (..),
                                                Limits (..), defaultLimits)
import           Auth.Biscuit.Datalog.Parser   (block, verifier)
import           Auth.Biscuit.Sel              (Keypair (..), PrivateKey,
                                                PublicKey, fromPrivateKey,
                                                newKeypair, parsePrivateKey,
                                                parsePublicKey,
                                                serializePrivateKey,
                                                serializePublicKey)
import           Auth.Biscuit.Token            (Biscuit, ParseError (..),
                                                VerificationError (..),
                                                addBlock, checkBiscuitSignature,
                                                mkBiscuit, parseBiscuit,
                                                serializeBiscuit, verifyBiscuit,
                                                verifyBiscuitWithLimits)
import           Auth.Biscuit.Utils            (maybeToRight)

-- $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 restrict its use),
-- and /public key verification/. Token rights and attenuation are expressed using a logic language.
--
-- Here's how to create a biscuit token:
--
-- > buildToken :: Keypair -> IO Biscuit
-- > buildToken keypair =
-- >   mkBiscuit keypair [block|
-- >       // the token holder is identified as `user_1234`
-- >       user(#authority, "user_1234");
-- >       // the token holder is granted access to resource `file1`
-- >       resource(#authority, "file1");
-- >       // the token can only be used before a specified date
-- >       check if time(#ambient, $time), $time < 2021-05-08T00:00:00Z;
-- >    |]
--
-- Here's how to attenuate a biscuit token:
--
-- > restrictToken :: Biscuit -> IO Biscuit
-- > restrictToken =
-- >   addBlock [block|
-- >       // restrict the token to local use only
-- >       check if user_ip_address(#ambient, "127.0.0.1");
-- >    |]
--
-- Here's how to verify a biscuit token:
--
-- > verifyToken :: PublicKey -> Biscuit -> IO Bool
-- > verifyToken publicKey biscuit = do
-- >   now <- getCurrentTime
-- >   let verif = [verifier|
-- >            // the datalog snippets can reference haskell variables
-- >            current_time(#ambient, ${now});
-- >
-- >            // policies are tried in order
-- >            allow if resource(#authority, "file1");
-- >            // catch-all policy if the previous ones did not match
-- >            deny if true;
-- >         |]
-- >   result <- verifyBiscuit biscuit [verifier|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(#ambient, $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 ByteString
input = do
  (ByteString
decoded, ByteString
"") <- (ByteString, ByteString) -> m (ByteString, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString, ByteString) -> m (ByteString, ByteString))
-> (ByteString, ByteString) -> m (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
Hex.decode ByteString
input
  ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded

-- | Get an hex bytestring from a private key
serializePrivateKeyHex :: PrivateKey -> ByteString
serializePrivateKeyHex :: PrivateKey -> ByteString
serializePrivateKeyHex = ByteString -> ByteString
Hex.encode (ByteString -> ByteString)
-> (PrivateKey -> ByteString) -> PrivateKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrivateKey -> ByteString
serializePrivateKey

-- | Get an hex bytestring from a public key
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
serializePublicKey

-- | Read a private key from an hex bytestring
parsePrivateKeyHex :: ByteString -> Maybe PrivateKey
parsePrivateKeyHex :: ByteString -> Maybe PrivateKey
parsePrivateKeyHex = ByteString -> Maybe PrivateKey
parsePrivateKey (ByteString -> Maybe PrivateKey)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Maybe PrivateKey
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 public key 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
parse :: ByteString -> Either ParseError Biscuit
parse :: ByteString -> Either ParseError Biscuit
parse = ByteString -> Either ParseError Biscuit
parseBiscuit

-- | Parse a biscuit from a URL-compatible base 64 encoded bytestring
parseB64 :: ByteString -> Either ParseError Biscuit
parseB64 :: ByteString -> Either ParseError Biscuit
parseB64 = ByteString -> Either ParseError Biscuit
parse (ByteString -> Either ParseError Biscuit)
-> (ByteString -> Either ParseError ByteString)
-> ByteString
-> Either ParseError Biscuit
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Text -> ParseError)
-> Either Text ByteString -> Either ParseError ByteString
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
InvalidB64Encoding) (Either Text ByteString -> Either ParseError ByteString)
-> (ByteString -> Either Text ByteString)
-> ByteString
-> Either ParseError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text ByteString
B64.decodeBase64

-- | Parse a biscuit from an hex-encoded bytestring
parseHex :: ByteString -> Either ParseError Biscuit
parseHex :: ByteString -> Either ParseError Biscuit
parseHex = ByteString -> Either ParseError Biscuit
parse (ByteString -> Either ParseError Biscuit)
-> (ByteString -> Either ParseError ByteString)
-> ByteString
-> Either ParseError Biscuit
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ParseError -> Maybe ByteString -> Either ParseError ByteString
forall b a. b -> Maybe a -> Either b a
maybeToRight ParseError
InvalidHexEncoding (Maybe ByteString -> Either ParseError ByteString)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Either ParseError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall (m :: * -> *). MonadFail m => ByteString -> m ByteString
fromHex

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

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

-- | Serialize a biscuit to a hex (base 16) string. Be advised that the specs
-- recommends base 64 instead.
serializeHex :: Biscuit -> ByteString
serializeHex :: Biscuit -> ByteString
serializeHex = ByteString -> ByteString
Hex.encode (ByteString -> ByteString)
-> (Biscuit -> ByteString) -> Biscuit -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Biscuit -> ByteString
serialize