{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}

-- | Stability: internal
--
-- Internal utilities
module Crypto.WebAuthn.Internal.Utils
  ( jsonEncodingOptions,
    enumJSONEncodingOptions,
    failure,
    certificateSubjectKeyIdentifier,
    IdFidoGenCeAAGUID (..),
  )
where

import Control.Monad (void)
import Crypto.Hash (hash)
import Crypto.WebAuthn.Model.Identifier (AAGUID (AAGUID), SubjectKeyIdentifier (SubjectKeyIdentifier))
import qualified Data.ASN1.BitArray as ASN1
import Data.ASN1.Parse (ParseASN1, getNext, runParseASN1)
import qualified Data.ASN1.Parse as ASN1
import Data.ASN1.Prim (ASN1 (OctetString))
import qualified Data.ASN1.Types as ASN1
import qualified Data.Aeson as Aeson
import Data.Bifunctor (first)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Char (toLower)
import Data.List (stripPrefix)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
import qualified Data.UUID as UUID
import Data.Validation (Validation (Failure))
import Data.X509 (Extension)
import qualified Data.X509 as X509

-- | Custom Aeson Options for use in the library. We add a "lit" prefix to every
-- field that would otherwise be a Haskell keyword.
jsonEncodingOptions :: Aeson.Options
jsonEncodingOptions :: Options
jsonEncodingOptions =
  Options
Aeson.defaultOptions
    { omitNothingFields :: Bool
Aeson.omitNothingFields = Bool
True,
      fieldLabelModifier :: String -> String
Aeson.fieldLabelModifier = \String
l -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
l (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"lit" String
l
    }

-- | Custom JSON Encoding for enumerations, strips the given prefix and maps
-- all constructors to lowercase.
enumJSONEncodingOptions :: String -> Aeson.Options
enumJSONEncodingOptions :: String -> Options
enumJSONEncodingOptions String
prefix =
  Options
Aeson.defaultOptions
    { omitNothingFields :: Bool
Aeson.omitNothingFields = Bool
True,
      fieldLabelModifier :: String -> String
Aeson.fieldLabelModifier = \String
l -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
l (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
l,
      constructorTagModifier :: String -> String
Aeson.constructorTagModifier = \String
l -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String)
-> (Maybe String -> String) -> Maybe String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
l (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
l
    }

-- | A convenience function for creating a 'Validation' failure of a single
-- 'NonEmpty' value
failure :: e -> Validation (NonEmpty e) a
failure :: e -> Validation (NonEmpty e) a
failure = NonEmpty e -> Validation (NonEmpty e) a
forall err a. err -> Validation err a
Failure (NonEmpty e -> Validation (NonEmpty e) a)
-> (e -> NonEmpty e) -> e -> Validation (NonEmpty e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> NonEmpty e
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | [(spec)](https://datatracker.ietf.org/doc/html/rfc5280#section-4.2.1.2)
-- Computes the 'SubjectKeyIdentifier' from a 'X509.Certificate' according to
-- method 1 in the above specification.
-- Note that this function only fails if the 'ASN1.ASN1Object' instance of
-- 'X509.PubKey' has a bug
certificateSubjectKeyIdentifier :: X509.Certificate -> SubjectKeyIdentifier
certificateSubjectKeyIdentifier :: Certificate -> SubjectKeyIdentifier
certificateSubjectKeyIdentifier Certificate
cert = Digest SHA1 -> SubjectKeyIdentifier
SubjectKeyIdentifier (Digest SHA1 -> SubjectKeyIdentifier)
-> (ByteString -> Digest SHA1)
-> ByteString
-> SubjectKeyIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA1
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash (ByteString -> SubjectKeyIdentifier)
-> ByteString -> SubjectKeyIdentifier
forall a b. (a -> b) -> a -> b
$ ByteString
publicKeyBytes
  where
    -- The x509 library doesn't expose the public key bytes directly
    -- so we instead render the ASN.1 from the public key,
    -- then decode only the public key bytes
    asns :: [ASN1]
asns = PubKey -> ASN1S
forall a. ASN1Object a => a -> ASN1S
ASN1.toASN1 (Certificate -> PubKey
X509.certPubKey Certificate
cert) []
    err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode the public key from the ASN.1 object generated: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ASN1] -> String
forall a. Show a => a -> String
show [ASN1]
asns
    publicKeyBytes :: ByteString
publicKeyBytes = (String -> ByteString)
-> (ByteString -> ByteString)
-> Either String ByteString
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ByteString
forall a. a
err ByteString -> ByteString
forall a. a -> a
id (Either String ByteString -> ByteString)
-> Either String ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ParseASN1 ByteString -> [ASN1] -> Either String ByteString
forall a. ParseASN1 a -> [ASN1] -> Either String a
ASN1.runParseASN1 ParseASN1 ByteString
parsePublicKeyBytes [ASN1]
asns

    -- SubjectPublicKeyInfo  ::=  SEQUENCE  {
    --      algorithm            AlgorithmIdentifier,
    --      subjectPublicKey     BIT STRING  }
    parsePublicKeyBytes :: ASN1.ParseASN1 BS.ByteString
    parsePublicKeyBytes :: ParseASN1 ByteString
parsePublicKeyBytes = ASN1ConstructionType
-> ParseASN1 ByteString -> ParseASN1 ByteString
forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
ASN1.onNextContainer ASN1ConstructionType
ASN1.Sequence (ParseASN1 ByteString -> ParseASN1 ByteString)
-> ParseASN1 ByteString -> ParseASN1 ByteString
forall a b. (a -> b) -> a -> b
$ do
      -- AlgorithmIdentifier  ::=  SEQUENCE  { ... }
      -- We're not interested in this
      ParseASN1 [ASN1] -> ParseASN1 ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParseASN1 [ASN1] -> ParseASN1 ())
-> ParseASN1 [ASN1] -> ParseASN1 ()
forall a b. (a -> b) -> a -> b
$ ASN1ConstructionType -> ParseASN1 [ASN1]
ASN1.getNextContainer ASN1ConstructionType
ASN1.Sequence
      ASN1.BitString BitArray
bitArray <- ParseASN1 ASN1
ASN1.getNext
      if BitArray -> Word64
ASN1.bitArrayLength BitArray
bitArray Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
8 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
        then ByteString -> ParseASN1 ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ParseASN1 ByteString)
-> ByteString -> ParseASN1 ByteString
forall a b. (a -> b) -> a -> b
$ BitArray -> ByteString
ASN1.bitArrayGetData BitArray
bitArray
        else -- This should never happen, because the x509 libraries 'ASN1.ASN1Object'
        -- instance for 'X509.PubKey' always inserts 8-bit aligned bit strings
          String -> ParseASN1 ByteString
forall a. String -> ParseASN1 a
ASN1.throwParseError String
"subjectPublicKey is not 8-bit aligned!"

-- | The `id-fido-gen-ce-aaguid` contains the AAGUID of the authenticator.
newtype IdFidoGenCeAAGUID = IdFidoGenCeAAGUID AAGUID
  deriving (IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool
(IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool)
-> (IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool)
-> Eq IdFidoGenCeAAGUID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool
$c/= :: IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool
== :: IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool
$c== :: IdFidoGenCeAAGUID -> IdFidoGenCeAAGUID -> Bool
Eq, Int -> IdFidoGenCeAAGUID -> String -> String
[IdFidoGenCeAAGUID] -> String -> String
IdFidoGenCeAAGUID -> String
(Int -> IdFidoGenCeAAGUID -> String -> String)
-> (IdFidoGenCeAAGUID -> String)
-> ([IdFidoGenCeAAGUID] -> String -> String)
-> Show IdFidoGenCeAAGUID
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [IdFidoGenCeAAGUID] -> String -> String
$cshowList :: [IdFidoGenCeAAGUID] -> String -> String
show :: IdFidoGenCeAAGUID -> String
$cshow :: IdFidoGenCeAAGUID -> String
showsPrec :: Int -> IdFidoGenCeAAGUID -> String -> String
$cshowsPrec :: Int -> IdFidoGenCeAAGUID -> String -> String
Show)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-packed-attestation-cert-requirements)
instance Extension IdFidoGenCeAAGUID where
  extOID :: IdFidoGenCeAAGUID -> OID
extOID = OID -> IdFidoGenCeAAGUID -> OID
forall a b. a -> b -> a
const [Integer
1, Integer
3, Integer
6, Integer
1, Integer
4, Integer
1, Integer
45724, Integer
1, Integer
1, Integer
4]
  extHasNestedASN1 :: Proxy IdFidoGenCeAAGUID -> Bool
extHasNestedASN1 = Bool -> Proxy IdFidoGenCeAAGUID -> Bool
forall a b. a -> b -> a
const Bool
True
  extEncode :: IdFidoGenCeAAGUID -> [ASN1]
extEncode = String -> IdFidoGenCeAAGUID -> [ASN1]
forall a. HasCallStack => String -> a
error String
"Unimplemented: This library does not implement encoding the ID_FIDO_GEN_CE_AAGUID extension"
  extDecode :: [ASN1] -> Either String IdFidoGenCeAAGUID
extDecode [ASN1]
asn1 =
    (String -> String)
-> Either String IdFidoGenCeAAGUID
-> Either String IdFidoGenCeAAGUID
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String
"Could not decode ASN1 id-fido-gen-ce-aaguid extension: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Either String IdFidoGenCeAAGUID
 -> Either String IdFidoGenCeAAGUID)
-> Either String IdFidoGenCeAAGUID
-> Either String IdFidoGenCeAAGUID
forall a b. (a -> b) -> a -> b
$
      ParseASN1 IdFidoGenCeAAGUID
-> [ASN1] -> Either String IdFidoGenCeAAGUID
forall a. ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 ParseASN1 IdFidoGenCeAAGUID
decodeFidoAAGUID [ASN1]
asn1
    where
      decodeFidoAAGUID :: ParseASN1 IdFidoGenCeAAGUID
      decodeFidoAAGUID :: ParseASN1 IdFidoGenCeAAGUID
decodeFidoAAGUID = do
        OctetString ByteString
bytes <- ParseASN1 ASN1
getNext
        case ByteString -> Maybe UUID
UUID.fromByteString (ByteString -> Maybe UUID) -> ByteString -> Maybe UUID
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bytes of
          Just UUID
aaguid -> IdFidoGenCeAAGUID -> ParseASN1 IdFidoGenCeAAGUID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdFidoGenCeAAGUID -> ParseASN1 IdFidoGenCeAAGUID)
-> IdFidoGenCeAAGUID -> ParseASN1 IdFidoGenCeAAGUID
forall a b. (a -> b) -> a -> b
$ AAGUID -> IdFidoGenCeAAGUID
IdFidoGenCeAAGUID (AAGUID -> IdFidoGenCeAAGUID) -> AAGUID -> IdFidoGenCeAAGUID
forall a b. (a -> b) -> a -> b
$ UUID -> AAGUID
AAGUID UUID
aaguid
          Maybe UUID
Nothing -> String -> ParseASN1 IdFidoGenCeAAGUID
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not extract aaguid"