{-# LANGUAGE RecordWildCards #-}

module Data.X509.Extended
  ( certToString,
    certDescription,
    CertDescription (..),
    Fingerprint,
    unFingerprint,
    certSha1Fingerprint,
    parseFingerprintHex,
    renderFingerprintHex,
  )
where

import Crypto.Hash
import Data.ASN1.OID
import Data.ASN1.Types
import Data.ByteArray qualified as BA
import Data.ByteArray.Encoding qualified as BAE
import Data.ByteString qualified as BS
import Data.Map qualified as Map
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.X509
import Imports

certToString :: SignedCertificate -> String
certToString :: SignedCertificate -> String
certToString SignedCertificate
signedCert =
  let desc :: CertDescription
desc = SignedCertificate -> CertDescription
certDescription SignedCertificate
signedCert
   in -- Split into pairs and join with ':'
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"; " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        [ String
"Issuer: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CertDescription
desc.issuer,
          String
"Subject: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CertDescription
desc.subject,
          CertDescription
desc.fingerprintAlgorithm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Fingerprint: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CertDescription
desc.fingerprint
        ]

data CertDescription = CertDescription
  { CertDescription -> String
fingerprintAlgorithm :: String,
    CertDescription -> String
fingerprint :: String,
    CertDescription -> String
subject :: String,
    CertDescription -> String
issuer :: String
  }
  deriving (CertDescription -> CertDescription -> Bool
(CertDescription -> CertDescription -> Bool)
-> (CertDescription -> CertDescription -> Bool)
-> Eq CertDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CertDescription -> CertDescription -> Bool
== :: CertDescription -> CertDescription -> Bool
$c/= :: CertDescription -> CertDescription -> Bool
/= :: CertDescription -> CertDescription -> Bool
Eq, Int -> CertDescription -> String -> String
[CertDescription] -> String -> String
CertDescription -> String
(Int -> CertDescription -> String -> String)
-> (CertDescription -> String)
-> ([CertDescription] -> String -> String)
-> Show CertDescription
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CertDescription -> String -> String
showsPrec :: Int -> CertDescription -> String -> String
$cshow :: CertDescription -> String
show :: CertDescription -> String
$cshowList :: [CertDescription] -> String -> String
showList :: [CertDescription] -> String -> String
Show)

-- | Extract structured certificate description information
certDescription :: SignedCertificate -> CertDescription
certDescription :: SignedCertificate -> CertDescription
certDescription SignedCertificate
signedCert =
  let cert :: Certificate
cert = SignedCertificate -> Certificate
getCertificate SignedCertificate
signedCert
      issuer :: String
issuer = DistinguishedName -> String
dnToString (DistinguishedName -> String) -> DistinguishedName -> String
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
certIssuerDN Certificate
cert
      subject :: String
subject = DistinguishedName -> String
dnToString (DistinguishedName -> String) -> DistinguishedName -> String
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
certSubjectDN Certificate
cert
      fingerprint :: String
fingerprint = Text -> String
T.unpack (Text -> String)
-> (SignedCertificate -> Text) -> SignedCertificate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> Text
renderFingerprintHex (Fingerprint -> Text)
-> (SignedCertificate -> Fingerprint) -> SignedCertificate -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Fingerprint
certSha1Fingerprint (SignedCertificate -> String) -> SignedCertificate -> String
forall a b. (a -> b) -> a -> b
$ SignedCertificate
signedCert
      fingerprintAlgorithm :: String
fingerprintAlgorithm = String
"SHA1"
   in CertDescription {String
fingerprintAlgorithm :: String
fingerprint :: String
subject :: String
issuer :: String
issuer :: String
subject :: String
fingerprint :: String
fingerprintAlgorithm :: String
..}

-- | SHA-1 fingerprint: 20 bytes. Build via 'certSha1Fingerprint' or
-- 'parseFingerprintHex' (both guarantee the length).
newtype Fingerprint = Fingerprint {Fingerprint -> ByteString
unFingerprint :: ByteString}
  deriving (Fingerprint -> Fingerprint -> Bool
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
/= :: Fingerprint -> Fingerprint -> Bool
Eq, Eq Fingerprint
Eq Fingerprint =>
(Fingerprint -> Fingerprint -> Ordering)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> Ord Fingerprint
Fingerprint -> Fingerprint -> Bool
Fingerprint -> Fingerprint -> Ordering
Fingerprint -> Fingerprint -> Fingerprint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fingerprint -> Fingerprint -> Ordering
compare :: Fingerprint -> Fingerprint -> Ordering
$c< :: Fingerprint -> Fingerprint -> Bool
< :: Fingerprint -> Fingerprint -> Bool
$c<= :: Fingerprint -> Fingerprint -> Bool
<= :: Fingerprint -> Fingerprint -> Bool
$c> :: Fingerprint -> Fingerprint -> Bool
> :: Fingerprint -> Fingerprint -> Bool
$c>= :: Fingerprint -> Fingerprint -> Bool
>= :: Fingerprint -> Fingerprint -> Bool
$cmax :: Fingerprint -> Fingerprint -> Fingerprint
max :: Fingerprint -> Fingerprint -> Fingerprint
$cmin :: Fingerprint -> Fingerprint -> Fingerprint
min :: Fingerprint -> Fingerprint -> Fingerprint
Ord, Int -> Fingerprint -> String -> String
[Fingerprint] -> String -> String
Fingerprint -> String
(Int -> Fingerprint -> String -> String)
-> (Fingerprint -> String)
-> ([Fingerprint] -> String -> String)
-> Show Fingerprint
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Fingerprint -> String -> String
showsPrec :: Int -> Fingerprint -> String -> String
$cshow :: Fingerprint -> String
show :: Fingerprint -> String
$cshowList :: [Fingerprint] -> String -> String
showList :: [Fingerprint] -> String -> String
Show)

certSha1Fingerprint :: SignedCertificate -> Fingerprint
certSha1Fingerprint :: SignedCertificate -> Fingerprint
certSha1Fingerprint SignedCertificate
signedCert =
  let der :: ByteString
der = SignedCertificate -> ByteString
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
encodeSignedObject SignedCertificate
signedCert
   in ByteString -> Fingerprint
Fingerprint (Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ByteString -> Digest SHA1
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash ByteString
der :: Digest SHA1))

