diff --git a/Examples/CheckCiphers.hs b/Examples/CheckCiphers.hs --- a/Examples/CheckCiphers.hs +++ b/Examples/CheckCiphers.hs @@ -71,13 +71,13 @@ , cipherIVSize = 0 , cipherKeyBlockSize = 0 , cipherPaddingSize = 0 - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherMACHash = (\_ -> undefined) , cipherF = undefined , cipherMinVer = Nothing } -clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] Nothing +clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] [] openConnection :: String -> String -> [Word16] -> IO (Maybe Word16) openConnection s p ciphers = do @@ -94,14 +94,12 @@ rng <- RNG.makeSystem let params = defaultParams { pCiphers = map fakeCipher ciphers } ctx <- client params rng handle - sendPacket ctx $ Handshake $ clienthello ciphers + sendPacket ctx $ Handshake [clienthello ciphers] catch (do rpkt <- recvPacket ctx ccid <- case rpkt of - Right (h:_) -> case h of - (Handshake (ServerHello _ _ _ i _ _)) -> return i - _ -> error "didn't received serverhello" - _ -> error ("packet received: " ++ show rpkt) + Right (Handshake ((ServerHello _ _ _ i _ _):_)) -> return i + _ -> error ("expecting server hello, packet received: " ++ show rpkt) bye ctx hClose handle return $ Just ccid diff --git a/Examples/RetrieveCertificate.hs b/Examples/RetrieveCertificate.hs --- a/Examples/RetrieveCertificate.hs +++ b/Examples/RetrieveCertificate.hs @@ -23,7 +23,7 @@ { pCiphers = ciphersuite_all , onCertificatesRecv = \l -> do modifyIORef ref (const $ Just l) - return True + return CertificateUsageAccept } ctx <- connectionClient s p params rng handshake ctx diff --git a/Examples/Stunnel.hs b/Examples/Stunnel.hs --- a/Examples/Stunnel.hs +++ b/Examples/Stunnel.hs @@ -10,7 +10,7 @@ import Control.Concurrent (forkIO) import Control.Exception (finally, try, throw) -import Control.Monad (when, forever) +import Control.Monad (when, forever, unless) import Data.Char (isDigit) @@ -45,7 +45,9 @@ tlsclient srchandle dsthandle = do hSetBuffering srchandle NoBuffering - handshake dsthandle + success <- handshake dsthandle + unless success $ do + error "client: handshake failed" _ <- forkIO $ forever $ do dat <- recvData dsthandle @@ -66,7 +68,9 @@ tlsserver srchandle dsthandle = do hSetBuffering dsthandle NoBuffering - handshake srchandle + success <- handshake srchandle + unless success $ do + error "server: handshake failed" loopUntil $ do d <- recvData srchandle @@ -76,14 +80,19 @@ return False putStrLn "end" -clientProcess certs handle dsthandle _ = do +clientProcess certs handle dsthandle dbg _ = do rng <- RNG.makeSystem + let logging = if not dbg then defaultLogging else defaultLogging + { loggingPacketSent = putStrLn . ("debug: send: " ++) + , loggingPacketRecv = putStrLn . ("debug: recv: " ++) + } let serverstate = defaultParams { pAllowedVersions = [SSL3,TLS10,TLS11] , pCiphers = ciphers , pCertificates = certs , pWantClientCert = False + , pLogging = logging } ctx <- server serverstate rng handle tlsserver ctx dsthandle @@ -132,6 +141,7 @@ , destination :: String , sourceType :: String , source :: String + , debug :: Bool , certificate :: FilePath , key :: FilePath } deriving (Show, Data, Typeable) @@ -151,6 +161,7 @@ , destination = "localhost:6060" &= help "destination address influenced by destination type" &= typ "ADDRESS" , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE" , source = "localhost:6061" &= help "source address influenced by source type" &= typ "ADDRESS" + , debug = False &= help "debug the TLS protocol printing debugging to stdout" &= typ "Bool" , certificate = "certificate.pem" &= help "X509 public certificate to use" &= typ "FILE" , key = "certificate.key" &= help "private key linked to the certificate" &= typ "FILE" } @@ -215,7 +226,7 @@ , loggingPacketRecv = putStrLn . ("debug: recv: " ++) } - let crecv = if validCert pargs then certificateVerifyChain else (\_ -> return True) + let crecv = if validCert pargs then certificateVerifyChain else (\_ -> return CertificateUsageAccept) let clientstate = defaultParams { pConnectVersion = TLS10 , pAllowedVersions = [ TLS10, TLS11 ] @@ -256,11 +267,14 @@ forever $ do (s, addr) <- accept srcsocket srch <- socketToHandle s ReadWriteMode - (StunnelSocket dst) <- connectAddressDescription dstaddr - dsth <- socketToHandle dst ReadWriteMode + r <- connectAddressDescription dstaddr + dsth <- case r of + StunnelFd _ _ -> return stdout + StunnelSocket dst -> socketToHandle dst ReadWriteMode + _ <- forkIO $ finally - (clientProcess [(cert, Just pk)] srch dsth addr >> return ()) - (hClose srch >> hClose dsth) + (clientProcess [(cert, Just pk)] srch dsth (debug pargs) addr >> return ()) + (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) return () AddrFD _ _ -> error "bad error fd. not implemented" @@ -269,4 +283,4 @@ x <- cmdArgsRun mode case x of Client _ _ _ _ _ _ -> doClient x - Server _ _ _ _ _ _ -> doServer x + Server _ _ _ _ _ _ _ -> doServer x diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010 Vincent Hanquez +Copyright (c) 2010-2011 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 @@ -7,8 +7,10 @@ -- Portability : unknown -- module Network.TLS.Extra.Certificate - ( certificateVerifyChain + ( certificateChecks + , certificateVerifyChain , certificateVerifyAgainst + , certificateSelfSigned , certificateVerifyDomain , certificateVerifyValidity , certificateFingerprint @@ -27,9 +29,19 @@ import qualified Crypto.Cipher.DSA as DSA import Data.Certificate.X509Cert (oidCommonName) +import Network.TLS (TLSCertificateUsage(..), TLSCertificateRejectReason(..)) import Data.Time.Calendar +import Data.List (find) +-- | combine many certificates checking function together. +-- if one check fail, the whole sequence of checking is cuted short and return the +-- reject reason. +certificateChecks :: [ [X509] -> IO TLSCertificateUsage ] -> [X509] -> IO TLSCertificateUsage +certificateChecks checks x509s = do + r <- sequence $ map (\c -> c x509s) checks + return $ maybe CertificateUsageAccept id $ find ((/=) CertificateUsageAccept) r + #if defined(NOCERTVERIFY) # warning "********certificate verify chain doesn't yet work on your platform *************" @@ -38,7 +50,7 @@ {- 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 Bool +certificateVerifyChain :: [X509] -> IO TLSCertificateUsage certificateVerifyChain _ = do putStrLn "****************** certificate verify chain doesn't yet work on your platform **********************" putStrLn "please consider contributing to the certificate package to fix this issue" @@ -59,24 +71,24 @@ -- -- TODO: verify validity, check revocation list if any, add optional user output to know -- the rejection reason. -certificateVerifyChain :: [X509] -> IO Bool -certificateVerifyChain l - | l == [] = return False - | otherwise = do - -- find a matching certificate that we trust (== installed on the system) - found <- SysCert.findCertificate (matchsysX509 $ head l) - case found of - Just sysx509 -> certificateVerifyAgainst (head l) sysx509 - Nothing -> do - validChain <- certificateVerifyAgainst (head l) (head $ tail l) +certificateVerifyChain :: [X509] -> IO TLSCertificateUsage +certificateVerifyChain [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates") +certificateVerifyChain (x:xs) = do + -- find a matching certificate that we trust (== installed on the system) + foundCert <- SysCert.findCertificate (certMatchDN x) + case foundCert 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 $ tail l - else return False - where - matchsysX509 (X509 cert _ _ _ _) (X509 syscert _ _ _ _) = do - let x = certSubjectDN syscert - let y = certIssuerDN cert - x == y + then certificateVerifyChain xs + else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") #endif -- | verify a certificate against another one. @@ -92,6 +104,14 @@ esig = B.pack sig pk = certPubKey scert +-- | returns if this certificate is self signed. +certificateSelfSigned :: X509 -> Bool +certificateSelfSigned x509 = certMatchDN x509 x509 + +certMatchDN :: X509 -> X509 -> Bool +certMatchDN (X509 testedCert _ _ _ _) (X509 issuerCert _ _ _ _) = + certSubjectDN issuerCert == certIssuerDN testedCert + verifyF :: SignatureALG -> PubKey -> B.ByteString -> B.ByteString -> Either String Bool -- md[245]WithRSAEncryption: @@ -125,28 +145,32 @@ RSA.PublicKey { RSA.public_sz = lenmodulus, RSA.public_n = modulus, RSA.public_e = e } -- | Verify that the given certificate chain is application to the given fully qualified host name. -certificateVerifyDomain :: String -> [X509] -> Bool -certificateVerifyDomain _ [] = False +certificateVerifyDomain :: String -> [X509] -> TLSCertificateUsage +certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list") certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) = case lookup oidCommonName $ certSubjectDN cert of - Nothing -> False + Nothing -> rejectMisc "no commonname OID in certificate cannot match to FQDN" Just (_, val) -> matchDomain (splitDot val) where matchDomain l - | length (filter (== "") l) > 0 = False + | length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain" | head l == "*" = wildcardMatch (reverse $ drop 1 l) - | otherwise = l == splitDot fqhn + | 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 = False + | 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 = False + | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = rejectMisc "commonname OID wildcard match too widely" | otherwise = - l == take (length l) (reverse $ splitDot fqhn) + if l == take (length l) (reverse $ splitDot fqhn) + then CertificateUsageAccept + else rejectMisc "FQDN and common name OID do not match" splitDot :: String -> [String] splitDot [] = [""] @@ -154,12 +178,18 @@ let (y, z) = break (== '.') x in y : (if z == "" then [] else splitDot $ drop 1 z) --- Maybe should verify whole chain -certificateVerifyValidity :: Day -> [X509] -> Bool -certificateVerifyValidity _ [] = False + 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] -> TLSCertificateUsage +certificateVerifyValidity _ [] = CertificateUsageReject $ CertificateRejectOther "empty list" certificateVerifyValidity ctime (X509 cert _ _ _ _ :_) = let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in - beforeDay < ctime && ctime <= afterDay + 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 certificateFingerprint hash x509 = hash $ getSigningData x509 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 @@ -103,7 +103,7 @@ , cipherKeyBlockSize = 0 , cipherPaddingSize = 0 , cipherMACHash = (const B.empty) - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherNoneF , cipherMinVer = Nothing } @@ -119,7 +119,7 @@ , cipherKeyBlockSize = 2 * (16 + 0 + 0) , cipherPaddingSize = 0 , cipherMACHash = MD5.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherNoneF , cipherMinVer = Nothing } @@ -135,7 +135,7 @@ , cipherKeyBlockSize = 2 * (20 + 0 + 0) , cipherPaddingSize = 0 , cipherMACHash = SHA1.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherNoneF , cipherMinVer = Nothing } @@ -151,7 +151,7 @@ , cipherKeyBlockSize = 2 * (16 + 16 + 0) , cipherPaddingSize = 0 , cipherMACHash = MD5.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4 , cipherMinVer = Nothing } @@ -167,7 +167,7 @@ , cipherKeyBlockSize = 2 * (20 + 16 + 0) , cipherPaddingSize = 0 , cipherMACHash = SHA1.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4 , cipherMinVer = Nothing } @@ -183,7 +183,7 @@ , cipherKeyBlockSize = 2 * (20 + 16 + 16) , cipherPaddingSize = 16 , cipherMACHash = SHA1.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt , cipherMinVer = Just SSL3 } @@ -199,7 +199,7 @@ , cipherKeyBlockSize = 2 * (20 + 32 + 16) , cipherPaddingSize = 16 , cipherMACHash = SHA1.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt , cipherMinVer = Just SSL3 } @@ -215,7 +215,7 @@ , cipherKeyBlockSize = 2 * (32 + 16 + 16) , cipherPaddingSize = 16 , cipherMACHash = SHA256.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt , cipherMinVer = Just TLS12 } @@ -231,7 +231,7 @@ , cipherKeyBlockSize = 2 * (32 + 32 + 16) , cipherPaddingSize = 16 , cipherMACHash = SHA256.hash - , cipherKeyExchange = CipherKeyExchangeRSA + , cipherKeyExchange = CipherKeyExchange_RSA , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt , cipherMinVer = Just TLS12 } 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.2.3 +Version: 0.3.0 Description: a set of extra definitions, default values and helpers for tls. License: BSD3 @@ -28,7 +28,7 @@ Library Build-Depends: base > 3 && < 5 - , tls >= 0.6.4 && < 0.7 + , tls >= 0.7 && < 0.8 , mtl , network >= 2.3 , cryptohash >= 0.6