{-# 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           -- FromPid ToPid
                    | SEND Pid Term          -- ToPid Message
                    | EXIT Pid Pid Term      -- FromPid ToPid Reason
                    | UNLINK Pid Pid         -- FromPid ToPid
                    | NODE_LINK              --
                    | REG_SEND Pid Term Term -- FromPid ToName Message
                    | GROUP_LEADER Pid Pid   -- FromPid ToPid
                    | EXIT2 Pid Pid Term     -- FromPid ToPid Reason
    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
                      ]