From cb850131da75e1c1ee9379bd0b77c8c1af873396 Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Mon, 20 Sep 2010 08:45:41 +0100
Subject: [PATCH] add a server callbacks when receiving Certificates

---
 Network/TLS/Server.hs | 9 +++++++++
 Stunnel.hs            | 2 ++
 2 files changed, 11 insertions(+)

diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs
index 8926b2b..253422b 100644
--- a/Network/TLS/Server.hs
+++ b/Network/TLS/Server.hs
@@ -12,6 +12,7 @@
 
 module Network.TLS.Server
 	( TLSServerParams(..)
+	, TLSServerCallbacks(..)
 	, TLSStateServer
 	, runTLSServer
 	-- * low level packet sending receiving.
@@ -44,12 +45,20 @@ import System.IO (Handle, hFlush)
 
 type TLSServerCert = (L.ByteString, Certificate, CertificateKey.PrivateKey)
 
+data TLSServerCallbacks = TLSServerCallbacks
+	{ cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates
+	}
+
+instance Show TLSServerCallbacks where
+	show _ = "[callbacks]"
+
 data TLSServerParams = TLSServerParams
 	{ spAllowedVersions :: [Version]           -- ^ allowed versions that we can use
 	, spSessions        :: [[Word8]]           -- ^ placeholder for futur known sessions
 	, spCiphers         :: [Cipher]            -- ^ all ciphers that the server side support
 	, spCertificate     :: Maybe TLSServerCert -- ^ the certificate we serve to the client
 	, spWantClientCert  :: Bool                -- ^ configure if we do a cert request to the client
+	, spCallbacks       :: TLSServerCallbacks  -- ^ user callbacks
 	}
 
 data TLSStateServer = TLSStateServer
diff --git a/Stunnel.hs b/Stunnel.hs
index 844855d..cabddf9 100644
--- a/Stunnel.hs
+++ b/Stunnel.hs
@@ -99,6 +99,8 @@ clientProcess ((certdata, cert), pk) (handle, src) = do
 		, S.spCiphers = ciphers
 		, S.spCertificate = Just (certdata, cert, pk)
 		, S.spWantClientCert = False
+		, S.spCallbacks = S.TLSServerCallbacks
+			{ S.cbCertificates = Nothing }
 		}
 
 	S.runTLSServer (tlsserver handle serverRandom) serverstate (makeSRandomGen seqInit)