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 @@ -7,14 +7,14 @@ -- Portability : unknown -- module Network.TLS.Extra.Certificate - ( certificateChecks - , certificateVerifyChain - , certificateVerifyAgainst - , certificateSelfSigned - , certificateVerifyDomain - , certificateVerifyValidity - , certificateFingerprint - ) where + ( certificateChecks + , certificateVerifyChain + , certificateVerifyAgainst + , certificateSelfSigned + , certificateVerifyDomain + , certificateVerifyValidity + , certificateFingerprint + ) where import Control.Applicative ((<$>)) import qualified Data.ByteString as B @@ -40,7 +40,7 @@ import Control.Monad (when) #endif --- | Returns 'CertificateUsageAccept' if all the checks pass, or the first +-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first -- failure. certificateChecks :: [ [X509] -> IO CertificateUsage ] -> [X509] -> IO CertificateUsage certificateChecks checks x509s = @@ -67,20 +67,37 @@ 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) - 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 - _ -> do - validChain <- certificateVerifyAgainst x (head xs) - if validChain - then certificateVerifyChain_ store xs - else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") + -- find a matching certificate that we trust (== installed on the system) + case findCertificate (certIssuerDN $ x509Cert x) store of + Just sysx509 -> do + validChain <- certificateVerifyAgainst x sysx509 + if validChain + then return CertificateUsageAccept + else return certificateChainDoesntMatch + Nothing -> + case xs of + [] -> return $ CertificateUsageReject CertificateRejectUnknownCA + cert:_ -> do + let exts = certExtensions (x509Cert cert) + case checkCA exts of + Just r -> return r + Nothing -> do + validChain <- certificateVerifyAgainst x cert + if validChain + then certificateVerifyChain_ store xs + else return certificateChainDoesntMatch + where checkCA Nothing = return $ certificateNotAllowedToSign + checkCA (Just es) = do + let kuCanCertSign = case extensionGet es of + Just (ExtKeyUsage l) -> elem KeyUsage_keyCertSign l + Nothing -> False + case extensionGet es of + Just (ExtBasicConstraints True _) + | kuCanCertSign -> Nothing + | otherwise -> Just certificateNotAllowedToSign + _ -> Just certificateNotAllowedToSign + certificateNotAllowedToSign = CertificateUsageReject $ CertificateRejectOther "certificate is not allowed to sign another certificate" + certificateChainDoesntMatch = CertificateUsageReject $ CertificateRejectOther "chain doesn't match each other" #endif -- | verify a certificates chain using the system certificates available. @@ -99,12 +116,12 @@ -- the rejection reason. certificateVerifyChain :: CertificateStore -> [X509] -> IO CertificateUsage certificateVerifyChain store = certificateVerifyChain_ store . reorderList - where - reorderList [] = [] - reorderList (x:xs) = - case find (certMatchDN x) xs of - Nothing -> x : reorderList xs - Just found -> x : found : reorderList (filter (/= found) xs) + where + reorderList [] = [] + reorderList (x:xs) = + case find (certMatchDN x) xs of + Nothing -> x : reorderList xs + Just found -> x : found : reorderList (filter (/= found) xs) -- | verify a certificate against another one. -- the first certificate need to be signed by the second one for this function to succeed. @@ -122,7 +139,7 @@ certMatchDN :: X509 -> X509 -> Bool certMatchDN (X509 testedCert _ _ _ _) (X509 issuerCert _ _ _ _) = - certSubjectDN issuerCert == certIssuerDN testedCert + certSubjectDN issuerCert == certIssuerDN testedCert verifyF :: SignatureALG -> PubKey -> B.ByteString -> B.ByteString -> Bool @@ -137,63 +154,63 @@ verifyF (SignatureALG HashMD5 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrMD5 rsak verifyF (SignatureALG HashSHA1 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrSHA1 rsak verifyF (SignatureALG HashSHA1 PubKeyALG_DSA) (PubKeyDSA dsak) = dsaSHA1Verify dsak - + verifyF _ _ = \_ _ -> False dsaSHA1Verify pk _ b = DSA.verify SHA1.hash pk asig b - where asig = (0,0) {- FIXME : need to work out how to get R/S from the bytestring a -} + where asig = (0,0) {- FIXME : need to work out how to get R/S from the bytestring a -} -- | Verify that the given certificate chain is application to the given fully qualified host name. certificateVerifyDomain :: String -> [X509] -> CertificateUsage certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list") certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) = - let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ getDistinguishedElements $ certSubjectDN cert) - ++ maybe [] (maybe [] toAltName . extensionGet) (certExtensions cert) in - orUsage $ map (matchDomain . splitDot) names - where - orUsage [] = rejectMisc "FQDN do not match this certificate" - orUsage (x:xs) - | x == CertificateUsageAccept = CertificateUsageAccept - | otherwise = orUsage xs + let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ getDistinguishedElements $ certSubjectDN cert) + ++ maybe [] (maybe [] toAltName . extensionGet) (certExtensions cert) in + orUsage $ map (matchDomain . splitDot) names + where + orUsage [] = rejectMisc "FQDN do not match this certificate" + orUsage (x:xs) + | x == CertificateUsageAccept = CertificateUsageAccept + | otherwise = orUsage xs - toAltName (ExtSubjectAltName l) = l - matchDomain l - | length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain" - | head l == "*" = wildcardMatch (reverse $ drop 1 l) - | otherwise = if l == splitDot fqhn - then CertificateUsageAccept - else rejectMisc "FQDN and common name OID do not match" + toAltName (ExtSubjectAltName l) = l + matchDomain l + | length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain" + | head l == "*" = wildcardMatch (reverse $ drop 1 l) + | otherwise = if l == splitDot fqhn + then CertificateUsageAccept + else rejectMisc "FQDN and common name OID do not match" - -- only 1 wildcard is valid, and if multiples are present - -- they won't have a wildcard meaning but will be match as normal star - -- character to the fqhn and inevitably will fail. - wildcardMatch l - -- .com or is always invalid - | length l < 2 = rejectMisc "commonname OID wildcard match too widely" - -- .com. is always invalid - | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = rejectMisc "commonname OID wildcard match too widely" - | otherwise = - if l == take (length l) (reverse $ splitDot fqhn) - then CertificateUsageAccept - else rejectMisc "FQDN and common name OID do not match" + -- only 1 wildcard is valid, and if multiples are present + -- they won't have a wildcard meaning but will be match as normal star + -- character to the fqhn and inevitably will fail. + wildcardMatch l + -- .com or is always invalid + | length l < 2 = rejectMisc "commonname OID wildcard match too widely" + -- .com. is always invalid + | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = rejectMisc "commonname OID wildcard match too widely" + | otherwise = + if l == take (length l) (reverse $ splitDot fqhn) + then CertificateUsageAccept + else rejectMisc "FQDN and common name OID do not match" - splitDot :: String -> [String] - splitDot [] = [""] - splitDot x = - let (y, z) = break (== '.') x in - y : (if z == "" then [] else splitDot $ drop 1 z) + splitDot :: String -> [String] + splitDot [] = [""] + splitDot x = + let (y, z) = break (== '.') x in + y : (if z == "" then [] else splitDot $ drop 1 z) - rejectMisc s = CertificateUsageReject (CertificateRejectOther s) + rejectMisc s = CertificateUsageReject (CertificateRejectOther s) -- | Verify certificate validity period that need to between the bounds of the certificate. -- TODO: maybe should verify whole chain. certificateVerifyValidity :: Day -> [X509] -> CertificateUsage certificateVerifyValidity _ [] = CertificateUsageReject $ CertificateRejectOther "empty list" certificateVerifyValidity ctime (X509 cert _ _ _ _ :_) = - let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in - if beforeDay < ctime && ctime <= afterDay - then CertificateUsageAccept - else CertificateUsageReject CertificateRejectExpired + let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in + if beforeDay < ctime && ctime <= afterDay + then CertificateUsageAccept + else CertificateUsageReject CertificateRejectExpired -- | hash the certificate signing data using the supplied hash function. certificateFingerprint :: (L.ByteString -> B.ByteString) -> X509 -> B.ByteString 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 @@ -8,23 +8,23 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} module Network.TLS.Extra.Cipher - ( - -- * cipher suite - ciphersuite_all - , ciphersuite_medium - , ciphersuite_strong - , ciphersuite_unencrypted - -- * individual ciphers - , cipher_null_null - , cipher_null_SHA1 - , cipher_null_MD5 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - , cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_AES128_SHA256 - , cipher_AES256_SHA256 - ) where + ( + -- * cipher suite + ciphersuite_all + , ciphersuite_medium + , ciphersuite_strong + , ciphersuite_unencrypted + -- * individual ciphers + , cipher_null_null + , cipher_null_SHA1 + , cipher_null_MD5 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + , cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_AES128_SHA256 + , cipher_AES256_SHA256 + ) where import qualified Data.ByteString as B @@ -69,10 +69,10 @@ -- this choice of ciphersuite should satisfy most normal need ciphersuite_all :: [Cipher] ciphersuite_all = - [ cipher_AES128_SHA256, cipher_AES256_SHA256 - , cipher_AES128_SHA1, cipher_AES256_SHA1 - , cipher_RC4_128_SHA1, cipher_RC4_128_MD5 - ] + [ cipher_AES128_SHA256, cipher_AES256_SHA256 + , cipher_AES128_SHA1, cipher_AES256_SHA1 + , cipher_RC4_128_SHA1, cipher_RC4_128_MD5 + ] -- | list of medium ciphers. ciphersuite_medium :: [Cipher] @@ -87,159 +87,159 @@ ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] bulk_null = Bulk - { bulkName = "null" - , bulkKeySize = 0 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = BulkNoneF - } + { bulkName = "null" + , bulkKeySize = 0 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkNoneF + } bulk_rc4 = Bulk - { bulkName = "RC4-128" - , bulkKeySize = 16 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = BulkStreamF initF_rc4 encryptF_rc4 decryptF_rc4 - } + { bulkName = "RC4-128" + , bulkKeySize = 16 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF initF_rc4 encryptF_rc4 decryptF_rc4 + } bulk_aes128 = Bulk - { bulkName = "AES128" - , bulkKeySize = 16 - , bulkIVSize = 16 - , bulkBlockSize = 16 - , bulkF = BulkBlockF aes128_cbc_encrypt aes128_cbc_decrypt - } + { bulkName = "AES128" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes128_cbc_encrypt aes128_cbc_decrypt + } bulk_aes256 = Bulk - { bulkName = "AES256" - , bulkKeySize = 32 - , bulkIVSize = 16 - , bulkBlockSize = 16 - , bulkF = BulkBlockF aes256_cbc_encrypt aes256_cbc_decrypt - } + { bulkName = "AES256" + , bulkKeySize = 32 + , bulkIVSize = 16 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes256_cbc_encrypt aes256_cbc_decrypt + } hash_md5 = Hash - { hashName = "MD5" - , hashSize = 16 - , hashF = MD5.hash - } + { hashName = "MD5" + , hashSize = 16 + , hashF = MD5.hash + } hash_sha1 = Hash - { hashName = "SHA1" - , hashSize = 20 - , hashF = SHA1.hash - } + { hashName = "SHA1" + , hashSize = 20 + , hashF = SHA1.hash + } hash_sha256 = Hash - { hashName = "SHA256" - , hashSize = 32 - , hashF = SHA256.hash - } + { hashName = "SHA256" + , hashSize = 32 + , hashF = SHA256.hash + } hash_null = Hash - { hashName = "null" - , hashSize = 0 - , hashF = const B.empty - } + { hashName = "null" + , hashSize = 0 + , hashF = const B.empty + } -- | this is not stricly a usable cipher; it's the initial cipher of a TLS connection cipher_null_null :: Cipher cipher_null_null = Cipher - { cipherID = 0x0 - , cipherName = "null-null" - , cipherBulk = bulk_null - , cipherHash = hash_null - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x0 + , cipherName = "null-null" + , cipherBulk = bulk_null + , cipherHash = hash_null + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher - { cipherID = 0x1 - , cipherName = "RSA-null-MD5" - , cipherBulk = bulk_null - , cipherHash = hash_md5 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x1 + , cipherName = "RSA-null-MD5" + , cipherBulk = bulk_null + , cipherHash = hash_md5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | unencrypted cipher using RSA for key exchange and SHA1 for digest cipher_null_SHA1 :: Cipher cipher_null_SHA1 = Cipher - { cipherID = 0x2 - , cipherName = "RSA-null-SHA1" - , cipherBulk = bulk_null - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x2 + , cipherName = "RSA-null-SHA1" + , cipherBulk = bulk_null + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | RC4 cipher, RSA key exchange and MD5 for digest cipher_RC4_128_MD5 :: Cipher cipher_RC4_128_MD5 = Cipher - { cipherID = 0x04 - , cipherName = "RSA-rc4-128-md5" - , cipherBulk = bulk_rc4 - , cipherHash = hash_md5 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x04 + , cipherName = "RSA-rc4-128-md5" + , cipherBulk = bulk_rc4 + , cipherHash = hash_md5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | RC4 cipher, RSA key exchange and SHA1 for digest cipher_RC4_128_SHA1 :: Cipher cipher_RC4_128_SHA1 = Cipher - { cipherID = 0x05 - , cipherName = "RSA-rc4-128-sha1" - , cipherBulk = bulk_rc4 - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x05 + , cipherName = "RSA-rc4-128-sha1" + , cipherBulk = bulk_rc4 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest cipher_AES128_SHA1 :: Cipher cipher_AES128_SHA1 = Cipher - { cipherID = 0x2f - , cipherName = "RSA-aes128-sha1" - , cipherBulk = bulk_aes128 - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just SSL3 - } + { cipherID = 0x2f + , cipherName = "RSA-aes128-sha1" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } -- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest cipher_AES256_SHA1 :: Cipher cipher_AES256_SHA1 = Cipher - { cipherID = 0x35 - , cipherName = "RSA-aes256-sha1" - , cipherBulk = bulk_aes256 - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just SSL3 - } + { cipherID = 0x35 + , cipherName = "RSA-aes256-sha1" + , cipherBulk = bulk_aes256 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } -- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest cipher_AES128_SHA256 :: Cipher cipher_AES128_SHA256 = Cipher - { cipherID = 0x3c - , cipherName = "RSA-aes128-sha256" - , cipherBulk = bulk_aes128 - , cipherHash = hash_sha256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } + { cipherID = 0x3c + , cipherName = "RSA-aes128-sha256" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha256 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } -- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest cipher_AES256_SHA256 :: Cipher cipher_AES256_SHA256 = Cipher - { cipherID = 0x3d - , cipherName = "RSA-aes256-sha256" - , cipherBulk = bulk_aes256 - , cipherHash = hash_sha256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } + { cipherID = 0x3d + , cipherName = "RSA-aes256-sha256" + , cipherBulk = bulk_aes256 + , cipherHash = hash_sha256 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } {- TLS 1.0 ciphers definition 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 @@ -6,7 +6,7 @@ -- Portability : unknown -- module Network.TLS.Extra.Compression - ( - ) where + ( + ) where import Network.TLS.Compression 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 @@ -6,8 +6,8 @@ -- Portability : unknown -- module Network.TLS.Extra.Connection - ( connectionClient - ) where + ( connectionClient + ) where import Crypto.Random.API import Control.Applicative ((<$>)) @@ -35,12 +35,12 @@ -- on port 7777. connectionClient :: CPRG 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 + pn <- if and $ map isDigit $ p + then return $ fromIntegral $ (read p :: Int) + else servicePort <$> getServiceByName p "tcp" + he <- getHostByName s - h <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do - connect sock (SockAddrInet pn (head $ hostAddresses he)) - socketToHandle sock ReadWriteMode - contextNewOnHandle h params rng + h <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do + connect sock (SockAddrInet pn (head $ hostAddresses he)) + socketToHandle sock ReadWriteMode + contextNewOnHandle h params rng diff --git a/Network/TLS/Extra/Thread.hs b/Network/TLS/Extra/Thread.hs --- a/Network/TLS/Extra/Thread.hs +++ b/Network/TLS/Extra/Thread.hs @@ -1,3 +1,3 @@ module Network.TLS.Extra.Thread - ( - ) where + ( + ) where 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.6.0 +Version: 0.6.1 Description: a set of extra definitions, default values and helpers for tls. License: BSD3 @@ -32,7 +32,7 @@ , vector , cipher-rc4 , cipher-aes >= 0.1 && < 0.2 - , certificate >= 1.3.0 && < 1.4.0 + , certificate >= 1.3.5 && < 1.4.0 , crypto-pubkey , crypto-random-api , pem >= 0.1.0 && < 0.2.0