blob: b7731ab1c403ab9e753cbeb7afe84b123b6a93cf [file] [log] [blame]
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -07001--
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 #-}
21module Main where
22
23import Control.Exception
24import Control.Monad
25import Data.Functor
26import Data.HashMap.Strict (HashMap)
27import Data.List
cdwijayarathnad9217912014-08-15 22:18:30 +053028import Data.List.Split
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -070029import Data.String
30import Network
31import System.Environment
32import System.Exit
33import System.IO
Nobuaki Sukegawae8c71d82015-11-23 19:51:37 +090034import Control.Concurrent (threadDelay)
Jens Geyerd629ea02015-09-23 21:16:50 +020035import qualified System.IO as IO
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -070036import qualified Data.HashMap.Strict as Map
37import qualified Data.HashSet as Set
38import qualified Data.Text.Lazy as Text
39import qualified Data.Vector as Vector
40
41import ThriftTest
42import ThriftTest_Iface
43import ThriftTest_Types
44
45import Thrift
46import Thrift.Server
47import Thrift.Transport.Framed
48import Thrift.Transport.Handle
49import Thrift.Protocol.Binary
50import Thrift.Protocol.Compact
Nobuaki Sukegawa3c420072016-01-24 04:01:27 +090051import Thrift.Protocol.Header
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -070052import Thrift.Protocol.JSON
53
54data Options = Options
55 { port :: Int
56 , domainSocket :: String
57 , serverType :: ServerType
58 , transport :: String
59 , protocol :: ProtocolType
60 , ssl :: Bool
61 , workers :: Int
62 }
cdwijayarathnad9217912014-08-15 22:18:30 +053063
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -070064data ServerType = Simple
65 | ThreadPool
66 | Threaded
67 | NonBlocking
68 deriving (Show, Eq)
69
70instance IsString ServerType where
71 fromString "simple" = Simple
72 fromString "thread-pool" = ThreadPool
73 fromString "threaded" = Threaded
74 fromString "nonblocking" = NonBlocking
75 fromString _ = error "not a valid server type"
76
Jens Geyerd629ea02015-09-23 21:16:50 +020077data TransportType = Buffered (Socket -> (IO IO.Handle))
78 | Framed (Socket -> (IO (FramedTransport IO.Handle)))
79 | NoTransport String
80
81getTransport :: String -> TransportType
82getTransport "buffered" = Buffered $ \s -> do
83 (h, _, _) <- (accept s)
84 IO.hSetBuffering h $ IO.BlockBuffering Nothing
85 return h
86getTransport "framed" = Framed $ \s -> do
87 (h, _, _) <- (accept s)
88 openFramedTransport h
89getTransport t = NoTransport $ "Unsupported transport: " ++ t
90
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -070091data ProtocolType = Binary
92 | Compact
93 | JSON
Nobuaki Sukegawa3c420072016-01-24 04:01:27 +090094 | Header
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -070095
96getProtocol :: String -> ProtocolType
97getProtocol "binary" = Binary
98getProtocol "compact" = Compact
99getProtocol "json" = JSON
Nobuaki Sukegawa3c420072016-01-24 04:01:27 +0900100getProtocol "header" = Header
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700101getProtocol p = error $"Unsupported Protocol: " ++ p
102
103defaultOptions :: Options
104defaultOptions = Options
105 { port = 9090
106 , domainSocket = ""
107 , serverType = Threaded
Jens Geyerd629ea02015-09-23 21:16:50 +0200108 , transport = "buffered"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700109 , protocol = Binary
Jens Geyerd629ea02015-09-23 21:16:50 +0200110 -- TODO: Haskell lib does not have SSL support
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700111 , ssl = False
112 , workers = 4
113 }
114
115stringifyMap :: (Show a, Show b) => Map.HashMap a b -> String
cdwijayarathnad9217912014-08-15 22:18:30 +0530116stringifyMap = Data.List.intercalate ", " . Data.List.map joinKV . Map.toList
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700117 where joinKV (k, v) = show k ++ " => " ++ show v
118
119stringifySet :: Show a => Set.HashSet a -> String
cdwijayarathnad9217912014-08-15 22:18:30 +0530120stringifySet = Data.List.intercalate ", " . Data.List.map show . Set.toList
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700121
122stringifyList :: Show a => Vector.Vector a -> String
cdwijayarathnad9217912014-08-15 22:18:30 +0530123stringifyList = Data.List.intercalate ", " . Data.List.map show . Vector.toList
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700124
125data TestHandler = TestHandler
cdwijayarathnad9217912014-08-15 22:18:30 +0530126instance ThriftTest_Iface TestHandler where
127 testVoid _ = System.IO.putStrLn "testVoid()"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700128
129 testString _ s = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530130 System.IO.putStrLn $ "testString(" ++ show s ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700131 return s
132
Nobuaki Sukegawaa649e742015-09-21 13:53:25 +0900133 testBool _ x = do
134 System.IO.putStrLn $ "testBool(" ++ show x ++ ")"
135 return x
136
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700137 testByte _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530138 System.IO.putStrLn $ "testByte(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700139 return x
140
141 testI32 _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530142 System.IO.putStrLn $ "testI32(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700143 return x
144
145 testI64 _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530146 System.IO.putStrLn $ "testI64(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700147 return x
cdwijayarathnad9217912014-08-15 22:18:30 +0530148
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700149 testDouble _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530150 System.IO.putStrLn $ "testDouble(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700151 return x
152
Jens Geyer8bcfdd92014-12-14 03:14:26 +0100153 testBinary _ x = do
154 System.IO.putStrLn $ "testBinary(" ++ show x ++ ")"
155 return x
156
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700157 testStruct _ struct@Xtruct{..} = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530158 System.IO.putStrLn $ "testStruct({" ++ show xtruct_string_thing
159 ++ ", " ++ show xtruct_byte_thing
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700160 ++ ", " ++ show xtruct_i32_thing
161 ++ ", " ++ show xtruct_i64_thing
162 ++ "})"
163 return struct
164
165 testNest _ nest@Xtruct2{..} = do
166 let Xtruct{..} = xtruct2_struct_thing
cdwijayarathnad9217912014-08-15 22:18:30 +0530167 System.IO.putStrLn $ "testNest({" ++ show xtruct2_byte_thing
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700168 ++ "{, " ++ show xtruct_string_thing
169 ++ ", " ++ show xtruct_byte_thing
170 ++ ", " ++ show xtruct_i32_thing
171 ++ ", " ++ show xtruct_i64_thing
172 ++ "}, " ++ show xtruct2_i32_thing
173 return nest
174
175 testMap _ m = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530176 System.IO.putStrLn $ "testMap({" ++ stringifyMap m ++ "})"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700177 return m
cdwijayarathnad9217912014-08-15 22:18:30 +0530178
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700179 testStringMap _ m = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530180 System.IO.putStrLn $ "testStringMap(" ++ stringifyMap m ++ "})"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700181 return m
182
183 testSet _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530184 System.IO.putStrLn $ "testSet({" ++ stringifySet x ++ "})"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700185 return x
186
187 testList _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530188 System.IO.putStrLn $ "testList(" ++ stringifyList x ++ "})"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700189 return x
190
191 testEnum _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530192 System.IO.putStrLn $ "testEnum(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700193 return x
194
195 testTypedef _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530196 System.IO.putStrLn $ "testTypedef(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700197 return x
198
199 testMapMap _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530200 System.IO.putStrLn $ "testMapMap(" ++ show x ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700201 return $ Map.fromList [ (-4, Map.fromList [ (-4, -4)
202 , (-3, -3)
203 , (-2, -2)
204 , (-1, -1)
205 ])
206 , (4, Map.fromList [ (1, 1)
207 , (2, 2)
208 , (3, 3)
209 , (4, 4)
210 ])
211 ]
212
213 testInsanity _ x = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530214 System.IO.putStrLn "testInsanity()"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700215 return $ Map.fromList [ (1, Map.fromList [ (TWO , x)
216 , (THREE, x)
217 ])
218 , (2, Map.fromList [ (SIX, default_Insanity)
219 ])
220 ]
221
222 testMulti _ byte i32 i64 _ _ _ = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530223 System.IO.putStrLn "testMulti()"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700224 return Xtruct{ xtruct_string_thing = Text.pack "Hello2"
225 , xtruct_byte_thing = byte
226 , xtruct_i32_thing = i32
227 , xtruct_i64_thing = i64
228 }
cdwijayarathnad9217912014-08-15 22:18:30 +0530229
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700230 testException _ s = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530231 System.IO.putStrLn $ "testException(" ++ show s ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700232 case s of
233 "Xception" -> throw $ Xception 1001 s
234 "TException" -> throw ThriftException
235 _ -> return ()
236
237 testMultiException _ s1 s2 = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530238 System.IO.putStrLn $ "testMultiException(" ++ show s1 ++ ", " ++ show s2 ++ ")"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700239 case s1 of
cdwijayarathnad9217912014-08-15 22:18:30 +0530240 "Xception" -> throw $ Xception 1001 "This is an Xception"
Nobuaki Sukegawa01ede042015-09-29 02:16:53 +0900241 "Xception2" -> throw $ Xception2 2002 $ Xtruct "This is an Xception2" 0 0 0
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700242 "TException" -> throw ThriftException
243 _ -> return default_Xtruct{ xtruct_string_thing = s2 }
244
245 testOneway _ i = do
cdwijayarathnad9217912014-08-15 22:18:30 +0530246 System.IO.putStrLn $ "testOneway(" ++ show i ++ "): Sleeping..."
Nobuaki Sukegawae8c71d82015-11-23 19:51:37 +0900247 threadDelay $ (fromIntegral i) * 1000000
cdwijayarathnad9217912014-08-15 22:18:30 +0530248 System.IO.putStrLn $ "testOneway(" ++ show i ++ "): done sleeping!"
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700249
250main :: IO ()
251main = do
252 options <- flip parseFlags defaultOptions <$> getArgs
253 case options of
254 Nothing -> showHelp
255 Just Options{..} -> do
Jens Geyerd629ea02015-09-23 21:16:50 +0200256 case Main.getTransport transport of
257 Buffered f -> runServer protocol f port
258 Framed f -> runServer protocol f port
259 NoTransport err -> putStrLn err
cdwijayarathnad9217912014-08-15 22:18:30 +0530260 System.IO.putStrLn $ "Starting \"" ++ show serverType ++ "\" server (" ++
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700261 show transport ++ ") listen on: " ++ domainSocket ++ show port
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700262 where
Jens Geyerd629ea02015-09-23 21:16:50 +0200263 acceptor p f socket = do
264 t <- f socket
265 return (p t, p t)
266
Nobuaki Sukegawa3c420072016-01-24 04:01:27 +0900267 headerAcceptor f socket = do
268 t <- f socket
269 p <- createHeaderProtocol1 t
270 return (p, p)
271
Jens Geyerd629ea02015-09-23 21:16:50 +0200272 doRunServer p f = do
273 runThreadedServer (acceptor p f) TestHandler ThriftTest.process . PortNumber . fromIntegral
274
275 runServer p f port = case p of
Nobuaki Sukegawa3c420072016-01-24 04:01:27 +0900276 Binary -> doRunServer BinaryProtocol f port
277 Compact -> doRunServer CompactProtocol f port
278 JSON -> doRunServer JSONProtocol f port
279 Header -> runThreadedServer (headerAcceptor f) TestHandler ThriftTest.process (PortNumber $ fromIntegral port)
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700280
281parseFlags :: [String] -> Options -> Maybe Options
cdwijayarathnad9217912014-08-15 22:18:30 +0530282parseFlags (flag : flags) opts = do
283 let pieces = splitOn "=" flag
284 case pieces of
285 "--port" : arg : _ -> parseFlags flags opts{ port = read arg }
286 "--domain-socket" : arg : _ -> parseFlags flags opts{ domainSocket = read arg }
287 "--server-type" : arg : _ -> parseFlags flags opts{ serverType = fromString arg }
288 "--transport" : arg : _ -> parseFlags flags opts{ transport = arg }
289 "--protocol" : arg : _ -> parseFlags flags opts{ protocol = getProtocol arg }
290 "--workers" : arg : _ -> parseFlags flags opts{ workers = read arg }
cdwijayarathna7191bc92014-08-16 23:36:07 +0530291 "-n" : arg : _ -> parseFlags flags opts{ workers = read arg }
cdwijayarathnad9217912014-08-15 22:18:30 +0530292 "--h" : _ -> Nothing
293 "--help" : _ -> Nothing
294 "--ssl" : _ -> parseFlags flags opts{ ssl = True }
295 "--processor-events" : _ -> parseFlags flags opts
cdwijayarathna7191bc92014-08-16 23:36:07 +0530296 _ -> Nothing
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700297parseFlags [] opts = Just opts
298
299showHelp :: IO ()
cdwijayarathnad9217912014-08-15 22:18:30 +0530300showHelp = System.IO.putStrLn
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700301 "Allowed options:\n\
302 \ -h [ --help ] produce help message\n\
303 \ --port arg (=9090) Port number to listen\n\
304 \ --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift)\n\
305 \ --server-type arg (=simple) type of server, \"simple\", \"thread-pool\",\n\
306 \ \"threaded\", or \"nonblocking\"\n\
Jens Geyerd629ea02015-09-23 21:16:50 +0200307 \ --transport arg (=buffered) transport: buffered, framed\n\
Noam Zilbersteinaf5d64a2014-07-31 15:44:13 -0700308 \ --protocol arg (=binary) protocol: binary, compact, json\n\
309 \ --ssl Encrypted Transport using SSL\n\
310 \ --processor-events processor-events\n\
cdwijayarathnad9217912014-08-15 22:18:30 +0530311 \ -n [ --workers ] arg (=4) Number of thread pools workers. Only valid for\n\
Jens Geyerd629ea02015-09-23 21:16:50 +0200312 \ thread-pool server type"