{-# 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 :: forall a. 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 forall a b. (a -> b) -> a -> b
$ Text -> MessageType -> Int32 -> Value TStruct -> Message
Message Text
m MessageType
Oneway Int32
0 (forall a. Pinchable a => a -> Value (Tag a)
pinch req
r)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      TCall Text
m req
r -> do
        Channel -> Message -> IO ()
writeMessage Channel
chan forall a b. (a -> b) -> a -> b
$ Text -> MessageType -> Int32 -> Value TStruct -> Message
Message Text
m MessageType
Call Int32
0 (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 -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError forall a b. (a -> b) -> a -> b
$ Text
"Reached EOF while awaiting reply"
          RRFailure String
err -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError forall a b. (a -> b) -> a -> b
$ Text
"Could not read message: " 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 forall a. Parser a -> Either String a
runParser forall a b. (a -> b) -> a -> b
$ forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch forall a b. (a -> b) -> a -> b
$ Message -> Value TStruct
messagePayload Message
reply' of
              Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
              Left String
err -> do
                forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError forall a b. (a -> b) -> a -> b
$ Text
"Could not parse reply payload: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
            MessageType
Exception -> case forall a. Parser a -> Either String a
runParser forall a b. (a -> b) -> a -> b
$ forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch forall a b. (a -> b) -> a -> b
$ Message -> Value TStruct
messagePayload Message
reply' of
              Right (ApplicationException
x :: ApplicationException) -> forall e a. Exception e => e -> IO a
throwIO ApplicationException
x
              Left String
err ->
                forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError forall a b. (a -> b) -> a -> b
$ Text
"Could not parse application exception: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
            MessageType
t -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> ThriftError
ThriftError forall a b. (a -> b) -> a -> b
$ Text
"Expected reply or exception, got " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show MessageType
t) 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 :: forall c a.
(ThriftClient c, ThriftResult a) =>
c -> ThriftCall a -> IO (ResultType a)
callOrThrow c
client' ThriftCall a
c = forall c a. ThriftClient c => c -> ThriftCall a -> IO a
call c
client' ThriftCall a
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall c. ThriftClient c => c -> ServiceName -> MultiplexClient
multiplexClient = forall c. ThriftClient c => c -> ServiceName -> MultiplexClient
MultiplexClient

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