{-# 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 -> [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
l (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
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 -> [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
l (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
prefix [Char]
l,
      constructorTagModifier :: [Char] -> [Char]
Aeson.constructorTagModifier = \[Char]
l -> (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char])
-> (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
l (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
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 = 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 = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to decode the public key from the ASN.1 object generated: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [ASN1] -> [Char]
forall a. Show a => a -> [Char]
show [ASN1]
asns
    publicKeyBytes :: ByteString
publicKeyBytes = ([Char] -> ByteString)
-> (ByteString -> ByteString)
-> Either [Char] ByteString
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> ByteString
forall {a}. a
err ByteString -> ByteString
forall a. a -> a
id (Either [Char] ByteString -> ByteString)
-> Either [Char] ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ParseASN1 ByteString -> [ASN1] -> Either [Char] ByteString
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 = 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
          [Char] -> ParseASN1 ByteString
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
(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 -> [Char] -> [Char]
[IdFidoGenCeAAGUID] -> [Char] -> [Char]
IdFidoGenCeAAGUID -> [Char]
(Int -> IdFidoGenCeAAGUID -> [Char] -> [Char])
-> (IdFidoGenCeAAGUID -> [Char])
-> ([IdFidoGenCeAAGUID] -> [Char] -> [Char])
-> Show IdFidoGenCeAAGUID
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 = 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 = [Char] -> IdFidoGenCeAAGUID -> [ASN1]
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 =
    ([Char] -> [Char])
-> Either [Char] IdFidoGenCeAAGUID
-> Either [Char] IdFidoGenCeAAGUID
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: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) (Either [Char] IdFidoGenCeAAGUID
 -> Either [Char] IdFidoGenCeAAGUID)
-> Either [Char] IdFidoGenCeAAGUID
-> Either [Char] IdFidoGenCeAAGUID
forall a b. (a -> b) -> a -> b
$
      ParseASN1 IdFidoGenCeAAGUID
-> [ASN1] -> Either [Char] IdFidoGenCeAAGUID
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 (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 -> [Char] -> ParseASN1 IdFidoGenCeAAGUID
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Could not extract aaguid"