{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
module Auth.Biscuit.Crypto
  ( SignedBlock
  , Blocks
  , signBlock
  , signExternalBlock
  , sign3rdPartyBlock
  , verifyBlocks
  , verifySecretProof
  , verifySignatureProof
  , getSignatureProof
  , verifyExternalSig
  , PublicKey
  , pkBytes
  , readEd25519PublicKey
  , SecretKey
  , skBytes
  , readEd25519SecretKey
  , Signature
  , sigBytes
  , signature
  , generateSecretKey
  , toPublic
  , sign
  ) where

import           Control.Arrow              ((&&&))
import           Crypto.Error               (maybeCryptoError)
import qualified Crypto.PubKey.Ed25519      as Ed25519
import           Data.ByteArray             (convert)
import           Data.ByteString            (ByteString)
import           Data.Function              (on)
import           Data.Int                   (Int32)
import           Data.List.NonEmpty         (NonEmpty (..))
import qualified Data.List.NonEmpty         as NE
import           Data.Maybe                 (catMaybes, fromJust)
import           Instances.TH.Lift          ()
import           Language.Haskell.TH.Syntax

import qualified Auth.Biscuit.Proto         as PB
import qualified Data.Serialize             as PB

newtype PublicKey = PublicKey Ed25519.PublicKey
  deriving newtype (PublicKey -> PublicKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PublicKey -> PublicKey -> Bool
$c/= :: PublicKey -> PublicKey -> Bool
== :: PublicKey -> PublicKey -> Bool
$c== :: PublicKey -> PublicKey -> Bool
Eq, Int -> PublicKey -> ShowS
[PublicKey] -> ShowS
PublicKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PublicKey] -> ShowS
$cshowList :: [PublicKey] -> ShowS
show :: PublicKey -> String
$cshow :: PublicKey -> String
showsPrec :: Int -> PublicKey -> ShowS
$cshowsPrec :: Int -> PublicKey -> ShowS
Show)

instance Ord PublicKey where
  compare :: PublicKey -> PublicKey -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PublicKey -> ByteString
serializePublicKey

instance Lift PublicKey where
  lift :: forall (m :: * -> *). Quote m => PublicKey -> m Exp
lift PublicKey
pk = [| fromJust $ readEd25519PublicKey $(lift $ pkBytes pk) |]
#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped :: forall (m :: * -> *). Quote m => PublicKey -> Code m PublicKey
liftTyped = forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#else
  liftTyped = unsafeTExpCoerce . lift
#endif

newtype SecretKey = SecretKey Ed25519.SecretKey
  deriving newtype (SecretKey -> SecretKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SecretKey -> SecretKey -> Bool
$c/= :: SecretKey -> SecretKey -> Bool
== :: SecretKey -> SecretKey -> Bool
$c== :: SecretKey -> SecretKey -> Bool
Eq, Int -> SecretKey -> ShowS
[SecretKey] -> ShowS
SecretKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SecretKey] -> ShowS
$cshowList :: [SecretKey] -> ShowS
show :: SecretKey -> String
$cshow :: SecretKey -> String
showsPrec :: Int -> SecretKey -> ShowS
$cshowsPrec :: Int -> SecretKey -> ShowS
Show)
newtype Signature = Signature ByteString
  deriving newtype (Signature -> Signature -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signature -> Signature -> Bool
$c/= :: Signature -> Signature -> Bool
== :: Signature -> Signature -> Bool
$c== :: Signature -> Signature -> Bool
Eq, Int -> Signature -> ShowS
[Signature] -> ShowS
Signature -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signature] -> ShowS
$cshowList :: [Signature] -> ShowS
show :: Signature -> String
$cshow :: Signature -> String
showsPrec :: Int -> Signature -> ShowS
$cshowsPrec :: Int -> Signature -> ShowS
Show)

signature :: ByteString -> Signature
signature :: ByteString -> Signature
signature = ByteString -> Signature
Signature

sigBytes :: Signature -> ByteString
sigBytes :: Signature -> ByteString
sigBytes (Signature ByteString
b) = ByteString
b

readEd25519PublicKey :: ByteString -> Maybe PublicKey
readEd25519PublicKey :: ByteString -> Maybe PublicKey
readEd25519PublicKey ByteString
bs = PublicKey -> PublicKey
PublicKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. CryptoFailable a -> Maybe a
maybeCryptoError (forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey ByteString
bs)

readEd25519SecretKey :: ByteString -> Maybe SecretKey
readEd25519SecretKey :: ByteString -> Maybe SecretKey
readEd25519SecretKey ByteString
bs = SecretKey -> SecretKey
SecretKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. CryptoFailable a -> Maybe a
maybeCryptoError (forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
Ed25519.secretKey ByteString
bs)

