{-# LANGUAGE RecordWildCards #-}

-- | Stability: experimental
-- This module contains functions to further decode
-- [FIDO Metadata Service](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html)
-- IDL types defined in 'Crypto.WebAuthn.Metadata.Service.WebIDL' into the Haskell-specific types defined in 'Crypto.WebAuthn.Metadata.Service.Types'
module Crypto.WebAuthn.Metadata.Service.Decode
  ( decodeMetadataPayload,
    decodeMetadataEntry,
  )
where

import qualified Crypto.WebAuthn.Metadata.Service.Types as ServiceTypes
import qualified Crypto.WebAuthn.Metadata.Service.WebIDL as ServiceIDL
import Crypto.WebAuthn.Metadata.Statement.Decode (decodeAAGUID, decodeCertificate, decodeMetadataStatement, decodeSubjectKeyIdentifier)
import qualified Crypto.WebAuthn.Metadata.WebIDL as IDL
import Data.Bifunctor (first)
import Data.Hourglass (Date, DateTime (dtDate), ISO8601_Date (ISO8601_Date), timeParse)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as Text

-- | Decodes a 'ServiceTypes.MetadataPayload' from a 'ServiceIDL.MetadataBLOBPayload',
-- discarding any 'ServiceIDL.MetadataBLOBPayloadEntry' that are not relevant to webauthn.
-- This includes entries of the protocol family 'StatementIDL.ProtocolFamilyUAF'
-- and entries whose 'StatementIDL.attestationTypes' doesn't include either
-- 'Registry.ATTESTATION_BASIC_FULL' or 'Registry.ATTESTATION_ATTCA'
decodeMetadataPayload :: ServiceIDL.MetadataBLOBPayload -> Either Text ServiceTypes.MetadataPayload
decodeMetadataPayload :: MetadataBLOBPayload -> Either Text MetadataPayload
decodeMetadataPayload ServiceIDL.MetadataBLOBPayload {Int
[MetadataBLOBPayloadEntry]
Maybe Text
Text
$sel:entries:MetadataBLOBPayload :: MetadataBLOBPayload -> [MetadataBLOBPayloadEntry]
$sel:nextUpdate:MetadataBLOBPayload :: MetadataBLOBPayload -> Text
$sel:no:MetadataBLOBPayload :: MetadataBLOBPayload -> Int
$sel:legalHeader:MetadataBLOBPayload :: MetadataBLOBPayload -> Maybe Text
entries :: [MetadataBLOBPayloadEntry]
nextUpdate :: Text
no :: Int
legalHeader :: Maybe Text
..} = do
  let mpLegalHeader :: Maybe Text
mpLegalHeader = Maybe Text
legalHeader
      mpNo :: Int
mpNo = Int
no
  Date
mpNextUpdate <- Text -> Either Text Date
decodeDate Text
nextUpdate
  [NonEmpty SomeMetadataEntry]
decodedEntries <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MetadataBLOBPayloadEntry
-> Maybe (Either Text (NonEmpty SomeMetadataEntry))
decodeMetadataEntry [MetadataBLOBPayloadEntry]
entries
  let mpEntries :: [SomeMetadataEntry]
mpEntries = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. NonEmpty a -> [a]
NE.toList [NonEmpty SomeMetadataEntry]
decodedEntries
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ServiceTypes.MetadataPayload {Int
[SomeMetadataEntry]
Maybe Text
Date
mpEntries :: [SomeMetadataEntry]
mpNextUpdate :: Date
mpNo :: Int
mpLegalHeader :: Maybe Text
mpEntries :: [SomeMetadataEntry]
mpNextUpdate :: Date
mpNo :: Int
mpLegalHeader :: Maybe Text
..}

liftEitherMaybe :: Either (Maybe a) b -> Maybe (Either a b)
liftEitherMaybe :: forall a b. Either (Maybe a) b -> Maybe (Either a b)
liftEitherMaybe (Left Maybe a
Nothing) = forall a. Maybe a
Nothing
liftEitherMaybe (Left (Just a
a)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
a
liftEitherMaybe (Right b
b) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right b
b

-- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#metadata-blob-payload-entry-dictionary)
-- | Decodes a 'ServiceIDL.MetadataBLOBPayloadEntry' into one or more
-- 'ServiceTypes.SomeMetadataEntry'. If the entry is not relevant for webauthn
-- (i.e. UAF authenticators or FIDO2 authenticators that only support basic
-- surrogate attestation), then this function returns 'Nothing'. If an error
-- occured during decoding, 'Left' is returned.
decodeMetadataEntry :: ServiceIDL.MetadataBLOBPayloadEntry -> Maybe (Either Text (NonEmpty ServiceTypes.SomeMetadataEntry))
decodeMetadataEntry :: MetadataBLOBPayloadEntry
-> Maybe (Either Text (NonEmpty SomeMetadataEntry))
decodeMetadataEntry ServiceIDL.MetadataBLOBPayloadEntry {Maybe (NonEmpty Text)
Maybe (NonEmpty BiometricStatusReport)
Maybe AAID
Maybe MetadataStatement
Maybe AAGUID
NonEmpty StatusReport
Text
$sel:timeOfLastStatusChange:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> Text
$sel:statusReports:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> NonEmpty StatusReport
$sel:biometricStatusReports:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> Maybe (NonEmpty BiometricStatusReport)
$sel:metadataStatement:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> Maybe MetadataStatement
$sel:attestationCertificateKeyIdentifiers:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> Maybe (NonEmpty Text)
$sel:aaguid:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> Maybe AAGUID
$sel:aaid:MetadataBLOBPayloadEntry :: MetadataBLOBPayloadEntry -> Maybe AAID
timeOfLastStatusChange :: Text
statusReports :: NonEmpty StatusReport
biometricStatusReports :: Maybe (NonEmpty BiometricStatusReport)
metadataStatement :: Maybe MetadataStatement
attestationCertificateKeyIdentifiers :: Maybe (NonEmpty Text)
aaguid :: Maybe AAGUID
aaid :: Maybe AAID
..} = forall a b. Either (Maybe a) b -> Maybe (Either a b)
liftEitherMaybe forall a b. (a -> b) -> a -> b
$
  case (Maybe AAID
aaid, Maybe AAGUID
aaguid, Maybe (NonEmpty Text)
attestationCertificateKeyIdentifiers) of
    (Just AAID
_aaid, Maybe AAGUID
Nothing, Maybe (NonEmpty Text)
Nothing) ->
      -- This is an UAF entry, we can skip it since it's not relevant for webauthn
      forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
    (Maybe AAID
Nothing, Just AAGUID
aaguid, Maybe (NonEmpty Text)
Nothing) -> do
      -- This is a FIDO 2 entry
      AuthenticatorIdentifier 'Fido2
meIdentifier <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AAGUID -> Either Text (AuthenticatorIdentifier 'Fido2)
decodeAAGUID AAGUID
aaguid
      Maybe MetadataStatement
meMetadataStatement <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetadataStatement -> Either (Maybe Text) MetadataStatement
decodeMetadataStatement Maybe MetadataStatement
metadataStatement
      NonEmpty StatusReport
meStatusReports <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StatusReport -> Either Text StatusReport
decodeStatusReport NonEmpty StatusReport
statusReports
      Date
meTimeOfLastStatusChange <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Either Text Date
decodeDate Text
timeOfLastStatusChange
      forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: ProtocolKind).
SingI p =>
MetadataEntry p -> SomeMetadataEntry
ServiceTypes.SomeMetadataEntry ServiceTypes.MetadataEntry {Maybe MetadataStatement
NonEmpty StatusReport
Date
AuthenticatorIdentifier 'Fido2
meTimeOfLastStatusChange :: Date
meStatusReports :: NonEmpty StatusReport
meMetadataStatement :: Maybe MetadataStatement
meIdentifier :: AuthenticatorIdentifier 'Fido2
meTimeOfLastStatusChange :: Date
meStatusReports :: NonEmpty StatusReport
meMetadataStatement :: Maybe MetadataStatement
meIdentifier :: AuthenticatorIdentifier 'Fido2
..}
    (Maybe AAID
Nothing, Maybe AAGUID
Nothing, Just NonEmpty Text
attestationCertificateKeyIdentifiers) -> do
      -- This is a FIDO U2F entry
      NonEmpty (AuthenticatorIdentifier 'FidoU2F)
identifiers <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text (AuthenticatorIdentifier 'FidoU2F)
decodeSubjectKeyIdentifier NonEmpty Text
attestationCertificateKeyIdentifiers
      Maybe MetadataStatement
meMetadataStatement <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetadataStatement -> Either (Maybe Text) MetadataStatement
decodeMetadataStatement Maybe MetadataStatement
metadataStatement
      NonEmpty StatusReport
meStatusReports <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StatusReport -> Either Text StatusReport
decodeStatusReport NonEmpty StatusReport
statusReports
      Date
meTimeOfLastStatusChange <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Either Text Date
decodeDate Text
timeOfLastStatusChange
      forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\AuthenticatorIdentifier 'FidoU2F
meIdentifier -> forall (p :: ProtocolKind).
SingI p =>
MetadataEntry p -> SomeMetadataEntry
ServiceTypes.SomeMetadataEntry ServiceTypes.MetadataEntry {Maybe MetadataStatement
NonEmpty StatusReport
Date
AuthenticatorIdentifier 'FidoU2F
meIdentifier :: AuthenticatorIdentifier 'FidoU2F
meTimeOfLastStatusChange :: Date
meStatusReports :: NonEmpty StatusReport
meMetadataStatement :: Maybe MetadataStatement
meTimeOfLastStatusChange :: Date
meStatusReports :: NonEmpty StatusReport
meMetadataStatement :: Maybe MetadataStatement
meIdentifier :: AuthenticatorIdentifier 'FidoU2F
..}) NonEmpty (AuthenticatorIdentifier 'FidoU2F)
identifiers
    (Maybe AAID
Nothing, Maybe AAGUID
Nothing, Maybe (NonEmpty Text)
Nothing) ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"None of aaid, aaguid or attestationCertificateKeyIdentifiers are set for this entry"
    (Maybe AAID, Maybe AAGUID, Maybe (NonEmpty Text))
_ ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"Multiple of aaid, aaguid and/or attestationCertificateKeyIdentifiers are set for this entry"

decodeStatusReport :: ServiceIDL.StatusReport -> Either Text ServiceTypes.StatusReport
decodeStatusReport :: StatusReport -> Either Text StatusReport
decodeStatusReport ServiceIDL.StatusReport {Maybe UnsignedLong
Maybe Text
AuthenticatorStatus
$sel:certificationRequirementsVersion:StatusReport :: StatusReport -> Maybe Text
$sel:certificationPolicyVersion:StatusReport :: StatusReport -> Maybe Text
$sel:certificateNumber:StatusReport :: StatusReport -> Maybe Text
$sel:certificationDescriptor:StatusReport :: StatusReport -> Maybe Text
$sel:url:StatusReport :: StatusReport -> Maybe Text
$sel:certificate:StatusReport :: StatusReport -> Maybe Text
$sel:authenticatorVersion:StatusReport :: StatusReport -> Maybe UnsignedLong
$sel:effectiveDate:StatusReport :: StatusReport -> Maybe Text
$sel:status:StatusReport :: StatusReport -> AuthenticatorStatus
certificationRequirementsVersion :: Maybe Text
certificationPolicyVersion :: Maybe Text
certificateNumber :: Maybe Text
certificationDescriptor :: Maybe Text
url :: Maybe Text
certificate :: Maybe Text
authenticatorVersion :: Maybe UnsignedLong
effectiveDate :: Maybe Text
status :: AuthenticatorStatus
..} = do
  let srStatus :: AuthenticatorStatus
srStatus = AuthenticatorStatus
status
  Maybe Date
srEffectiveDate <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text Date
decodeDate Maybe Text
effectiveDate
  let srAuthenticatorVersion :: Maybe UnsignedLong
srAuthenticatorVersion = Maybe UnsignedLong
authenticatorVersion
  Maybe SignedCertificate
srCertificate <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text SignedCertificate
decodeCertificate Maybe Text
certificate
  let srUrl :: Maybe Text
srUrl = Maybe Text
url
      srCertificationDescriptor :: Maybe Text
srCertificationDescriptor = Maybe Text
certificationDescriptor
      srCertificateNumber :: Maybe Text
srCertificateNumber = Maybe Text
certificateNumber
      srCertificationPolicyVersion :: Maybe Text
srCertificationPolicyVersion = Maybe Text
certificationPolicyVersion
      srCertificationRequirementsVersion :: Maybe Text
srCertificationRequirementsVersion = Maybe Text
certificationRequirementsVersion
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ServiceTypes.StatusReport {Maybe UnsignedLong
Maybe Text
Maybe Date
Maybe SignedCertificate
AuthenticatorStatus
srCertificationRequirementsVersion :: Maybe Text
srCertificationPolicyVersion :: Maybe Text
srCertificateNumber :: Maybe Text
srCertificationDescriptor :: Maybe Text
srUrl :: Maybe Text
srCertificate :: Maybe SignedCertificate
srAuthenticatorVersion :: Maybe UnsignedLong
srEffectiveDate :: Maybe Date
srStatus :: AuthenticatorStatus
srCertificationRequirementsVersion :: Maybe Text
srCertificationPolicyVersion :: Maybe Text
srCertificateNumber :: Maybe Text
srCertificationDescriptor :: Maybe Text
srUrl :: Maybe Text
srCertificate :: Maybe SignedCertificate
srAuthenticatorVersion :: Maybe UnsignedLong
srEffectiveDate :: Maybe Date
srStatus :: AuthenticatorStatus
..}

decodeDate :: IDL.DOMString -> Either Text Date
decodeDate :: Text -> Either Text Date
decodeDate Text
text = case forall format.
TimeFormat format =>
format -> String -> Maybe DateTime
timeParse ISO8601_Date
ISO8601_Date (Text -> String
Text.unpack Text
text) of
  Maybe DateTime
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse ISO 8601 date: " forall a. Semigroup a => a -> a -> a
<> Text
text
  Just DateTime
dt -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ DateTime -> Date
dtDate DateTime
dt