diff --git a/Network/XMPP.hs b/Network/XMPP.hs index bea6cac..1a78bba 100644 --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -50,7 +50,6 @@ module Network.XMPP ( -- Network.XMPP.JID , replyToChallenge1 -- Network.XMPP.Session - , Certificate , ClientHandler (..) , ClientState (..) , ConnectResult (..) diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index a2139c2..a162eaa 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -114,6 +114,8 @@ import qualified Data.List as DL import qualified Data.Text as DT import qualified Data.Text.Lazy as DTL +import Data.Certificate.X509 (X509) + -- ============================================================================= @@ -227,8 +229,13 @@ defaultState c t h s i = State { stateClientHandlers = h , stateIDGenerator = i } -- TODO: Prefix +-- | +-- Convenience function for calling "openStream" and "secureWithTLS" and\/or +-- "authenticate". See the documentation for the three separate functions for +-- details on how they operate. + connect :: MonadIO m => Session s m -> HostName -> PortNumber -> - Maybe (Certificate, (Certificate -> Bool)) -> + Maybe (Maybe ([X509], Bool), ([X509] -> Bool), Maybe [String]) -> Maybe (UserName, Password, Maybe Resource) -> (ConnectResult -> StateT s m ()) -> StateT s m () @@ -236,8 +243,8 @@ connect s h p t a c = openStream s h p connect' where connect' r = case r of OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support? - Just (certificate, certificateValidator) -> - secureWithTLS s certificate certificateValidator connect'' + Just (certificate, certificateValidator, paths) -> + secureWithTLS s certificate certificateValidator paths connect'' Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO OpenStreamFailure -> c ConnectOpenStreamFailure connect'' r = case r of @@ -260,14 +267,29 @@ openStream s h p c = CMS.get >>= (IEC (CEOpenStream h p c))) -secureWithTLS :: MonadIO m => Session s m -> Certificate -> - (Certificate -> Bool) -> +-- | +-- Tries to secure the connection with TLS. +-- +-- If the list of certificates is provided, they will be presented to the +-- server; the boolean value controls whether the client will show its +-- certificates before the server has authed. +-- +-- The third parameter is an optional custom validation function for the server +-- certificates. Note that Pontarius XMPP will perform its own validation +-- according to the RFC 6120, including comparing the domain name specified in +-- the certificate against the connected server, as well as checking the +-- integrity, the certificate authority, and CRL and\/or OCSP repositories of +-- the certificate chain. The fourth parameter is a list of directories that +-- contains trusted certificate authorities. + +secureWithTLS :: MonadIO m => Session s m -> Maybe ([X509], Bool) -> + ([X509] -> Bool) -> Maybe [String] -> (SecureWithTLSResult -> StateT s m ()) -> StateT s m () -secureWithTLS s c a c_ = CMS.get >>= +secureWithTLS s c a p c_ = CMS.get >>= (\ state -> lift $ liftIO $ writeChan (sessionChannel s) - (IEC (CESecureWithTLS c a c_))) + (IEC (CESecureWithTLS c a p c_))) -- | @@ -430,7 +452,7 @@ processEvent e = get >>= \ state -> put $ state { stateShouldExit = True } return $ Just e - IEC (CESecureWithTLS certificate verifyCertificate callback) -> do + IEC (CESecureWithTLS certificate verifyCertificate paths callback) -> do -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ()) let Connected _ handle = stateConnectionState state lift $ liftIO $ send "" (Left handle) diff --git a/Network/XMPP/TLS.hs b/Network/XMPP/TLS.hs index 4f57321..79b7e2c 100644 --- a/Network/XMPP/TLS.hs +++ b/Network/XMPP/TLS.hs @@ -25,11 +25,14 @@ with Pontarius XMPP. If not, see . module Network.XMPP.TLS (tlsParams) where import Network.TLS -import Network.TLS.Extra (cipher_AES128_SHA1) +import Network.TLS.Extra -- (cipher_AES128_SHA1) import Network.TLS.Cipher +import Crypto.Hash.SHA1 import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) +import Data.Time.Calendar tlsParams :: TLSParams + tlsParams = TLSParams { pConnectVersion = TLS10 -- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? , pAllowedVersions = [SSL3, TLS10,TLS11] -- TODO: TLS12 when supported in tls , pCiphers = [cipher_AES128_SHA1] -- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? @@ -38,4 +41,21 @@ tlsParams = TLSParams { pConnectVersion = TLS10 -- TODO: TLS12 when supported , pUseSecureRenegotiation = False -- TODO: No renegotiation! , pCertificates = [] -- TODO , pLogging = defaultLogging -- TODO - , onCertificatesRecv = \_ -> return CertificateUsageAccept } -- TODO + , onCertificatesRecv = \ certificate -> do + putStrLn "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" + putStrLn $ show certificate + putStrLn "0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! verify chain (will be false if self-signed - not the case)" + lolz <- certificateVerifyChain certificate + putStrLn $ show lolz + putStrLn "1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! self signed (only cas can be self-signed)" + putStrLn $ show $ certificateSelfSigned $ head certificate + putStrLn "2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! verify domain" + putStrLn $ show $ certificateVerifyDomain "jonkristensen.com" certificate + putStrLn "3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! verify validity" + putStrLn $ show $ certificateVerifyValidity (fromGregorian 2011 07 14) certificate + putStrLn "4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! fingerprint (didn't change when i changed last bytes - good!)" + putStrLn $ show $ certificateFingerprint hashlazy $ head certificate + putStrLn "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" + return CertificateUsageAccept } -- TODO + + diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index 3662cf6..092514e 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -58,7 +58,6 @@ ConnectionState (..), ClientEvent (..), StreamState (..), AuthenticationState (..), -Certificate, ConnectResult (..), OpenStreamResult (..), SecureWithTLSResult (..), @@ -88,6 +87,7 @@ import qualified Control.Monad.Error as CME import Data.IORef +import Data.Certificate.X509 (X509) -- ============================================================================= @@ -377,7 +377,7 @@ data AuthenticationState = NoAuthentication | AuthenticatingPreChallenge1 String data ClientEvent s m = CEOpenStream N.HostName PortNumber (OpenStreamResult -> StateT s m ()) | - CESecureWithTLS Certificate (Certificate -> Bool) + CESecureWithTLS (Maybe ([X509], Bool)) ([X509] -> Bool) (Maybe [String]) (SecureWithTLSResult -> StateT s m ()) | CEAuthenticate UserName Password (Maybe Resource) (AuthenticateResult -> StateT s m ()) | @@ -388,7 +388,7 @@ data ClientEvent s m = CEOpenStream N.HostName PortNumber instance Show (ClientEvent s m) where show (CEOpenStream h p _) = "CEOpenStream " ++ h ++ " " ++ (show p) - show (CESecureWithTLS c _ _) = "CESecureWithTLS " ++ c + show (CESecureWithTLS c _ _ _) = "CESecureWithTLS " ++ (show c) show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++ (show r) show (CEIQ s _ _ _) = "CEIQ" @@ -425,8 +425,6 @@ data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure -type Certificate = String -- TODO - -- Address is a data type that has to be constructed in this module using either -- address or stringToAddress. diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 1ea3c49..1ae60e7 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -31,7 +31,8 @@ Library base64-string, pureMD5, utf8-string, network, xml-types, text, transformers, bytestring, binary, random, xml-enumerator, tls, tls-extra, containers, mtl, text-icu, - stringprep, idna2008 ==0.0.1.0 + stringprep, idna2008 ==0.0.1.0, asn1-data, cryptohash, + time, certificate -- Other-Modules: -- HS-Source-Dirs: -- Extensions: