{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Stability: internal
-- This module contain some useful orphan 'ToJSON' instances for pretty-printing values from third-party libraries
module Crypto.WebAuthn.Internal.ToJSONOrphans () where

import Crypto.Hash (Digest)
import qualified Crypto.PubKey.ECC.Types as ECC
import Data.ASN1.Types (ASN1Object)
import qualified Data.ASN1.Types as ASN1
import Data.Aeson (ToJSON, Value (String), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.ByteArray (convert)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.Hourglass as HG
import Data.List (intercalate)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.X509 as X509
import qualified Data.X509.Validation as X509

instance ToJSON BS.ByteString where
  toJSON :: ByteString -> Value
toJSON = Text -> Value
String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode

instance ToJSON (Digest h) where
  toJSON :: Digest h -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Digest h -> Text) -> Digest h -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (Digest h -> ByteString) -> Digest h -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (Digest h -> ByteString) -> Digest h -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest h -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert

instance (Eq a, Show a, ASN1Object a, ToJSON a) => ToJSON (X509.SignedExact a) where
  toJSON :: SignedExact a -> Value
toJSON = a -> Value
forall a. ToJSON a => a -> Value
toJSON (a -> Value) -> (SignedExact a -> a) -> SignedExact a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signed a -> a
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X509.signedObject (Signed a -> a)
-> (SignedExact a -> Signed a) -> SignedExact a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedExact a -> Signed a
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X509.getSigned

instance ToJSON X509.Certificate where
  toJSON :: Certificate -> Value
toJSON X509.Certificate {Int
Integer
(DateTime, DateTime)
PubKey
DistinguishedName
Extensions
SignatureALG
certVersion :: Certificate -> Int
certSerial :: Certificate -> Integer
certSignatureAlg :: Certificate -> SignatureALG
certIssuerDN :: Certificate -> DistinguishedName
certValidity :: Certificate -> (DateTime, DateTime)
certSubjectDN :: Certificate -> DistinguishedName
certPubKey :: Certificate -> PubKey
certExtensions :: Certificate -> Extensions
certExtensions :: Extensions
certPubKey :: PubKey
certSubjectDN :: DistinguishedName
certValidity :: (DateTime, DateTime)
certIssuerDN :: DistinguishedName
certSignatureAlg :: SignatureALG
certSerial :: Integer
certVersion :: Int
..} =
    [Pair] -> Value
object
      [ Key
"certIssuerDN" Key -> DistinguishedName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DistinguishedName
certIssuerDN,
        Key
"certValidity"
          Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"notBefore" Key -> DateTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (DateTime, DateTime) -> DateTime
forall a b. (a, b) -> a
fst (DateTime, DateTime)
certValidity,
              Key
"notAfter" Key -> DateTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (DateTime, DateTime) -> DateTime
forall a b. (a, b) -> b
snd (DateTime, DateTime)
certValidity
            ],
        Key
"certSubjectDN" Key -> DistinguishedName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DistinguishedName
certSubjectDN,
        Key
"certExtensions" Key -> Extensions -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Extensions
certExtensions
      ]

instance ToJSON X509.FailedReason where
  toJSON :: FailedReason -> Value
toJSON = Text -> Value
String (Text -> Value) -> (FailedReason -> Text) -> FailedReason -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Text)
-> (FailedReason -> [Char]) -> FailedReason -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailedReason -> [Char]
forall a. Show a => a -> [Char]
show

instance ToJSON X509.Extensions where
  toJSON :: Extensions -> Value
toJSON (X509.Extensions Maybe [ExtensionRaw]
raws) = [ExtensionRaw] -> Value
forall a. ToJSON a => a -> Value
toJSON ([ExtensionRaw] -> Value) -> [ExtensionRaw] -> Value
forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> Maybe [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [ExtensionRaw]
raws

instance ToJSON X509.ExtensionRaw where
  toJSON :: ExtensionRaw -> Value
toJSON X509.ExtensionRaw {Bool
OID
ByteString
extRawOID :: ExtensionRaw -> OID
extRawCritical :: ExtensionRaw -> Bool
extRawContent :: ExtensionRaw -> ByteString
extRawContent :: ByteString
extRawCritical :: Bool
extRawOID :: OID
..} =
    [Pair] -> Value
object
      [ Key
"extRawOID" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OID -> Value
oidToJSON OID
extRawOID,
        Key
"extRawContent" Key -> ByteString -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString
extRawContent
      ]

instance ToJSON ECC.CurveName where
  toJSON :: CurveName -> Value
toJSON = Text -> Value
String (Text -> Value) -> (CurveName -> Text) -> CurveName -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Text) -> (CurveName -> [Char]) -> CurveName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurveName -> [Char]
forall a. Show a => a -> [Char]
show

oidToJSON :: ASN1.OID -> Value
oidToJSON :: OID -> Value
oidToJSON OID
oid = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Integer -> [Char]) -> OID -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> [Char]
forall a. Show a => a -> [Char]
show OID
oid

instance ToJSON HG.DateTime where
  toJSON :: DateTime -> Value
toJSON = Text -> Value
String (Text -> Value) -> (DateTime -> Text) -> DateTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Text) -> (DateTime -> [Char]) -> DateTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ISO8601_DateAndTime -> DateTime -> [Char]
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> [Char]
HG.timePrint ISO8601_DateAndTime
HG.ISO8601_DateAndTime

instance ToJSON HG.Date where
  toJSON :: Date -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Date -> Text) -> Date -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Text) -> (Date -> [Char]) -> Date -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ISO8601_Date -> Date -> [Char]
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> [Char]
HG.timePrint ISO8601_Date
HG.ISO8601_Date

instance ToJSON X509.DistinguishedName where
  toJSON :: DistinguishedName -> Value
toJSON DistinguishedName
dn = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (DnElement -> Maybe Pair) -> [DnElement] -> [Pair]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DnElement -> Maybe Pair
getPair [DnElement]
dnElements
    where
      getPair :: X509.DnElement -> Maybe Pair
      getPair :: DnElement -> Maybe Pair
getPair DnElement
el = do
        ASN1CharacterString
asnStr <- DnElement -> DistinguishedName -> Maybe ASN1CharacterString
X509.getDnElement DnElement
el DistinguishedName
dn
        [Char]
str <- ASN1CharacterString -> Maybe [Char]
ASN1.asn1CharacterToString ASN1CharacterString
asnStr
        let key :: Key
key = [Char] -> Key
forall a. IsString a => [Char] -> a
fromString ([Char] -> Key) -> [Char] -> Key
forall a b. (a -> b) -> a -> b
$ DnElement -> [Char]
forall a. Show a => a -> [Char]
show DnElement
el
            value :: Value
value = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
str
        Pair -> Maybe Pair
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key
key, Value
value)

      dnElements :: [X509.DnElement]
      dnElements :: [DnElement]
dnElements =
        [ DnElement
X509.DnCommonName,
          DnElement
X509.DnCountry,
          DnElement
X509.DnOrganization,
          DnElement
X509.DnOrganizationUnit,
          DnElement
X509.DnEmailAddress
        ]