{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Stability: experimental
-- This module contains additional Haskell-specific type definitions for the
-- [FIDO Metadata Service](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html)
-- specification
module Crypto.WebAuthn.Metadata.Service.Types
  ( MetadataServiceRegistry (..),
    MetadataPayload (..),
    MetadataEntry (..),
    SomeMetadataEntry (..),
    StatusReport (..),
    ClaimSetSubtype (..),
  )
where

import qualified Crypto.JWT as JWT
import qualified Crypto.WebAuthn.Metadata.Service.WebIDL as ServiceIDL
import Crypto.WebAuthn.Metadata.Statement.Types (MetadataStatement)
import qualified Crypto.WebAuthn.Model as M
import Crypto.WebAuthn.Model.Identifier (AAGUID, AuthenticatorIdentifier, SubjectKeyIdentifier)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Hourglass (Date)
import Data.List.NonEmpty (NonEmpty)
import Data.Singletons (SingI)
import Data.Text (Text)
import Data.Word (Word32)
import qualified Data.X509 as X509
import GHC.Generics (Generic)

-- | A registry of 'MetadataEntry's, allowing fast lookup using 'M.AAGUID's or
-- 'SubjectKeyIdentifier's. This is used by 'Crypto.WebAuthn.Operation.Registration.verifyRegistrationResponse'
-- as a way to look up root certificates of authenticators and return meta information.
-- Using 'Crypto.WebAuthn.Metadata.Service.Processing.createMetadataRegistry'
-- it's also possible to create additional custom entries, which can be merged
-- with '<>'. Meanwhile 'mempty' can be used if no metadata is needed.
data MetadataServiceRegistry = MetadataServiceRegistry
  { MetadataServiceRegistry -> HashMap AAGUID (MetadataEntry 'Fido2)
fido2Entries :: HashMap AAGUID (MetadataEntry 'M.Fido2),
    MetadataServiceRegistry
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'M.FidoU2F)
  }

instance Semigroup MetadataServiceRegistry where
  MetadataServiceRegistry HashMap AAGUID (MetadataEntry 'Fido2)
l2 HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
lu2f <> :: MetadataServiceRegistry
-> MetadataServiceRegistry -> MetadataServiceRegistry
<> MetadataServiceRegistry HashMap AAGUID (MetadataEntry 'Fido2)
r2 HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
ru2f =
    HashMap AAGUID (MetadataEntry 'Fido2)
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
-> MetadataServiceRegistry
MetadataServiceRegistry (HashMap AAGUID (MetadataEntry 'Fido2)
l2 HashMap AAGUID (MetadataEntry 'Fido2)
-> HashMap AAGUID (MetadataEntry 'Fido2)
-> HashMap AAGUID (MetadataEntry 'Fido2)
forall a. Semigroup a => a -> a -> a
<> HashMap AAGUID (MetadataEntry 'Fido2)
r2) (HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
lu2f HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
forall a. Semigroup a => a -> a -> a
<> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
ru2f)

instance Monoid MetadataServiceRegistry where
  mempty :: MetadataServiceRegistry
mempty = HashMap AAGUID (MetadataEntry 'Fido2)
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
-> MetadataServiceRegistry
MetadataServiceRegistry HashMap AAGUID (MetadataEntry 'Fido2)
forall a. Monoid a => a
mempty HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
forall a. Monoid a => a
mempty

-- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#metadata-blob-payload-dictionary)
-- Same as 'StatementIDL.MetadataBLOBPayload', but fully decoded. However all
-- 'StatementIDL.entries' not relevant for webauthn are discarded
data MetadataPayload = MetadataPayload
  { -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayload-legalheader)
    -- The legalHeader, which MUST be in each BLOB, is an indication of the
    -- acceptance of the relevant legal agreement for using the MDS.
    MetadataPayload -> Maybe Text
mpLegalHeader :: Maybe Text,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayload-no)
    -- The serial number of this UAF Metadata BLOB Payload. Serial numbers MUST
    -- be consecutive and strictly monotonic, i.e. the successor BLOB will have
    -- a no value exactly incremented by one.
    MetadataPayload -> Int
mpNo :: Int,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayload-nextupdate)
    -- Date when the next update will be provided at latest.
    MetadataPayload -> Date
mpNextUpdate :: Date,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayload-entries)
    -- List of zero or more entries. This can be passed to
    -- 'Crypto.WebAuthn.Metadata.Service.Processing.createMetadataRegistry'
    MetadataPayload -> [SomeMetadataEntry]
mpEntries :: [SomeMetadataEntry]
  }

-- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#metadata-blob-payload-entry-dictionary)
-- Same as 'StatementIDL.MetadataBLOBPayloadEntry', but fully decoded. This type
-- is parametrized over the 'StatementIDL.ProtocolFamily' this metadata entry is for
data MetadataEntry (p :: M.ProtocolKind) = MetadataEntry
  { -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayloadentry-aaguid) or [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayloadentry-attestationcertificatekeyidentifiers)
    forall (p :: ProtocolKind).
MetadataEntry p -> AuthenticatorIdentifier p
meIdentifier :: AuthenticatorIdentifier p,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayloadentry-metadatastatement)
    forall (p :: ProtocolKind).
MetadataEntry p -> Maybe MetadataStatement
meMetadataStatement :: Maybe MetadataStatement,
    -- TODO: Implement this, currently not used in the blob however
    -- meBiometricStatusReports :: Maybe (NonEmpty BiometricStatusReport),

    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayloadentry-statusreports)
    forall (p :: ProtocolKind).
MetadataEntry p -> NonEmpty StatusReport
meStatusReports :: NonEmpty StatusReport,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-metadatablobpayloadentry-timeoflaststatuschange)
    forall (p :: ProtocolKind). MetadataEntry p -> Date
meTimeOfLastStatusChange :: Date
    -- rogueListURL, rogueListHash. TODO, but not currently used in the
    -- BLOB and difficult to implement since it involves JWT
  }
  deriving (MetadataEntry p -> MetadataEntry p -> Bool
(MetadataEntry p -> MetadataEntry p -> Bool)
-> (MetadataEntry p -> MetadataEntry p -> Bool)
-> Eq (MetadataEntry p)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (p :: ProtocolKind).
MetadataEntry p -> MetadataEntry p -> Bool
$c== :: forall (p :: ProtocolKind).
MetadataEntry p -> MetadataEntry p -> Bool
== :: MetadataEntry p -> MetadataEntry p -> Bool
$c/= :: forall (p :: ProtocolKind).
MetadataEntry p -> MetadataEntry p -> Bool
/= :: MetadataEntry p -> MetadataEntry p -> Bool
Eq, Int -> MetadataEntry p -> ShowS
[MetadataEntry p] -> ShowS
MetadataEntry p -> String
(Int -> MetadataEntry p -> ShowS)
-> (MetadataEntry p -> String)
-> ([MetadataEntry p] -> ShowS)
-> Show (MetadataEntry p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (p :: ProtocolKind). Int -> MetadataEntry p -> ShowS
forall (p :: ProtocolKind). [MetadataEntry p] -> ShowS
forall (p :: ProtocolKind). MetadataEntry p -> String
$cshowsPrec :: forall (p :: ProtocolKind). Int -> MetadataEntry p -> ShowS
showsPrec :: Int -> MetadataEntry p -> ShowS
$cshow :: forall (p :: ProtocolKind). MetadataEntry p -> String
show :: MetadataEntry p -> String
$cshowList :: forall (p :: ProtocolKind). [MetadataEntry p] -> ShowS
showList :: [MetadataEntry p] -> ShowS
Show, (forall x. MetadataEntry p -> Rep (MetadataEntry p) x)
-> (forall x. Rep (MetadataEntry p) x -> MetadataEntry p)
-> Generic (MetadataEntry p)
forall x. Rep (MetadataEntry p) x -> MetadataEntry p
forall x. MetadataEntry p -> Rep (MetadataEntry p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (p :: ProtocolKind) x.
Rep (MetadataEntry p) x -> MetadataEntry p
forall (p :: ProtocolKind) x.
MetadataEntry p -> Rep (MetadataEntry p) x
$cfrom :: forall (p :: ProtocolKind) x.
MetadataEntry p -> Rep (MetadataEntry p) x
from :: forall x. MetadataEntry p -> Rep (MetadataEntry p) x
$cto :: forall (p :: ProtocolKind) x.
Rep (MetadataEntry p) x -> MetadataEntry p
to :: forall x. Rep (MetadataEntry p) x -> MetadataEntry p
Generic)

-- | An arbitrary and potentially unstable JSON encoding, only intended for
-- logging purposes. To actually encode and decode structures, use the
-- "Crypto.WebAuthn.Encoding" modules
deriving instance Aeson.ToJSON (MetadataEntry p)

-- | Same as 'MetadataEntry', but with its type parameter erased
data SomeMetadataEntry = forall p. (SingI p) => SomeMetadataEntry (MetadataEntry p)

-- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#statusreport-dictionary)
-- Same as 'StatementIDL.StatusReport', but fully decoded.
data StatusReport = StatusReport
  { -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-status)
    StatusReport -> AuthenticatorStatus
srStatus :: ServiceIDL.AuthenticatorStatus,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-effectivedate)
    StatusReport -> Maybe Date
srEffectiveDate :: Maybe Date,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-authenticatorversion)
    StatusReport -> Maybe Word32
srAuthenticatorVersion :: Maybe Word32,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-certificate)
    StatusReport -> Maybe SignedCertificate
srCertificate :: Maybe X509.SignedCertificate,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-url)
    StatusReport -> Maybe Text
srUrl :: Maybe Text,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-certificationdescriptor)
    StatusReport -> Maybe Text
srCertificationDescriptor :: Maybe Text,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-certificatenumber)
    StatusReport -> Maybe Text
srCertificateNumber :: Maybe Text,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-certificationpolicyversion)
    StatusReport -> Maybe Text
