From 31e363efd7f3798e9ed0891eeb70dcb6690b2e20 Mon Sep 17 00:00:00 2001
From: John Millikin <jmillikin@gmail.com>
Date: Sun, 25 Apr 2010 22:54:51 +0000
Subject: [PATCH] Migrate 'Handle' to a more modern TLS binding.

---
 Network/Protocol/XMPP/Handle.hs | 55 ++++++++++++++++-----------------
 network-protocol-xmpp.cabal     |  2 +-
 2 files changed, 27 insertions(+), 30 deletions(-)

diff --git a/Network/Protocol/XMPP/Handle.hs b/Network/Protocol/XMPP/Handle.hs
index 9a1c829..68d214b 100644
--- a/Network/Protocol/XMPP/Handle.hs
+++ b/Network/Protocol/XMPP/Handle.hs
@@ -24,49 +24,46 @@ module Network.Protocol.XMPP.Handle
 import Control.Monad (when)
 import qualified Control.Monad.Error as E
 import Control.Monad.Trans (liftIO)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Unsafe as B
+import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import qualified System.IO as IO
-import qualified Network.GnuTLS as GnuTLS
-import Network.GnuTLS (AttrOp (..))
-import Foreign (allocaBytes, plusPtr)
-import Foreign.C (peekCAStringLen)
+import qualified Network.Protocol.TLS.GNU as TLS
 import Network.Protocol.XMPP.ErrorT
 
 data Handle =
 	  PlainHandle IO.Handle
-	| SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client)
+	| SecureHandle IO.Handle TLS.Session
+
+liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT T.Text IO a
+liftTLS s = liftTLS' . TLS.runTLS s
+
+liftTLS' :: IO (Either TLS.Error a) -> ErrorT T.Text IO a
+liftTLS' io = do
+	eitherX <- liftIO io
+	case eitherX of
+		Left err -> E.throwError $ T.pack $ show err
+		Right x -> return x
 
 startTLS :: Handle -> ErrorT T.Text IO Handle
 startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle"
-startTLS (PlainHandle h) = liftIO $ do
-	session <- GnuTLS.tlsClient
-		[ GnuTLS.handle := h
-		, GnuTLS.priorities := [GnuTLS.CrtX509]
-		, GnuTLS.credentials := GnuTLS.certificateCredentials
-		]
-	GnuTLS.handshake session
-	return $ SecureHandle h session
+startTLS (PlainHandle h) = liftTLS' $ TLS.runClient $ do
+	TLS.setTransport $ TLS.transportHandle h
+	TLS.setPriority [TLS.X509]
+	TLS.setCredentials TLS.certificateCredentials
+	TLS.handshake
+	SecureHandle h `fmap` TLS.getSession
 
 hPutBytes :: Handle -> B.ByteString -> ErrorT T.Text IO ()
-hPutBytes (PlainHandle h)           bytes = liftIO $ B.hPut h bytes
-hPutBytes (SecureHandle _ session) bytes = liftIO useLoop where
-	useLoop = B.unsafeUseAsCStringLen bytes $ uncurry loop
-	loop ptr len = do
-		r <- GnuTLS.tlsSend session ptr len
-		case len - r of
-			x | x > 0     -> loop (plusPtr ptr r) x
-			  | otherwise -> return ()
+hPutBytes (PlainHandle h)  = liftIO . B.hPut h
+hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes
 
 hGetChar :: Handle -> ErrorT T.Text IO Char
 hGetChar (PlainHandle h) = liftIO $ IO.hGetChar h
-hGetChar (SecureHandle h session) = liftIO $ allocaBytes 1 $ \ptr -> do
-	pending <- GnuTLS.tlsCheckPending session
+hGetChar (SecureHandle h s) = liftTLS s $ do
+	pending <- TLS.checkPending
 	when (pending == 0) $ do
-		IO.hWaitForInput h (-1)
+		liftIO $ IO.hWaitForInput h (- 1)
 		return ()
 	
-	len <- GnuTLS.tlsRecv session ptr 1
-	[char] <- peekCAStringLen (ptr, len)
-	return char
+	bytes <- TLS.getBytes 1
+	return . head . B.unpack $ bytes
diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal
index f5581a8..bf51286 100644
--- a/network-protocol-xmpp.cabal
+++ b/network-protocol-xmpp.cabal
@@ -25,7 +25,7 @@ library
     , stringprep >= 0.1.2 && < 0.2
     , ranges >= 0.2.2 && < 0.3
     , hxt >= 8.5 && < 8.6
-    , hsgnutls >= 0.2 && < 0.3
+    , gnutls >= 0.1 && < 0.3
     , bytestring >= 0.9 && < 0.10
     , libxml-sax >= 0.3 && < 0.4
     , gsasl >= 0.3 && < 0.4
-- 
2.45.2