THRIFT-3347 Improve cross test servers and clients
Client: TestSuite, C++, Perl, NodeJS, c_glib, Haskell, Python
Patch: Nobuaki Sukegawa <nsukeg@gmail.com>
This closes #621
diff --git a/test/hs/TestServer.hs b/test/hs/TestServer.hs
index fb80cf8..a880a5e 100755
--- a/test/hs/TestServer.hs
+++ b/test/hs/TestServer.hs
@@ -32,6 +32,7 @@
import System.Exit
import System.IO
import System.Posix.Unistd
+import qualified System.IO as IO
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.Text.Lazy as Text
@@ -72,6 +73,20 @@
fromString "nonblocking" = NonBlocking
fromString _ = error "not a valid server type"
+data TransportType = Buffered (Socket -> (IO IO.Handle))
+ | Framed (Socket -> (IO (FramedTransport IO.Handle)))
+ | NoTransport String
+
+getTransport :: String -> TransportType
+getTransport "buffered" = Buffered $ \s -> do
+ (h, _, _) <- (accept s)
+ IO.hSetBuffering h $ IO.BlockBuffering Nothing
+ return h
+getTransport "framed" = Framed $ \s -> do
+ (h, _, _) <- (accept s)
+ openFramedTransport h
+getTransport t = NoTransport $ "Unsupported transport: " ++ t
+
data ProtocolType = Binary
| Compact
| JSON
@@ -87,8 +102,9 @@
{ port = 9090
, domainSocket = ""
, serverType = Threaded
- , transport = "framed"
+ , transport = "buffered"
, protocol = Binary
+ -- TODO: Haskell lib does not have SSL support
, ssl = False
, workers = 4
}
@@ -234,17 +250,24 @@
case options of
Nothing -> showHelp
Just Options{..} -> do
+ case Main.getTransport transport of
+ Buffered f -> runServer protocol f port
+ Framed f -> runServer protocol f port
+ NoTransport err -> putStrLn err
System.IO.putStrLn $ "Starting \"" ++ show serverType ++ "\" server (" ++
show transport ++ ") listen on: " ++ domainSocket ++ show port
- case protocol of
- Binary -> runServer BinaryProtocol port
- Compact -> runServer CompactProtocol port
- JSON -> runServer JSONProtocol port
where
- runServer p = runThreadedServer (accepter p) TestHandler ThriftTest.process . PortNumber . fromIntegral
- accepter p s = do
- (h, _, _) <- accept s
- return (p h, p h)
+ acceptor p f socket = do
+ t <- f socket
+ return (p t, p t)
+
+ doRunServer p f = do
+ runThreadedServer (acceptor p f) TestHandler ThriftTest.process . PortNumber . fromIntegral
+
+ runServer p f port = case p of
+ Binary -> do doRunServer BinaryProtocol f port
+ Compact -> do doRunServer CompactProtocol f port
+ JSON -> do doRunServer JSONProtocol f port
parseFlags :: [String] -> Options -> Maybe Options
parseFlags (flag : flags) opts = do
@@ -272,9 +295,9 @@
\ --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift)\n\
\ --server-type arg (=simple) type of server, \"simple\", \"thread-pool\",\n\
\ \"threaded\", or \"nonblocking\"\n\
- \ --transport arg (=buffered) transport: buffered, framed, http\n\
+ \ --transport arg (=buffered) transport: buffered, framed\n\
\ --protocol arg (=binary) protocol: binary, compact, json\n\
\ --ssl Encrypted Transport using SSL\n\
\ --processor-events processor-events\n\
\ -n [ --workers ] arg (=4) Number of thread pools workers. Only valid for\n\
- \ thread-pool server type"
\ No newline at end of file
+ \ thread-pool server type"