{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE LiberalTypeSynonyms        #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.ManagedProcess.UnsafeClient
-- Copyright   :  (c) Tim Watson 2012 - 2017
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- Unsafe variant of the /Managed Process Client API/. This module implements
-- the client portion of a Managed Process using the unsafe variants of cloud
-- haskell's messaging primitives. It relies on the -extras implementation of
-- @UnsafePrimitives@, which forces evaluation for types that provide an
-- @NFData@ instance. Direct use of the underlying unsafe primitives (from
-- the distributed-process library) without @NFData@ instances is unsupported.
--
-- IMPORTANT NOTE: As per the platform documentation, it is not possible to
-- /guarantee/ that an @NFData@ instance will force evaluation in the same way
-- that a @Binary@ instance would (when encoding to a byte string). Please read
-- the unsafe primitives documentation carefully and make sure you know what
-- you're doing. You have been warned.
--
-- See "Control.Distributed.Process.Extras".
-- See "Control.Distributed.Process.Extras.UnsafePrimitives".
-- See "Control.Distributed.Process.UnsafePrimitives".
-----------------------------------------------------------------------------

-- TODO: This module is basically cut+paste duplicaton of the /safe/ Client - fix
-- Caveats... we've got to support two different type constraints, somehow, so
-- that the correct implementation gets used depending on whether or not we're
-- passing NFData or just Binary instances...

module Control.Distributed.Process.ManagedProcess.UnsafeClient
  ( -- * Unsafe variants of the Client API
    sendControlMessage
  , shutdown
  , call
  , safeCall
  , tryCall
  , callTimeout
  , flushPendingCalls
  , callAsync
  , cast
  , callChan
  , syncCallChan
  , syncSafeCallChan
  ) where

import Control.Distributed.Process
  ( Process
  , ProcessId
  , ReceivePort
  , newChan
  , matchChan
  , match
  , die
  , terminate
  , receiveTimeout
  , unsafeSendChan
  , getSelfPid
  , catchesExit
  , handleMessageIf
  )
import Control.Distributed.Process.Async
  ( Async
  , async
  , task
  )
import Control.Distributed.Process.Extras
  ( awaitResponse
  , Addressable
  , Routable(..)
  , NFSerializable
  , ExitReason(..)
  , Shutdown(..)
  )
import Control.Distributed.Process.ManagedProcess.Internal.Types
  ( Message(CastMessage, ChanMessage)
  , CallResponse(..)
  , ControlPort(..)
  , unsafeInitCall
  , waitResponse
  )
import Control.Distributed.Process.Extras.Time
  ( TimeInterval
  , asTimeout
  )
import Control.Distributed.Process.Serializable hiding (SerializableDict)
import Data.Maybe (fromJust)

-- | Send a control message over a 'ControlPort'. This version of
-- @shutdown@ uses /unsafe primitives/.
--
sendControlMessage :: Serializable m => ControlPort m -> m -> Process ()
sendControlMessage :: forall m. Serializable m => ControlPort m -> m -> Process ()
sendControlMessage ControlPort m
cp m
m = SendPort (Message m ()) -> Message m () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
unsafeSendChan (ControlPort m -> SendPort (Message m ())
forall m. ControlPort m -> SendPort (Message m ())
unPort ControlPort m
cp) (m -> Message m ()
forall a b. a -> Message a b
CastMessage m
m)

-- | Send a signal instructing the process to terminate. This version of
-- @shutdown@ uses /unsafe primitives/.
shutdown :: ProcessId -> Process ()
shutdown :: ProcessId -> Process ()
shutdown ProcessId
pid = ProcessId -> Shutdown -> Process ()
forall a m.
(Addressable a, NFSerializable m) =>
a -> m -> Process ()
cast ProcessId
pid Shutdown
Shutdown

-- | Make a synchronous call - uses /unsafe primitives/.
call :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
                 => s -> a -> Process b
call :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
call s
sid a
msg = s -> a -> Process (CallRef b)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (CallRef b)
unsafeInitCall s
sid a
msg Process (CallRef b)
-> (CallRef b -> Process (Maybe (Either ExitReason b)))
-> Process (Maybe (Either ExitReason b))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
forall b.
Serializable b =>
Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
waitResponse Maybe TimeInterval
forall a. Maybe a
Nothing Process (Maybe (Either ExitReason b))
-> (Maybe (Either ExitReason b) -> Process b) -> Process b
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Either ExitReason b) -> Process b
forall {a} {a}.
(Binary a, Typeable a) =>
Maybe (Either a a) -> Process a
decodeResult
  where decodeResult :: Maybe (Either a a) -> Process a
decodeResult (Just (Right a
r))  = a -> Process a
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
        decodeResult (Just (Left a
err)) = a -> Process a
forall a b. Serializable a => a -> Process b
die a
err
        decodeResult Maybe (Either a a)
Nothing {- the impossible happened -} = Process a
forall a. Process a
terminate

