{-# 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 :: [Char] -> [Char]
Aeson.fieldLabelModifier = \[Char]
l -> forall a. a -> Maybe a -> a
fromMaybe [Char]
l forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"lit" [Char]
l
    }

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

-- | A convenience function for creating a 'Validation' failure of a single
-- 'NonEmpty' value
failure :: e -> Validation (NonEmpty e) a
failure :: forall e a. e -> Validation (NonEmpty e) a
failure = forall err a. err -> Validation err a
Failure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash 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 = forall a. ASN1Object a => a -> ASN1S
ASN1.toASN1 (Certificate -> PubKey
X509.certPubKey Certificate
cert) []
    err :: a
err = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to decode the public key from the ASN.1 object generated: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [ASN1]
asns
    publicKeyBytes :: ByteString
publicKeyBytes = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. a
err forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. ParseASN1 a -> [ASN1] -> Either [Char] a
ASN1.runParseASN1 ParseASN1 ByteString
parsePublicKeyBytes [ASN1]
asns

    -- SubjectPublicKeyInfo  ::=  SEQUENCE  {
    --      algorithm            AlgorithmIdentifier,
    --      subjectPublicKey     BIT STRING  }
    parsePublicKeyBytes :: ASN1.ParseASN1 BS.ByteString
    parsePublicKeyBytes :: ParseASN1 ByteString
parsePublicKeyBytes = forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
ASN1.onNextContainer ASN1ConstructionType
ASN1.Sequence forall a b. (a -> b) -> a -> b
$ do
      -- AlgorithmIdentifier  ::=  SEQUENCE  { ... }
      -- We're not interested in this
      forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 forall a. Integral a => a -> a -> a
`mod` Word64
8 forall a. Eq a => a -> a -> Bool
== Word64
0
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
          forall a. [Char] -> ParseASN1 a
ASN1.throwParseError [Char]
"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
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 -> [Char] -> [Char]
[IdFidoGenCeAAGUID] -> [Char] -> [Char]
IdFidoGenCeAAGUID -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [IdFidoGenCeAAGUID] -> [Char] -> [Char]
$cshowList :: [IdFidoGenCeAAGUID] -> [Char] -> [Char]
show :: IdFidoGenCeAAGUID -> [Char]
$cshow :: IdFidoGenCeAAGUID -> [Char]
showsPrec :: Int -> IdFidoGenCeAAGUID -> [Char] -> [Char]
$cshowsPrec :: Int -> IdFidoGenCeAAGUID -> [Char] -> [Char]
Show)

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