{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | If you don't know exactly what this module is for and precisely
-- how to use the types within, you should move on, quickly!
--
-- [Implementation Notes]
-- This module provides facilities for forcibly sending non-serializable
-- data via cloud haskell's messaging primitives, such as @send@ et al.
-- Of course, if you attmept to do this when interacting with a remote process,
-- your application will break.
--
-- NB: this module will be deprecated in the next dot release, pending rewrite
-- of the libraries that currently rely on it, to use the new supporting APIs
-- for STM interactions in distributed-process-client-server.
--
module Control.Distributed.Process.Extras.Internal.Unsafe
  ( -- * Copying non-serializable data
    PCopy()
  , pCopy
  , matchP
  , matchChanP
  , pUnwrap
    -- * Arbitrary (unmanaged) message streams
  , InputStream(Null)
  , newInputStream
  , matchInputStream
  , readInputStream
  , InvalidBinaryShim(..)
  ) where

import Control.Concurrent.STM (STM, atomically)
import Control.Distributed.Process
  ( matchAny
  , matchChan
  , matchSTM
  , match
  , handleMessage
  , receiveChan
  , liftIO
  , die
  , Match
  , ReceivePort
  , Message
  , Process
  )
import Control.Distributed.Process.Serializable (Serializable)
import Data.Binary
import Control.DeepSeq (NFData)
import Data.Typeable (Typeable)
import GHC.Generics

data InvalidBinaryShim = InvalidBinaryShim
  deriving (Typeable, Int -> InvalidBinaryShim -> ShowS
[InvalidBinaryShim] -> ShowS
InvalidBinaryShim -> String
(Int -> InvalidBinaryShim -> ShowS)
-> (InvalidBinaryShim -> String)
-> ([InvalidBinaryShim] -> ShowS)
-> Show InvalidBinaryShim
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InvalidBinaryShim -> ShowS
showsPrec :: Int -> InvalidBinaryShim -> ShowS
$cshow :: InvalidBinaryShim -> String
show :: InvalidBinaryShim -> String
$cshowList :: [InvalidBinaryShim] -> ShowS
showList :: [InvalidBinaryShim] -> ShowS
Show, InvalidBinaryShim -> InvalidBinaryShim -> Bool
(InvalidBinaryShim -> InvalidBinaryShim -> Bool)
-> (InvalidBinaryShim -> InvalidBinaryShim -> Bool)
-> Eq InvalidBinaryShim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InvalidBinaryShim -> InvalidBinaryShim -> Bool
== :: InvalidBinaryShim -> InvalidBinaryShim -> Bool
$c/= :: InvalidBinaryShim -> InvalidBinaryShim -> Bool
/= :: InvalidBinaryShim -> InvalidBinaryShim -> Bool
Eq)

-- NB: PCopy is a shim, allowing us to copy a pointer to otherwise
-- non-serializable data directly to another local process'
-- mailbox with no serialisation or even deepseq evaluation
-- required. We disallow remote queries (i.e., from other nodes)
-- and thus the Binary instance below is never used (though it's
-- required by the type system) and will in fact generate errors if
-- you attempt to use it at runtime. In other words, if you attempt
-- to make a @Message@ out of this, you'd better make sure you're
-- calling @unsafeCreateUnencodedMessage@, otherwise /BOOM/! You have
-- been warned.
--
data PCopy a = PCopy !a
  deriving (Typeable, (forall x. PCopy a -> Rep (PCopy a) x)
-> (forall x. Rep (PCopy a) x -> PCopy a) -> Generic (PCopy a)
forall x. Rep (PCopy a) x -> PCopy a
forall x. PCopy a -> Rep (PCopy a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PCopy a) x -> PCopy a
forall a x. PCopy a -> Rep (PCopy a) x
$cfrom :: forall a x. PCopy a -> Rep (PCopy a) x
from :: forall x. PCopy a -> Rep (PCopy a) x
$cto :: forall a x. Rep (PCopy a) x -> PCopy a
to :: forall x. Rep (PCopy a) x -> PCopy a
Generic)
instance (NFData a) => NFData (PCopy a) where

instance (Typeable a) => Binary (PCopy a) where
  put :: PCopy a -> Put
put PCopy a
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"InvalidBinaryShim"
  get :: Get (PCopy a)
get   = String -> Get (PCopy a)
forall a. HasCallStack => String -> a
error String
"InvalidBinaryShim"

-- | Wrap any @Typeable@ datum in a @PCopy@. We hide the constructor to
-- discourage arbitrary uses of the type, since @PCopy@ is a specialised
-- and potentially dangerous construct.
pCopy :: (Typeable a) => a -> PCopy a
pCopy :: forall a. Typeable a => a -> PCopy a
pCopy = a -> PCopy a
forall a. a -> PCopy a
PCopy

-- | Matches on @PCopy m@ and returns the /m/ within.
-- This potentially allows us to bypass serialization (and the type constraints
-- it enforces) for local message passing (i.e., with @UnencodedMessage@ data),
-- since PCopy is just a shim.
matchP :: (Typeable m) => Match (Maybe m)
matchP :: forall m. Typeable m => Match (Maybe m)
matchP = (Message -> Process (Maybe m)) -> Match (Maybe m)
forall b. (Message -> Process b) -> Match b
matchAny Message -> Process (Maybe m)
forall m. Typeable m => Message -> Process (Maybe m)
pUnwrap

-- | Given a raw @Message@, attempt to unwrap a @Typeable@ datum from
-- an enclosing @PCopy@ wrapper.
pUnwrap :: (Typeable m) => Message -> Process (Maybe m)
pUnwrap :: forall m. Typeable m => Message -> Process (Maybe m)
pUnwrap Message
m = Message -> (PCopy m -> Process m) -> Process (Maybe m)
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m (\(PCopy m
m' :: PCopy m) -> m -> Process m
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return m
m')

-- | Matches on a @TypedChannel (PCopy a)@.
matchChanP :: (Typeable m) => ReceivePort (PCopy m) -> Match m
matchChanP :: forall m. Typeable m => ReceivePort (PCopy m) -> Match m
matchChanP ReceivePort (PCopy m)
rp = ReceivePort (PCopy m) -> (PCopy m -> Process m) -> Match m
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort (PCopy m)
rp (\(PCopy m
m' :: PCopy m) -> m -> Process m
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return m
m')

-- | A generic input channel that can be read from in the same fashion
-- as a typed channel (i.e., @ReceivePort@). To read from an input stream
-- in isolation, see 'readInputStream'. To compose an 'InputStream' with
-- reads on a process' mailbox (and/or typed channels), see 'matchInputStream'.
--
data InputStream a = ReadChan (ReceivePort a) | ReadSTM (STM a) | Null
  deriving (Typeable)

data NullInputStream = NullInputStream
  deriving (Typeable, (forall x. NullInputStream -> Rep NullInputStream x)
-> (forall x. Rep NullInputStream x -> NullInputStream)
-> Generic NullInputStream
forall x. Rep NullInputStream x -> NullInputStream
forall x. NullInputStream -> Rep NullInputStream x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NullInputStream -> Rep NullInputStream x
from :: forall x. NullInputStream -> Rep NullInputStream x
$cto :: forall x. Rep NullInputStream x -> NullInputStream
to :: forall x. Rep NullInputStream x -> NullInputStream
Generic, Int -> NullInputStream -> ShowS
[NullInputStream] -> ShowS
NullInputStream -> String
(Int -> NullInputStream -> ShowS)
-> (NullInputStream -> String)
-> ([NullInputStream] -> ShowS)
-> Show NullInputStream
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NullInputStream -> ShowS
showsPrec :: Int -> NullInputStream -> ShowS
$cshow :: NullInputStream -> String
show :: NullInputStream -> String
$cshowList :: [NullInputStream] -> ShowS
showList :: [NullInputStream] -> ShowS
Show, NullInputStream -> NullInputStream -> Bool
(NullInputStream -> NullInputStream -> Bool)
-> (NullInputStream -> NullInputStream -> Bool)
-> Eq NullInputStream
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NullInputStream -> NullInputStream -> Bool
== :: NullInputStream -> NullInputStream -> Bool
$c/= :: NullInputStream -> NullInputStream -> Bool
/= :: NullInputStream -> NullInputStream -> Bool
Eq)
instance Binary NullInputStream where
instance NFData NullInputStream where

-- [note: InputStream]
-- InputStream wraps either a ReceivePort or an arbitrary STM action. Used
-- internally when we want to allow internal clients to completely bypass
-- regular messaging primitives (which is rare but occaisionally useful),
-- the type (only, minus its constructors) is exposed to users of some
-- @Exchange@ APIs.

-- | Create a new 'InputStream'.
newInputStream :: forall a. (Typeable a)
               => Either (ReceivePort a) (STM a)
               -> InputStream a
newInputStream :: forall a.
Typeable a =>
Either (ReceivePort a) (STM a) -> InputStream a
newInputStream (Left ReceivePort a
rp)   = ReceivePort a -> InputStream a
forall a. ReceivePort a -> InputStream a
ReadChan ReceivePort a
rp
newInputStream (Right STM a
stm) = STM a -> InputStream a
forall a. STM a -> InputStream a
ReadSTM STM a
stm

-- | Read from an 'InputStream'. This is a blocking operation.
readInputStream :: (Serializable a) => InputStream a -> Process a
readInputStream :: forall a. Serializable a => InputStream a -> Process a
readInputStream (ReadChan ReceivePort a
rp) = ReceivePort a -> Process a
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort a
rp
readInputStream (ReadSTM STM a
stm) = IO a -> Process a
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Process a) -> IO a -> Process a
forall a b. (a -> b) -> a -> b
$ STM a -> IO a
forall a. STM a -> IO a
atomically STM a
stm
readInputStream InputStream a
Null          = NullInputStream -> Process a
forall a b. Serializable a => a -> Process b
die (NullInputStream -> Process a) -> NullInputStream -> Process a
forall a b. (a -> b) -> a -> b
$ NullInputStream
NullInputStream

-- | Constructs a @Match@ for a given 'InputChannel'.
matchInputStream :: InputStream a -> Match a
matchInputStream :: forall a. InputStream a -> Match a
matchInputStream (ReadChan ReceivePort a
rp) = ReceivePort a -> (a -> Process a) -> Match a
forall a b. ReceivePort a -> (a -> Process b) -> Match b
matchChan ReceivePort a
rp a -> Process a
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return
matchInputStream (ReadSTM STM a
stm) = STM a -> (a -> Process a) -> Match a
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM STM a
stm a -> Process a
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return
matchInputStream InputStream a
Null          = (NullInputStream -> Process a) -> Match a
forall a b. Serializable a => (a -> Process b) -> Match b
match (\NullInputStream
NullInputStream -> do
                                           String -> Process a
forall a. HasCallStack => String -> a
error String
"NullInputStream")