-- | Safe version of 'call' that returns information about the error
-- if the operation fails - uses /unsafe primitives/.
safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
                 => s -> a -> Process (Either ExitReason b)
safeCall :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (Either ExitReason b)
safeCall s
s a
m = do
  ProcessId
us <- Process ProcessId
getSelfPid
  ((Maybe (Either ExitReason b) -> Either ExitReason b)
-> Process (Maybe (Either ExitReason b))
-> Process (Either ExitReason b)
forall a b. (a -> b) -> Process a -> Process b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Either ExitReason b) -> Either ExitReason b
forall a. HasCallStack => Maybe a -> a
fromJust (s -> a -> Process (CallRef b)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (CallRef b)
unsafeInitCall s
s a
m Process (CallRef b)
-> (CallRef b -> Process (Maybe (Either ExitReason b)))
-> Process (Maybe (Either ExitReason b))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
forall b.
Serializable b =>
Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
waitResponse Maybe TimeInterval
forall a. Maybe a
Nothing) :: Process (Either ExitReason b))
    Process (Either ExitReason b)
-> [ProcessId -> Message -> Process (Maybe (Either ExitReason b))]
-> Process (Either ExitReason b)
forall b.
Process b
-> [ProcessId -> Message -> Process (Maybe b)] -> Process b
`catchesExit` [\ProcessId
pid Message
msg -> Message
-> (ExitReason -> Bool)
-> (ExitReason -> Process (Either ExitReason b))
-> Process (Maybe (Either ExitReason b))
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> Bool) -> (a -> m b) -> m (Maybe b)
handleMessageIf Message
msg (ProcessId -> ProcessId -> ExitReason -> Bool
forall {a}. Eq a => a -> a -> ExitReason -> Bool
weFailed ProcessId
pid ProcessId
us)
                                                   (Either ExitReason b -> Process (Either ExitReason b)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ExitReason b -> Process (Either ExitReason b))
-> (ExitReason -> Either ExitReason b)
-> ExitReason
-> Process (Either ExitReason b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitReason -> Either ExitReason b
forall a b. a -> Either a b
Left)]

  where

    weFailed :: a -> a -> ExitReason -> Bool
weFailed a
a a
b (ExitOther String
_) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b
    weFailed a
_ a
_ ExitReason
_             = Bool
False

-- | Version of 'safeCall' that returns 'Nothing' if the operation fails.
--  Uses /unsafe primitives/.
tryCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
                 => s -> a -> Process (Maybe b)
tryCall :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (Maybe b)
tryCall s
s a
m = s -> a -> Process (CallRef b)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (CallRef b)
unsafeInitCall s
s a
m Process (CallRef b)
-> (CallRef b -> Process (Maybe (Either ExitReason b)))
-> Process (Maybe (Either ExitReason b))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
forall b.
Serializable b =>
Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
waitResponse Maybe TimeInterval
forall a. Maybe a
Nothing Process (Maybe (Either ExitReason b))
-> (Maybe (Either ExitReason b) -> Process (Maybe b))
-> Process (Maybe b)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Either ExitReason b) -> Process (Maybe b)
forall {m :: * -> *} {a} {a}.
Monad m =>
Maybe (Either a a) -> m (Maybe a)
decodeResult
  where decodeResult :: Maybe (Either a a) -> m (Maybe a)
decodeResult (Just (Right a
r)) = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
r
        decodeResult Maybe (Either a a)
_                = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- | Make a synchronous call, but timeout and return @Nothing@ if a reply
-- is not received within the specified time interval  - uses /unsafe primitives/.
--
callTimeout :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
                 => s -> a -> TimeInterval -> Process (Maybe b)
callTimeout :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> TimeInterval -> Process (Maybe b)
callTimeout s
s a
m TimeInterval
d = s -> a -> Process (CallRef b)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (CallRef b)
unsafeInitCall s
s a
m Process (CallRef b)
-> (CallRef b -> Process (Maybe (Either ExitReason b)))
-> Process (Maybe (Either ExitReason b))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
forall b.
Serializable b =>
Maybe TimeInterval
-> CallRef b -> Process (Maybe (Either ExitReason b))
waitResponse (TimeInterval -> Maybe TimeInterval
forall a. a -> Maybe a
Just TimeInterval
d) Process (Maybe (Either ExitReason b))
-> (Maybe (Either ExitReason b) -> Process (Maybe b))
-> Process (Maybe b)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Either ExitReason b) -> Process (Maybe b)
NFSerializable b =>
Maybe (Either ExitReason b) -> Process (Maybe b)
decodeResult
  where decodeResult :: (NFSerializable b)
               => Maybe (Either ExitReason b)
               -> Process (Maybe b)
        decodeResult :: NFSerializable b =>
