blob: 93fb591b343a64c587b2cb411d5e1597d59233c0 [file] [log] [blame]
--
-- Licensed to the Apache Software Foundation (ASF) under one
-- or more contributor license agreements. See the NOTICE file
-- distributed with this work for additional information
-- regarding copyright ownership. The ASF licenses this file
-- to you under the Apache License, Version 2.0 (the
-- "License"); you may not use this file except in compliance
-- with the License. You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing,
-- software distributed under the License is distributed on an
-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
-- KIND, either express or implied. See the License for the
-- specific language governing permissions and limitations
-- under the License.
--
{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
module Main where
import Control.Exception
import Control.Monad
import Data.Functor
import Data.List.Split
import Data.String
import Network
import Network.URI
import System.Environment
import System.Exit
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
import Thrift.Protocol.Header
import Thrift.Protocol.JSON
data Options = Options
{ host :: String
, port :: Int
, 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
| Header
deriving (Show, Eq)
getProtocol :: String -> ProtocolType
getProtocol "binary" = Binary
getProtocol "compact" = Compact
getProtocol "json" = JSON
getProtocol "header" = Header
getProtocol p = error $ "Unsupported Protocol: " ++ p
defaultOptions :: Options
defaultOptions = Options
{ port = 9090
, domainSocket = ""
, host = "localhost"
, transport = "buffered"
, protocol = Binary
, ssl = False
, testLoops = 1
}
runClient :: Protocol p => p -> IO ()
runClient p = do
let prot = (p,p)
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
-- 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"
, xtruct_byte_thing = 1
, xtruct_i32_thing = -3
, xtruct_i64_thing = -5
}
putStrLn "testStruct"
structOut <- Client.testStruct prot structIn
when (structIn /= structOut) exitFailure
-- Nested Struct Test
let nestIn = Xtruct2{ xtruct2_byte_thing = 1
, xtruct2_struct_thing = structIn
, xtruct2_i32_thing = 5
}
putStrLn "testNest"
nestOut <- Client.testNest prot nestIn
when (nestIn /= nestOut) exitFailure
-- Map Test
let mapIn = Map.fromList $ map (\i -> (i, i-10)) [1..5]
putStrLn "testMap"
mapOut <- Client.testMap prot mapIn
when (mapIn /= mapOut) exitFailure
-- 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
Right _ -> return ()
main :: IO ()
main = do
options <- flip parseFlags defaultOptions <$> getArgs
case options of
Nothing -> showHelp
Just Options{..} -> do
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
Header -> createHeaderProtocol t t >>= runClient
runTest loops p t = do
let client = makeClient p t
replicateM_ loops client
putStrLn "COMPLETED SUCCESSFULLY"
parseFlags :: [String] -> Options -> Maybe Options
parseFlags (flag : flags) opts = do
let pieces = splitOn "=" flag
case pieces of
"--port" : arg : _ -> parseFlags flags opts{ port = read arg }
"--domain-socket" : arg : _ -> parseFlags flags opts{ domainSocket = read arg }
"--host" : arg : _ -> parseFlags flags opts{ host = arg }
"--transport" : arg : _ -> parseFlags flags opts{ transport = arg }
"--protocol" : arg : _ -> parseFlags flags opts{ protocol = getProtocol arg }
"-n" : arg : _ -> parseFlags flags opts{ testLoops = read arg }
"--h" : _ -> Nothing
"--help" : _ -> Nothing
"--ssl" : _ -> parseFlags flags opts{ ssl = True }
"--processor-events" : _ -> parseFlags flags opts
_ -> Nothing
parseFlags [] opts = Just opts
showHelp :: IO ()
showHelp = putStrLn
"Allowed options:\n\
\ -h [ --help ] produce help message\n\
\ --host arg (=localhost) Host to connect\n\
\ --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\n\
\ --protocol arg (=binary) Protocol: binary, compact, json\n\
\ --ssl Encrypted Transport using SSL\n\
\ -n [ --testloops ] arg (=1) Number of Tests"