updated TLS API, debug information on received certificates, added dependencies

Network/XMPP.hs

@@ -50,7 +50,6 @@ module Network.XMPP ( -- Network.XMPP.JID
                     , replyToChallenge1
 
                       -- Network.XMPP.Session
-                    , Certificate
                     , ClientHandler (..)
                     , ClientState (..)
                     , ConnectResult (..)

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) ->
+        Just (certificate, certificateValidator, paths) ->
-          secureWithTLS s certificate certificateValidator connect''
+          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 "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>" (Left handle)

Network/XMPP/TLS.hs

@@ -25,11 +25,14 @@ with Pontarius XMPP. If not, see <http://www.gnu.org/licenses/>.
 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
+
+

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.
 

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: