{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | Stability: experimental
-- This module contains a partial implementation of the
-- [COSE_Key](https://datatracker.ietf.org/doc/html/rfc8152#section-7) format,
-- limited to what is needed for Webauthn, and in a structured way.
module Crypto.WebAuthn.Cose.PublicKeyWithSignAlg
  ( -- * COSE public Key
    PublicKeyWithSignAlg (PublicKeyWithSignAlg, Crypto.WebAuthn.Cose.PublicKeyWithSignAlg.publicKey, signAlg),
    CosePublicKey,
    makePublicKeyWithSignAlg,
  )
where

import Codec.CBOR.Decoding (Decoder, TokenType (TypeBool, TypeBytes), decodeBytesCanonical, decodeMapLenCanonical, peekTokenType)
import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeMapLen)
import Codec.Serialise (Serialise (decode, encode))
import Control.Monad (unless)
import Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip)
import qualified Crypto.WebAuthn.Cose.Internal.Registry as R
import qualified Crypto.WebAuthn.Cose.PublicKey as P
import qualified Crypto.WebAuthn.Cose.SignAlg as A
import Crypto.WebAuthn.Internal.ToJSONOrphans ()
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import Data.Functor (($>))
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)

-- | A combination of a t'P.PublicKey' holding the public key data and a
-- 'A.CoseSignAlg' holding the exact signature algorithm that should be used.
-- This type can only be constructed with 'makePublicKeyWithSignAlg', which
-- ensures that the signature scheme matches between 'P.PublicKey' and
-- 'A.CoseSignAlg'. This type is equivalent to a COSE public key, which holds
-- the same information, see 'CosePublicKey'
data PublicKeyWithSignAlg = PublicKeyWithSignAlgInternal
  { PublicKeyWithSignAlg -> PublicKey
publicKeyInternal :: P.PublicKey,
    PublicKeyWithSignAlg -> CoseSignAlg
signAlgInternal :: A.CoseSignAlg
    -- TODO: Consider adding a RawField here to replace
    -- acdCredentialPublicKeyBytes. This would then require parametrizing
    -- 'PublicKeyWithSignAlg' with 'raw :: Bool'
  }
  deriving (PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool
(PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool)
-> (PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool)
-> Eq PublicKeyWithSignAlg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool
$c/= :: PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool
== :: PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool
$c== :: PublicKeyWithSignAlg -> PublicKeyWithSignAlg -> Bool
Eq, Int -> PublicKeyWithSignAlg -> ShowS
[PublicKeyWithSignAlg] -> ShowS
PublicKeyWithSignAlg -> String
(Int -> PublicKeyWithSignAlg -> ShowS)
-> (PublicKeyWithSignAlg -> String)
-> ([PublicKeyWithSignAlg] -> ShowS)
-> Show PublicKeyWithSignAlg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PublicKeyWithSignAlg] -> ShowS
$cshowList :: [PublicKeyWithSignAlg] -> ShowS
show :: PublicKeyWithSignAlg -> String
$cshow :: PublicKeyWithSignAlg -> String
showsPrec :: Int -> PublicKeyWithSignAlg -> ShowS
$cshowsPrec :: Int -> PublicKeyWithSignAlg -> ShowS
Show, (forall x. PublicKeyWithSignAlg -> Rep PublicKeyWithSignAlg x)
-> (forall x. Rep PublicKeyWithSignAlg x -> PublicKeyWithSignAlg)
-> Generic PublicKeyWithSignAlg
forall x. Rep PublicKeyWithSignAlg x -> PublicKeyWithSignAlg
forall x. PublicKeyWithSignAlg -> Rep PublicKeyWithSignAlg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PublicKeyWithSignAlg x -> PublicKeyWithSignAlg
$cfrom :: forall x. PublicKeyWithSignAlg -> Rep PublicKeyWithSignAlg x
Generic, [PublicKeyWithSignAlg] -> Encoding
[PublicKeyWithSignAlg] -> Value
PublicKeyWithSignAlg -> Encoding
PublicKeyWithSignAlg -> Value
(PublicKeyWithSignAlg -> Value)
-> (PublicKeyWithSignAlg -> Encoding)
-> ([PublicKeyWithSignAlg] -> Value)
-> ([PublicKeyWithSignAlg] -> Encoding)
-> ToJSON PublicKeyWithSignAlg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PublicKeyWithSignAlg] -> Encoding
$ctoEncodingList :: [PublicKeyWithSignAlg] -> Encoding
toJSONList :: [PublicKeyWithSignAlg] -> Value
$ctoJSONList :: [PublicKeyWithSignAlg] -> Value
toEncoding :: PublicKeyWithSignAlg -> Encoding
$ctoEncoding :: PublicKeyWithSignAlg -> Encoding
toJSON :: PublicKeyWithSignAlg -> Value
$ctoJSON :: PublicKeyWithSignAlg -> Value
Aeson.ToJSON)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#credentialpublickey)
-- A structured and checked representation of a
-- [COSE_Key](https://datatracker.ietf.org/doc/html/rfc8152#section-7), limited
-- to what is know to be necessary for Webauthn public keys for the
-- [credentialPublicKey](https://www.w3.org/TR/webauthn-2/#credentialpublickey)
-- field.
type CosePublicKey = PublicKeyWithSignAlg

-- | Deconstructs a 'makePublicKeyWithSignAlg' into its t'P.PublicKey' and
-- 'A.CoseSignAlg'. Since 'makePublicKeyWithSignAlg' can only be constructed
-- using 'makePublicKeyWithSignAlg', we can be sure that the signature scheme
-- of t'P.PublicKey' and 'A.CoseSignAlg' matches.
pattern PublicKeyWithSignAlg :: P.PublicKey -> A.CoseSignAlg -> PublicKeyWithSignAlg
pattern $mPublicKeyWithSignAlg :: forall r.
PublicKeyWithSignAlg
-> (PublicKey -> CoseSignAlg -> r) -> (Void# -> r) -> r
PublicKeyWithSignAlg {PublicKeyWithSignAlg -> PublicKey
publicKey, PublicKeyWithSignAlg -> CoseSignAlg
signAlg} <- PublicKeyWithSignAlgInternal {publicKeyInternal = publicKey, signAlgInternal = signAlg}

{-# COMPLETE PublicKeyWithSignAlg #-}

-- | Constructs a t'PublicKeyWithSignAlg' from a t'P.PublicKey' and
-- 'A.CoseSignAlg', returning an error if the signature schemes between these
-- two types don't match.
makePublicKeyWithSignAlg :: P.PublicKey -> A.CoseSignAlg -> Either Text PublicKeyWithSignAlg
makePublicKeyWithSignAlg :: PublicKey -> CoseSignAlg -> Either Text PublicKeyWithSignAlg
makePublicKeyWithSignAlg key :: PublicKey
key@(P.PublicKey UncheckedPublicKey
k) CoseSignAlg
alg =
  UncheckedPublicKey -> CoseSignAlg -> Either Text ()
verifyValid UncheckedPublicKey
k CoseSignAlg
alg
    Either Text ()
-> PublicKeyWithSignAlg -> Either Text PublicKeyWithSignAlg
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PublicKeyWithSignAlgInternal :: PublicKey -> CoseSignAlg -> PublicKeyWithSignAlg
PublicKeyWithSignAlgInternal
      { publicKeyInternal :: PublicKey
publicKeyInternal = PublicKey
key,
        signAlgInternal :: CoseSignAlg
signAlgInternal = CoseSignAlg
alg
      }
  where
    verifyValid :: P.UncheckedPublicKey -> A.CoseSignAlg -> Either Text ()
    verifyValid :: UncheckedPublicKey -> CoseSignAlg -> Either Text ()
verifyValid P.PublicKeyEdDSA {} CoseSignAlg
A.CoseSignAlgEdDSA = () -> Either Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    verifyValid P.PublicKeyEdDSA {} CoseSignAlg
alg = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"EdDSA public key cannot be used with signing algorithm " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (CoseSignAlg -> String
forall a. Show a => a -> String
show CoseSignAlg
alg)
    verifyValid P.PublicKeyECDSA {} A.CoseSignAlgECDSA {} = () -> Either Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    verifyValid P.PublicKeyECDSA {} CoseSignAlg
alg = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"ECDSA public key cannot be used with signing algorithm " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (CoseSignAlg -> String
forall a. Show a => a -> String
show CoseSignAlg
alg)
    verifyValid P.PublicKeyRSA {} A.CoseSignAlgRSA {} = () -> Either Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    verifyValid P.PublicKeyRSA {} CoseSignAlg
alg = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"RSA public key cannot be used with signing algorithm " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (CoseSignAlg -> String
forall a. Show a => a -> String
show CoseSignAlg
alg)

-- | CBOR encoding as a [COSE_Key](https://tools.ietf.org/html/rfc8152#section-7)
-- using the [CTAP2 canonical CBOR encoding form](https://fidoalliance.org/specs/fido-v2.0-ps-20190130/fido-client-to-authenticator-protocol-v2.0-ps-20190130.html#ctap2-canonical-cbor-encoding-form)
instance Serialise CosePublicKey where
  encode :: PublicKeyWithSignAlg -> Encoding
encode PublicKeyWithSignAlg {CoseSignAlg
PublicKey
signAlg :: CoseSignAlg
publicKey :: PublicKey
signAlg :: PublicKeyWithSignAlg -> CoseSignAlg
publicKey :: PublicKeyWithSignAlg -> PublicKey
..} = case PublicKey
publicKey of
    P.PublicKey P.PublicKeyEdDSA {ByteString
CoseCurveEdDSA
eddsaX :: UncheckedPublicKey -> ByteString
eddsaCurve :: UncheckedPublicKey -> CoseCurveEdDSA
eddsaX :: ByteString
eddsaCurve :: CoseCurveEdDSA
..} ->
      CoseKeyType -> Encoding
common CoseKeyType
R.CoseKeyTypeOKP
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterOKP -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterOKP
R.CoseKeyTypeParameterOKPCrv
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseEllipticCurveOKP -> Encoding
forall a. Serialise a => a -> Encoding
encode (CoseCurveEdDSA -> CoseEllipticCurveOKP
fromCurveEdDSA CoseCurveEdDSA
eddsaCurve)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterOKP -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterOKP
R.CoseKeyTypeParameterOKPX
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBytes ByteString
eddsaX
    P.PublicKey P.PublicKeyECDSA {Integer
CoseCurveECDSA
ecdsaY :: UncheckedPublicKey -> Integer
ecdsaX :: UncheckedPublicKey -> Integer
ecdsaCurve :: UncheckedPublicKey -> CoseCurveECDSA
ecdsaY :: Integer
ecdsaX :: Integer
ecdsaCurve :: CoseCurveECDSA
..} ->
      CoseKeyType -> Encoding
common CoseKeyType
R.CoseKeyTypeEC2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterEC2 -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterEC2
R.CoseKeyTypeParameterEC2Crv
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseEllipticCurveEC2 -> Encoding
forall a. Serialise a => a -> Encoding
encode (CoseCurveECDSA -> CoseEllipticCurveEC2
fromCurveECDSA CoseCurveECDSA
ecdsaCurve)
        -- https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-algs-12#section-7.1.1
        -- > Leading zero octets MUST be preserved.
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterEC2 -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterEC2
R.CoseKeyTypeParameterEC2X
        -- This version of i2ospOf_ throws if the bytestring is larger than
        -- size, but this can't happen due to the PublicKey invariants
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBytes (Int -> Integer -> ByteString
forall ba. ByteArray ba => Int -> Integer -> ba
i2ospOf_ Int
size Integer
ecdsaX)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterEC2 -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterEC2
R.CoseKeyTypeParameterEC2Y
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBytes (Int -> Integer -> ByteString
forall ba. ByteArray ba => Int -> Integer -> ba
i2ospOf_ Int
size Integer
ecdsaY)
      where
        size :: Int
size = CoseCurveECDSA -> Int
P.coordinateSizeECDSA CoseCurveECDSA
ecdsaCurve
    P.PublicKey P.PublicKeyRSA {Integer
rsaE :: UncheckedPublicKey -> Integer
rsaN :: UncheckedPublicKey -> Integer
rsaE :: Integer
rsaN :: Integer
..} ->
      CoseKeyType -> Encoding
common CoseKeyType
R.CoseKeyTypeRSA
        -- https://www.rfc-editor.org/rfc/rfc8230.html#section-4
        -- > The octet sequence MUST utilize the minimum
        -- number of octets needed to represent the value.
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterRSA -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterRSA
R.CoseKeyTypeParameterRSAN
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBytes (Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
rsaN)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyTypeParameterRSA -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyTypeParameterRSA
R.CoseKeyTypeParameterRSAE
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBytes (Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
rsaE)
    where
      common :: R.CoseKeyType -> Encoding
      common :: CoseKeyType -> Encoding
common CoseKeyType
kty =
        Word -> Encoding
encodeMapLen (CoseKeyType -> Word
R.parameterCount CoseKeyType
kty)
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyCommonParameter -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyCommonParameter
R.CoseKeyCommonParameterKty
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyType -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyType
kty
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseKeyCommonParameter -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseKeyCommonParameter
R.CoseKeyCommonParameterAlg
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CoseSignAlg -> Encoding
forall a. Serialise a => a -> Encoding
encode CoseSignAlg
signAlg

  -- NOTE: CBOR itself doesn't give an ordering of map keys, but the CTAP2 canonical CBOR encoding form does:
  -- > The keys in every map must be sorted lowest value to highest. The sorting rules are:
  -- >
  -- > * If the major types are different, the one with the lower value in numerical order sorts earlier.
  -- > * If two keys have different lengths, the shorter one sorts earlier;
  -- > * If two keys have the same length, the one with the lower value in (byte-wise) lexical order sorts earlier.
  --
  -- This has the effect that numeric keys are sorted like 1, 2, 3, ..., -1, -2, -3, ...
  -- Which aligns very nicely with the fact that common parameters use positive
  -- values and can therefore be decoded first, while key type specific
  -- parameters use negative values
  decode :: Decoder s PublicKeyWithSignAlg
decode = do
    Word
n <- Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Decoder s Int -> Decoder s Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
decodeMapLenCanonical
    -- https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-struct-15#section-7.1
    -- This parameter MUST be present in a key object.
    CoseKeyCommonParameter -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyCommonParameter
R.CoseKeyCommonParameterKty
    CoseKeyType
kty <- Decoder s CoseKeyType
forall a s. Serialise a => Decoder s a
decode
    -- https://www.w3.org/TR/webauthn-2/#credentialpublickey
    -- The COSE_Key-encoded credential public key MUST contain the "alg"
    -- parameter and MUST NOT contain any other OPTIONAL parameters.
    CoseKeyCommonParameter -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyCommonParameter
R.CoseKeyCommonParameterAlg
    CoseSignAlg
alg <- Decoder s CoseSignAlg
forall a s. Serialise a => Decoder s a
decode

    UncheckedPublicKey
uncheckedKey <- Word -> CoseKeyType -> CoseSignAlg -> Decoder s UncheckedPublicKey
forall s.
Word -> CoseKeyType -> CoseSignAlg -> Decoder s UncheckedPublicKey
decodeKey Word
n CoseKeyType
kty CoseSignAlg
alg
    case UncheckedPublicKey -> Either Text PublicKey
P.checkPublicKey UncheckedPublicKey
uncheckedKey of
      Left Text
err -> String -> Decoder s PublicKeyWithSignAlg
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s PublicKeyWithSignAlg)
-> String -> Decoder s PublicKeyWithSignAlg
forall a b. (a -> b) -> a -> b
$ String
"Key check failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
err
      Right PublicKey
result ->
        PublicKeyWithSignAlg -> Decoder s PublicKeyWithSignAlg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublicKeyWithSignAlg -> Decoder s PublicKeyWithSignAlg)
-> PublicKeyWithSignAlg -> Decoder s PublicKeyWithSignAlg
forall a b. (a -> b) -> a -> b
$
          PublicKeyWithSignAlgInternal :: PublicKey -> CoseSignAlg -> PublicKeyWithSignAlg
PublicKeyWithSignAlgInternal
            { publicKeyInternal :: PublicKey
publicKeyInternal = PublicKey
result,
              signAlgInternal :: CoseSignAlg
signAlgInternal = CoseSignAlg
alg
            }
    where
      decodeKey :: Word -> R.CoseKeyType -> A.CoseSignAlg -> Decoder s P.UncheckedPublicKey
      decodeKey :: Word -> CoseKeyType -> CoseSignAlg -> Decoder s UncheckedPublicKey
decodeKey Word
n CoseKeyType
kty CoseSignAlg
alg = case CoseSignAlg
alg of
        CoseSignAlg
A.CoseSignAlgEdDSA -> Decoder s UncheckedPublicKey
forall s. Decoder s UncheckedPublicKey
decodeEdDSAKey
        A.CoseSignAlgECDSA CoseHashAlgECDSA
_ -> Decoder s UncheckedPublicKey
forall s. Decoder s UncheckedPublicKey
decodeECDSAKey
        A.CoseSignAlgRSA CoseHashAlgRSA
_ -> Decoder s UncheckedPublicKey
forall s. Decoder s UncheckedPublicKey
decodeRSAKey
        where
          -- [(spec)](https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-struct-15#section-7.1)
          -- Implementations MUST verify that the key type is appropriate for
          -- the algorithm being processed.
          checkKty :: R.CoseKeyType -> Decoder s ()
          checkKty :: CoseKeyType -> Decoder s ()
checkKty CoseKeyType
expectedKty = do
            Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CoseKeyType
expectedKty CoseKeyType -> CoseKeyType -> Bool
forall a. Eq a => a -> a -> Bool
== CoseKeyType
kty) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
              String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
                String
"Expected COSE key type "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CoseKeyType -> String
forall a. Show a => a -> String
show CoseKeyType
expectedKty
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" for COSE algorithm "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CoseSignAlg -> String
forall a. Show a => a -> String
show CoseSignAlg
alg
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but got COSE key type "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CoseKeyType -> String
forall a. Show a => a -> String
show CoseKeyType
kty
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" instead"
            Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CoseKeyType -> Word
R.parameterCount CoseKeyType
kty Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
n) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
              String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
                String
"Expected CBOR map to contain "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show (CoseKeyType -> Word
R.parameterCount CoseKeyType
kty)
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" parameters for COSE key type "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CoseKeyType -> String
forall a. Show a => a -> String
show CoseKeyType
kty
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but got "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
n
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" parameters instead"

          decodeEdDSAKey :: Decoder s P.UncheckedPublicKey
          decodeEdDSAKey :: Decoder s UncheckedPublicKey
decodeEdDSAKey = do
            -- https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-algs-12#section-2.2
            -- > The 'kty' field MUST be present, and it MUST be 'OKP' (Octet Key Pair).
            CoseKeyType -> Decoder s ()
forall s. CoseKeyType -> Decoder s ()
checkKty CoseKeyType
R.CoseKeyTypeOKP
            -- https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-algs-12#section-7.2
            CoseKeyTypeParameterOKP -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterOKP
R.CoseKeyTypeParameterOKPCrv
            CoseCurveEdDSA
eddsaCurve <- CoseEllipticCurveOKP -> CoseCurveEdDSA
toCurveEdDSA (CoseEllipticCurveOKP -> CoseCurveEdDSA)
-> Decoder s CoseEllipticCurveOKP -> Decoder s CoseCurveEdDSA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s CoseEllipticCurveOKP
forall a s. Serialise a => Decoder s a
decode
            CoseKeyTypeParameterOKP -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterOKP
R.CoseKeyTypeParameterOKPX
            ByteString
eddsaX <- Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical
            UncheckedPublicKey -> Decoder s UncheckedPublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKeyEdDSA :: CoseCurveEdDSA -> ByteString -> UncheckedPublicKey
P.PublicKeyEdDSA {ByteString
CoseCurveEdDSA
eddsaX :: ByteString
eddsaCurve :: CoseCurveEdDSA
eddsaX :: ByteString
eddsaCurve :: CoseCurveEdDSA
..}

          decodeECDSAKey :: Decoder s P.UncheckedPublicKey
          decodeECDSAKey :: Decoder s UncheckedPublicKey
decodeECDSAKey = do
            -- https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-algs-12#section-2.1
            -- > The 'kty' field MUST be present, and it MUST be 'EC2'.
            CoseKeyType -> Decoder s ()
forall s. CoseKeyType -> Decoder s ()
checkKty CoseKeyType
R.CoseKeyTypeEC2
            -- https://datatracker.ietf.org/doc/html/draft-ietf-cose-rfc8152bis-algs-12#section-7.1.1
            CoseKeyTypeParameterEC2 -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterEC2
R.CoseKeyTypeParameterEC2Crv
            CoseCurveECDSA
ecdsaCurve <- CoseEllipticCurveEC2 -> CoseCurveECDSA
toCurveECDSA (CoseEllipticCurveEC2 -> CoseCurveECDSA)
-> Decoder s CoseEllipticCurveEC2 -> Decoder s CoseCurveECDSA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s CoseEllipticCurveEC2
forall a s. Serialise a => Decoder s a
decode
            let size :: Int
size = CoseCurveECDSA -> Int
P.coordinateSizeECDSA CoseCurveECDSA
ecdsaCurve
            CoseKeyTypeParameterEC2 -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterEC2
R.CoseKeyTypeParameterEC2X
            Integer
ecdsaX <- Int -> ByteString -> Decoder s Integer
forall (m :: * -> *). MonadFail m => Int -> ByteString -> m Integer
os2ipWithSize Int
size (ByteString -> Decoder s Integer)
-> Decoder s ByteString -> Decoder s Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical

            CoseKeyTypeParameterEC2 -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterEC2
R.CoseKeyTypeParameterEC2Y
            Integer
ecdsaY <-
              Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s Integer) -> Decoder s Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TokenType
TypeBytes -> Int -> ByteString -> Decoder s Integer
forall (m :: * -> *). MonadFail m => Int -> ByteString -> m Integer
os2ipWithSize Int
size (ByteString -> Decoder s Integer)
-> Decoder s ByteString -> Decoder s Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical
                TokenType
TypeBool -> String -> Decoder s Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Compressed EC2 y coordinate not yet supported"
                TokenType
typ -> String -> Decoder s Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Integer) -> String -> Decoder s Integer
forall a b. (a -> b) -> a -> b
$ String
"Unexpected type in EC2 y parameter: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TokenType -> String
forall a. Show a => a -> String
show TokenType
typ

            UncheckedPublicKey -> Decoder s UncheckedPublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKeyECDSA :: CoseCurveECDSA -> Integer -> Integer -> UncheckedPublicKey
P.PublicKeyECDSA {Integer
CoseCurveECDSA
ecdsaY :: Integer
ecdsaX :: Integer
ecdsaCurve :: CoseCurveECDSA
ecdsaY :: Integer
ecdsaX :: Integer
ecdsaCurve :: CoseCurveECDSA
..}

          decodeRSAKey :: Decoder s P.UncheckedPublicKey
          decodeRSAKey :: Decoder s UncheckedPublicKey
decodeRSAKey = do
            -- https://www.rfc-editor.org/rfc/rfc8812.html#section-2
            -- > Implementations need to check that the key type is 'RSA' when creating or verifying a signature.
            CoseKeyType -> Decoder s ()
forall s. CoseKeyType -> Decoder s ()
checkKty CoseKeyType
R.CoseKeyTypeRSA
            -- https://www.rfc-editor.org/rfc/rfc8230.html#section-4
            CoseKeyTypeParameterRSA -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterRSA
R.CoseKeyTypeParameterRSAN
            -- > The octet sequence MUST utilize the minimum number of octets needed to represent the value.
            Integer
rsaN <- ByteString -> Decoder s Integer
forall (m :: * -> *). MonadFail m => ByteString -> m Integer
os2ipNoLeading (ByteString -> Decoder s Integer)
-> Decoder s ByteString -> Decoder s Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical
            CoseKeyTypeParameterRSA -> Decoder s ()
forall a s. (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected CoseKeyTypeParameterRSA
R.CoseKeyTypeParameterRSAE
            Integer
rsaE <- ByteString -> Decoder s Integer
forall (m :: * -> *). MonadFail m => ByteString -> m Integer
os2ipNoLeading (ByteString -> Decoder s Integer)
-> Decoder s ByteString -> Decoder s Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical
            UncheckedPublicKey -> Decoder s UncheckedPublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicKeyRSA :: Integer -> Integer -> UncheckedPublicKey
P.PublicKeyRSA {Integer
rsaE :: Integer
rsaN :: Integer
rsaE :: Integer
rsaN :: Integer
..}

-- | Same as 'os2ip', but throws an error if there are not exactly as many bytes as expected. Thus any successful result of this function will give the same 'BS.ByteString' back if encoded with @'i2ospOf_' size@.
os2ipWithSize :: MonadFail m => Int -> BS.ByteString -> m Integer
os2ipWithSize :: Int -> ByteString -> m Integer
os2ipWithSize Int
size ByteString
bytes
  | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size = Integer -> m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
bytes
  | Bool
otherwise =
    String -> m Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Integer) -> String -> m Integer
forall a b. (a -> b) -> a -> b
$
      String
"bytes have length " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bytes)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" when length "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
size
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" was expected"

-- | Same as 'os2ip', but throws an error if there are leading zero bytes. Thus any successful result of this function will give the same 'BS.ByteString' back if encoded with 'i2osp'.
os2ipNoLeading :: MonadFail m => BS.ByteString -> m Integer
os2ipNoLeading :: ByteString -> m Integer
os2ipNoLeading ByteString
bytes
  | Int
leadingZeroCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Integer -> m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
bytes
  | Bool
otherwise =
    String -> m Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Integer) -> String -> m Integer
forall a b. (a -> b) -> a -> b
$
      String
"bytes of length "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bytes)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
leadingZeroCount
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" leading zero bytes when none were expected"
  where
    leadingZeroCount :: Int
leadingZeroCount = ByteString -> Int
BS.length ((Word8 -> Bool) -> ByteString -> ByteString
BS.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bytes)

-- | Decode a value and ensure it's the same as the value that was given
decodeExpected :: (Show a, Eq a, Serialise a) => a -> Decoder s ()
decodeExpected :: a -> Decoder s ()
decodeExpected a
expected = do
  a
actual <- Decoder s a
forall a s. Serialise a => Decoder s a
decode
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
expected String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
actual

fromCurveEdDSA :: P.CoseCurveEdDSA -> R.CoseEllipticCurveOKP
fromCurveEdDSA :: CoseCurveEdDSA -> CoseEllipticCurveOKP
fromCurveEdDSA CoseCurveEdDSA
P.CoseCurveEd25519 = CoseEllipticCurveOKP
R.CoseEllipticCurveEd25519

