diff --git a/examples/clcertClient.hs b/examples/clcertClient.hs --- a/examples/clcertClient.hs +++ b/examples/clcertClient.hs @@ -21,10 +21,7 @@ h <- connectTo "localhost" $ PortNumber 443 g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do - p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca - nms <- getNames p - unless ("localhost" `elem` nms) $ - error "certificate name mismatch" + p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n" doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn diff --git a/examples/clcertEcdsaClient.hs b/examples/clcertEcdsaClient.hs --- a/examples/clcertEcdsaClient.hs +++ b/examples/clcertEcdsaClient.hs @@ -23,10 +23,8 @@ h <- connectTo "localhost" $ PortNumber 443 g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do - p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca - nms <- getNames p - unless ("localhost" `elem` nms) $ - error "certificate name mismatch" + p <- open' h "localhost" + ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n" doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn diff --git a/examples/eccClient.hs b/examples/eccClient.hs --- a/examples/eccClient.hs +++ b/examples/eccClient.hs @@ -30,10 +30,7 @@ h <- connectTo "localhost" $ PortNumber 443 g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do - p <- open h cipherSuites [] ca - nms <- getNames p - unless ("localhost" `elem` nms p) $ - error "certificate name mismatch" + p <- open' h "localhost" cipherSuites [] ca hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n" doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn diff --git a/examples/simpleClient.hs b/examples/simpleClient.hs --- a/examples/simpleClient.hs +++ b/examples/simpleClient.hs @@ -19,10 +19,7 @@ h <- connectTo "localhost" $ PortNumber 443 g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do - p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca - nms <- getNames p - unless ("localhost" `elem` nms) $ - error "certificate name mismatch" + p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n" doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn diff --git a/peyotls.cabal b/peyotls.cabal --- a/peyotls.cabal +++ b/peyotls.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: peyotls -version: 0.1.1.0 +version: 0.1.2.0 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -147,10 +147,8 @@ > h <- connectTo "localhost" $ PortNumber 443 > g <- cprgCreate <$> createEntropyPool :: IO SystemRNG > (`run` g) $ do - > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca + > p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca > nms <- getNames p - > unless ("localhost" `elem` nms) $ - > error "certificate name mismatch" > hlPut p "GET / HTTP/1.1 \r\n" > hlPut p "Host: localhost\r\n\r\n" > doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn @@ -181,9 +179,9 @@ > > rk <- readKey "client_rsa.key" > > rc <- readCertificateChain ["client_rsa.crt"] > 20c22 - > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca + > < p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca > --- - > > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca + > > p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca . Client certificate client (ECDSA or RSA certificate) . @@ -194,9 +192,9 @@ > > ek <- readKey "client_ecdsa.key" > > ec <- readCertificateChain ["client_ecdsa.crt"] > 22c24 - > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca + > < p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca > --- - > > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca + > > p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca . ECC server (use ECC or RSA depending on client) . @@ -246,9 +244,9 @@ > > "TLS_RSA_WITH_AES_128_CBC_SHA" ] > > > 20c31 - > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca + > < p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca > --- - > > p <- open h cipherSuites [] ca + > > p <- open' h "localhost" cipherSuites [] ca . extra-source-files: @@ -283,7 +281,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git - tag: peyotls-0.1.1.0 + tag: peyotls-0.1.2.0 library hs-source-dirs: src diff --git a/src/Network/PeyoTLS/Client.hs b/src/Network/PeyoTLS/Client.hs --- a/src/Network/PeyoTLS/Client.hs +++ b/src/Network/PeyoTLS/Client.hs @@ -12,7 +12,8 @@ module Network.PeyoTLS.Client ( -- * Basic - PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, getNames, + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, + run, open, open', getNames, checkName, -- * Renegotiation renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, -- * Cipher Suite @@ -25,6 +26,7 @@ import "monads-tf" Control.Monad.Error.Class (strMsg) import Data.Maybe (fromMaybe) import Data.List (find, intersect) +import Data.Function (on) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) @@ -84,12 +86,47 @@ getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] getNames = BASE.getNames . tlsHandleC +checkName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool +checkName t n = flip toCheckName n `liftM` getNames t + +toCheckName :: [String] -> String -> Bool +toCheckName s0s s = any (`toCheckName1` s) s0s + +toCheckName1 :: String -> String -> Bool +toCheckName1 = on checkSepNames $ sepBy '.' + +sepBy :: Eq a => a ->[a] -> [[a]] +sepBy x0 xs + | (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d + | otherwise = [xs] + +checkSepNames :: [String] -> [String] -> Bool +checkSepNames [] [] = True +checkSepNames _ [] = False +checkSepNames [] _ = False +checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns +checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns + +-- | Don't forget check server name by checkName. + open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> TlsM h g (TlsHandle h g) open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do setSettingsC (cscl, crts, ca) handshake crts ca =<< clientHello cscl + +-- | This function open and check server name. +-- Use this so as not to forget to check server name. + +open' :: (ValidateHandle h, CPRG g) => h -> String -> [CipherSuite] -> + [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> + TlsM h g (TlsHandle h g) +open' h n cscl crts ca = do + t <- open h cscl crts ca + c <- checkName t n + unless c . E.throwError $ strMsg "certificate name mismatch" + return t renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleC t) = rerunHandshakeM t $ do