-- | Permissive: ignores case and ':'/whitespace separators.
parseFingerprintHex :: Text -> Either String Fingerprint
parseFingerprintHex :: Text -> Either String Fingerprint
parseFingerprintHex Text
t =
  let cleaned :: Text
cleaned = (Char -> Bool) -> Text -> Text
T.filter (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpace Char
c)) Text
t
      asBs :: ByteString
asBs = Text -> ByteString
T.encodeUtf8 Text
cleaned
   in case Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
BAE.convertFromBase Base
BAE.Base16 ByteString
asBs of
        Left String
e -> String -> Either String Fingerprint
forall a b. a -> Either a b
Left (String
"invalid hex fingerprint: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e)
        Right ByteString
bytes
          | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
20 -> Fingerprint -> Either String Fingerprint
forall a b. b -> Either a b
Right (ByteString -> Fingerprint
Fingerprint ByteString
bytes)
          | Bool
otherwise ->
              String -> Either String Fingerprint
forall a b. a -> Either a b
Left (String -> Either String Fingerprint)
-> String -> Either String Fingerprint
forall a b. (a -> b) -> a -> b
$
                String
"invalid SHA-1 fingerprint length: expected 20 bytes, got "
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bytes)

-- | Canonical openssl form: uppercase pairs, ':'-separated.
--
-- >>> renderFingerprintHex (Fingerprint "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14")
-- "01:02:03:04:05:06:07:08:09:0A:0B:0C:0D:0E:0F:10:11:12:13:14"
renderFingerprintHex :: Fingerprint -> Text
renderFingerprintHex :: Fingerprint -> Text
renderFingerprintHex (Fingerprint ByteString
bs) =
  let hex :: Text
hex = Text -> Text
T.toUpper (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
BAE.convertToBase Base
BAE.Base16 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
bs
   in Text -> [Text] -> Text
T.intercalate Text
":" (Int -> Text -> [Text]
T.chunksOf Int
2 Text
hex)

dnToString :: DistinguishedName -> String
dnToString :: DistinguishedName -> String
dnToString (DistinguishedName -> [(OID, ASN1CharacterString)]
getDistinguishedElements -> [(OID, ASN1CharacterString)]
es) =
  let [String]
dess :: [String] = ((OID, ASN1CharacterString) -> Maybe String)
-> [(OID, ASN1CharacterString)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (OID, ASN1CharacterString) -> Maybe String
distinguishedElementString [(OID, ASN1CharacterString)]
es
   in [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"," [String]
dess
  where
    distinguishedElementString :: (OID, ASN1CharacterString) -> Maybe String
    distinguishedElementString :: (OID, ASN1CharacterString) -> Maybe String
distinguishedElementString (OID
oid, ASN1CharacterString
aSN1CharacterString) = do
      (_element, desc) <- OID -> Map OID (DnElement, String) -> Maybe (DnElement, String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup OID
oid Map OID (DnElement, String)
dnElementMap
      val <- asn1CharacterToString aSN1CharacterString
      pure $ desc <> "=" <> val

    dnElementMap :: Map OID (DnElement, String)
    dnElementMap :: Map OID (DnElement, String)
dnElementMap =
      [(OID, (DnElement, String))] -> Map OID (DnElement, String)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (DnElement -> String -> (OID, (DnElement, String))
mkEntry DnElement
DnCommonName String
"CN"),
          (DnElement -> String -> (OID, (DnElement, String))
mkEntry DnElement
DnCountry String
"Country"),
          (DnElement -> String -> (OID, (DnElement, String))
mkEntry DnElement
DnOrganization String
"O"),
          (DnElement -> String -> (OID, (DnElement, String))
mkEntry DnElement
DnOrganizationUnit String
"OU"),
          (DnElement -> String -> (OID, (DnElement, String))
mkEntry DnElement
DnEmailAddress String
"Email Address")
        ]
      where
        mkEntry :: DnElement -> String -> (OID, (DnElement, String))
        mkEntry :: DnElement -> String -> (OID, (DnElement, String))
mkEntry DnElement
e String
s = (DnElement -> OID
forall a. OIDable a => a -> OID
getObjectID DnElement
e, (DnElement
e, String
s))