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)
|
|
|
|
import qualified Network.GRPC.LowLevel.CompletionQueue.Unregistered as U
|
2016-06-08 18:18:43 +02:00
|
|
|
import Network.GRPC.LowLevel.GRPC
|
2016-06-08 19:45:47 +02:00
|
|
|
import Network.GRPC.LowLevel.Op (OpRecvResult (..))
|
|
|
|
import qualified Network.GRPC.LowLevel.Op.Unregistered as U
|
2016-06-08 21:38:01 +02:00
|
|
|
import Network.GRPC.LowLevel.Server (Server (..),
|
|
|
|
serverOpsGetNormalCall,
|
|
|
|
serverOpsSendNormalResponse)
|
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 19:45:47 +02:00
|
|
|
U.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-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
|
|
|
|
= ByteString -> MetadataMap -> MethodName
|
|
|
|
-> IO (ByteString, MetadataMap, StatusDetails)
|
|
|
|
|
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 19:45:47 +02:00
|
|
|
opResults <- U.runServerOps call serverCQ recvOps timeLimit
|
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
|
|
|
|
(respBody, respMetadata, details) <- f body requestMeta methodName
|
|
|
|
let status = C.GrpcStatusOk
|
|
|
|
let respOps = serverOpsSendNormalResponse
|
|
|
|
respBody respMetadata status details
|
2016-06-08 19:45:47 +02:00
|
|
|
respOpsResults <- U.runServerOps call serverCQ respOps timeLimit
|
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
|