test/hs/TestClient.hs

--
-- 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.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
                  deriving (Show, Eq)

getProtocol :: String -> ProtocolType
getProtocol "binary"  = Binary
getProtocol "compact" = Compact
getProtocol "json"    = JSON
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, Transport t) => p t -> 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
    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"