From b40a307e7733ed38be42c2b1b25c5f49de12cf19 Mon Sep 17 00:00:00 2001
From: Jeremie Dimino <jeremie@dimino.org>
Date: Fri, 23 Nov 2012 20:41:44 +0100
Subject: [PATCH] Lwt_ssl.*_channel_of_decr now close the socket when the
 channel is closed

Ignore-this: a830f5819ec08fb996cc271d03267fce

darcs-hash:20121123194144-c41ad-21f7ce5d97a32f642dec2cc0f421ab6ead727bab
---
 src/ssl/lwt_ssl.ml | 25 +++++++++++++++++++------
 1 file changed, 19 insertions(+), 6 deletions(-)

diff --git a/src/ssl/lwt_ssl.ml b/src/ssl/lwt_ssl.ml
index 7767089b92..a022bd4db7 100644
--- a/src/ssl/lwt_ssl.ml
+++ b/src/ssl/lwt_ssl.ml
@@ -21,6 +21,8 @@
  * 02111-1307, USA.
  *)
 
+let (>>=) = Lwt.bind
+
 type t =
     Plain
   | SSL of Ssl.socket
@@ -150,12 +152,6 @@ let wait_write (fd, s) =
     Plain -> Lwt_unix.wait_write fd
   | SSL _ -> Lwt_unix.yield ()
 
-let out_channel_of_descr s =
-  Lwt_io.make ~mode:Lwt_io.output (fun buf pos len -> write_bytes s buf pos len)
-
-let in_channel_of_descr s =
-  Lwt_io.make ~mode:Lwt_io.input (fun buf pos len -> read_bytes s buf pos len)
-
 let ssl_shutdown (fd, s) =
   match s with
     Plain -> Lwt.return ()
@@ -167,6 +163,23 @@ let close (fd, _) = Lwt_unix.close fd
 
 let abort (fd, _) = Lwt_unix.abort fd
 
+let shutdown_and_close s =
+  ssl_shutdown s >>= fun () ->
+  Lwt.wrap2 shutdown s Unix.SHUTDOWN_ALL >>= fun () ->
+  close s
+
+let out_channel_of_descr s =
+  Lwt_io.make
+    ~mode:Lwt_io.output
+    ~close:(fun () -> shutdown_and_close s)
+    (fun buf pos len -> write_bytes s buf pos len)
+
+let in_channel_of_descr s =
+  Lwt_io.make
+    ~mode:Lwt_io.input
+    ~close:(fun () -> shutdown_and_close s)
+    (fun buf pos len -> read_bytes s buf pos len)
+
 let get_fd (fd,socket) =
   match socket with
     | Plain -> Lwt_unix.unix_file_descr fd