ceph/src/jaegertracing/thrift/test/hs/TestClient.hs

   1 --
   2 -- Licensed to the Apache Software Foundation (ASF) under one
   3 -- or more contributor license agreements. See the NOTICE file
   4 -- distributed with this work for additional information
   5 -- regarding copyright ownership. The ASF licenses this file
   6 -- to you under the Apache License, Version 2.0 (the
   7 -- "License"); you may not use this file except in compliance
   8 -- with the License. You may obtain a copy of the License at
   9 --
  10 --   http://www.apache.org/licenses/LICENSE-2.0
  11 --
  12 -- Unless required by applicable law or agreed to in writing,
  13 -- software distributed under the License is distributed on an
  14 -- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
  15 -- KIND, either express or implied. See the License for the
  16 -- specific language governing permissions and limitations
  17 -- under the License.
  18 --
  19
  20 {-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
  21 module Main where
  22
  23 import Control.Exception
  24 import Control.Monad
  25 import Data.Functor
  26 import Data.List.Split
  27 import Data.String
  28 import Network
  29 import Network.URI
  30 import System.Environment
  31 import System.Exit
  32 import qualified Data.ByteString.Lazy as LBS
  33 import qualified Data.HashMap.Strict as Map
  34 import qualified Data.HashSet as Set
  35 import qualified Data.Vector as Vector
  36 import qualified System.IO as IO
  37
  38 import ThriftTest_Iface
  39 import ThriftTest_Types
  40 import qualified ThriftTest_Client as Client
  41
  42 import Thrift.Transport
  43 import Thrift.Transport.Framed
  44 import Thrift.Transport.Handle
  45 import Thrift.Transport.HttpClient
  46 import Thrift.Protocol
  47 import Thrift.Protocol.Binary
  48 import Thrift.Protocol.Compact
  49 import Thrift.Protocol.Header
  50 import Thrift.Protocol.JSON
  51
  52 data Options = Options
  53   { host         :: String
  54   , port         :: Int
  55   , domainSocket :: String
  56   , transport    :: String
  57   , protocol     :: ProtocolType
  58   -- TODO: Haskell lib does not have SSL support
  59   , ssl          :: Bool
  60   , testLoops    :: Int
  61   }
  62   deriving (Show, Eq)
  63
  64 data TransportType = Buffered IO.Handle
  65                    | Framed (FramedTransport IO.Handle)
  66                    | Http HttpClient
  67                    | NoTransport String
  68
  69 getTransport :: String -> String -> Int -> (IO TransportType)
  70 getTransport "buffered" host port = do
  71   h <- hOpen (host, PortNumber $ fromIntegral port)
  72   IO.hSetBuffering h $ IO.BlockBuffering Nothing
  73   return $ Buffered h
  74 getTransport "framed" host port = do
  75   h <- hOpen (host, PortNumber $ fromIntegral port)
  76   t <- openFramedTransport h
  77   return $ Framed t
  78 getTransport "http" host port = let uriStr = "http://" ++ host ++ ":" ++ show port in
  79                                 case parseURI uriStr of
  80                                   Nothing -> do return (NoTransport $ "Failed to parse URI: " ++ uriStr)
  81                                   Just(uri) -> do
  82                                     t <- openHttpClient uri
  83                                     return $ Http t
  84 getTransport t host port = do return (NoTransport $ "Unsupported transport: " ++ t)
  85
  86 data ProtocolType = Binary
  87                   | Compact
  88                   | JSON
  89                   | Header
  90                   deriving (Show, Eq)
  91
  92 getProtocol :: String -> ProtocolType
  93 getProtocol "binary"  = Binary
  94 getProtocol "compact" = Compact
  95 getProtocol "json"    = JSON
  96 getProtocol "header" = Header
  97 getProtocol p = error $ "Unsupported Protocol: " ++ p
  98
  99 defaultOptions :: Options
 100 defaultOptions = Options
 101   { port         = 9090
 102   , domainSocket = ""
 103   , host         = "localhost"
 104   , transport    = "buffered"
 105   , protocol     = Binary
 106   , ssl          = False
 107   , testLoops    = 1
 108   }
 109
 110 runClient :: Protocol p => p -> IO ()
 111 runClient p = do
 112   let prot = (p,p)
 113   putStrLn "Starting Tests"
 114
 115   -- VOID Test
 116   putStrLn "testVoid"
 117   Client.testVoid prot
 118
 119   -- String Test
 120   putStrLn "testString"
 121   s <- Client.testString prot "Test"
 122   when (s /= "Test") exitFailure
 123
 124   -- Bool Test
 125   putStrLn "testBool"
 126   bool <- Client.testBool prot True
 127   when (not bool) exitFailure
 128   putStrLn "testBool"
 129   bool <- Client.testBool prot False
 130   when (bool) exitFailure
 131
 132   -- Byte Test
 133   putStrLn "testByte"
 134   byte <- Client.testByte prot 1
 135   when (byte /= 1) exitFailure
 136
 137   -- I32 Test
 138   putStrLn "testI32"
 139   i32 <- Client.testI32 prot (-1)
 140   when (i32 /= -1) exitFailure
 141
 142   -- I64 Test
 143   putStrLn "testI64"
 144   i64 <- Client.testI64 prot (-34359738368)
 145   when (i64 /= -34359738368) exitFailure
 146
 147   -- Double Test
 148   putStrLn "testDouble"
 149   dub <- Client.testDouble prot (-5.2098523)
 150   when (abs (dub + 5.2098523) > 0.001) exitFailure
 151
 152   -- Binary Test
 153   putStrLn "testBinary"
 154   bin <- Client.testBinary prot (LBS.pack . reverse $ [-128..127])
 155   when ((reverse [-128..127]) /= LBS.unpack bin) exitFailure
 156
 157   -- Struct Test
 158   let structIn = Xtruct{ xtruct_string_thing = "Zero"
 159                        , xtruct_byte_thing   = 1
 160                        , xtruct_i32_thing    = -3
 161                        , xtruct_i64_thing    = -5
 162                        }
 163   putStrLn "testStruct"
 164   structOut <- Client.testStruct prot structIn
 165   when (structIn /= structOut) exitFailure
 166
 167   -- Nested Struct Test
 168   let nestIn = Xtruct2{ xtruct2_byte_thing   = 1
 169                       , xtruct2_struct_thing = structIn
 170                       , xtruct2_i32_thing    = 5
 171                       }
 172   putStrLn "testNest"
 173   nestOut <- Client.testNest prot nestIn
 174   when (nestIn /= nestOut) exitFailure
 175
 176   -- Map Test
 177   let mapIn = Map.fromList $ map (\i -> (i, i-10)) [1..5]
 178   putStrLn "testMap"
 179   mapOut <- Client.testMap prot mapIn
 180   when (mapIn /= mapOut) exitFailure
 181
 182   -- Set Test
 183   let setIn = Set.fromList [-2..3]
 184   putStrLn "testSet"
 185   setOut <- Client.testSet prot setIn
 186   when (setIn /= setOut) exitFailure
 187
 188   -- List Test
 189   let listIn = Vector.fromList [-2..3]
 190   putStrLn "testList"
 191   listOut <- Client.testList prot listIn
 192   when (listIn /= listOut) exitFailure
 193
 194   -- Enum Test
 195   putStrLn "testEnum"
 196   numz1 <- Client.testEnum prot ONE
 197   when (numz1 /= ONE) exitFailure
 198
 199   putStrLn "testEnum"
 200   numz2 <- Client.testEnum prot TWO
 201   when (numz2 /= TWO) exitFailure
 202
 203   putStrLn "testEnum"
 204   numz5 <- Client.testEnum prot FIVE
 205   when (numz5 /= FIVE) exitFailure
 206
 207   -- Typedef Test
 208   putStrLn "testTypedef"
 209   uid <- Client.testTypedef prot 309858235082523
 210   when (uid /= 309858235082523) exitFailure
 211
 212   -- Nested Map Test
 213   putStrLn "testMapMap"
 214   _ <- Client.testMapMap prot 1
 215
 216   -- Exception Test
 217   putStrLn "testException"
 218   exn1 <- try $ Client.testException prot "Xception"
 219   case exn1 of
 220     Left (Xception _ _) -> return ()
 221     _ -> putStrLn (show exn1) >> exitFailure
 222
 223   putStrLn "testException"
 224   exn2 <- try $ Client.testException prot "TException"
 225   case exn2 of
 226     Left (_ :: SomeException) -> return ()
 227     Right _ -> exitFailure
 228
 229   putStrLn "testException"
 230   exn3 <- try $ Client.testException prot "success"
 231   case exn3 of
 232     Left (_ :: SomeException) -> exitFailure
 233     Right _ -> return ()
 234
 235   -- Multi Exception Test
 236   putStrLn "testMultiException"
 237   multi1 <- try $ Client.testMultiException prot "Xception" "test 1"
 238   case multi1 of
 239     Left (Xception _ _) -> return ()
 240     _ -> exitFailure
 241
 242   putStrLn "testMultiException"
 243   multi2 <- try $ Client.testMultiException prot "Xception2" "test 2"
 244   case multi2 of
 245     Left (Xception2 _ _) -> return ()
 246     _ -> exitFailure
 247
 248   putStrLn "testMultiException"
 249   multi3 <- try $ Client.testMultiException prot "success" "test 3"
 250   case multi3 of
 251     Left (_ :: SomeException) -> exitFailure
 252     Right _ -> return ()
 253
 254
 255 main :: IO ()
 256 main = do
 257   options <- flip parseFlags defaultOptions <$> getArgs
 258   case options of
 259     Nothing -> showHelp
 260     Just Options{..} -> do
 261       trans <- Main.getTransport transport host port
 262       case trans of
 263         Buffered t -> runTest testLoops protocol t
 264         Framed t   -> runTest testLoops protocol t
 265         Http t     -> runTest testLoops protocol t
 266         NoTransport err -> putStrLn err
 267   where
 268     makeClient p t = case p of
 269                        Binary  -> runClient $ BinaryProtocol t
 270                        Compact -> runClient $ CompactProtocol t
 271                        JSON    -> runClient $ JSONProtocol t
 272                        Header  -> createHeaderProtocol t t >>= runClient
 273     runTest loops p t = do
 274       let client = makeClient p t
 275       replicateM_ loops client
 276       putStrLn "COMPLETED SUCCESSFULLY"
 277
 278 parseFlags :: [String] -> Options -> Maybe Options
 279 parseFlags (flag : flags) opts = do
 280   let pieces = splitOn "=" flag
 281   case pieces of
 282     "--port" : arg : _ -> parseFlags flags opts{ port = read arg }
 283     "--domain-socket" : arg : _ -> parseFlags flags opts{ domainSocket = read arg }
 284     "--host" : arg : _ -> parseFlags flags opts{ host = arg }
 285     "--transport" : arg : _ -> parseFlags flags opts{ transport = arg }
 286     "--protocol" : arg : _ -> parseFlags flags opts{ protocol = getProtocol arg }
 287     "-n" : arg : _ -> parseFlags flags opts{ testLoops = read arg }
 288     "--h" : _ -> Nothing
 289     "--help" : _ -> Nothing
 290     "--ssl" : _ -> parseFlags flags opts{ ssl = True }
 291     "--processor-events" : _ -> parseFlags flags opts
 292     _ -> Nothing
 293 parseFlags [] opts = Just opts
 294
 295 showHelp :: IO ()
 296 showHelp = putStrLn
 297   "Allowed options:\n\
 298   \  -h [ --help ]               produce help message\n\
 299   \  --host arg (=localhost)     Host to connect\n\
 300   \  --port arg (=9090)          Port number to connect\n\
 301   \  --domain-socket arg         Domain Socket (e.g. /tmp/ThriftTest.thrift),\n\
 302   \                              instead of host and port\n\
 303   \  --transport arg (=buffered) Transport: buffered, framed, http\n\
 304   \  --protocol arg (=binary)    Protocol: binary, compact, json\n\
 305   \  --ssl                       Encrypted Transport using SSL\n\
 306   \  -n [ --testloops ] arg (=1) Number of Tests"