readEd25519Signature :: Signature -> Maybe Ed25519.Signature
readEd25519Signature :: Signature -> Maybe Signature
readEd25519Signature (Signature ByteString
bs) = forall a. CryptoFailable a -> Maybe a
maybeCryptoError (forall ba. ByteArrayAccess ba => ba -> CryptoFailable Signature
Ed25519.signature ByteString
bs)

-- | Generate a public key from a secret key
toPublic :: SecretKey -> PublicKey
toPublic :: SecretKey -> PublicKey
toPublic (SecretKey SecretKey
sk) = PublicKey -> PublicKey
PublicKey forall a b. (a -> b) -> a -> b
$ SecretKey -> PublicKey
Ed25519.toPublic SecretKey
sk

generateSecretKey :: IO SecretKey
generateSecretKey :: IO SecretKey
generateSecretKey = SecretKey -> SecretKey
SecretKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadRandom m => m SecretKey
Ed25519.generateSecretKey

sign :: SecretKey -> PublicKey -> ByteString -> Signature
sign :: SecretKey -> PublicKey -> ByteString -> Signature
sign (SecretKey SecretKey
sk) (PublicKey PublicKey
pk) ByteString
payload =
  ByteString -> Signature
Signature forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert forall a b. (a -> b) -> a -> b
$ forall ba.
ByteArrayAccess ba =>
SecretKey -> PublicKey -> ba -> Signature
Ed25519.sign SecretKey
sk PublicKey
pk ByteString
payload

verify :: PublicKey -> ByteString -> Signature -> Bool
verify :: PublicKey -> ByteString -> Signature -> Bool
verify (PublicKey PublicKey
pk) ByteString
payload Signature
sig =
  case Signature -> Maybe Signature
readEd25519Signature Signature
sig of
    Just Signature
sig' -> forall ba.
ByteArrayAccess ba =>
PublicKey -> ba -> Signature -> Bool
Ed25519.verify PublicKey
pk ByteString
payload Signature
sig'
    Maybe Signature
Nothing   -> Bool
False

pkBytes :: PublicKey -> ByteString
pkBytes :: PublicKey -> ByteString
pkBytes (PublicKey PublicKey
pk) = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert PublicKey
pk

skBytes :: SecretKey -> ByteString
skBytes :: SecretKey -> ByteString
skBytes (SecretKey SecretKey
sk) = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert SecretKey
sk

type SignedBlock = (ByteString, Signature, PublicKey, Maybe (Signature, PublicKey))
type Blocks = NonEmpty SignedBlock

-- | Biscuit 2.0 allows multiple signature algorithms.
-- For now this lib only supports Ed25519, but the spec mandates flagging
-- each publicKey with an algorithm identifier when serializing it. The
-- serializing itself is handled by protobuf, but we still need to manually
-- serialize keys when we include them in something we want sign (block
-- signatures, and the final signature for sealed tokens).
serializePublicKey :: PublicKey -> ByteString
serializePublicKey :: PublicKey -> ByteString
serializePublicKey PublicKey
pk =
  let keyBytes :: ByteString
keyBytes = PublicKey -> ByteString
pkBytes PublicKey
pk
      algId :: Int32
      algId :: Int32
algId = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Algorithm
PB.Ed25519
      -- The spec mandates that we serialize the algorithm id as a little-endian int32
      algBytes :: ByteString
algBytes = Put -> ByteString
PB.runPut forall a b. (a -> b) -> a -> b
$ Putter Int32
PB.putInt32le Int32
algId
   in ByteString
algBytes forall a. Semigroup a => a -> a -> a
<> ByteString
keyBytes

signBlock :: SecretKey
          -> ByteString
          -> Maybe (Signature, PublicKey)
          -> IO (SignedBlock, SecretKey)
signBlock :: SecretKey
-> ByteString
-> Maybe (Signature, PublicKey)
-> IO (SignedBlock, SecretKey)
signBlock SecretKey
sk ByteString
payload Maybe (Signature, PublicKey)
eSig = do
  let pk :: PublicKey
pk = SecretKey -> PublicKey
toPublic SecretKey
sk
  (PublicKey
nextPk, SecretKey
nextSk) <- (SecretKey -> PublicKey
toPublic forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SecretKey
generateSecretKey
  let toSign :: ByteString
toSign = forall a.
(ByteString, a, PublicKey, Maybe (Signature, PublicKey))
-> ByteString
getToSig (ByteString
payload, (), PublicKey
nextPk, Maybe (Signature, PublicKey)
eSig)
      sig :: Signature
sig = SecretKey -> PublicKey -> ByteString -> Signature
sign SecretKey
sk PublicKey
pk ByteString
toSign
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString
payload, Signature
sig, PublicKey
nextPk, Maybe (Signature, PublicKey)
eSig), SecretKey
nextSk)

