diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2011 Vincent Hanquez +Copyright (c) 2010-2012 Vincent Hanquez All rights reserved. diff --git a/Network/TLS/Extra/Certificate.hs b/Network/TLS/Extra/Certificate.hs --- a/Network/TLS/Extra/Certificate.hs +++ b/Network/TLS/Extra/Certificate.hs @@ -9,7 +9,6 @@ module Network.TLS.Extra.Certificate ( certificateChecks , certificateVerifyChain - , certificateVerifyChainAgainst , certificateVerifyAgainst , certificateSelfSigned , certificateVerifyDomain @@ -21,7 +20,6 @@ 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 @@ -30,23 +28,22 @@ 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 (TLSCertificateUsage(..), TLSCertificateRejectReason(..)) +import Network.TLS (CertificateUsage(..), CertificateRejectReason(..)) import Data.Time.Calendar import Data.List (find) import Data.Maybe (fromMaybe) #if defined(NOCERTVERIFY) - import System.IO (hPutStrLn, stderr, hIsTerminalDevice) import Control.Monad (when) - #endif -- | Returns 'CertificateUsageAccept' if all the checks pass, or the first -- failure. -certificateChecks :: [ [X509] -> IO TLSCertificateUsage ] -> [X509] -> IO TLSCertificateUsage +certificateChecks :: [ [X509] -> IO CertificateUsage ] -> [X509] -> IO CertificateUsage certificateChecks checks x509s = fromMaybe CertificateUsageAccept . find (CertificateUsageAccept /=) <$> mapM ($ x509s) checks @@ -56,10 +53,10 @@ # 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, +{- on windows, the trusted certificates are not yet accessible, - for now, print a big fat warning (better than nothing) and returns true -} -certificateVerifyChain_ :: [X509] -> IO TLSCertificateUsage -certificateVerifyChain_ _ = do +certificateVerifyChain_ :: CertificateStore -> [X509] -> IO CertificateUsage +certificateVerifyChain_ _ _ = do wvisible <- hIsTerminalDevice stderr when wvisible $ do hPutStrLn stderr "tls-extra:Network.TLS.Extra.Certificate" @@ -68,39 +65,25 @@ return CertificateUsageAccept #else -certificateVerifyChain_ :: [X509] -> IO TLSCertificateUsage -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) = -- find a matching certificate that we trust (== installed on the system) - foundCert <- SysCert.findCertificate (certMatchDN x) - case foundCert of - Just sysx509 -> - if certificateVerifyAgainst x sysx509 + case findCertificate (certIssuerDN $ x509Cert x) store of + Just sysx509 -> do + validChain <- certificateVerifyAgainst x sysx509 + if validChain then return CertificateUsageAccept else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") Nothing -> case xs of [] -> return $ CertificateUsageReject CertificateRejectUnknownCA - _ -> if certificateVerifyAgainst x (head xs) - then certificateVerifyChain_ xs - else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") + _ -> do + validChain <- certificateVerifyAgainst x (head xs) + if validChain + then certificateVerifyChain_ store xs + else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") #endif -certificateVerifyChainAgainst_ :: [X509] -> [X509] -> TLSCertificateUsage -certificateVerifyChainAgainst_ _ [] = CertificateUsageReject (CertificateRejectOther "empty chain / no certificates") -certificateVerifyChainAgainst_ allCerts (x:xs) = - -- find a matching certificate that we trust (== installed on the system) - -- foundCert <- SysCert.findCertificate (certMatchDN x) - case find (certMatchDN x) allCerts of - Just sysx509 -> - if certificateVerifyAgainst x sysx509 - then CertificateUsageAccept - else CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") - Nothing -> case xs of - [] -> CertificateUsageReject CertificateRejectUnknownCA - _ -> if certificateVerifyAgainst x (head xs) - then certificateVerifyChainAgainst_ allCerts xs - else CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") - -- | verify a certificates chain using the system certificates available. -- -- each certificate of the list is verified against the next certificate, until @@ -115,17 +98,8 @@ -- -- TODO: verify validity, check revocation list if any, add optional user output to know -- the rejection reason. -certificateVerifyChain :: [X509] -> IO TLSCertificateUsage -certificateVerifyChain = certificateVerifyChain_ . reorderList - where - reorderList [] = [] - reorderList (x:xs) = - case find (certMatchDN x) xs of - Nothing -> x : reorderList xs - Just found -> x : found : reorderList (filter (/= found) xs) - -certificateVerifyChainAgainst :: [X509] -> [X509] -> TLSCertificateUsage -certificateVerifyChainAgainst allCerts = certificateVerifyChainAgainst_ allCerts . reorderList +certificateVerifyChain :: CertificateStore -> [X509] -> IO CertificateUsage +certificateVerifyChain store = certificateVerifyChain_ store . reorderList where reorderList [] = [] reorderList (x:xs) = @@ -135,11 +109,12 @@ -- | verify a certificate against another one. -- the first certificate need to be signed by the second one for this function to succeed. -certificateVerifyAgainst :: X509 -> X509 -> Bool +certificateVerifyAgainst :: X509 -> X509 -> IO Bool certificateVerifyAgainst ux509@(X509 _ _ _ sigalg sig) (X509 scert _ _ _ _) = do - case verifyF sigalg pk udata esig of - Right True -> True - _ -> False + let f = verifyF sigalg pk + case f udata esig of + Right True -> return True + _ -> return False where udata = B.concat $ L.toChunks $ getSigningData ux509 esig = B.pack sig @@ -181,10 +156,10 @@ rsaVerify h hdesc pk a b = either (Left . show) (Right) $ RSA.verify h hdesc pk a b -- | Verify that the given certificate chain is application to the given fully qualified host name. -certificateVerifyDomain :: String -> [X509] -> TLSCertificateUsage +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 @@ -224,7 +199,7 @@ -- | Verify certificate validity period that need to between the bounds of the certificate. -- TODO: maybe should verify whole chain. -certificateVerifyValidity :: Day -> [X509] -> TLSCertificateUsage +certificateVerifyValidity :: Day -> [X509] -> CertificateUsage certificateVerifyValidity _ [] = CertificateUsageReject $ CertificateRejectOther "empty list" certificateVerifyValidity ctime (X509 cert _ _ _ _ :_) = let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -5,6 +5,8 @@ -- Stability : experimental -- Portability : unknown -- +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} module Network.TLS.Extra.Cipher ( -- * cipher suite @@ -29,13 +31,30 @@ import Network.TLS (Version(..)) import Network.TLS.Cipher -import qualified Crypto.Cipher.AES as AES import qualified Crypto.Cipher.RC4 as RC4 import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 +#ifdef CIPHER_AES +import qualified "cipher-aes" Crypto.Cipher.AES as AES + + +aes_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes_cbc_encrypt key iv d = AES.encryptCBC (AES.initKey key) (AES.IV iv) d + +aes_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes_cbc_decrypt key iv d = AES.decryptCBC (AES.initKey key) (AES.IV iv) d + +aes128_cbc_encrypt = aes_cbc_encrypt +aes128_cbc_decrypt = aes_cbc_decrypt +aes256_cbc_encrypt = aes_cbc_encrypt +aes256_cbc_decrypt = aes_cbc_decrypt + +#else +import qualified "cryptocipher" Crypto.Cipher.AES as AES + aes128_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString aes128_cbc_encrypt key iv d = AES.encryptCBC pkey iv d where (Right pkey) = AES.initKey128 key @@ -51,6 +70,8 @@ aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString aes256_cbc_decrypt key iv d = AES.decryptCBC pkey iv d where (Right pkey) = AES.initKey256 key + +#endif toIV :: RC4.Ctx -> IV toIV (v, x, y) = B.pack (x : y : Vector.toList v) diff --git a/Network/TLS/Extra/Compression.hs b/Network/TLS/Extra/Compression.hs --- a/Network/TLS/Extra/Compression.hs +++ b/Network/TLS/Extra/Compression.hs @@ -1,3 +1,10 @@ +-- | +-- Module : Network.TLS.Extra.Compression +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.TLS.Extra.Compression ( ) where diff --git a/Network/TLS/Extra/Connection.hs b/Network/TLS/Extra/Connection.hs --- a/Network/TLS/Extra/Connection.hs +++ b/Network/TLS/Extra/Connection.hs @@ -33,14 +33,14 @@ -- -- will make a new RNG (using system entropy) and connect to IP 192.168.2.2 -- on port 7777. -connectionClient :: CryptoRandomGen g => String -> String -> TLSParams -> g -> IO (TLSCtx Handle) +connectionClient :: CryptoRandomGen g => String -> String -> TLSParams -> g -> IO Context connectionClient s p params rng = do pn <- if and $ map isDigit $ p then return $ fromIntegral $ (read p :: Int) else servicePort <$> getServiceByName p "tcp" - he <- getHostByName s + he <- getHostByName s - h <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do + h <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do connect sock (SockAddrInet pn (head $ hostAddresses he)) socketToHandle sock ReadWriteMode - client params rng h + contextNewOnHandle h params rng diff --git a/tls-extra.cabal b/tls-extra.cabal --- a/tls-extra.cabal +++ b/tls-extra.cabal @@ -1,5 +1,5 @@ Name: tls-extra -Version: 0.4.7.1 +Version: 0.5.0 Description: a set of extra definitions, default values and helpers for tls. License: BSD3 @@ -12,15 +12,19 @@ Category: Network stability: experimental Cabal-Version: >=1.6 -Homepage: http://github.com/vincenthz/hs-tls-extra +Homepage: http://github.com/vincenthz/hs-tls Flag test Description: Build unit test Default: False +Flag fastaes + Description: Use fast AES if available + Default: True + Library Build-Depends: base > 3 && < 5 - , tls >= 0.9.4 && < 1.0.0 + , tls >= 1.0.0 && < 1.1.0 , mtl , network >= 2.3 , cryptohash >= 0.6 @@ -28,7 +32,7 @@ , vector , crypto-api >= 0.5 , cryptocipher >= 0.3.0 && < 0.4.0 - , certificate >= 1.2.0 && < 1.3.0 + , certificate >= 1.3.0 && < 1.4.0 , pem >= 0.1.0 && < 0.2.0 , text >= 0.5 && < 1.0 , time @@ -42,6 +46,9 @@ 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 executable Tests Main-is: Tests.hs @@ -54,7 +61,12 @@ , 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 source-repository head type: git - location: git://github.com/vincenthz/hs-tls-extra + location: git://github.com/vincenthz/hs-tls