pretty show for Credential

haskell-tls · Jan 16, 2025 · 4348b7f · 4348b7f
1 parent fcbfb32
commit 4348b7f
Show file tree

Hide file tree

Showing 2 changed files with 19 additions and 9 deletions.
diff --git a/tls/Network/TLS/Credentials.hs b/tls/Network/TLS/Credentials.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Network.TLS.Credentials (
     Credential,
@@ -26,6 +29,9 @@ import qualified Network.TLS.Struct as TLS
 
 type Credential = (CertificateChain, PrivKey)
 
+instance {-# OVERLAPS #-} Show Credential where
+    show (cc, _) = TLS.showCertificateChain cc
+
 newtype Credentials = Credentials [Credential] deriving (Show)
 
 instance Semigroup Credentials where

diff --git a/tls/Network/TLS/Struct.hs b/tls/Network/TLS/Struct.hs
@@ -112,6 +112,7 @@ module Network.TLS.Struct (
     module Network.TLS.HashAndSignature,
     ExtensionRaw (..),
     ExtensionID (..),
+    showCertificateChain,
 ) where
 
 import Data.X509 (
@@ -408,15 +409,18 @@ data CH = CH
 
 newtype TLSCertificateChain = TLSCertificateChain CertificateChain deriving (Eq)
 instance Show TLSCertificateChain where
-    show (TLSCertificateChain (CertificateChain xs)) = show $ map getName xs
-      where
-        getName =
-            maybe "" getCharacterStringRawData
-                . lookup [2, 5, 4, 3]
-                . getDistinguishedElements
-                . certSubjectDN
-                . signedObject
-                . getSigned
+    show (TLSCertificateChain cc) = showCertificateChain cc
+
+showCertificateChain :: CertificateChain -> String
+showCertificateChain (CertificateChain xs) = show $ map getName xs
+  where
+    getName =
+        maybe "" getCharacterStringRawData
+            . lookup [2, 5, 4, 3]
+            . getDistinguishedElements
+            . certSubjectDN
+            . signedObject
+            . getSigned
 
 data Handshake
     = ClientHello