2016-06-08 18:18:43 +02:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
|
|
|
|
module Network.GRPC.LowLevel.Server.Unregistered where
|
|
|
|
|
2016-06-08 19:45:47 +02:00
|
|
|
import Control.Exception (finally)
|
|
|
|
import Data.ByteString (ByteString)
|
|
|
|
import Network.GRPC.LowLevel.Call (MethodName)
|
2016-06-08 18:18:43 +02:00
|
|
|
import Network.GRPC.LowLevel.Call.Unregistered
|
2016-06-08 19:45:47 +02:00
|
|
|
import Network.GRPC.LowLevel.CompletionQueue (TimeoutSeconds)
|
2016-06-08 22:53:09 +02:00
|
|
|
import Network.GRPC.LowLevel.CompletionQueue.Unregistered (serverRequestCall)
|
2016-06-08 18:18:43 +02:00
|
|
|
import Network.GRPC.LowLevel.GRPC
|
2016-06-13 22:51:53 +02:00
|
|
|
import Network.GRPC.LowLevel.Op (Op(..), OpRecvResult (..), runOps)
|
|
|
|
import Network.GRPC.LowLevel.Server (Server (..))
|
2016-06-08 19:45:47 +02:00
|
|
|
import qualified Network.GRPC.Unsafe.Op as C
|
2016-06-08 18:18:43 +02:00
|
|
|
|
2016-06-08 18:50:57 +02:00
|
|
|
serverCreateCall :: Server -> TimeoutSeconds
|
2016-06-08 18:41:58 +02:00
|
|
|
-> IO (Either GRPCIOError ServerCall)
|
2016-06-08 18:50:57 +02:00
|
|
|
serverCreateCall Server{..} timeLimit =
|
2016-06-08 22:53:09 +02:00
|
|
|
serverRequestCall internalServer serverCQ timeLimit
|
2016-06-08 18:18:43 +02:00
|
|
|
|
2016-06-08 18:50:57 +02:00
|
|
|
withServerCall :: Server -> TimeoutSeconds
|
2016-06-08 18:41:58 +02:00
|
|
|
-> (ServerCall -> IO (Either GRPCIOError a))
|
2016-06-08 18:18:43 +02:00
|
|
|
-> IO (Either GRPCIOError a)
|
2016-06-08 18:50:57 +02:00
|
|
|
withServerCall server timeout f = do
|
|
|
|
createResult <- serverCreateCall server timeout
|
2016-06-08 18:18:43 +02:00
|
|
|
case createResult of
|
|
|
|
Left x -> return $ Left x
|
|
|
|
Right call -> f call `finally` logDestroy call
|
|
|
|
where logDestroy c = grpcDebug "withServerCall: destroying."
|
2016-06-08 18:41:58 +02:00
|
|
|
>> destroyServerCall c
|
2016-06-08 18:18:43 +02:00
|
|
|
|
2016-06-13 22:51:53 +02:00
|
|
|
-- | Sequence of 'Op's needed to receive a normal (non-streaming) call.
|
|
|
|
-- TODO: We have to put 'OpRecvCloseOnServer' in the response ops, or else the
|
|
|
|
-- client times out. Given this, I have no idea how to check for cancellation on
|
|
|
|
-- the server.
|
|
|
|
serverOpsGetNormalCall :: MetadataMap -> [Op]
|
|
|
|
serverOpsGetNormalCall initMetadata =
|
|
|
|
[OpSendInitialMetadata initMetadata,
|
|
|
|
OpRecvMessage]
|
|
|
|
|
|
|
|
-- | Sequence of 'Op's needed to respond to a normal (non-streaming) call.
|
|
|
|
serverOpsSendNormalResponse :: ByteString
|
|
|
|
-> MetadataMap
|
|
|
|
-> C.StatusCode
|
|
|
|
-> StatusDetails
|
|
|
|
-> [Op]
|
|
|
|
serverOpsSendNormalResponse body metadata code details =
|
|
|
|
[OpRecvCloseOnServer,
|
|
|
|
OpSendMessage body,
|
|
|
|
OpSendStatusFromServer metadata code details]
|
|
|
|
|
2016-06-08 18:50:57 +02:00
|
|
|
-- | A handler for an unregistered server call; bytestring arguments are the
|
|
|
|
-- request body and response body respectively.
|
|
|
|
type ServerHandler
|
2016-06-13 22:51:53 +02:00
|
|
|
= ServerCall -> ByteString -> MetadataMap -> MethodName
|
2016-06-16 17:23:54 +02:00
|
|
|
-> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)
|
2016-06-08 18:50:57 +02:00
|
|
|
|
2016-06-08 18:18:43 +02:00
|
|
|
-- | Handle one unregistered call.
|
2016-06-08 18:50:57 +02:00
|
|
|
serverHandleNormalCall :: Server
|
|
|
|
-> TimeoutSeconds
|
|
|
|
-> MetadataMap -- ^ Initial server metadata.
|
|
|
|
-> ServerHandler
|
|
|
|
-> IO (Either GRPCIOError ())
|
2016-06-08 18:18:43 +02:00
|
|
|
serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do
|
2016-06-08 18:50:57 +02:00
|
|
|
withServerCall s timeLimit $ \call -> do
|
2016-06-08 21:38:01 +02:00
|
|
|
grpcDebug "serverHandleNormalCall(U): starting batch."
|
2016-06-08 18:18:43 +02:00
|
|
|
let recvOps = serverOpsGetNormalCall srvMetadata
|
2016-06-08 22:53:09 +02:00
|
|
|
call' = unServerCall call
|
2016-06-15 19:30:17 +02:00
|
|
|
opResults <- runOps call' serverCQ recvOps
|
2016-06-08 18:18:43 +02:00
|
|
|
case opResults of
|
2016-06-08 18:50:57 +02:00
|
|
|
Left x -> do grpcDebug "serverHandleNormalCall(U): ops failed; aborting"
|
2016-06-08 18:18:43 +02:00
|
|
|
return $ Left x
|
|
|
|
Right [OpRecvMessageResult (Just body)] -> do
|
2016-06-08 18:41:58 +02:00
|
|
|
requestMeta <- serverCallGetMetadata call
|
2016-06-08 18:18:43 +02:00
|
|
|
grpcDebug $ "got client metadata: " ++ show requestMeta
|
2016-06-08 18:41:58 +02:00
|
|
|
methodName <- serverCallGetMethodName call
|
|
|
|
hostName <- serverCallGetHost call
|
2016-06-08 18:18:43 +02:00
|
|
|
grpcDebug $ "call_details host is: " ++ show hostName
|
2016-06-16 17:23:54 +02:00
|
|
|
(respBody, respMetadata, status, details) <- f call
|
|
|
|
body
|
|
|
|
requestMeta
|
|
|
|
methodName
|
2016-06-08 18:18:43 +02:00
|
|
|
let respOps = serverOpsSendNormalResponse
|
|
|
|
respBody respMetadata status details
|
2016-06-15 19:30:17 +02:00
|
|
|
respOpsResults <- runOps call' serverCQ respOps
|
2016-06-08 18:18:43 +02:00
|
|
|
case respOpsResults of
|
2016-06-08 18:50:57 +02:00
|
|
|
Left x -> do grpcDebug "serverHandleNormalCall(U): resp failed."
|
2016-06-08 18:18:43 +02:00
|
|
|
return $ Left x
|
2016-06-08 18:50:57 +02:00
|
|
|
Right _ -> grpcDebug "serverHandleNormalCall(U): ops done."
|
2016-06-08 18:18:43 +02:00
|
|
|
>> return (Right ())
|
|
|
|
x -> error $ "impossible pattern match: " ++ show x
|