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/TestClient.hs b/test/hs/TestClient.hs
index 6c25f5b..057a560 100644
--- a/test/hs/TestClient.hs
+++ b/test/hs/TestClient.hs
@@ -26,19 +26,24 @@
import Data.List.Split
import Data.String
import Network
+import Network.URI
import System.Environment
import System.Exit
import System.Posix.Unistd
+import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.Vector as Vector
+import qualified System.IO as IO
import ThriftTest_Iface
import ThriftTest_Types
import qualified ThriftTest_Client as Client
import Thrift.Transport
+import Thrift.Transport.Framed
import Thrift.Transport.Handle
+import Thrift.Transport.HttpClient
import Thrift.Protocol
import Thrift.Protocol.Binary
import Thrift.Protocol.Compact
@@ -50,11 +55,34 @@
, domainSocket :: String
, transport :: String
, protocol :: ProtocolType
+ -- TODO: Haskell lib does not have SSL support
, ssl :: Bool
, testLoops :: Int
}
deriving (Show, Eq)
+data TransportType = Buffered IO.Handle
+ | Framed (FramedTransport IO.Handle)
+ | Http HttpClient
+ | NoTransport String
+
+getTransport :: String -> String -> Int -> (IO TransportType)
+getTransport "buffered" host port = do
+ h <- hOpen (host, PortNumber $ fromIntegral port)
+ IO.hSetBuffering h $ IO.BlockBuffering Nothing
+ return $ Buffered h
+getTransport "framed" host port = do
+ h <- hOpen (host, PortNumber $ fromIntegral port)
+ t <- openFramedTransport h
+ return $ Framed t
+getTransport "http" host port = let uriStr = "http://" ++ host ++ ":" ++ show port in
+ case parseURI uriStr of
+ Nothing -> do return (NoTransport $ "Failed to parse URI: " ++ uriStr)
+ Just(uri) -> do
+ t <- openHttpClient uri
+ return $ Http t
+getTransport t host port = do return (NoTransport $ "Unsupported transport: " ++ t)
+
data ProtocolType = Binary
| Compact
| JSON
@@ -71,7 +99,7 @@
{ port = 9090
, domainSocket = ""
, host = "localhost"
- , transport = "framed"
+ , transport = "buffered"
, protocol = Binary
, ssl = False
, testLoops = 1
@@ -83,29 +111,46 @@
putStrLn "Starting Tests"
-- VOID Test
+ putStrLn "testVoid"
Client.testVoid prot
-- String Test
+ putStrLn "testString"
s <- Client.testString prot "Test"
when (s /= "Test") exitFailure
+ -- Bool Test
+ putStrLn "testBool"
+ bool <- Client.testBool prot True
+ when (not bool) exitFailure
+ putStrLn "testBool"
+ bool <- Client.testBool prot False
+ when (bool) exitFailure
+
-- Byte Test
+ putStrLn "testByte"
byte <- Client.testByte prot 1
when (byte /= 1) exitFailure
-- I32 Test
+ putStrLn "testI32"
i32 <- Client.testI32 prot (-1)
when (i32 /= -1) exitFailure
-- I64 Test
+ putStrLn "testI64"
i64 <- Client.testI64 prot (-34359738368)
when (i64 /= -34359738368) exitFailure
-- Double Test
+ putStrLn "testDouble"
dub <- Client.testDouble prot (-5.2098523)
when (abs (dub + 5.2098523) > 0.001) exitFailure
- -- TODO: call Client.testBinary
+ -- Binary Test
+ putStrLn "testBinary"
+ bin <- Client.testBinary prot (LBS.pack . reverse $ [-128..127])
+ when ((reverse [-128..127]) /= LBS.unpack bin) exitFailure
-- Struct Test
let structIn = Xtruct{ xtruct_string_thing = "Zero"
@@ -113,6 +158,7 @@
, xtruct_i32_thing = -3
, xtruct_i64_thing = -5
}
+ putStrLn "testStruct"
structOut <- Client.testStruct prot structIn
when (structIn /= structOut) exitFailure
@@ -121,68 +167,83 @@
, xtruct2_struct_thing = structIn
, xtruct2_i32_thing = 5
}
+ putStrLn "testNest"
nestOut <- Client.testNest prot nestIn
when (nestIn /= nestOut) exitSuccess
-- Map Test
let mapIn = Map.fromList $ map (\i -> (i, i-10)) [1..5]
+ putStrLn "testMap"
mapOut <- Client.testMap prot mapIn
when (mapIn /= mapOut) exitSuccess
-- Set Test
let setIn = Set.fromList [-2..3]
+ putStrLn "testSet"
setOut <- Client.testSet prot setIn
when (setIn /= setOut) exitFailure
-- List Test
let listIn = Vector.fromList [-2..3]
+ putStrLn "testList"
listOut <- Client.testList prot listIn
when (listIn /= listOut) exitFailure
-- Enum Test
+ putStrLn "testEnum"
numz1 <- Client.testEnum prot ONE
when (numz1 /= ONE) exitFailure
+ putStrLn "testEnum"
numz2 <- Client.testEnum prot TWO
when (numz2 /= TWO) exitFailure
+ putStrLn "testEnum"
numz5 <- Client.testEnum prot FIVE
when (numz5 /= FIVE) exitFailure
-- Typedef Test
+ putStrLn "testTypedef"
uid <- Client.testTypedef prot 309858235082523
when (uid /= 309858235082523) exitFailure
-- Nested Map Test
+ putStrLn "testMapMap"
_ <- Client.testMapMap prot 1
-- Exception Test
+ putStrLn "testException"
exn1 <- try $ Client.testException prot "Xception"
case exn1 of
Left (Xception _ _) -> return ()
_ -> putStrLn (show exn1) >> exitFailure
+ putStrLn "testException"
exn2 <- try $ Client.testException prot "TException"
case exn2 of
Left (_ :: SomeException) -> return ()
Right _ -> exitFailure
+ putStrLn "testException"
exn3 <- try $ Client.testException prot "success"
case exn3 of
Left (_ :: SomeException) -> exitFailure
Right _ -> return ()
-- Multi Exception Test
+ putStrLn "testMultiException"
multi1 <- try $ Client.testMultiException prot "Xception" "test 1"
case multi1 of
Left (Xception _ _) -> return ()
_ -> exitFailure
+ putStrLn "testMultiException"
multi2 <- try $ Client.testMultiException prot "Xception2" "test 2"
case multi2 of
Left (Xception2 _ _) -> return ()
_ -> exitFailure
+ putStrLn "testMultiException"
multi3 <- try $ Client.testMultiException prot "success" "test 3"
case multi3 of
Left (_ :: SomeException) -> exitFailure
@@ -195,12 +256,20 @@
case options of
Nothing -> showHelp
Just Options{..} -> do
- handle <- hOpen (host, PortNumber $ fromIntegral port)
- let client = case protocol of
- Binary -> runClient $ BinaryProtocol handle
- Compact -> runClient $ CompactProtocol handle
- JSON -> runClient $ JSONProtocol handle
- replicateM_ testLoops client
+ trans <- Main.getTransport transport host port
+ case trans of
+ Buffered t -> runTest testLoops protocol t
+ Framed t -> runTest testLoops protocol t
+ Http t -> runTest testLoops protocol t
+ NoTransport err -> putStrLn err
+ where
+ makeClient p t = case p of
+ Binary -> runClient $ BinaryProtocol t
+ Compact -> runClient $ CompactProtocol t
+ JSON -> runClient $ JSONProtocol t
+ runTest loops p t = do
+ let client = makeClient p t
+ replicateM_ loops client
putStrLn "COMPLETED SUCCESSFULLY"
parseFlags :: [String] -> Options -> Maybe Options
@@ -228,7 +297,7 @@
\ --port arg (=9090) Port number to connect\n\
\ --domain-socket arg Domain Socket (e.g. /tmp/ThriftTest.thrift),\n\
\ instead of host and port\n\
- \ --transport arg (=buffered) Transport: buffered, framed, http, evhttp\n\
+ \ --transport arg (=buffered) Transport: buffered, framed, http\n\
\ --protocol arg (=binary) Protocol: binary, compact, json\n\
\ --ssl Encrypted Transport using SSL\n\
- \ -n [ --testloops ] arg (=1) Number of Tests"
\ No newline at end of file
+ \ -n [ --testloops ] arg (=1) Number of Tests"
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"