srCertificationPolicyVersion :: Maybe Text,
    -- | [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#dom-statusreport-certificationrequirementsversion)
    StatusReport -> Maybe Text
srCertificationRequirementsVersion :: Maybe Text
  }
  deriving (StatusReport -> StatusReport -> Bool
(StatusReport -> StatusReport -> Bool)
-> (StatusReport -> StatusReport -> Bool) -> Eq StatusReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StatusReport -> StatusReport -> Bool
== :: StatusReport -> StatusReport -> Bool
$c/= :: StatusReport -> StatusReport -> Bool
/= :: StatusReport -> StatusReport -> Bool
Eq, Int -> StatusReport -> ShowS
[StatusReport] -> ShowS
StatusReport -> String
(Int -> StatusReport -> ShowS)
-> (StatusReport -> String)
-> ([StatusReport] -> ShowS)
-> Show StatusReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatusReport -> ShowS
showsPrec :: Int -> StatusReport -> ShowS
$cshow :: StatusReport -> String
show :: StatusReport -> String
$cshowList :: [StatusReport] -> ShowS
showList :: [StatusReport] -> ShowS
Show, (forall x. StatusReport -> Rep StatusReport x)
-> (forall x. Rep StatusReport x -> StatusReport)
-> Generic StatusReport
forall x. Rep StatusReport x -> StatusReport
forall x. StatusReport -> Rep StatusReport x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StatusReport -> Rep StatusReport x
from :: forall x. StatusReport -> Rep StatusReport x
$cto :: forall x. Rep StatusReport x -> StatusReport
to :: forall x. Rep StatusReport x -> StatusReport
Generic)

