yogsototh/hs-tls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

repair retrieve certificate validation, and improve fingerprints

Browse source
This commit is contained in:
Vincent Hanquez 2014-04-18 06:09:42 +01:00
parent dbe54e51ac
commit 9c7736bc20
1 changed files with 18 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
debug/src/RetrieveCertificate.hs
View file

@ -10,6 +10,7 @@ import Data.Default.Class
import Data.IORef import Data.IORef
import Data.X509 as X509 import Data.X509 as X509
import Data.X509.Validation import Data.X509.Validation
import System.X509
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
@ -113,12 +114,17 @@ main = do
outputFormat (Format s:_ ) = s outputFormat (Format s:_ ) = s
outputFormat (_ :xs) = outputFormat xs outputFormat (_ :xs) = outputFormat xs
getFQDN [] = Nothing
getFQDN (VerifyFQDN fqdn:_) = Just fqdn
getFQDN (_:xs) = getFQDN xs
doMain destination port opts = do doMain destination port opts = do
_ <- printf "connecting to %s on port %s ...\n" destination port _ <- printf "connecting to %s on port %s ...\n" destination port
chain <- openConnection destination port chain <- openConnection destination port
let (CertificateChain certs) = chain let (CertificateChain certs) = chain
format = outputFormat opts format = outputFormat opts
fqdn = getFQDN opts
case PrintChain `elem` opts of case PrintChain `elem` opts of
True -> True ->
forM_ (zip [0..] certs) $ \(n, cert) -> do forM_ (zip [0..] certs) $ \(n, cert) -> do
@ -129,17 +135,21 @@ main = do
let fingerprints = foldl (doFingerprint (head certs)) [] opts let fingerprints = foldl (doFingerprint (head certs)) [] opts
unless (null fingerprints) $ putStrLn ("Fingerprints:") unless (null fingerprints) $ putStrLn ("Fingerprints:")
mapM_ (\(alg,fprint) -> putStrLn (" " ++ alg ++ " = " ++ show fprint)) fingerprints mapM_ (\(alg,fprint) -> putStrLn (" " ++ alg ++ " = " ++ show fprint)) $ concat fingerprints
doFingerprint cert acc GetFingerprint =
("SHA1", getFingerprint cert X509.HashSHA1) : acc
doFingerprint _ acc _ = acc
{-
when (Verify `elem` opts) $ do when (Verify `elem` opts) $ do
store <- getSystemCertificateStore store <- getSystemCertificateStore
putStrLn "### certificate chain trust" putStrLn "### certificate chain trust"
let checks = (defaultChecks Nothing) { checkExhaustive = True } let checks = defaultChecks { checkExhaustive = True
reasons <- validate checks store chain , checkFQHN = maybe False (const True) fqdn }
servId = (maybe "" id fqdn, B.empty)
reasons <- validate X509.HashSHA256 def checks store def servId chain
when (not $ null reasons) $ do putStrLn "fail validation:" when (not $ null reasons) $ do putStrLn "fail validation:"
putStrLn $ show reasons putStrLn $ show reasons
-}
doFingerprint cert acc GetFingerprint =
[ ("SHA1", getFingerprint cert X509.HashSHA1)
, ("SHA256", getFingerprint cert X509.HashSHA256)
, ("SHA512", getFingerprint cert X509.HashSHA512)
] : acc
doFingerprint _ acc _ = acc