diff --git a/examples/TestPusher.hs b/examples/TestPusher.hs --- a/examples/TestPusher.hs +++ b/examples/TestPusher.hs @@ -1,16 +1,25 @@ {-# LANGUAGE TupleSections, TypeFamilies, FlexibleContexts #-} -module TestPusher (XmlPusher(..), Zero(..), One(..), Two(..), testPusher) where +module TestPusher ( + XmlPusher(..), Zero(..), One(..), Two(..), + testPusher, checkFingerprint) where import Control.Applicative import Control.Monad import Control.Concurrent import Data.Maybe +import Data.List +import Data.Char import Data.Pipe import Data.Pipe.ByteString +import Data.X509 +import Data.X509.Validation import System.IO import Text.XML.Pipe +import Numeric +import qualified Data.ByteString as BS + import Network.XmlPush testPusher :: XmlPusher xp => @@ -25,3 +34,13 @@ =$= convert fromJust =$= xmlNode [] =$= writeTo xp + +checkFingerprint :: [String] -> SignedCertificate -> Bool +checkFingerprint fps c = cutFingerprint (getFingerprint c HashSHA256) `elem` fps + +cutFingerprint :: Fingerprint -> String +cutFingerprint (Fingerprint bs) = lastN 29 . + intercalate ":" . map (map toUpper . flip showHex "") $ BS.unpack bs + +lastN :: Int -> [a] -> [a] +lastN n xs = drop (length xs - n) xs diff --git a/examples/httpPullTlsCl.hs b/examples/httpPullTlsCl.hs --- a/examples/httpPullTlsCl.hs +++ b/examples/httpPullTlsCl.hs @@ -17,7 +17,7 @@ testPusher (undefined :: HttpPullTlsCl Handle) (One h) (HttpPullTlsClArgs (HttpPullClArgs "localhost" 443 "/" gtPth mkPoll pendingQ (Just 10000000) drtn) - (TlsArgs "localhost" (const Nothing) + (TlsArgs "localhost" True (const Nothing) ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) ) mkPoll :: IO XmlNode diff --git a/examples/httpPushTlsE.hs b/examples/httpPushTlsE.hs --- a/examples/httpPushTlsE.hs +++ b/examples/httpPushTlsE.hs @@ -19,7 +19,7 @@ testPusher (undefined :: HttpPushTls Handle) (Two (Just ch) Nothing) (HttpPushTlsArgs (HttpPushArgs (const Nothing) getServerHandle (Just ("localhost", 80, "")) gtPth wntRspns) - (tlsArgsCl "localhost" (const Nothing) + (tlsArgsCl "localhost" True (const Nothing) ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k', c')]) (tlsArgsSv gtNm (const Nothing) diff --git a/examples/httpPushTlsT.hs b/examples/httpPushTlsT.hs --- a/examples/httpPushTlsT.hs +++ b/examples/httpPushTlsT.hs @@ -1,18 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Monad -import Data.List -import Data.Char import Data.X509 -import Data.X509.Validation import System.IO import Text.XML.Pipe import Network import Network.XmlPush.HttpPush.Tls import Network.PeyoTLS.ReadFile -import Numeric -import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import TestPusher @@ -29,7 +24,7 @@ (HttpPushTlsArgs (HttpPushArgs getClientHandle Nothing Nothing gtPth wntRspns) - (tlsArgsCl "Yoshikuni" checkCertXml + (tlsArgsCl "Yoshikuni" True checkCertXml ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k', c')]) (tlsArgsSv gtNm (const Nothing) @@ -40,15 +35,7 @@ checkCertXml = const $ Just checkCert checkCert :: SignedCertificate -> Bool -checkCert c = cutFingerprint (getFingerprint c HashSHA256) `elem` [ - "81:9A:16:4A:57:AE:82:92:78:E0" ] - -cutFingerprint :: Fingerprint -> String -cutFingerprint (Fingerprint bs) = lastN 29 . - intercalate ":" . map (map toUpper . flip showHex "") $ BS.unpack bs - -lastN :: Int -> [a] -> [a] -lastN n xs = drop (length xs - n) xs +checkCert = checkFingerprint ["81:9A:16:4A:57:AE:82:92:78:E0"] getClientHandle :: XmlNode -> Maybe (IO Handle, String, Int, FilePath) getClientHandle (XmlNode (_, "client") [] [] [XmlCharData hn]) = Just ( diff --git a/examples/xmppTls.hs b/examples/xmppTls.hs --- a/examples/xmppTls.hs +++ b/examples/xmppTls.hs @@ -23,7 +23,7 @@ testPusher (undefined :: XmppTls Handle) (One h) (XmppTlsArgs (XmppArgs ["EXTERNAL", "SCRAM-SHA-1", "DIGEST-MD5", "PLAIN"] (toJid me) ps (toJid you) iNdRspns wntRspns) - (TlsArgs "localhost" (const Nothing) + (TlsArgs "localhost" True (const Nothing) ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) ) wntRspns :: XmlNode -> Bool diff --git a/src/Network/XmlPush/HttpPull/Tls/Client.hs b/src/Network/XmlPush/HttpPull/Tls/Client.hs --- a/src/Network/XmlPush/HttpPull/Tls/Client.hs +++ b/src/Network/XmlPush/HttpPull/Tls/Client.hs @@ -77,7 +77,7 @@ makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => One h -> HttpPullTlsClArgs h -> HandleMonad h (HttpPullTlsCl h) makeHttpPull (One h) (HttpPullTlsClArgs - (HttpPullClArgs hn pn fp gp pl ip d gd) (TlsArgs dn _ cs ca kcs)) = do + (HttpPullClArgs hn pn fp gp pl ip d gd) (TlsArgs dn _ _ cs ca kcs)) = do dr <- liftBase . atomically $ newTVar d (inc, otc) <- do (g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool diff --git a/src/Network/XmlPush/HttpPush/Tls.hs b/src/Network/XmlPush/HttpPush/Tls.hs --- a/src/Network/XmlPush/HttpPush/Tls.hs +++ b/src/Network/XmlPush/HttpPush/Tls.hs @@ -40,7 +40,7 @@ type TlsArgsCl = TC.TlsArgs -tlsArgsCl :: String -> +tlsArgsCl :: String -> Bool -> (XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Cl.CipherSuite] -> CertificateStore -> [(CertSecretKey, CertificateChain)] -> TlsArgsCl @@ -79,7 +79,7 @@ Maybe h -> Maybe h -> HttpPushTlsArgs h -> HandleMonad h (HttpPushTls h) makeHttpPushTls mch msh (HttpPushTlsArgs (HttpPushArgs gc gs hi gp wr) - (TC.TlsArgs dn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do + (TC.TlsArgs dn cdn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do vch <- liftBase . atomically $ newTVar mch vsh <- liftBase . atomically $ newTVar msh case hi of @@ -88,18 +88,18 @@ _ -> return () v <- liftBase . atomically $ newTVar False vhi <- liftBase . atomically $ newTVar hi - (ci, co) <- clientC vch vhi cc' gp cs ca kcs + (ci, co) <- clientC vch vhi cdn cc' gp cs ca kcs (si, so) <- talk wr vsh gn cc cs' mca' kcs' vch vhi gc gs return $ HttpPushTls v ci co si so clientC :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => - TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) -> + TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) -> Bool -> (XmlNode -> Maybe (SignedCertificate -> Bool)) -> (XmlNode -> FilePath) -> [Cl.CipherSuite] -> CertificateStore -> [(CertSecretKey, CertificateChain)] -> HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode)) -clientC vh vhi cc gp cs ca kcs = do +clientC vh vhi cdn cc gp cs ca kcs = do inc <- liftBase $ atomically newTChan otc <- liftBase $ atomically newTChan (g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool @@ -115,7 +115,7 @@ Just hi -> return hi _ -> retry (`Cl.run` g) $ do - t <- Cl.open h cs kcs ca + t <- (if cdn then Cl.open' h hn else Cl.open h) cs kcs ca runPipe_ $ fromTChan otc =$= filter isJust =$= convert fromJust diff --git a/src/Network/XmlPush/Tls/Client.hs b/src/Network/XmlPush/Tls/Client.hs --- a/src/Network/XmlPush/Tls/Client.hs +++ b/src/Network/XmlPush/Tls/Client.hs @@ -9,6 +9,7 @@ data TlsArgs = TlsArgs { serverName :: String, + checkServerName :: Bool, checkCertificate :: XmlNode -> Maybe (SignedCertificate -> Bool), cipherSuites :: [CipherSuite], certificateAuthorities :: CertificateStore, diff --git a/src/Network/XmlPush/Xmpp/Tls.hs b/src/Network/XmlPush/Xmpp/Tls.hs --- a/src/Network/XmlPush/Xmpp/Tls.hs +++ b/src/Network/XmlPush/Xmpp/Tls.hs @@ -56,7 +56,7 @@ MonadError (HandleMonad h), Error (ErrorType (HandleMonad h)) ) => One h -> XmppTlsArgs h -> HandleMonad h (XmppTls h) makeXmppTls (One h) - (XmppTlsArgs (XmppArgs ms me ps you inr wr) (TlsArgs dn _ cs ca kcs)) = do + (XmppTlsArgs (XmppArgs ms me ps you inr wr) (TlsArgs dn _ _ cs ca kcs)) = do nr <- liftBase $ atomically newTChan wc <- liftBase $ atomically newTChan (g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool diff --git a/xml-push.cabal b/xml-push.cabal --- a/xml-push.cabal +++ b/xml-push.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: xml-push -version: 0.0.0.9 +version: 0.0.0.10 stability: Experimenmtal author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -100,7 +100,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/xml-push.git - tag: xml-push-0.0.0.9 + tag: xml-push-0.0.0.10 library hs-source-dirs: src