tls-extra 0.2.3 → 0.3.0
raw patch · 7 files changed
+103/−61 lines, 7 filesdep ~tls
Dependency ranges changed: tls
Files
- Examples/CheckCiphers.hs +5/−7
- Examples/RetrieveCertificate.hs +1/−1
- Examples/Stunnel.hs +24/−10
- LICENSE +1/−1
- Network/TLS/Extra/Certificate.hs +61/−31
- Network/TLS/Extra/Cipher.hs +9/−9
- tls-extra.cabal +2/−2
Examples/CheckCiphers.hs view
@@ -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
Examples/RetrieveCertificate.hs view
@@ -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
Examples/Stunnel.hs view
@@ -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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org> All rights reserved.
Network/TLS/Extra/Certificate.hs view
@@ -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 -- <star>.com or <star> is always invalid- | length l < 2 = False+ | length l < 2 = rejectMisc "commonname OID wildcard match too widely" -- <star>.com.<country> 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
Network/TLS/Extra/Cipher.hs view
@@ -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 }
tls-extra.cabal view
@@ -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