f67c45d · curryer · git.iko.soy

git.iko.soy/curryer

convert thrown TimeoutException into TimeoutError in client

commitf67c45d1bfcb753d32ed3fe51b8e07b4c021c9bb authorAgentM <agentm@themactionfaction.com> dateSat 19 Dec 2020, 22:52 (6 years ago) parent54d72a1

2 files changed+42−7

compare with master

unifiedsplit

src/Network/RPC/Curryer/Server.hs+19−6 test/Curryer/Test/Basic.hs+23−1

src/Network/RPC/Curryer/Server.hs+19−6

@@ -42,7 +42,7 @@ import Foreign.ForeignPtr (plusForeignPtr)

4242import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

4343import GHC.Ptr (plusPtr)

4444-}

45−-- #define CURRYER_SHOW_BYTES 1

45+-- define CURRYER_SHOW_BYTES 1

4646#if CURRYER_SHOW_BYTES == 1

4747import Debug.Trace

4848#endif

@@ -144,6 +144,11 @@ data ConnectionError = CodecError String -- show of WineryException from excepti

144144 deriving (Generic, Show, Eq)

145145 deriving Serialise via WineryVariant ConnectionError

146146

147+data TimeoutException = TimeoutException

148+ deriving Show

149+

150+instance Exception TimeoutException

151+

147152type HostAddr = (Word8, Word8, Word8, Word8)

148153

149154allHostAddrs,localHostAddr :: HostAddr

@@ -161,7 +166,11 @@ envelopeP = do

161166 (P.satisfy (== 3) $> ExceptionResponseMessage)

162167 lenPrefixedByteStringP = do

163168 c <- fromIntegral <$> word32P

164− BS.pack <$> P.takeEQ c s

169+ --streamly can't handle takeEQ 0, so add special handling

170+ if c == 0 then

171+ pure BS.empty

172+ else

173+ BS.pack <$> P.takeEQ c s

165174 Envelope <$> fingerprintP <*> msgTypeP <*> uuidP <*> lenPrefixedByteStringP

166175

167176encodeEnvelope :: Envelope -> BS.ByteString

@@ -262,10 +271,13 @@ serverEnvelopeHandler sockLock msgHandlers serverState envelope@(Envelope _ (Req

262271 let runTimeout :: IO b -> IO (Maybe b)

263272 runTimeout m =

264273 if timeoutms == 0 then

265− Just <$> m

274+ (Just <$> m) `catch` timeoutExcHandler

266275 else

267− timeout (fromIntegral timeoutms) m

268−

276+ (timeout (fromIntegral timeoutms) m) `catch` timeoutExcHandler

277+ --allow server-side function to throw TimeoutError which is caught here and becomes TimeoutError value

278+ timeoutExcHandler :: TimeoutException -> IO (Maybe b)

279+ timeoutExcHandler _ = pure Nothing

280+

269281 sState = ConnectionState {

270282 connectionServerState = serverState,

271283 connectionSocket = sockLock

@@ -281,7 +293,7 @@ serverEnvelopeHandler sockLock msgHandlers serverState envelope@(Envelope _ (Req

281293 case mResponse of

282294 Just response ->

283295 Envelope (fingerprint response) ResponseMessage msgId (serialise response)

284− Nothing ->

296+ Nothing ->

285297 Envelope (fingerprint TimeoutError) TimeoutResponseMessage msgId BS.empty

286298 sendEnvelope envelopeResponse sockLock

287299 pure (Just ())

@@ -315,6 +327,7 @@ sendEnvelope envelope sockLock = do

315327 --Socket.sendAll syscalls send() on a loop until all the bytes are sent, so we need socket locking here to account for serialized messages of size > PIPE_BUF

316328 withLock sockLock $ \socket' ->

317329 Socket.sendAll socket' fullbytes

330+ --traceShowM ("sendEnvelope", envelope)

318331 traceBytes "sendEnvelope" fullbytes

319332

320333fingerprint :: Typeable a => a -> Fingerprint

test/Curryer/Test/Basic.hs+23−1

@@ -10,6 +10,7 @@ import Control.Concurrent.Async

1010import Control.Monad

1111import Control.Concurrent

1212import Control.Concurrent.STM

13+import Control.Exception

1314import Data.List

1415

1516import Network.RPC.Curryer.Server

@@ -25,6 +26,7 @@ testTree = testGroup "basic" [testCase "simple" testSimpleCall

2526 ,testCase "server-side exception" testSyncException

2627 ,testCase "multi-threaded client" testMultithreadedClient

2728 ,testCase "server state" testServerState

29+ ,testCase "request handler throws timeout" testRequestHandlerThrowTimeout

2830 ]

2931

3032

@@ -61,6 +63,10 @@ data AsyncHelloReq = AsyncHelloReq String

6163 deriving (Generic, Show)

6264 deriving Serialise via WineryVariant AsyncHelloReq

6365

66+data ThrowTimeout = ThrowTimeout

67+ deriving (Generic, Show)

68+ deriving Serialise via WineryVariant ThrowTimeout

69+

6470testServerRequestHandlers :: Maybe (MVar String) -> RequestHandlers ()

6571testServerRequestHandlers mAsyncMVar =

6672 [ RequestHandler $ \_ (AddTwoNumbersReq x y) -> pure (x + y)

@@ -202,5 +208,21 @@ testServerState = do

202208 assertEqual "server state" 2 serverState'

203209 close conn

204210 cancel server

205−

206211

212+--test that the request handler can throw a TimeoutError exception which is converted into a TimeoutError response

213+testRequestHandlerThrowTimeout :: Assertion

214+testRequestHandlerThrowTimeout = do

215+ readyVar <- newEmptyMVar

216+

217+ let serverHandlers = [RequestHandler (\_ ThrowTimeout ->

218+ throw TimeoutException >> pure (1 :: Int)

219+ )

220+ ]

221+ server <- async (serve serverHandlers () localHostAddr 0 (Just readyVar))

222+ (SockAddrInet port _) <- takeMVar readyVar

223+ conn <- connect [] localHostAddr port

224+ ret <- call @_ @Int conn ThrowTimeout

225+ assertEqual "handler timeout exception" (Left TimeoutError) ret

226+ close conn

227+ cancel server

228+