{-# LANGUAGE RecordWildCards #-}
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
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
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) ->
forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
(Maybe AAID
Nothing, Just AAGUID
aaguid, Maybe (NonEmpty Text)
Nothing) -> do
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
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