gRPC-haskell/examples/echo/echo-server/Main.hs
Joel Stanley 72160cea89 Fixes a concurrency bug wherein a thread (running beyond the maximum number of
pluckers) would register a CQ notification via
grpc_server_request_registered_call prior to obtaining pluck permission, block
on acquiring such permission, and thus miss notification of the server call.

The bug can could be witnessed with particular interleavings by ensuring that
GRPC_MAX_COMPLETION_QUEUE_PLUCKERS server threads are blocked on their own
server call notifications, and then using the
(GRPC_MAX_COMPLETION_QUEUE_PLUCKERS+1)th server thread to attempt to block on a
notification for an additional server call.

In order to fix this, we simply extended the pluck permission held window for
serverRequestCall, and created a variant of pluck (called pluck') which assumes
permission to pluck is already held by the calling thread.
2016-07-10 17:15:57 -05:00

76 lines
2.9 KiB
Haskell

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
import Data.ByteString (ByteString)
import Network.GRPC.LowLevel
import Network.GRPC.LowLevel.Call
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
serverMeta :: MetadataMap
serverMeta = [("test_meta", "test_meta_value")]
handler :: U.ServerCall
-> ByteString
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
handler U.ServerCall{..} reqBody = do
--putStrLn $ "Got request for method: " ++ show method
--putStrLn $ "Got metadata: " ++ show reqMeta
return (reqBody, serverMeta, StatusOk, StatusDetails "")
unregMain :: IO ()
unregMain = withGRPC $ \grpc -> do
withServer grpc (ServerConfig "localhost" 50051 [] []) $ \server -> forever $ do
result <- U.serverHandleNormalCall server serverMeta handler
case result of
Left x -> putStrLn $ "handle call result error: " ++ show x
Right _ -> return ()
regMain :: IO ()
regMain = withGRPC $ \grpc -> do
let methods = [(MethodName "/echo.Echo/DoEcho", Normal)]
withServer grpc (ServerConfig "localhost" 50051 methods []) $ \server ->
forever $ do
let method = head (normalMethods server)
result <- serverHandleNormalCall server method serverMeta $
\_call reqBody _reqMeta -> return (reqBody, serverMeta, StatusOk,
StatusDetails "")
case result of
Left x -> putStrLn $ "registered call result error: " ++ show x
Right _ -> return ()
tputStrLn x = do
tid <- myThreadId
putStrLn $ "[" ++ show tid ++ "]: " ++ x
regLoop :: Server -> RegisteredMethod 'Normal -> IO ()
regLoop server method = forever $ do
-- tputStrLn "about to block on call handler"
result <- serverHandleNormalCall server method serverMeta $
\_call reqBody _reqMeta ->
return (reqBody, serverMeta, StatusOk, StatusDetails "")
case result of
Left x -> error $! "registered call result error: " ++ show x
Right _ -> return ()
regMainThreaded :: IO ()
regMainThreaded = do
withGRPC $ \grpc -> do
let methods = [(MethodName "/echo.Echo/DoEcho", Normal)]
withServer grpc (ServerConfig "localhost" 50051 methods []) $ \server -> do
let method = head (normalMethods server)
tids <- replicateM 7 $ async $ do tputStrLn "starting handler"
regLoop server method
waitAnyCancel tids
tputStrLn "finishing"
main :: IO ()
main = regMainThreaded