-- | An arbitrary and potentially unstable JSON encoding, only intended for
-- logging purposes. To actually encode and decode structures, use the
-- "Crypto.WebAuthn.Encoding" modules
deriving instance Aeson.ToJSON StatusReport

data ClaimSetSubtype addData = ClaimSetSubtype
  { forall addData. ClaimSetSubtype addData -> addData
additionalData :: addData,
    forall addData. ClaimSetSubtype addData -> ClaimsSet
claimSet :: JWT.ClaimsSet
  }

instance (Aeson.FromJSON addData) => Aeson.FromJSON (ClaimSetSubtype addData) where
  parseJSON :: Value -> Parser (ClaimSetSubtype addData)
parseJSON = String
-> (Object -> Parser (ClaimSetSubtype addData))
-> Value
-> Parser (ClaimSetSubtype addData)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ClaimSetSubtype" ((Object -> Parser (ClaimSetSubtype addData))
 -> Value -> Parser (ClaimSetSubtype addData))
-> (Object -> Parser (ClaimSetSubtype addData))
-> Value
-> Parser (ClaimSetSubtype addData)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    addData -> ClaimsSet -> ClaimSetSubtype addData
forall addData. addData -> ClaimsSet -> ClaimSetSubtype addData
ClaimSetSubtype
      (addData -> ClaimsSet -> ClaimSetSubtype addData)
-> Parser addData -> Parser (ClaimsSet -> ClaimSetSubtype addData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser addData
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON (Object -> Value
Aeson.Object Object
o)
      Parser (ClaimsSet -> ClaimSetSubtype addData)
-> Parser ClaimsSet -> Parser (ClaimSetSubtype addData)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser ClaimsSet
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON (Object -> Value
Aeson.Object Object
o)

instance JWT.HasClaimsSet (ClaimSetSubtype a) where
  claimsSet :: Lens' (ClaimSetSubtype a) ClaimsSet
claimsSet ClaimsSet -> f ClaimsSet
f ClaimSetSubtype a
s = (ClaimsSet -> ClaimSetSubtype a)
-> f ClaimsSet -> f (ClaimSetSubtype a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ClaimsSet
cs -> ClaimSetSubtype a
s {claimSet :: ClaimsSet
claimSet = ClaimsSet
cs}) (ClaimsSet -> f ClaimsSet
f (ClaimSetSubtype a -> ClaimsSet
forall addData. ClaimSetSubtype addData -> ClaimsSet
claimSet ClaimSetSubtype a
s))