]>
Commit | Line | Data |
---|---|---|
f67539c2 TL |
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 #-} | |
21 | module Main where | |
22 | ||
23 | import Control.Exception | |
24 | import Control.Monad | |
25 | import Data.Functor | |
26 | import Data.HashMap.Strict (HashMap) | |
27 | import Data.List | |
28 | import Data.List.Split | |
29 | import Data.String | |
30 | import Network | |
31 | import System.Environment | |
32 | import System.Exit | |
33 | import System.IO | |
34 | import Control.Concurrent (threadDelay) | |
35 | import qualified System.IO as IO | |
36 | import qualified Data.HashMap.Strict as Map | |
37 | import qualified Data.HashSet as Set | |
38 | import qualified Data.Text.Lazy as Text | |
39 | import qualified Data.Vector as Vector | |
40 | ||
41 | import ThriftTest | |
42 | import ThriftTest_Iface | |
43 | import ThriftTest_Types | |
44 | ||
45 | import Thrift | |
46 | import Thrift.Server | |
47 | import Thrift.Transport.Framed | |
48 | import Thrift.Transport.Handle | |
49 | import Thrift.Protocol.Binary | |
50 | import Thrift.Protocol.Compact | |
51 | import Thrift.Protocol.Header | |
52 | import Thrift.Protocol.JSON | |
53 | ||
54 | data Options = Options | |
55 | { port :: Int | |
56 | , domainSocket :: String | |
57 | , serverType :: ServerType | |
58 | , transport :: String | |
59 | , protocol :: ProtocolType | |
60 | , ssl :: Bool | |
61 | , workers :: Int | |
62 | } | |
63 | ||
64 | data ServerType = Simple | |
65 | | ThreadPool | |
66 | | Threaded | |
67 | | NonBlocking | |
68 | deriving (Show, Eq) | |
69 | ||
70 | instance 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 | ||
77 | data TransportType = Buffered (Socket -> (IO IO.Handle)) | |
78 | | Framed (Socket -> (IO (FramedTransport IO.Handle))) | |
79 | | NoTransport String | |
80 | ||
81 | getTransport :: String -> TransportType | |
82 | getTransport "buffered" = Buffered $ \s -> do | |
83 | (h, _, _) <- (accept s) | |
84 | IO.hSetBuffering h $ IO.BlockBuffering Nothing | |
85 | return h | |
86 | getTransport "framed" = Framed $ \s -> do | |
87 | (h, _, _) <- (accept s) | |
88 | openFramedTransport h | |
89 | getTransport t = NoTransport $ "Unsupported transport: " ++ t | |
90 | ||
91 | data ProtocolType = Binary | |
92 | | Compact | |
93 | | JSON | |
94 | | Header | |
95 | ||
96 | getProtocol :: String -> ProtocolType | |
97 | getProtocol "binary" = Binary | |
98 | getProtocol "compact" = Compact | |
99 | getProtocol "json" = JSON | |
100 | getProtocol "header" = Header | |
101 | getProtocol p = error $"Unsupported Protocol: " ++ p | |
102 | ||
103 | defaultOptions :: Options | |
104 | defaultOptions = Options | |
105 | { port = 9090 | |
106 | , domainSocket = "" | |
107 | , serverType = Threaded | |
108 | , transport = "buffered" | |
109 | , protocol = Binary | |
110 | -- TODO: Haskell lib does not have SSL support | |
111 | , ssl = False | |
112 | , workers = 4 | |
113 | } | |
114 | ||
115 | stringifyMap :: (Show a, Show b) => Map.HashMap a b -> String | |
116 | stringifyMap = Data.List.intercalate ", " . Data.List.map joinKV . Map.toList | |
117 | where joinKV (k, v) = show k ++ " => " ++ show v | |
118 | ||
119 | stringifySet :: Show a => Set.HashSet a -> String | |
120 | stringifySet = Data.List.intercalate ", " . Data.List.map show . Set.toList | |
121 | ||
122 | stringifyList :: Show a => Vector.Vector a -> String | |
123 | stringifyList = Data.List.intercalate ", " . Data.List.map show . Vector.toList | |
124 | ||
125 | data TestHandler = TestHandler | |
126 | instance ThriftTest_Iface TestHandler where | |
127 | testVoid _ = System.IO.putStrLn "testVoid()" | |
128 | ||
129 | testString _ s = do | |
130 | System.IO.putStrLn $ "testString(" ++ show s ++ ")" | |
131 | return s | |
132 | ||
133 | testBool _ x = do | |
134 | System.IO.putStrLn $ "testBool(" ++ show x ++ ")" | |
135 | return x | |
136 | ||
137 | testByte _ x = do | |
138 | System.IO.putStrLn $ "testByte(" ++ show x ++ ")" | |
139 | return x | |
140 | ||
141 | testI32 _ x = do | |
142 | System.IO.putStrLn $ "testI32(" ++ show x ++ ")" | |
143 | return x | |
144 | ||
145 | testI64 _ x = do | |
146 | System.IO.putStrLn $ "testI64(" ++ show x ++ ")" | |
147 | return x | |
148 | ||
149 | testDouble _ x = do | |
150 | System.IO.putStrLn $ "testDouble(" ++ show x ++ ")" | |
151 | return x | |
152 | ||
153 | testBinary _ x = do | |
154 | System.IO.putStrLn $ "testBinary(" ++ show x ++ ")" | |
155 | return x | |
156 | ||
157 | testStruct _ struct@Xtruct{..} = do | |
158 | System.IO.putStrLn $ "testStruct({" ++ show xtruct_string_thing | |
159 | ++ ", " ++ show xtruct_byte_thing | |
160 | ++ ", " ++ 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 | |
167 | System.IO.putStrLn $ "testNest({" ++ show xtruct2_byte_thing | |
168 | ++ "{, " ++ 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 | |
176 | System.IO.putStrLn $ "testMap({" ++ stringifyMap m ++ "})" | |
177 | return m | |
178 | ||
179 | testStringMap _ m = do | |
180 | System.IO.putStrLn $ "testStringMap(" ++ stringifyMap m ++ "})" | |
181 | return m | |
182 | ||
183 | testSet _ x = do | |
184 | System.IO.putStrLn $ "testSet({" ++ stringifySet x ++ "})" | |
185 | return x | |
186 | ||
187 | testList _ x = do | |
188 | System.IO.putStrLn $ "testList(" ++ stringifyList x ++ "})" | |
189 | return x | |
190 | ||
191 | testEnum _ x = do | |
192 | System.IO.putStrLn $ "testEnum(" ++ show x ++ ")" | |
193 | return x | |
194 | ||
195 | testTypedef _ x = do | |
196 | System.IO.putStrLn $ "testTypedef(" ++ show x ++ ")" | |
197 | return x | |
198 | ||
199 | testMapMap _ x = do | |
200 | System.IO.putStrLn $ "testMapMap(" ++ show x ++ ")" | |
201 | 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 | |
214 | System.IO.putStrLn "testInsanity()" | |
215 | 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 | |
223 | System.IO.putStrLn "testMulti()" | |
224 | return Xtruct{ xtruct_string_thing = Text.pack "Hello2" | |
225 | , xtruct_byte_thing = byte | |
226 | , xtruct_i32_thing = i32 | |
227 | , xtruct_i64_thing = i64 | |
228 | } | |
229 | ||
230 | testException _ s = do | |
231 | System.IO.putStrLn $ "testException(" ++ show s ++ ")" | |
232 | case s of | |
233 | "Xception" -> throw $ Xception 1001 s | |
234 | "TException" -> throw ThriftException | |
235 | _ -> return () | |
236 | ||
237 | testMultiException _ s1 s2 = do | |
238 | System.IO.putStrLn $ "testMultiException(" ++ show s1 ++ ", " ++ show s2 ++ ")" | |
239 | case s1 of | |
240 | "Xception" -> throw $ Xception 1001 "This is an Xception" | |
241 | "Xception2" -> throw $ Xception2 2002 $ Xtruct "This is an Xception2" 0 0 0 | |
242 | "TException" -> throw ThriftException | |
243 | _ -> return default_Xtruct{ xtruct_string_thing = s2 } | |
244 | ||
245 | testOneway _ i = do | |
246 | System.IO.putStrLn $ "testOneway(" ++ show i ++ "): Sleeping..." | |
247 | threadDelay $ (fromIntegral i) * 1000000 | |
248 | System.IO.putStrLn $ "testOneway(" ++ show i ++ "): done sleeping!" | |
249 | ||
250 | main :: IO () | |
251 | main = do | |
252 | options <- flip parseFlags defaultOptions <$> getArgs | |
253 | case options of | |
254 | Nothing -> showHelp | |
255 | Just Options{..} -> do | |
256 | case Main.getTransport transport of | |
257 | Buffered f -> runServer protocol f port | |
258 | Framed f -> runServer protocol f port | |
259 | NoTransport err -> putStrLn err | |
260 | System.IO.putStrLn $ "Starting \"" ++ show serverType ++ "\" server (" ++ | |
261 | show transport ++ ") listen on: " ++ domainSocket ++ show port | |
262 | where | |
263 | acceptor p f socket = do | |
264 | t <- f socket | |
265 | return (p t, p t) | |
266 | ||
267 | headerAcceptor f socket = do | |
268 | t <- f socket | |
269 | p <- createHeaderProtocol1 t | |
270 | return (p, p) | |
271 | ||
272 | doRunServer p f = do | |
273 | runThreadedServer (acceptor p f) TestHandler ThriftTest.process . PortNumber . fromIntegral | |
274 | ||
275 | runServer p f port = case p of | |
276 | 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) | |
280 | ||
281 | parseFlags :: [String] -> Options -> Maybe Options | |
282 | parseFlags (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 } | |
291 | "-n" : arg : _ -> parseFlags flags opts{ workers = read arg } | |
292 | "--h" : _ -> Nothing | |
293 | "--help" : _ -> Nothing | |
294 | "--ssl" : _ -> parseFlags flags opts{ ssl = True } | |
295 | "--processor-events" : _ -> parseFlags flags opts | |
296 | _ -> Nothing | |
297 | parseFlags [] opts = Just opts | |
298 | ||
299 | showHelp :: IO () | |
300 | showHelp = System.IO.putStrLn | |
301 | "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\ | |
307 | \ --transport arg (=buffered) transport: buffered, framed\n\ | |
308 | \ --protocol arg (=binary) protocol: binary, compact, json\n\ | |
309 | \ --ssl Encrypted Transport using SSL\n\ | |
310 | \ --processor-events processor-events\n\ | |
311 | \ -n [ --workers ] arg (=4) Number of thread pools workers. Only valid for\n\ | |
312 | \ thread-pool server type" |