toCurveEdDSA :: R.CoseEllipticCurveOKP -> P.CoseCurveEdDSA
toCurveEdDSA :: CoseEllipticCurveOKP -> CoseCurveEdDSA
toCurveEdDSA CoseEllipticCurveOKP
R.CoseEllipticCurveEd25519 = CoseCurveEdDSA
P.CoseCurveEd25519

fromCurveECDSA :: P.CoseCurveECDSA -> R.CoseEllipticCurveEC2
fromCurveECDSA :: CoseCurveECDSA -> CoseEllipticCurveEC2
fromCurveECDSA CoseCurveECDSA
P.CoseCurveP256 = CoseEllipticCurveEC2
R.CoseEllipticCurveEC2P256
fromCurveECDSA CoseCurveECDSA
P.CoseCurveP384 = CoseEllipticCurveEC2
R.CoseEllipticCurveEC2P384
fromCurveECDSA CoseCurveECDSA
P.CoseCurveP521 = CoseEllipticCurveEC2
R.CoseEllipticCurveEC2P521

toCurveECDSA :: R.CoseEllipticCurveEC2 -> P.CoseCurveECDSA
toCurveECDSA :: CoseEllipticCurveEC2 -> CoseCurveECDSA
toCurveECDSA CoseEllipticCurveEC2
R.CoseEllipticCurveEC2P256 = CoseCurveECDSA
P.CoseCurveP256
toCurveECDSA CoseEllipticCurveEC2
R.CoseEllipticCurveEC2P384 = CoseCurveECDSA
P.CoseCurveP384
toCurveECDSA CoseEllipticCurveEC2
R.CoseEllipticCurveEC2P521 = CoseCurveECDSA
P.CoseCurveP521