gRPC-haskell/src/Network/GRPC/LowLevel/Server/Unregistered.hs

{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}

module Network.GRPC.LowLevel.Server.Unregistered where

import           Control.Exception                                  (finally)
import           Data.ByteString                                    (ByteString)
import           Network.GRPC.LowLevel.Call.Unregistered
import           Network.GRPC.LowLevel.CompletionQueue.Unregistered (serverRequestCall)
import           Network.GRPC.LowLevel.GRPC
import           Network.GRPC.LowLevel.Op                           (Op (..), OpRecvResult (..),
                                                                     runOps)
import           Network.GRPC.LowLevel.Server                       (Server (..))
import qualified Network.GRPC.Unsafe.Op                             as C

serverCreateCall :: Server -> IO (Either GRPCIOError ServerCall)
serverCreateCall Server{..} =
  serverRequestCall internalServer serverCQ

withServerCall :: Server
                  -> (ServerCall -> IO (Either GRPCIOError a))
                  -> IO (Either GRPCIOError a)
withServerCall server f = do
  createResult <- serverCreateCall server
  case createResult of
    Left x -> return $ Left x
    Right call -> f call `finally` logDestroy call
      where logDestroy c = grpcDebug "withServerCall: destroying."
                           >> destroyServerCall c

-- | 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]

-- | A handler for an unregistered server call; bytestring arguments are the
-- request body and response body respectively.
type ServerHandler
  =  ServerCall -> ByteString
  -> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)

-- | Handle one unregistered call.
serverHandleNormalCall :: Server
                       -> MetadataMap -- ^ Initial server metadata.
                       -> ServerHandler
                       -> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{..} srvMetadata f =
  withServerCall s $ \call@ServerCall{..} -> do
    grpcDebug "serverHandleNormalCall(U): starting batch."
    runOps unServerCall serverCQ
      [ OpSendInitialMetadata srvMetadata
      , OpRecvMessage
      ]
      >>= \case
        Left x -> do
          grpcDebug "serverHandleNormalCall(U): ops failed; aborting"
          return $ Left x
        Right [OpRecvMessageResult (Just body)] -> do
          grpcDebug $ "got client metadata: " ++ show requestMetadataRecv
          grpcDebug $ "call_details host is: " ++ show callHost
          (rspBody, rspMeta, status, ds) <- f call body
          runOps unServerCall serverCQ
            [ OpRecvCloseOnServer
            , OpSendMessage rspBody,
              OpSendStatusFromServer rspMeta status ds
            ]
            >>= \case
              Left x -> do
                grpcDebug "serverHandleNormalCall(U): resp failed."
                return $ Left x
              Right _ -> do
                grpcDebug "serverHandleNormalCall(U): ops done."
                return $ Right ()
        x -> error $ "impossible pattern match: " ++ show x