{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}

module Pinch.Client
  (
    -- * Basic Thrift client
    Client
  , client
  , Channel
  , createChannel
  , createChannel1

  , ThriftCall(..)
  , ThriftClient(..)
  , callOrThrow

    -- * Multiplexing Client
  , MultiplexClient
  , multiplexClient


    -- * Errors
  , ApplicationException(..)
  , ExceptionType(..)
  , ThriftError(..)
  ) where

import           Control.Exception        (throwIO)

import qualified Data.Text                as T

import           Pinch.Internal.Exception
import           Pinch.Internal.Message
import           Pinch.Internal.Pinchable
import           Pinch.Internal.RPC
import           Pinch.Internal.TType

-- | A simple Thrift Client.
newtype Client = Client Channel

-- | Instantiates a new Thrift client.
client :: Channel -> Client
client :: Channel -> Client
client = Channel -> Client
Client

-- | A call to a Thrift server resulting in the return datatype `a`.
data ThriftCall a where
  TCall :: (Pinchable req, Tag req ~ TStruct, Pinchable res, Tag res ~ TStruct)
    => !T.Text -> !req -> ThriftCall res
  TOneway :: (Pinchable req, Tag req ~ TStruct) => !T.Text -> !req -> ThriftCall ()

class ThriftClient c where
  -- | Calls a Thrift service and returns the result/error data structure.
  -- Application-level exceptions defined in the thrift service are returned
  -- as part of the result/error data structure.
  call :: c -> ThriftCall a -> IO a

instance ThriftClient Client where
  call :: Client -> ThriftCall a -> IO a
call (Client Channel
chan) ThriftCall a
tcall = do
    case ThriftCall a
tcall of
      TOneway Text
m req
r -> do
        Channel -> Message -> IO ()
writeMessage Channel
chan (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> MessageType -> Int32 -> Value TStruct -> Message
Message Text
m MessageType
Oneway Int32
0 (req -> Value (Tag req)
forall a. Pinchable a => a -> Value (Tag a)
pinch req
r)
        () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      TCall Text
m req
r -> do
        Channel -> Message -> IO ()
writeMessage Channel
chan (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> MessageType -> Int32 -> Value TStruct -> Message
Message Text
m MessageType
Call Int32
0 (req -> Value (Tag req)
forall a. Pinchable a => a -> Value (Tag a)
pinch req
r)
        ReadResult Message
reply <- Channel -> IO (ReadResult Message)
readMessage Channel
chan
        case ReadResult Message
reply of
          ReadResult Message
RREOF -> ThriftError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ThriftError -> IO a) -> ThriftError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError (Text -> ThriftError) -> Text -> ThriftError
forall a b. (a -> b) -> a -> b
$ Text
"Reached EOF while awaiting reply"
          RRFailure String
err -> ThriftError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ThriftError -> IO a) -> ThriftError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError (Text -> ThriftError) -> Text -> ThriftError
forall a b. (a -> b) -> a -> b
$ Text
"Could not read message: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
          RRSuccess Message
reply' -> case Message -> MessageType
messageType Message
reply' of
            MessageType
Reply -> case Parser a -> Either String a
forall a. Parser a -> Either String a
runParser (Parser a -> Either String a) -> Parser a -> Either String a
forall a b. (a -> b) -> a -> b
$ Value (Tag a) -> Parser a
forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch (Value (Tag a) -> Parser a) -> Value (Tag a) -> Parser a
forall a b. (a -> b) -> a -> b
$ Message -> Value TStruct
messagePayload Message
reply' of
              Right a
x -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
              Left String
err -> do
                ThriftError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ThriftError -> IO a) -> ThriftError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError (Text -> ThriftError) -> Text -> ThriftError
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse reply payload: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
            MessageType
Exception -> case Parser ApplicationException -> Either String ApplicationException
forall a. Parser a -> Either String a
runParser (Parser ApplicationException -> Either String ApplicationException)
-> Parser ApplicationException
-> Either String ApplicationException
forall a b. (a -> b) -> a -> b
$ Value (Tag ApplicationException) -> Parser ApplicationException
forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch (Value (Tag ApplicationException) -> Parser ApplicationException)
-> Value (Tag ApplicationException) -> Parser ApplicationException
forall a b. (a -> b) -> a -> b
$ Message -> Value TStruct
messagePayload Message
reply' of
              Right (ApplicationException
x :: ApplicationException) -> ApplicationException -> IO a
forall e a. Exception e => e -> IO a
throwIO ApplicationException
x
              Left String
err ->
                ThriftError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ThriftError -> IO a) -> ThriftError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError (Text -> ThriftError) -> Text -> ThriftError
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse application exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
            MessageType
t -> ThriftError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ThriftError -> IO a) -> ThriftError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError (Text -> ThriftError) -> Text -> ThriftError
forall a b. (a -> b) -> a -> b
$ Text
"Expected reply or exception, got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (MessageType -> String
forall a. Show a => a -> String
show MessageType
t) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

-- | Calls a Thrift service. If an application-level thrift exception as defined in the Thrift service definition
-- is returned by the server, it will be re-thrown using `throwIO`.
callOrThrow :: (ThriftClient c, ThriftResult a) => c -> ThriftCall a -> IO (ResultType a)
callOrThrow :: c -> ThriftCall a -> IO (ResultType a)
callOrThrow c
client' ThriftCall a
c = c -> ThriftCall a -> IO a
forall c a. ThriftClient c => c -> ThriftCall a -> IO a
call c
client' ThriftCall a
c IO a -> (a -> IO (ResultType a)) -> IO (ResultType a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (ResultType a)
forall a. ThriftResult a => a -> IO (ResultType a)
unwrap

-- | A multiplexing thrift client.
data MultiplexClient = forall c . ThriftClient c => MultiplexClient c ServiceName

-- | Create a new multiplexing thrift client targeting the given service.
multiplexClient :: ThriftClient c => c -> ServiceName -> MultiplexClient
multiplexClient :: c -> ServiceName -> MultiplexClient
multiplexClient = c -> ServiceName -> MultiplexClient
forall c. ThriftClient c => c -> ServiceName -> MultiplexClient
MultiplexClient

instance ThriftClient MultiplexClient where
  call :: MultiplexClient -> ThriftCall a -> IO a
call (MultiplexClient c
client' (ServiceName Text
serviceName)) ThriftCall a
tcall = case ThriftCall a
tcall of
    TOneway Text
r req
req -> c -> ThriftCall () -> IO ()
forall c a. ThriftClient c => c -> ThriftCall a -> IO a
call c
client' (ThriftCall () -> IO ()) -> ThriftCall () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> req -> ThriftCall ()
forall req.
(Pinchable req, Tag req ~ TStruct) =>
Text -> req -> ThriftCall ()
TOneway (Text
serviceName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r) req
req
    TCall Text
r req
req   -> c -> ThriftCall a -> IO a
forall c a. ThriftClient c => c -> ThriftCall a -> IO a
call c
client' (ThriftCall a -> IO a) -> ThriftCall a -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> req -> ThriftCall a
forall req res.
(Pinchable req, Tag req ~ TStruct, Pinchable res,
 Tag res ~ TStruct) =>
Text -> req -> ThriftCall res
TCall (Text
serviceName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r) req
req