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: