Thrift: OCaml and HS servers more general

Summary: The library now provides servers that are general like the other languages.
Reviewed by: mcslee
Test plan: Yes
Revert plan: yes


git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@665195 13f79535-47bb-0310-9956-ffa450edef68

5 files changed, 61 insertions, 24 deletions

diff --git a/lib/ocaml/src/Makefile b/lib/ocaml/src/Makefile
index 0b989ce28..723402b11 100644
--- a/lib/ocaml/src/Makefile
+++ b/lib/ocaml/src/Makefile
@@ -1,6 +1,7 @@
-SOURCES = Thrift.ml TBinaryProtocol.ml TSocket.ml TChannelTransport.ml TServer.ml TSimpleServer.ml
+SOURCES = Thrift.ml TBinaryProtocol.ml TSocket.ml TChannelTransport.ml TServer.ml TSimpleServer.ml TServerSocket.ml TThreadedServer.ml
 RESULT = thrift
-LIBS = unix
+LIBS = unix threads
+THREADS = yes
 all: native-code-library byte-code-library top
 OCAMLMAKEFILE = ../OCamlMakefile
 include $(OCAMLMAKEFILE)
diff --git a/lib/ocaml/src/TServer.ml b/lib/ocaml/src/TServer.ml
index d8509ff4a..a4dcc4428 100644
--- a/lib/ocaml/src/TServer.ml
+++ b/lib/ocaml/src/TServer.ml
@@ -1,23 +1,17 @@
 open Thrift
 
 class virtual t
-    (pf : Processor.factory) 
+    (pf : Processor.t) 
     (st : Transport.server_t)
-    (itf : Transport.factory)
-    (otf : Transport.factory)
+    (tf : Transport.factory)
     (ipf : Protocol.factory)
     (opf : Protocol.factory)=
 object
-  val processorFactory = pf
-  val serverTransport = st
-  val inputTransportFactory = itf
-  val outputTransportFactory = otf
-  val inputProtocolFactory = ipf
-  val outputProtocolFactory = opf
   method virtual serve : unit
 end;;
 
 
+
 let run_basic_server proc port =
   Unix.establish_server (fun inp -> fun out ->
                            let trans = new TChannelTransport.t (inp,out) in
diff --git a/lib/ocaml/src/TServerSocket.ml b/lib/ocaml/src/TServerSocket.ml
new file mode 100644
index 000000000..ac98b087b
--- /dev/null
+++ b/lib/ocaml/src/TServerSocket.ml
@@ -0,0 +1,21 @@
+open Thrift
+
+class t port =
+object
+  inherit Transport.server_t
+  val mutable sock = None
+  method listen =
+    let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      sock <- Some s;
+      Unix.bind s (Unix.ADDR_INET (Unix.inet_addr_any, port));
+      Unix.listen s 256
+  method close =
+    match sock with
+        Some s -> Unix.shutdown s Unix.SHUTDOWN_ALL; Unix.close s; sock <- None
+      | _ -> ()
+  method acceptImpl =
+    match sock with
+        Some s -> let (fd,_) = Unix.accept s in
+                    new TChannelTransport.t (Unix.in_channel_of_descr fd,Unix.out_channel_of_descr fd)
+      | _ -> Transport.raise_TTransportExn "ServerSocket: Not listening but tried to accept" Transport.NOT_OPEN
+end
diff --git a/lib/ocaml/src/TSimpleServer.ml b/lib/ocaml/src/TSimpleServer.ml
index 1a85809b0..db3ac3bcb 100644
--- a/lib/ocaml/src/TSimpleServer.ml
+++ b/lib/ocaml/src/TSimpleServer.ml
@@ -1,24 +1,19 @@
 open Thrift
 module S = TServer
 
-class t pf st itf otf ipf opf =
+class t pf st tf ipf opf =
 object
-  inherit S.t pf st itf otf ipf opf
+  inherit S.t pf st tf ipf opf
   method serve =
     try
       st#listen;
       let c = st#accept in
-      let proc = pf#getProcessor c in
-      let itrans = itf#getTransport c in
-      let otrans = try
-          otf#getTransport c
-        with e -> itrans#close; raise e
-      in
-      let inp = ipf#getProtocol itrans in
-      let op = opf#getProtocol otrans in
+      let trans = tf#getTransport c in
+      let inp = ipf#getProtocol trans in
+      let op = opf#getProtocol trans in
         try
-          while (proc#process inp op) do () done;
-          itrans#close; otrans#close
-        with e -> itrans#close; otrans#close; raise e
+          while (pf#process inp op) do () done;
+          trans#close
+        with e -> trans#close; raise e
     with _ -> ()
 end
diff --git a/lib/ocaml/src/TThreadedServer.ml b/lib/ocaml/src/TThreadedServer.ml
new file mode 100644
index 000000000..10f161411
--- /dev/null
+++ b/lib/ocaml/src/TThreadedServer.ml
@@ -0,0 +1,26 @@
+open Thrift
+
+class t 
+  (pf : Processor.t) 
+  (st : Transport.server_t)
+  (tf : Transport.factory)
+  (ipf : Protocol.factory)
+  (opf : Protocol.factory)=
+object
+  inherit TServer.t pf st tf ipf opf
+  method serve =
+    st#listen;
+    while true do
+      let tr = tf#getTransport (st#accept) in
+        ignore (Thread.create 
+          (fun _ ->          
+             let ip = ipf#getProtocol tr in
+             let op = opf#getProtocol tr in
+               try
+                 while pf#process ip op do
+                   ()
+                 done
+               with _ -> ()) ())
+    done
+end
+