-- | Stability: experimental
-- A function for decoding a [FIDO Alliance Metadata Service](https://fidoalliance.org/metadata/)
-- BLOB in order to be able to enforce a set of requirements on the authenticator
-- used, e.g. to only allow authenticators that have been
-- [FIDO certified](https://fidoalliance.org/certification/functional-certification/).
module Crypto.WebAuthn.Metadata
  ( metadataBlobToRegistry,
    Service.MetadataServiceRegistry,
  )
where

import qualified Crypto.WebAuthn.Metadata.Service.Processing as Service
import qualified Crypto.WebAuthn.Metadata.Service.Types as Service
import Data.Bifunctor (Bifunctor (second), first)
import qualified Data.ByteString as BS
import qualified Data.Hourglass as HG
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as Text
import Data.These (These)

-- | Verifies, decodes and extracts a 'Service.MetadataServiceRegistry' from a
-- [FIDO Alliance Metadata Service](https://fidoalliance.org/metadata/) BLOB.
-- The result can be passed to 'Crypto.WebAuthn.Operation.Registration.verifyRegistrationResponse'.
metadataBlobToRegistry ::
  -- | A Metadata BLOB fetched from <https://mds.fidoalliance.org>
  BS.ByteString ->
  -- | The time at which it was fetched
  HG.DateTime ->
  -- | Either a certifcate error or a list of errors, a registry of metadata entries or both where the MDS has bad entries
  Either Text (These (NE.NonEmpty Text) Service.MetadataServiceRegistry)
metadataBlobToRegistry :: ByteString
-> DateTime
-> Either Text (These (NonEmpty Text) MetadataServiceRegistry)
metadataBlobToRegistry ByteString
bytes DateTime
now = do
  HashMap Text Value
json <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (ByteString
-> RootCertificate
-> DateTime
-> Either ProcessingError (HashMap Text Value)
Service.jwtToJson ByteString
bytes RootCertificate
Service.fidoAllianceRootCertificate DateTime
now)
  let payload :: These (NonEmpty Text) MetadataPayload
payload = HashMap Text Value -> These (NonEmpty Text) MetadataPayload
Service.jsonToPayload HashMap Text Value
json
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([SomeMetadataEntry] -> MetadataServiceRegistry
Service.createMetadataRegistry forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetadataPayload -> [SomeMetadataEntry]
Service.mpEntries) These (NonEmpty Text) MetadataPayload
payload