tls-extra 0.4.7.1 → 0.5.0
raw patch · 6 files changed
+79/−64 lines, 6 filesdep +cipher-aesdep ~certificatedep ~tls
Dependencies added: cipher-aes
Dependency ranges changed: certificate, tls
Files
- LICENSE +1/−1
- Network/TLS/Extra/Certificate.hs +28/−53
- Network/TLS/Extra/Cipher.hs +22/−1
- Network/TLS/Extra/Compression.hs +7/−0
- Network/TLS/Extra/Connection.hs +4/−4
- tls-extra.cabal +17/−5
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2010-2012 Vincent Hanquez <vincent@snarc.org> All rights reserved.
Network/TLS/Extra/Certificate.hs view
@@ -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
Network/TLS/Extra/Cipher.hs view
@@ -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)
Network/TLS/Extra/Compression.hs view
@@ -1,3 +1,10 @@+-- |+-- Module : Network.TLS.Extra.Compression+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+-- module Network.TLS.Extra.Compression ( ) where
Network/TLS/Extra/Connection.hs view
@@ -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
tls-extra.cabal view
@@ -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