signExternalBlock :: SecretKey
                  -> SecretKey
                  -> PublicKey
                  -> ByteString
                  -> IO (SignedBlock, SecretKey)
signExternalBlock :: SecretKey
-> SecretKey
-> PublicKey
-> ByteString
-> IO (SignedBlock, SecretKey)
signExternalBlock SecretKey
sk SecretKey
eSk PublicKey
pk ByteString
payload =
  let eSig :: (Signature, PublicKey)
eSig = SecretKey -> PublicKey -> ByteString -> (Signature, PublicKey)
sign3rdPartyBlock SecretKey
eSk PublicKey
pk ByteString
payload
   in SecretKey
-> ByteString
-> Maybe (Signature, PublicKey)
-> IO (SignedBlock, SecretKey)
signBlock SecretKey
sk ByteString
payload (forall a. a -> Maybe a
Just (Signature, PublicKey)
eSig)

sign3rdPartyBlock :: SecretKey
                  -> PublicKey
                  -> ByteString
                  -> (Signature, PublicKey)
sign3rdPartyBlock :: SecretKey -> PublicKey -> ByteString -> (Signature, PublicKey)
sign3rdPartyBlock SecretKey
eSk PublicKey
nextPk ByteString
payload =
  let toSign :: ByteString
toSign = ByteString
payload forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
nextPk
      ePk :: PublicKey
ePk = SecretKey -> PublicKey
toPublic SecretKey
eSk
      eSig :: Signature
eSig = SecretKey -> PublicKey -> ByteString -> Signature
sign SecretKey
eSk PublicKey
ePk ByteString
toSign
   in (Signature
eSig, PublicKey
ePk)

getSignatureProof :: SignedBlock -> SecretKey -> Signature
getSignatureProof :: SignedBlock -> SecretKey -> Signature
getSignatureProof (ByteString
lastPayload, Signature ByteString
lastSig, PublicKey
lastPk, Maybe (Signature, PublicKey)
_todo) SecretKey
nextSecret =
  let sk :: SecretKey
sk = SecretKey
nextSecret
      pk :: PublicKey
pk = SecretKey -> PublicKey
toPublic SecretKey
nextSecret
      toSign :: ByteString
toSign = ByteString
lastPayload forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
lastPk forall a. Semigroup a => a -> a -> a
<> ByteString
lastSig
   in SecretKey -> PublicKey -> ByteString -> Signature
sign SecretKey
sk PublicKey
pk ByteString
toSign

getToSig :: (ByteString, a, PublicKey, Maybe (Signature, PublicKey)) -> ByteString
getToSig :: forall a.
(ByteString, a, PublicKey, Maybe (Signature, PublicKey))
-> ByteString
getToSig (ByteString
p, a
_, PublicKey
nextPk, Maybe (Signature, PublicKey)
ePk) =
  ByteString
p forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Signature -> ByteString
sigBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Maybe (Signature, PublicKey)
ePk forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
nextPk

getSignature :: SignedBlock -> Signature
getSignature :: SignedBlock -> Signature
getSignature (ByteString
_, Signature
sig, PublicKey
_, Maybe (Signature, PublicKey)
_) = Signature
sig

getPublicKey :: SignedBlock -> PublicKey
getPublicKey :: SignedBlock -> PublicKey
getPublicKey (ByteString
_, Signature
_, PublicKey
pk, Maybe (Signature, PublicKey)
_) = PublicKey
pk

-- | The data signed by the external key is the payload for the current block + the public key from
-- the previous block: this prevents signature reuse (the external signature cannot be used on another
-- token)
getExternalSigPayload :: PublicKey -> SignedBlock -> Maybe (PublicKey, ByteString, Signature)
getExternalSigPayload :: PublicKey
-> SignedBlock -> Maybe (PublicKey, ByteString, Signature)
getExternalSigPayload PublicKey
pkN (ByteString
payload, Signature
_, PublicKey
_, Just (Signature
eSig, PublicKey
ePk)) = forall a. a -> Maybe a
Just (PublicKey
ePk, ByteString
payload forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
pkN, Signature
eSig)
getExternalSigPayload PublicKey
_ SignedBlock
_ = forall a. Maybe a
Nothing

