{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
module Foreign.Erlang.ControlMessage ( ControlMessage(..) ) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.Maybe
import Foreign.Erlang.Term
import Prelude hiding (length)
import Test.QuickCheck
import Util.Binary
data ControlMessage = TICK
| LINK Pid Pid
| SEND Pid Term
| EXIT Pid Pid Term
| UNLINK Pid Pid
| NODE_LINK
| REG_SEND Pid Term Term
| GROUP_LEADER Pid Pid
| EXIT2 Pid Pid Term
deriving (ControlMessage -> ControlMessage -> Bool
(ControlMessage -> ControlMessage -> Bool)
-> (ControlMessage -> ControlMessage -> Bool) -> Eq ControlMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlMessage -> ControlMessage -> Bool
$c/= :: ControlMessage -> ControlMessage -> Bool
== :: ControlMessage -> ControlMessage -> Bool
$c== :: ControlMessage -> ControlMessage -> Bool
Eq, Int -> ControlMessage -> ShowS
[ControlMessage] -> ShowS
ControlMessage -> String
(Int -> ControlMessage -> ShowS)
-> (ControlMessage -> String)
-> ([ControlMessage] -> ShowS)
-> Show ControlMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlMessage] -> ShowS
$cshowList :: [ControlMessage] -> ShowS
show :: ControlMessage -> String
$cshow :: ControlMessage -> String
showsPrec :: Int -> ControlMessage -> ShowS
$cshowsPrec :: Int -> ControlMessage -> ShowS
Show)
instance Binary ControlMessage where
put :: ControlMessage -> Put
put ControlMessage
TICK = Word32 -> Put
putWord32be Word32
0
put ControlMessage
controlMessage = HasCallStack => Put -> Put
Put -> Put
putWithLength32be (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
Word8 -> Put
putWord8 Word8
pass_through
ControlMessage -> Put
put' ControlMessage
controlMessage
where
put' :: ControlMessage -> Put
put' ControlMessage
TICK = String -> Put
forall a. HasCallStack => String -> a
error String
"Unreachable code"
put' (LINK Pid
fromPid Pid
toPid) =
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((TlinkTag, Pid, Pid) -> Term
forall a. ToTerm a => a -> Term
toTerm (TlinkTag
linkTag, Pid
fromPid, Pid
toPid)))
put' (SEND Pid
toPid Term
message) = do
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((TsendTag, Term, Pid) -> Term
forall a. ToTerm a => a -> Term
toTerm (TsendTag
sendTag, Term
unused, Pid
toPid)))
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm (Term -> Term
forall a. ToTerm a => a -> Term
toTerm Term
message))
put' (EXIT Pid
fromPid Pid
toPid Term
reason) =
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((TexitTag, Pid, Pid, Term) -> Term
forall a. ToTerm a => a -> Term
toTerm (TexitTag
exitTag, Pid
fromPid, Pid
toPid, Term
reason)))
put' (UNLINK Pid
fromPid Pid
toPid) =
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((TunlinkTag, Pid, Pid) -> Term
forall a. ToTerm a => a -> Term
toTerm (TunlinkTag
unlinkTag, Pid
fromPid, Pid
toPid)))
put' ControlMessage
NODE_LINK =
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm (Tuple1 TnodeLinkTag -> Term
forall a. ToTerm a => a -> Term
toTerm (TnodeLinkTag -> Tuple1 TnodeLinkTag
forall a. a -> Tuple1 a
Tuple1 TnodeLinkTag
nodeLinkTag)))
put' (REG_SEND Pid
fromPid Term
toName Term
message) = do
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((TregSendTag, Pid, Term, Term) -> Term
forall a. ToTerm a => a -> Term
toTerm (TregSendTag
regSendTag, Pid
fromPid, Term
unused, Term
toName)))
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm (Term -> Term
forall a. ToTerm a => a -> Term
toTerm Term
message))
put' (GROUP_LEADER Pid
fromPid Pid
toPid) =
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((TgroupLeaderTag, Pid, Pid) -> Term
forall a. ToTerm a => a -> Term
toTerm (TgroupLeaderTag
groupLeaderTag, Pid
fromPid, Pid
toPid)))
put' (EXIT2 Pid
fromPid Pid
toPid Term
reason) =
ExternalTerm -> Put
forall t. Binary t => t -> Put
put (Term -> ExternalTerm
MkExternalTerm ((Texit2Tag, Pid, Pid, Term) -> Term
forall a. ToTerm a => a -> Term
toTerm (Texit2Tag
exit2Tag, Pid
fromPid, Pid
toPid, Term
reason)))
get :: Get ControlMessage
get = do
Word32
expectedLen <- Get Word32
getWord32be
if Word32
expectedLen Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
then ControlMessage -> Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
TICK
else do
Int64
pos0 <- Get Int64
bytesRead
HasCallStack => Word8 -> Get ()
Word8 -> Get ()
matchWord8 Word8
pass_through
ControlMessage
controlMessage <- Get ControlMessage
get'
Int64
pos1 <- Get Int64
bytesRead
let actualLen :: Int64
actualLen = Int64
pos1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
pos0
if Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
expectedLen Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
actualLen
then
ControlMessage -> Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
controlMessage
else
String -> Get ControlMessage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bad control message length"
where
badControlMsg :: a -> m a
badControlMsg a
term = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Bad control message: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
term)
get' :: Get ControlMessage
get' = do
MkExternalTerm Term
term <- Get ExternalTerm
forall t. Binary t => Get t
get
Maybe ControlMessage
res <- MaybeT Get ControlMessage -> Get (Maybe ControlMessage)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Get ControlMessage -> Get (Maybe ControlMessage))
-> MaybeT Get ControlMessage -> Get (Maybe ControlMessage)
forall a b. (a -> b) -> a -> b
$ Term -> MaybeT Get ControlMessage
get'' Term
term
Get ControlMessage
-> (ControlMessage -> Get ControlMessage)
-> Maybe ControlMessage
-> Get ControlMessage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Term -> Get ControlMessage
forall (m :: * -> *) a a. (MonadFail m, Show a) => a -> m a
badControlMsg Term
term) ControlMessage -> Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ControlMessage
res
where
get'' :: Term -> MaybeT Get ControlMessage
get'' :: Term -> MaybeT Get ControlMessage
get'' Term
term = MaybeT Get ControlMessage
getLINK
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getSEND
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getEXIT
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getUNLINK
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getNODE_LINK
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getREG_SEND
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getGROUP_LEADER
MaybeT Get ControlMessage
-> MaybeT Get ControlMessage -> MaybeT Get ControlMessage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Get ControlMessage
getEXIT2
where
getLINK :: MaybeT Get ControlMessage
getLINK = do
(TlinkTag
_ :: TlinkTag, Pid
p2, Pid
p3) <- Term -> MaybeT Get (TlinkTag, Pid, Pid)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Pid -> ControlMessage
LINK Pid
p2 Pid
p3)
getSEND :: MaybeT Get ControlMessage
getSEND = do
(TsendTag
_ :: TsendTag, Term
_ :: Term, Pid
p1) <- Term -> MaybeT Get (TsendTag, Term, Pid)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
MkExternalTerm Term
message <- Get ExternalTerm -> MaybeT Get ExternalTerm
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get ExternalTerm
forall t. Binary t => Get t
get
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Term -> ControlMessage
SEND Pid
p1 Term
message)
getEXIT :: MaybeT Get ControlMessage
getEXIT = do
(TexitTag
_ :: TexitTag, Pid
p2, Pid
p3, Term
p4) <- Term -> MaybeT Get (TexitTag, Pid, Pid, Term)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Pid -> Term -> ControlMessage
EXIT Pid
p2 Pid
p3 Term
p4)
getUNLINK :: MaybeT Get ControlMessage
getUNLINK = do
(TunlinkTag
_ :: TunlinkTag, Pid
p2, Pid
p3) <- Term -> MaybeT Get (TunlinkTag, Pid, Pid)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Pid -> ControlMessage
UNLINK Pid
p2 Pid
p3)
getNODE_LINK :: MaybeT Get ControlMessage
getNODE_LINK = do
(Tuple1 TnodeLinkTag
_ :: Tuple1 TnodeLinkTag) <- Term -> MaybeT Get (Tuple1 TnodeLinkTag)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
NODE_LINK
getREG_SEND :: MaybeT Get ControlMessage
getREG_SEND = do
(TregSendTag
_ :: TregSendTag, Pid
p2, Term
_p3 :: Term, Term
p4) <- Term -> MaybeT Get (TregSendTag, Pid, Term, Term)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
MkExternalTerm Term
message <- Get ExternalTerm -> MaybeT Get ExternalTerm
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get ExternalTerm
forall t. Binary t => Get t
get
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Term -> Term -> ControlMessage
REG_SEND Pid
p2 Term
p4 Term
message)
getGROUP_LEADER :: MaybeT Get ControlMessage
getGROUP_LEADER = do
(TgroupLeaderTag
_ :: TgroupLeaderTag, Pid
p2, Pid
p3) <- Term -> MaybeT Get (TgroupLeaderTag, Pid, Pid)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Pid -> ControlMessage
GROUP_LEADER Pid
p2 Pid
p3)
getEXIT2 :: MaybeT Get ControlMessage
getEXIT2 = do
(Texit2Tag
_ :: Texit2Tag, Pid
p2, Pid
p3, Term
p4) <- Term -> MaybeT Get (Texit2Tag, Pid, Pid, Term)
forall a (m :: * -> *). (FromTerm a, Alternative m) => Term -> m a
fromTermA Term
term
ControlMessage -> MaybeT Get ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Pid -> Pid -> Term -> ControlMessage
EXIT2 Pid
p2 Pid
p3 Term
p4)
pass_through :: Word8
pass_through :: Word8
pass_through = Word8
112
type TlinkTag = SInteger 1
linkTag :: TlinkTag
linkTag :: TlinkTag
linkTag = TlinkTag
forall (n :: Nat). SInteger n
SInteger
type TsendTag = SInteger 2
sendTag :: TsendTag
sendTag :: TsendTag
sendTag = TsendTag
forall (n :: Nat). SInteger n
SInteger
type TexitTag = SInteger 3
exitTag :: TexitTag
exitTag :: TexitTag
exitTag = TexitTag
forall (n :: Nat). SInteger n
SInteger
type TunlinkTag = SInteger 4
unlinkTag :: TunlinkTag
unlinkTag :: TunlinkTag
unlinkTag = TunlinkTag
forall (n :: Nat). SInteger n
SInteger
type TnodeLinkTag = SInteger 5
nodeLinkTag :: TnodeLinkTag
nodeLinkTag :: TnodeLinkTag
nodeLinkTag = TnodeLinkTag
forall (n :: Nat). SInteger n
SInteger
type TregSendTag = SInteger 6
regSendTag :: TregSendTag
regSendTag :: TregSendTag
regSendTag = TregSendTag
forall (n :: Nat). SInteger n
SInteger
type TgroupLeaderTag = SInteger 7
groupLeaderTag :: TgroupLeaderTag
groupLeaderTag :: TgroupLeaderTag
groupLeaderTag = TgroupLeaderTag
forall (n :: Nat). SInteger n
SInteger
type Texit2Tag = SInteger 8
exit2Tag :: Texit2Tag
exit2Tag :: Texit2Tag
exit2Tag = Texit2Tag
forall (n :: Nat). SInteger n
SInteger
unused :: Term
unused :: Term
unused = ByteString -> Term
atom ByteString
""
instance Arbitrary ControlMessage where
arbitrary :: Gen ControlMessage
arbitrary = [Gen ControlMessage] -> Gen ControlMessage
forall a. [Gen a] -> Gen a
oneof [ ControlMessage -> Gen ControlMessage
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControlMessage
TICK
, Pid -> Pid -> ControlMessage
LINK (Pid -> Pid -> ControlMessage)
-> Gen Pid -> Gen (Pid -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Pid -> ControlMessage) -> Gen Pid -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary
, Pid -> Term -> ControlMessage
SEND (Pid -> Term -> ControlMessage)
-> Gen Pid -> Gen (Term -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Term -> ControlMessage) -> Gen Term -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Term
forall a. Arbitrary a => Gen a
arbitrary
, Pid -> Pid -> Term -> ControlMessage
EXIT (Pid -> Pid -> Term -> ControlMessage)
-> Gen Pid -> Gen (Pid -> Term -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Pid -> Term -> ControlMessage)
-> Gen Pid -> Gen (Term -> ControlMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Term -> ControlMessage) -> Gen Term -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Term
forall a. Arbitrary a => Gen a
arbitrary
, Pid -> Pid -> ControlMessage
UNLINK (Pid -> Pid -> ControlMessage)
-> Gen Pid -> Gen (Pid -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Pid -> ControlMessage) -> Gen Pid -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary
, ControlMessage -> Gen ControlMessage
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControlMessage
NODE_LINK
, Pid -> Term -> Term -> ControlMessage
REG_SEND (Pid -> Term -> Term -> ControlMessage)
-> Gen Pid -> Gen (Term -> Term -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Term -> Term -> ControlMessage)
-> Gen Term -> Gen (Term -> ControlMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Term
forall a. Arbitrary a => Gen a
arbitrary Gen (Term -> ControlMessage) -> Gen Term -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Term
forall a. Arbitrary a => Gen a
arbitrary
, Pid -> Pid -> ControlMessage
GROUP_LEADER (Pid -> Pid -> ControlMessage)
-> Gen Pid -> Gen (Pid -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Pid -> ControlMessage) -> Gen Pid -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary
, Pid -> Pid -> Term -> ControlMessage
EXIT2 (Pid -> Pid -> Term -> ControlMessage)
-> Gen Pid -> Gen (Pid -> Term -> ControlMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Pid -> Term -> ControlMessage)
-> Gen Pid -> Gen (Term -> ControlMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pid
forall a. Arbitrary a => Gen a
arbitrary Gen (Term -> ControlMessage) -> Gen Term -> Gen ControlMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Term
forall a. Arbitrary a => Gen a
arbitrary
]