change related to the new certificatestore.
This commit is contained in:
parent
b125a04215
commit
12a28a833a
6 changed files with 21 additions and 44 deletions
|
@ -3,12 +3,11 @@
|
|||
import Network.TLS
|
||||
import Network.TLS.Extra
|
||||
|
||||
import Data.Char
|
||||
import Data.IORef
|
||||
import Data.Time.Clock
|
||||
import Data.Certificate.X509
|
||||
import System.Certificate.X509
|
||||
|
||||
import System.IO
|
||||
import Control.Monad
|
||||
|
||||
import qualified Crypto.Random.AESCtr as RNG
|
||||
|
@ -77,9 +76,10 @@ main = do
|
|||
showCert (output a) $ head certs
|
||||
|
||||
when (verify a) $ do
|
||||
store <- getSystemCertificateStore
|
||||
putStrLn "### certificate chain trust"
|
||||
ctime <- utctDay `fmap` getCurrentTime
|
||||
certificateVerifyChain certs >>= showUsage "chain validity"
|
||||
certificateVerifyChain store certs >>= showUsage "chain validity"
|
||||
showUsage "time validity" (certificateVerifyValidity ctime certs)
|
||||
when (verifyFQDN a /= "") $
|
||||
showUsage "fqdn match" (certificateVerifyDomain (verifyFQDN a) certs)
|
||||
|
|
|
@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy.Char8 as LC
|
|||
import Control.Exception
|
||||
import qualified Control.Exception as E
|
||||
import System.Environment
|
||||
import System.Certificate.X509
|
||||
|
||||
import Data.IORef
|
||||
|
||||
|
@ -43,7 +44,7 @@ instance SessionManager SessionRef where
|
|||
sessionResume (SessionRef ref) sid = readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing
|
||||
sessionInvalidate _ _ = return ()
|
||||
|
||||
getDefaultParams sStorage session = updateClientParams setCParams $ setSessionManager (SessionRef sStorage) $ defaultParams
|
||||
getDefaultParams store sStorage session = updateClientParams setCParams $ setSessionManager (SessionRef sStorage) $ defaultParamsClient
|
||||
{ pConnectVersion = TLS10
|
||||
, pAllowedVersions = [TLS10,TLS11,TLS12]
|
||||
, pCiphers = ciphers
|
||||
|
@ -57,7 +58,7 @@ getDefaultParams sStorage session = updateClientParams setCParams $ setSessionMa
|
|||
{ loggingPacketSent = putStrLn . ("debug: >> " ++)
|
||||
, loggingPacketRecv = putStrLn . ("debug: << " ++)
|
||||
}
|
||||
crecv = if validateCert then certificateVerifyChain else (\_ -> return CertificateUsageAccept)
|
||||
crecv = if validateCert then certificateVerifyChain store else (\_ -> return CertificateUsageAccept)
|
||||
|
||||
|
||||
main = do
|
||||
|
@ -65,7 +66,8 @@ main = do
|
|||
args <- getArgs
|
||||
let hostname = args !! 0
|
||||
let port = read (args !! 1) :: Int
|
||||
runTLS (getDefaultParams sStorage Nothing) hostname (fromIntegral port) $ \ctx -> do
|
||||
store <- getSystemCertificateStore
|
||||
runTLS (getDefaultParams store sStorage Nothing) hostname (fromIntegral port) $ \ctx -> do
|
||||
handshake ctx
|
||||
sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n"
|
||||
d <- recvData' ctx
|
||||
|
|
|
@ -5,6 +5,7 @@ import Network.Socket
|
|||
import System.IO
|
||||
import System.IO.Error (isEOFError)
|
||||
import System.Console.CmdArgs
|
||||
import System.Certificate.X509
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
@ -199,7 +200,8 @@ doClient pargs = do
|
|||
, loggingPacketRecv = putStrLn . ("debug: recv: " ++)
|
||||
}
|
||||
|
||||
let crecv = if validCert pargs then certificateVerifyChain else (\_ -> return CertificateUsageAccept)
|
||||
store <- getSystemCertificateStore
|
||||
let crecv = if validCert pargs then certificateVerifyChain store else (\_ -> return CertificateUsageAccept)
|
||||
let clientstate = defaultParamsClient
|
||||
{ pConnectVersion = TLS10
|
||||
, pAllowedVersions = [TLS10,TLS11,TLS12]
|
||||
|
|
|
@ -20,7 +20,6 @@ import Control.Applicative ((<$>))
|
|||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Certificate.X509
|
||||
import System.Certificate.X509 as SysCert
|
||||
|
||||
-- for signing/verifying certificate
|
||||
import qualified Crypto.Hash.SHA1 as SHA1
|
||||
|
@ -29,6 +28,7 @@ import qualified Crypto.Hash.MD5 as MD5
|
|||
import qualified Crypto.Cipher.RSA as RSA
|
||||
import qualified Crypto.Cipher.DSA as DSA
|
||||
|
||||
import Data.CertificateStore
|
||||
import Data.Certificate.X509.Cert (oidCommonName)
|
||||
import Network.TLS (CertificateUsage(..), CertificateRejectReason(..))
|
||||
|
||||
|
@ -36,39 +36,17 @@ import Data.Time.Calendar
|
|||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
#if defined(NOCERTVERIFY)
|
||||
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
|
||||
#endif
|
||||
|
||||
-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first
|
||||
-- failure.
|
||||
certificateChecks :: [ [X509] -> IO CertificateUsage ] -> [X509] -> IO CertificateUsage
|
||||
certificateChecks checks x509s =
|
||||
fromMaybe CertificateUsageAccept . find (CertificateUsageAccept /=) <$> mapM ($ x509s) checks
|
||||
|
||||
#if defined(NOCERTVERIFY)
|
||||
|
||||
# warning "********certificate verify chain doesn't yet work on your platform *************"
|
||||
# warning "********please consider contributing to the certificate to fix this issue *************"
|
||||
# warning "********getting trusted system certificate is platform dependant *************"
|
||||
|
||||
{- on windows and OSX, the trusted certificates are not yet accessible,
|
||||
- for now, print a big fat warning (better than nothing) and returns true -}
|
||||
certificateVerifyChain_ :: [X509] -> IO CertificateUsage
|
||||
certificateVerifyChain_ _ = do
|
||||
hPutStrLn stderr "****************** certificate verify chain doesn't yet work on your platform **********************"
|
||||
hPutStrLn stderr "please consider contributing to the certificate package to fix this issue"
|
||||
return CertificateUsageAccept
|
||||
|
||||
#else
|
||||
certificateVerifyChain_ :: [X509] -> IO CertificateUsage
|
||||
certificateVerifyChain_ [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates")
|
||||
certificateVerifyChain_ (x:xs) = do
|
||||
certificateVerifyChain_ :: CertificateStore -> [X509] -> IO CertificateUsage
|
||||
certificateVerifyChain_ _ [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates")
|
||||
certificateVerifyChain_ store (x:xs) = do
|
||||
-- find a matching certificate that we trust (== installed on the system)
|
||||
foundCert <- SysCert.findCertificate (certMatchDN x)
|
||||
case foundCert of
|
||||
case findCertificate (certIssuerDN $ x509Cert x) store of
|
||||
Just sysx509 -> do
|
||||
validChain <- certificateVerifyAgainst x sysx509
|
||||
if validChain
|
||||
|
@ -79,9 +57,8 @@ certificateVerifyChain_ (x:xs) = do
|
|||
_ -> do
|
||||
validChain <- certificateVerifyAgainst x (head xs)
|
||||
if validChain
|
||||
then certificateVerifyChain_ xs
|
||||
then certificateVerifyChain_ store xs
|
||||
else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")
|
||||
#endif
|
||||
|
||||
-- | verify a certificates chain using the system certificates available.
|
||||
--
|
||||
|
@ -97,8 +74,8 @@ certificateVerifyChain_ (x:xs) = do
|
|||
--
|
||||
-- TODO: verify validity, check revocation list if any, add optional user output to know
|
||||
-- the rejection reason.
|
||||
certificateVerifyChain :: [X509] -> IO CertificateUsage
|
||||
certificateVerifyChain = certificateVerifyChain_ . reorderList
|
||||
certificateVerifyChain :: CertificateStore -> [X509] -> IO CertificateUsage
|
||||
certificateVerifyChain store = certificateVerifyChain_ store . reorderList
|
||||
where
|
||||
reorderList [] = []
|
||||
reorderList (x:xs) =
|
||||
|
@ -158,7 +135,7 @@ rsaVerify h hdesc pk a b = either (Left . show) (Right) $ RSA.verify h hdesc pk
|
|||
certificateVerifyDomain :: String -> [X509] -> CertificateUsage
|
||||
certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list")
|
||||
certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) =
|
||||
let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ certSubjectDN cert)
|
||||
let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ getDistinguishedElements $ certSubjectDN cert)
|
||||
++ maybe [] (maybe [] toAltName . extensionGet) (certExtensions cert) in
|
||||
orUsage $ map (matchDomain . splitDot) names
|
||||
where
|
||||
|
|
|
@ -12,7 +12,7 @@ import Data.Time.Clock (secondsToDiffTime)
|
|||
readableChar :: Gen Char
|
||||
readableChar = elements (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])
|
||||
|
||||
arbitraryDN = return []
|
||||
arbitraryDN = return $ X509Cert.DistinguishedName []
|
||||
|
||||
arbitraryTime = do
|
||||
year <- choose (1951, 2050)
|
||||
|
|
|
@ -44,8 +44,6 @@ Library
|
|||
Network.TLS.Extra.Thread
|
||||
Network.TLS.Extra.File
|
||||
ghc-options: -Wall -fno-warn-missing-signatures
|
||||
if os(windows)
|
||||
cpp-options: -DNOCERTVERIFY
|
||||
if os(linux) && flag(fastaes) && (arch(i386) || arch(x86_64))
|
||||
cpp-options: -DCIPHER_AES
|
||||
Build-Depends: cipher-aes >= 0.1 && < 0.2
|
||||
|
@ -61,8 +59,6 @@ executable Tests
|
|||
, cprng-aes >= 0.2.3
|
||||
else
|
||||
Buildable: False
|
||||
if os(windows)
|
||||
cpp-options: -DNOCERTVERIFY
|
||||
if os(linux) && flag(fastaes)
|
||||
cpp-options: -DCIPHER_AES
|
||||
Build-Depends: cipher-aes >= 0.1 && < 0.2
|
||||
|
|
Loading…
Reference in a new issue