-- | When adding a pre-signed third-party block to a token, we make sure the third-party block is correctly
-- signed (pk-signature match, and the third-party block is pinned to the last biscuit block)
verifyExternalSig :: PublicKey -> (ByteString, Signature, PublicKey) -> Bool
verifyExternalSig :: PublicKey -> (ByteString, Signature, PublicKey) -> Bool
verifyExternalSig PublicKey
previousPk (ByteString
payload, Signature
eSig, PublicKey
ePk) =
  PublicKey -> ByteString -> Signature -> Bool
verify PublicKey
ePk (ByteString
payload forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
previousPk) Signature
eSig

verifyBlocks :: Blocks
             -> PublicKey
             -> Bool
verifyBlocks :: Blocks -> PublicKey -> Bool
verifyBlocks Blocks
blocks PublicKey
rootPk =
  let attachKey :: a -> (b, c) -> (a, b, c)
attachKey a
pk (b
payload, c
sig) = (a
pk, b
payload, c
sig)
      uncurry3 :: (t -> t -> t -> t) -> (t, t, t) -> t
uncurry3 t -> t -> t -> t
f (t
a, t
b, t
c) = t -> t -> t -> t
f t
a t
b t
c
      sigs :: NonEmpty Signature
sigs = SignedBlock -> Signature
getSignature forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocks
blocks
      toSigs :: NonEmpty ByteString
toSigs = forall a.
(ByteString, a, PublicKey, Maybe (Signature, PublicKey))
-> ByteString
getToSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocks
blocks
      -- key for block 0 is the root key
      -- key for block n is the key from block (n - 1)
      keys :: NonEmpty PublicKey
keys = forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKey
rootPk forall a. Semigroup a => a -> a -> a
<> (SignedBlock -> PublicKey
getPublicKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocks
blocks)
      keysPayloadsSigs :: NonEmpty (PublicKey, ByteString, Signature)
keysPayloadsSigs = forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith forall {a} {b} {c}. a -> (b, c) -> (a, b, c)
attachKey NonEmpty PublicKey
keys (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty ByteString
toSigs NonEmpty Signature
sigs)

      -- external_signature(block_n) = sign(external_key_n, payload_n <> public_key_n-1)
      -- so we need to pair each block with the public key carried by the previous block
      -- (the authority block can't have an external signature)
      previousKeys :: [PublicKey]
previousKeys = SignedBlock -> PublicKey
getPublicKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NE.init Blocks
blocks
      blocksAfterAuthority :: [SignedBlock]
blocksAfterAuthority = forall a. NonEmpty a -> [a]
NE.tail Blocks
blocks
      eKeysPayloadsESigs :: [(PublicKey, ByteString, Signature)]
eKeysPayloadsESigs = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PublicKey
-> SignedBlock -> Maybe (PublicKey, ByteString, Signature)
getExternalSigPayload [PublicKey]
previousKeys [SignedBlock]
blocksAfterAuthority
   in  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t} {t} {t} {t}. (t -> t -> t -> t) -> (t, t, t) -> t
uncurry3 PublicKey -> ByteString -> Signature -> Bool
verify) NonEmpty (PublicKey, ByteString, Signature)
keysPayloadsSigs
    Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t} {t} {t} {t}. (t -> t -> t -> t) -> (t, t, t) -> t
uncurry3 PublicKey -> ByteString -> Signature -> Bool
verify) [(PublicKey, ByteString, Signature)]
eKeysPayloadsESigs

verifySecretProof :: SecretKey
                  -> SignedBlock
                  -> Bool
verifySecretProof :: SecretKey -> SignedBlock -> Bool
verifySecretProof SecretKey
nextSecret (ByteString
_, Signature
_, PublicKey
lastPk, Maybe (Signature, PublicKey)
_) =
  PublicKey
lastPk forall a. Eq a => a -> a -> Bool
== SecretKey -> PublicKey
toPublic SecretKey
nextSecret

verifySignatureProof :: Signature
                     -> SignedBlock
                     -> Bool
verifySignatureProof :: Signature -> SignedBlock -> Bool
verifySignatureProof Signature
extraSig (ByteString
lastPayload, Signature ByteString
lastSig, PublicKey
lastPk, Maybe (Signature, PublicKey)
_) =
  let toSign :: ByteString
toSign = ByteString
lastPayload forall a. Semigroup a => a -> a -> a
<> PublicKey -> ByteString
serializePublicKey PublicKey
lastPk forall a. Semigroup a => a -> a -> a
<> ByteString
lastSig
   in PublicKey -> ByteString -> Signature -> Bool
verify PublicKey
lastPk ByteString
toSign Signature
extraSig