Maybe (Either ExitReason b) -> Process (Maybe b)
decodeResult Maybe (Either ExitReason b)
Nothing               = Maybe b -> Process (Maybe b)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
        decodeResult (Just (Right b
result)) = Maybe b -> Process (Maybe b)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> Process (Maybe b)) -> Maybe b -> Process (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
result
        decodeResult (Just (Left ExitReason
reason))  = ExitReason -> Process (Maybe b)
forall a b. Serializable a => a -> Process b
die ExitReason
reason

-- | Block for @TimeInterval@ waiting for any matching @CallResponse@
flushPendingCalls :: forall b . (NFSerializable b)
                  => TimeInterval
                  -> (b -> Process b)
                  -> Process (Maybe b)
flushPendingCalls :: forall b.
NFSerializable b =>
TimeInterval -> (b -> Process b) -> Process (Maybe b)
flushPendingCalls TimeInterval
d b -> Process b
proc =
  Int -> [Match b] -> Process (Maybe b)
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout (TimeInterval -> Int
asTimeout TimeInterval
d) [
      (CallResponse b -> Process b) -> Match b
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(CallResponse (b
m :: b) CallId
_) -> b -> Process b
proc b
m)
    ]

-- | Invokes 'call' /out of band/, and returns an "async handle."
-- Uses /unsafe primitives/.
--
callAsync :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
          => s -> a -> Process (Async b)
callAsync :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (Async b)
callAsync s
server a
msg = AsyncTask b -> Process (Async b)
forall a. Serializable a => AsyncTask a -> Process (Async a)
async (AsyncTask b -> Process (Async b))
-> AsyncTask b -> Process (Async b)
forall a b. (a -> b) -> a -> b
$ Process b -> AsyncTask b
forall a. Process a -> AsyncTask a
task (Process b -> AsyncTask b) -> Process b -> AsyncTask b
forall a b. (a -> b) -> a -> b
$ s -> a -> Process b
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
call s
server a
msg

-- | Sends a /cast/ message to the server identified by @server@ - uses /unsafe primitives/.
--
cast :: forall a m . (Addressable a, NFSerializable m)
                 => a -> m -> Process ()
cast :: forall a m.
(Addressable a, NFSerializable m) =>
a -> m -> Process ()
cast a
server m
msg = a -> Message m () -> Process ()
forall a m.
(Routable a, NFSerializable m, Resolvable a) =>
a -> m -> Process ()
forall m. (NFSerializable m, Resolvable a) => a -> m -> Process ()
unsafeSendTo a
server ((m -> Message m ()
forall a b. a -> Message a b
CastMessage m
msg) :: Message m ())

-- | Sends a /channel/ message to the server and returns a @ReceivePort@ - uses /unsafe primitives/.
callChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
         => s -> a -> Process (ReceivePort b)
callChan :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (ReceivePort b)
callChan s
server a
msg = do
  (SendPort b
sp, ReceivePort b
rp) <- Process (SendPort b, ReceivePort b)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  s -> Message a b -> Process ()
forall a m.
(Routable a, NFSerializable m, Resolvable a) =>
a -> m -> Process ()
forall m. (NFSerializable m, Resolvable s) => s -> m -> Process ()
unsafeSendTo s
server ((a -> SendPort b -> Message a b
forall a b. a -> SendPort b -> Message a b
ChanMessage a
msg SendPort b
sp) :: Message a b)
  ReceivePort b -> Process (ReceivePort b)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ReceivePort b
rp

-- | A synchronous version of 'callChan'.
syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
         => s -> a -> Process b
syncCallChan :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process b
syncCallChan s
server a
msg = do
  Either ExitReason b
r <- s -> a -> Process (Either ExitReason b)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (Either ExitReason b)
syncSafeCallChan s
server a
msg
  case Either ExitReason b
r of
    Left ExitReason
e   -> ExitReason -> Process b
forall a b. Serializable a => a -> Process b
die ExitReason
e
    Right b
r' -> b -> Process b
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r'

-- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the
-- call fails.
syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)
            => s -> a -> Process (Either ExitReason b)
syncSafeCallChan :: forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (Either ExitReason b)
syncSafeCallChan s
server a
msg = do
  ReceivePort b
rp <- s -> a -> Process (ReceivePort b)
forall s a b.
(Addressable s, NFSerializable a, NFSerializable b) =>
s -> a -> Process (ReceivePort b)
callChan s
server a
msg
  s -> [Match (Either ExitReason b)] -> Process (Either ExitReason b)
forall a b.
Addressable a =>
a -> [Match (Either ExitReason b)] -> Process (Either ExitReason b)
awaitResponse s
server [ ReceivePort b
-> (b -> Process (Either ExitReason b))
-> Match (Either ExitReason b)
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort b
rp (Either ExitReason b -> Process (Either ExitReason b)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ExitReason b -> Process (Either ExitReason b))
-> (b -> Either ExitReason b) -> b -> Process (Either ExitReason b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either ExitReason b
forall a b. b -> Either a b
Right) ]