tls-debug 0.3.2 → 0.3.3

raw patch · 2 files changed

+20/−12 lines, 2 filesdep −groom

Dependencies removed: groom

Files

• src/RetrieveCertificate.hs +19/−10
• tls-debug.cabal +1/−2

@@ -10,6 +10,7 @@ import Data.IORef import Data.X509 as X509 import Data.X509.Validation+import System.X509  import Control.Applicative import Control.Monad@@ -21,7 +22,6 @@ import Data.PEM  import Text.Printf-import Text.Groom  import System.Console.GetOpt import System.Environment@@ -82,7 +82,7 @@                     , pemHeader = []                     , pemContent = encodeSignedObject cert                     }-showCert "full" cert = putStrLn $ groom cert+showCert "full" cert = putStrLn $ show cert  showCert _ (signedCert)  = do     putStrLn ("serial:   " ++ (show $ certSerial cert))@@ -113,12 +113,17 @@         outputFormat (Format s:_ ) = s         outputFormat (_       :xs) = outputFormat xs +        getFQDN []                  = Nothing+        getFQDN (VerifyFQDN fqdn:_) = Just fqdn+        getFQDN (_:xs)              = getFQDN xs+         doMain destination port opts = do             _ <- printf "connecting to %s on port %s ...\n" destination port              chain <- openConnection destination port             let (CertificateChain certs) = chain                 format = outputFormat opts+                fqdn   = getFQDN opts             case PrintChain `elem` opts of                 True ->                     forM_ (zip [0..] certs) $ \(n, cert) -> do@@ -129,17 +134,21 @@              let fingerprints = foldl (doFingerprint (head certs)) [] opts             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                 store <- getSystemCertificateStore                 putStrLn "### certificate chain trust"-                let checks = (defaultChecks Nothing) { checkExhaustive = True }-                reasons <- validate checks store chain+                let checks = defaultChecks { checkExhaustive = True+                                           , 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:"                                                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

@@ -1,5 +1,5 @@ Name:                tls-debug-Version:             0.3.2+Version:             0.3.3 Description:    A set of program to test and debug various aspect of the TLS package.    .@@ -50,7 +50,6 @@   Build-Depends:     base >= 4 && < 5                    , network                    , bytestring-                   , groom                    , time                    , pem                    , cprng-aes >= 0.5.0