From f927d408ab04ae989ec3bdd2deeeded5d36d6f43 Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Wed, 23 Nov 2011 21:49:33 +0000
Subject: [PATCH] add some option to do certificate verification when retriving
 a certificate.

---
 Examples/RetrieveCertificate.hs | 19 ++++++++++++++++++-
 1 file changed, 18 insertions(+), 1 deletion(-)

diff --git a/Examples/RetrieveCertificate.hs b/Examples/RetrieveCertificate.hs
index 3d75ae4..dc2dba8 100644
--- a/Examples/RetrieveCertificate.hs
+++ b/Examples/RetrieveCertificate.hs
@@ -5,6 +5,7 @@ import Network.TLS.Extra
 
 import Data.Char
 import Data.IORef
+import Data.Time.Clock
 
 import System.IO
 import Control.Monad
@@ -38,6 +39,8 @@ data PArgs = PArgs
 	, port        :: String
 	, chain       :: Bool
 	, output      :: String
+	, verify      :: Bool
+	, verifyFQDN  :: String
 	} deriving (Show, Data, Typeable)
 
 progArgs = PArgs
@@ -45,6 +48,8 @@ progArgs = PArgs
 	, port        = "443"       &= help "destination port to connect to" &= typ "port"
 	, chain       = False       &= help "also output the chain of certificate used"
 	, output      = "pem"       &= help "define the format of output (PEM by default)" &= typ "format"
+	, verify      = False       &= help "verify the chain received with the trusted system certificates"
+	, verifyFQDN  = ""          &= help "verify the chain against a specific fully qualified domain name (e.g. web.example.com)" &= explicit &= name "verify-domain-name"
 	} &= summary "RetrieveCertificate remotely for SSL/TLS protocol"
 	&= details
 		[ "Retrieve the remote certificate and optionally its chain from a remote destination"
@@ -61,7 +66,19 @@ main = do
 	case (chain a) of
 		True ->
 			forM_ (zip [0..] certs) $ \(n, cert) -> do
-				putStrLn ("###### Certificate " ++ show (n + 1) ++ " ######")
+				putStrLn ("###### Certificate " ++ show (n + 1 :: Int) ++ " ######")
 				showCert (output a) cert
 		False ->
 			showCert (output a) $ head certs
+
+	when (verify a) $ do
+		putStrLn "### certificate chain trust"
+		ctime <- utctDay `fmap` getCurrentTime
+		certificateVerifyChain certs >>= showUsage "chain validity"
+		showUsage "time validity" (certificateVerifyValidity ctime certs)
+		when (verifyFQDN a /= "") $
+			showUsage "fqdn match" (certificateVerifyDomain (verifyFQDN a) certs)
+	where
+		showUsage :: String -> TLSCertificateUsage -> IO ()
+		showUsage s CertificateUsageAccept     = printf "%s : accepted\n" s
+		showUsage s (CertificateUsageReject r) = printf "%s : rejected: %s\n" s (show r)