{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE Strict     #-}

module Foreign.Erlang.Handshake
    ( HandshakeData(..)
    , doConnect
    , doAccept
    , Name(..)
    , Status(..)
    , Challenge(..)
    , ChallengeReply(..)
    , ChallengeAck(..)
    ) where

import           Control.Monad           ( unless, when )
import           Util.IOExtra
import           Data.Ix                 ( inRange )

import qualified Data.ByteString         as BS
import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Util.Binary
import           Foreign.Erlang.Digest
import           Foreign.Erlang.NodeData

data HandshakeData = HandshakeData { HandshakeData -> Name
name     :: Name
                                   , HandshakeData -> NodeData
nodeData :: NodeData
                                   , HandshakeData -> ByteString
cookie   :: BS.ByteString
                                   }

nodeTypeR6, challengeStatus, challengeReply, challengeAck :: Char
nodeTypeR6 :: Char
nodeTypeR6 = Char
'n'

challengeStatus :: Char
challengeStatus = Char
's'

challengeReply :: Char
challengeReply = Char
'r'

challengeAck :: Char
challengeAck = Char
'a'

data Name = Name { Name -> DistributionVersion
n_distVer   :: DistributionVersion
                 , Name -> DistributionFlags
n_distFlags :: DistributionFlags
                 , Name -> ByteString
n_nodeName  :: BS.ByteString
                 }
    deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show)

instance Binary Name where
    put :: Name -> Put
put Name{DistributionVersion
n_distVer :: DistributionVersion
n_distVer :: Name -> DistributionVersion
n_distVer,DistributionFlags
n_distFlags :: DistributionFlags
n_distFlags :: Name -> DistributionFlags
n_distFlags,ByteString
n_nodeName :: ByteString
n_nodeName :: Name -> ByteString
n_nodeName} =
        HasCallStack => Put -> Put
Put -> Put
putWithLength16be (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
            HasCallStack => Char -> Put
Char -> Put
putChar8 Char
nodeTypeR6
            DistributionVersion -> Put
forall t. Binary t => t -> Put
put DistributionVersion
n_distVer
            DistributionFlags -> Put
forall t. Binary t => t -> Put
put DistributionFlags
n_distFlags
            ByteString -> Put
putByteString ByteString
n_nodeName
    get :: Get Name
get = do
        Word16
len <- Get Word16
getWord16be
        (((), DistributionVersion
n_distVer, DistributionFlags
n_distFlags), Word16
l) <- Get ((), DistributionVersion, DistributionFlags)
-> Get (((), DistributionVersion, DistributionFlags), Word16)
forall a. HasCallStack => Get a -> Get (a, Word16)
getWithLength16be (Get ((), DistributionVersion, DistributionFlags)
 -> Get (((), DistributionVersion, DistributionFlags), Word16))
-> Get ((), DistributionVersion, DistributionFlags)
-> Get (((), DistributionVersion, DistributionFlags), Word16)
forall a b. (a -> b) -> a -> b
$
                                                 (,,) (()
 -> DistributionVersion
 -> DistributionFlags
 -> ((), DistributionVersion, DistributionFlags))
-> Get ()
-> Get
     (DistributionVersion
      -> DistributionFlags
      -> ((), DistributionVersion, DistributionFlags))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Char -> Get ()
Char -> Get ()
matchChar8 Char
nodeTypeR6
                                                      Get
  (DistributionVersion
   -> DistributionFlags
   -> ((), DistributionVersion, DistributionFlags))
-> Get DistributionVersion
-> Get
     (DistributionFlags -> ((), DistributionVersion, DistributionFlags))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get DistributionVersion
forall t. Binary t => Get t
get
                                                      Get
  (DistributionFlags -> ((), DistributionVersion, DistributionFlags))
-> Get DistributionFlags
-> Get ((), DistributionVersion, DistributionFlags)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get DistributionFlags
forall t. Binary t => Get t
get
        ByteString
n_nodeName <- Int -> Get ByteString
getByteString (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
len Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
l))
        Name -> Get Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name :: DistributionVersion -> DistributionFlags -> ByteString -> Name
Name { DistributionVersion
n_distVer :: DistributionVersion
n_distVer :: DistributionVersion
n_distVer, DistributionFlags
n_distFlags :: DistributionFlags
n_distFlags :: DistributionFlags
n_distFlags, ByteString
n_nodeName :: ByteString
n_nodeName :: ByteString
n_nodeName }

data Status = Ok | OkSimultaneous | Nok | NotAllowed | Alive
    deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, Status
Status -> Status -> Bounded Status
forall a. a -> a -> Bounded a
maxBound :: Status
$cmaxBound :: Status
minBound :: Status
$cminBound :: Status
Bounded, Int -> Status
Status -> Int
Status -> [Status]
Status -> Status
Status -> Status -> [Status]
Status -> Status -> Status -> [Status]
(Status -> Status)
-> (Status -> Status)
-> (Int -> Status)
-> (Status -> Int)
-> (Status -> [Status])
-> (Status -> Status -> [Status])
-> (Status -> Status -> [Status])
-> (Status -> Status -> Status -> [Status])
-> Enum Status
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Status -> Status -> Status -> [Status]
$cenumFromThenTo :: Status -> Status -> Status -> [Status]
enumFromTo :: Status -> Status -> [Status]
$cenumFromTo :: Status -> Status -> [Status]
enumFromThen :: Status -> Status -> [Status]
$cenumFromThen :: Status -> Status -> [Status]
enumFrom :: Status -> [Status]
$cenumFrom :: Status -> [Status]
fromEnum :: Status -> Int
$cfromEnum :: Status -> Int
toEnum :: Int -> Status
$ctoEnum :: Int -> Status
pred :: Status -> Status
$cpred :: Status -> Status
succ :: Status -> Status
$csucc :: Status -> Status
Enum)

instance Binary Status where
    put :: Status -> Put
put Status
status = HasCallStack => Put -> Put
Put -> Put
putWithLength16be (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
        HasCallStack => Char -> Put
Char -> Put
putChar8 Char
challengeStatus
        case Status
status of
            Status
Ok -> ByteString -> Put
putByteString ByteString
"ok"
            Status
OkSimultaneous -> ByteString -> Put
putByteString ByteString
"ok_simultaneous"
            Status
Nok -> ByteString -> Put
putByteString ByteString
"nok"
            Status
NotAllowed -> ByteString -> Put
putByteString ByteString
"not_allowed"
            Status
Alive -> ByteString -> Put
putByteString ByteString
"alive"
    get :: Get Status
get = do
        Word16
len <- Get Word16
getWord16be
        ((), Word16
l) <- Get () -> Get ((), Word16)
forall a. HasCallStack => Get a -> Get (a, Word16)
getWithLength16be (Get () -> Get ((), Word16)) -> Get () -> Get ((), Word16)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Char -> Get ()
Char -> Get ()
matchChar8 Char
challengeStatus
        ByteString
status <- Int -> Get ByteString
getByteString (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
len Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
l))
        case ByteString
status of
            ByteString
"ok" -> Status -> Get Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Ok
            ByteString
"ok_simultaneous" -> Status -> Get Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
OkSimultaneous
            ByteString
"nok" -> Status -> Get Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Nok
            ByteString
"not_allowed" -> Status -> Get Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
NotAllowed
            ByteString
"alive" -> Status -> Get Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Alive
            ByteString
_ -> String -> Get Status
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Status) -> String -> Get Status
forall a b. (a -> b) -> a -> b
$ String
"Bad status: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
status

data Challenge = Challenge { Challenge -> DistributionVersion
c_distVer   :: DistributionVersion
                           , Challenge -> DistributionFlags
c_distFlags :: DistributionFlags
                           , Challenge -> Word32
c_challenge :: Word32
                           , Challenge -> ByteString
c_nodeName  :: BS.ByteString
                           }
    deriving (Challenge -> Challenge -> Bool
(Challenge -> Challenge -> Bool)
-> (Challenge -> Challenge -> Bool) -> Eq Challenge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Challenge -> Challenge -> Bool
$c/= :: Challenge -> Challenge -> Bool
== :: Challenge -> Challenge -> Bool
$c== :: Challenge -> Challenge -> Bool
Eq, Int -> Challenge -> ShowS
[Challenge] -> ShowS
Challenge -> String
(Int -> Challenge -> ShowS)
-> (Challenge -> String)
-> ([Challenge] -> ShowS)
-> Show Challenge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Challenge] -> ShowS
$cshowList :: [Challenge] -> ShowS
show :: Challenge -> String
$cshow :: Challenge -> String
showsPrec :: Int -> Challenge -> ShowS
$cshowsPrec :: Int -> Challenge -> ShowS
Show)

instance Binary Challenge where
    put :: Challenge -> Put
put Challenge{DistributionVersion
c_distVer :: DistributionVersion
c_distVer :: Challenge -> DistributionVersion
c_distVer,DistributionFlags
c_distFlags :: DistributionFlags
c_distFlags :: Challenge -> DistributionFlags
c_distFlags,Word32
c_challenge :: Word32
c_challenge :: Challenge -> Word32
c_challenge,ByteString
c_nodeName :: ByteString
c_nodeName :: Challenge -> ByteString
c_nodeName} =
        HasCallStack => Put -> Put
Put -> Put
putWithLength16be (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
            HasCallStack => Char -> Put
Char -> Put
putChar8 Char
nodeTypeR6
            DistributionVersion -> Put
forall t. Binary t => t -> Put
put DistributionVersion
c_distVer
            DistributionFlags -> Put
forall t. Binary t => t -> Put
put DistributionFlags
c_distFlags
            Word32 -> Put
putWord32be Word32
c_challenge
            ByteString -> Put
putByteString ByteString
c_nodeName
    get :: Get Challenge
get = do
        Word16
len <- Get Word16
getWord16be
        (((), DistributionVersion
c_distVer, DistributionFlags
c_distFlags, Word32
c_challenge), Word16
l) <- Get ((), DistributionVersion, DistributionFlags, Word32)
-> Get
     (((), DistributionVersion, DistributionFlags, Word32), Word16)
forall a. HasCallStack => Get a -> Get (a, Word16)
getWithLength16be (Get ((), DistributionVersion, DistributionFlags, Word32)
 -> Get
      (((), DistributionVersion, DistributionFlags, Word32), Word16))
-> Get ((), DistributionVersion, DistributionFlags, Word32)
-> Get
     (((), DistributionVersion, DistributionFlags, Word32), Word16)
forall a b. (a -> b) -> a -> b
$
                                                              (,,,) (()
 -> DistributionVersion
 -> DistributionFlags
 -> Word32
 -> ((), DistributionVersion, DistributionFlags, Word32))
-> Get ()
-> Get
     (DistributionVersion
      -> DistributionFlags
      -> Word32
      -> ((), DistributionVersion, DistributionFlags, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Char -> Get ()
Char -> Get ()
matchChar8 Char
nodeTypeR6
                                                                    Get
  (DistributionVersion
   -> DistributionFlags
   -> Word32
   -> ((), DistributionVersion, DistributionFlags, Word32))
-> Get DistributionVersion
-> Get
     (DistributionFlags
      -> Word32 -> ((), DistributionVersion, DistributionFlags, Word32))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get DistributionVersion
forall t. Binary t => Get t
get
                                                                    Get
  (DistributionFlags
   -> Word32 -> ((), DistributionVersion, DistributionFlags, Word32))
-> Get DistributionFlags
-> Get
     (Word32 -> ((), DistributionVersion, DistributionFlags, Word32))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get DistributionFlags
forall t. Binary t => Get t
get
                                                                    Get
  (Word32 -> ((), DistributionVersion, DistributionFlags, Word32))
-> Get Word32
-> Get ((), DistributionVersion, DistributionFlags, Word32)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32be
        ByteString
c_nodeName <- Int -> Get ByteString
getByteString (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
len Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
l))
        Challenge -> Get Challenge
forall (m :: * -> *) a. Monad m => a -> m a
return Challenge :: DistributionVersion
-> DistributionFlags -> Word32 -> ByteString -> Challenge
Challenge { DistributionVersion
c_distVer :: DistributionVersion
c_distVer :: DistributionVersion
c_distVer, DistributionFlags
c_distFlags :: DistributionFlags
c_distFlags :: DistributionFlags
c_distFlags, Word32
c_challenge :: Word32
c_challenge :: Word32
c_challenge, ByteString
c_nodeName :: ByteString
c_nodeName :: ByteString
c_nodeName }

data ChallengeReply = ChallengeReply { ChallengeReply -> Word32
cr_challenge :: Word32
                                     , ChallengeReply -> ByteString
cr_digest    :: BS.ByteString
                                     }
    deriving (ChallengeReply -> ChallengeReply -> Bool
(ChallengeReply -> ChallengeReply -> Bool)
-> (ChallengeReply -> ChallengeReply -> Bool) -> Eq ChallengeReply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChallengeReply -> ChallengeReply -> Bool
$c/= :: ChallengeReply -> ChallengeReply -> Bool
== :: ChallengeReply -> ChallengeReply -> Bool
$c== :: ChallengeReply -> ChallengeReply -> Bool
Eq, Int -> ChallengeReply -> ShowS
[ChallengeReply] -> ShowS
ChallengeReply -> String
(Int -> ChallengeReply -> ShowS)
-> (ChallengeReply -> String)
-> ([ChallengeReply] -> ShowS)
-> Show ChallengeReply
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChallengeReply] -> ShowS
$cshowList :: [ChallengeReply] -> ShowS
show :: ChallengeReply -> String
$cshow :: ChallengeReply -> String
showsPrec :: Int -> ChallengeReply -> ShowS
$cshowsPrec :: Int -> ChallengeReply -> ShowS
Show)

instance Binary ChallengeReply where
    put :: ChallengeReply -> Put
put ChallengeReply{Word32
cr_challenge :: Word32
cr_challenge :: ChallengeReply -> Word32
cr_challenge,ByteString
cr_digest :: ByteString
cr_digest :: ChallengeReply -> ByteString
cr_digest} =
        HasCallStack => Put -> Put
Put -> Put
putWithLength16be (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
            HasCallStack => Char -> Put
Char -> Put
putChar8 Char
challengeReply
            Word32 -> Put
putWord32be Word32
cr_challenge
            ByteString -> Put
putByteString ByteString
cr_digest
    get :: Get ChallengeReply
get = do
        Word16
len <- Get Word16
getWord16be
        (((), Word32
cr_challenge), Word16
l) <- Get ((), Word32) -> Get (((), Word32), Word16)
forall a. HasCallStack => Get a -> Get (a, Word16)
getWithLength16be (Get ((), Word32) -> Get (((), Word32), Word16))
-> Get ((), Word32) -> Get (((), Word32), Word16)
forall a b. (a -> b) -> a -> b
$
                                       (,) (() -> Word32 -> ((), Word32))
-> Get () -> Get (Word32 -> ((), Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Char -> Get ()
Char -> Get ()
matchChar8 Char
challengeReply
                                           Get (Word32 -> ((), Word32)) -> Get Word32 -> Get ((), Word32)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32be
        ByteString
cr_digest <- Int -> Get ByteString
getByteString (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
len Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
l))
        ChallengeReply -> Get ChallengeReply
forall (m :: * -> *) a. Monad m => a -> m a
return ChallengeReply :: Word32 -> ByteString -> ChallengeReply
ChallengeReply { Word32
cr_challenge :: Word32
cr_challenge :: Word32
cr_challenge, ByteString
cr_digest :: ByteString
cr_digest :: ByteString
cr_digest }

data ChallengeAck = ChallengeAck { ChallengeAck -> ByteString
ca_digest :: BS.ByteString }
    deriving (ChallengeAck -> ChallengeAck -> Bool
(ChallengeAck -> ChallengeAck -> Bool)
-> (ChallengeAck -> ChallengeAck -> Bool) -> Eq ChallengeAck
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChallengeAck -> ChallengeAck -> Bool
$c/= :: ChallengeAck -> ChallengeAck -> Bool
== :: ChallengeAck -> ChallengeAck -> Bool
$c== :: ChallengeAck -> ChallengeAck -> Bool
Eq, Int -> ChallengeAck -> ShowS
[ChallengeAck] -> ShowS
ChallengeAck -> String
(Int -> ChallengeAck -> ShowS)
-> (ChallengeAck -> String)
-> ([ChallengeAck] -> ShowS)
-> Show ChallengeAck
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChallengeAck] -> ShowS
$cshowList :: [ChallengeAck] -> ShowS
show :: ChallengeAck -> String
$cshow :: ChallengeAck -> String
showsPrec :: Int -> ChallengeAck -> ShowS
$cshowsPrec :: Int -> ChallengeAck -> ShowS
Show)

instance Binary ChallengeAck where
    put :: ChallengeAck -> Put
put ChallengeAck{ByteString
ca_digest :: ByteString
ca_digest :: ChallengeAck -> ByteString
ca_digest} =
        HasCallStack => Put -> Put
Put -> Put
putWithLength16be (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
            HasCallStack => Char -> Put
Char -> Put
putChar8 Char
challengeAck
            ByteString -> Put
putByteString ByteString
ca_digest
    get :: Get ChallengeAck
get = do
        Word16
len <- Get Word16
getWord16be
        ((), Word16
l) <- Get () -> Get ((), Word16)
forall a. HasCallStack => Get a -> Get (a, Word16)
getWithLength16be (Get () -> Get ((), Word16)) -> Get () -> Get ((), Word16)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Char -> Get ()
Char -> Get ()
matchChar8 Char
challengeAck
        ByteString
ca_digest <- Int -> Get ByteString
getByteString (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
len Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
l))
        ChallengeAck -> Get ChallengeAck
forall (m :: * -> *) a. Monad m => a -> m a
return ChallengeAck :: ByteString -> ChallengeAck
ChallengeAck { ByteString
ca_digest :: ByteString
ca_digest :: ByteString
ca_digest }

doConnect :: (MonadCatch m, MonadIO m)
          => (forall o. Binary o => o -> m ())
          -> (forall i. (Binary i) => m i)
          -> HandshakeData
          -> m ()
doConnect :: (forall o. Binary o => o -> m ())
-> (forall i. Binary i => m i) -> HandshakeData -> m ()
doConnect forall o. Binary o => o -> m ()
send forall i. Binary i => m i
recv HandshakeData{Name
name :: Name
name :: HandshakeData -> Name
name,nodeData :: HandshakeData -> NodeData
nodeData = NodeData{DistributionVersion
loVer :: NodeData -> DistributionVersion
loVer :: DistributionVersion
loVer,DistributionVersion
hiVer :: NodeData -> DistributionVersion
hiVer :: DistributionVersion
hiVer},ByteString
cookie :: ByteString
cookie :: HandshakeData -> ByteString
cookie} = do
    Name -> m ()
forall o. Binary o => o -> m ()
send Name
name
    do
        Status
her_status <- m Status
forall i. Binary i => m i
recv
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status
her_status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
/= Status
Ok) (BadHandshakeStatus -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Status -> BadHandshakeStatus
BadHandshakeStatus Status
her_status))

    Challenge{c_distVer :: Challenge -> DistributionVersion
c_distVer = DistributionVersion
her_distVer,c_challenge :: Challenge -> Word32
c_challenge = Word32
her_challenge} <- m Challenge
forall i. Binary i => m i
recv
    DistributionVersion
-> DistributionVersion -> DistributionVersion -> m ()
forall (m :: * -> *).
MonadThrow m =>
DistributionVersion
-> DistributionVersion -> DistributionVersion -> m ()
checkVersionRange DistributionVersion
her_distVer DistributionVersion
loVer DistributionVersion
hiVer

    Word32
our_challenge <- IO Word32 -> m Word32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word32
genChallenge
    ChallengeReply -> m ()
forall o. Binary o => o -> m ()
send ChallengeReply :: Word32 -> ByteString -> ChallengeReply
ChallengeReply { cr_challenge :: Word32
cr_challenge = Word32
our_challenge
                        , cr_digest :: ByteString
cr_digest = Word32 -> ByteString -> ByteString
genDigest Word32
her_challenge ByteString
cookie
                        }
    ChallengeAck{ca_digest :: ChallengeAck -> ByteString
ca_digest = ByteString
her_digest} <- m ChallengeAck
forall i. Binary i => m i
recv
    ByteString -> Word32 -> ByteString -> m ()
forall (m :: * -> *).
MonadThrow m =>
ByteString -> Word32 -> ByteString -> m ()
checkCookie ByteString
her_digest Word32
our_challenge ByteString
cookie

newtype BadHandshakeStatus = BadHandshakeStatus Status
    deriving Int -> BadHandshakeStatus -> ShowS
[BadHandshakeStatus] -> ShowS
BadHandshakeStatus -> String
(Int -> BadHandshakeStatus -> ShowS)
-> (BadHandshakeStatus -> String)
-> ([BadHandshakeStatus] -> ShowS)
-> Show BadHandshakeStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadHandshakeStatus] -> ShowS
$cshowList :: [BadHandshakeStatus] -> ShowS
show :: BadHandshakeStatus -> String
$cshow :: BadHandshakeStatus -> String
showsPrec :: Int -> BadHandshakeStatus -> ShowS
$cshowsPrec :: Int -> BadHandshakeStatus -> ShowS
Show

instance Exception BadHandshakeStatus

doAccept :: (MonadCatch m, MonadIO m)
         => (forall o. Binary o => o -> m ()) -- TODO
         -> (forall i. (Binary i) => m i)
         -> HandshakeData
         -> m BS.ByteString
doAccept :: (forall o. Binary o => o -> m ())
-> (forall i. Binary i => m i) -> HandshakeData -> m ByteString
doAccept forall o. Binary o => o -> m ()
send forall i. Binary i => m i
recv HandshakeData{name :: HandshakeData -> Name
name = Name{DistributionFlags
n_distFlags :: DistributionFlags
n_distFlags :: Name -> DistributionFlags
n_distFlags,ByteString
n_nodeName :: ByteString
n_nodeName :: Name -> ByteString
n_nodeName},nodeData :: HandshakeData -> NodeData
nodeData = NodeData{DistributionVersion
loVer :: DistributionVersion
loVer :: NodeData -> DistributionVersion
loVer,DistributionVersion
hiVer :: DistributionVersion
hiVer :: NodeData -> DistributionVersion
hiVer},ByteString
cookie :: ByteString
cookie :: HandshakeData -> ByteString
cookie} = do
    Name{n_distVer :: Name -> DistributionVersion
n_distVer = DistributionVersion
her_distVer,n_nodeName :: Name -> ByteString
n_nodeName = ByteString
her_nodeName} <- m Name
forall i. Binary i => m i
recv
    DistributionVersion
-> DistributionVersion -> DistributionVersion -> m ()
forall (m :: * -> *).
MonadThrow m =>
DistributionVersion
-> DistributionVersion -> DistributionVersion -> m ()
checkVersionRange DistributionVersion
her_distVer DistributionVersion
loVer DistributionVersion
hiVer

    Status -> m ()
forall o. Binary o => o -> m ()
send Status
Ok

    Word32
our_challenge <- IO Word32 -> m Word32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word32
genChallenge
    Challenge -> m ()
forall o. Binary o => o -> m ()
send Challenge :: DistributionVersion
-> DistributionFlags -> Word32 -> ByteString -> Challenge
Challenge { c_distVer :: DistributionVersion
c_distVer = DistributionVersion
R6B
                   , c_distFlags :: DistributionFlags
c_distFlags = DistributionFlags
n_distFlags
                   , c_challenge :: Word32
c_challenge = Word32
our_challenge
                   , c_nodeName :: ByteString
c_nodeName = ByteString
n_nodeName
                   }

    ChallengeReply{cr_challenge :: ChallengeReply -> Word32
cr_challenge = Word32
her_challenge,cr_digest :: ChallengeReply -> ByteString
cr_digest = ByteString
her_digest} <- m ChallengeReply
forall i. Binary i => m i
recv
    ByteString -> Word32 -> ByteString -> m ()
forall (m :: * -> *).
MonadThrow m =>
ByteString -> Word32 -> ByteString -> m ()
checkCookie ByteString
her_digest Word32
our_challenge ByteString
cookie

    ChallengeAck -> m ()
forall o. Binary o => o -> m ()
send ChallengeAck :: ByteString -> ChallengeAck
ChallengeAck { ca_digest :: ByteString
ca_digest = Word32 -> ByteString -> ByteString
genDigest Word32
her_challenge ByteString
cookie }
    ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
her_nodeName

checkVersionRange :: MonadThrow m
                  => DistributionVersion
                  -> DistributionVersion
                  -> DistributionVersion
                  -> m ()
checkVersionRange :: DistributionVersion
-> DistributionVersion -> DistributionVersion -> m ()
checkVersionRange DistributionVersion
herVersion DistributionVersion
lowVersion DistributionVersion
highVersion =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((DistributionVersion, DistributionVersion)
-> DistributionVersion -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (DistributionVersion
lowVersion, DistributionVersion
highVersion) DistributionVersion
herVersion)
           (DistributionVersionMismatch -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM DistributionVersionMismatch :: DistributionVersion
-> DistributionVersion
-> DistributionVersion
-> DistributionVersionMismatch
DistributionVersionMismatch { DistributionVersion
herVersion :: DistributionVersion
herVersion :: DistributionVersion
herVersion
                                               , DistributionVersion
lowVersion :: DistributionVersion
lowVersion :: DistributionVersion
lowVersion
                                               , DistributionVersion
highVersion :: DistributionVersion
highVersion :: DistributionVersion
highVersion
                                               })

checkCookie :: MonadThrow m => BS.ByteString -> Word32 -> BS.ByteString -> m ()
checkCookie :: ByteString -> Word32 -> ByteString -> m ()
checkCookie ByteString
her_digest Word32
our_challenge ByteString
cookie =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
her_digest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Word32 -> ByteString -> ByteString
genDigest Word32
our_challenge ByteString
cookie)
           (CookieMismatch -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM CookieMismatch
CookieMismatch)

data DistributionVersionMismatch =
      DistributionVersionMismatch { DistributionVersionMismatch -> DistributionVersion
herVersion  :: DistributionVersion
                                  , DistributionVersionMismatch -> DistributionVersion
lowVersion  :: DistributionVersion
                                  , DistributionVersionMismatch -> DistributionVersion
highVersion :: DistributionVersion
                                  }
    deriving Int -> DistributionVersionMismatch -> ShowS
[DistributionVersionMismatch] -> ShowS
DistributionVersionMismatch -> String
(Int -> DistributionVersionMismatch -> ShowS)
-> (DistributionVersionMismatch -> String)
-> ([DistributionVersionMismatch] -> ShowS)
-> Show DistributionVersionMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DistributionVersionMismatch] -> ShowS
$cshowList :: [DistributionVersionMismatch] -> ShowS
show :: DistributionVersionMismatch -> String
$cshow :: DistributionVersionMismatch -> String
showsPrec :: Int -> DistributionVersionMismatch -> ShowS
$cshowsPrec :: Int -> DistributionVersionMismatch -> ShowS
Show

instance Exception DistributionVersionMismatch

data CookieMismatch = CookieMismatch
    deriving Int -> CookieMismatch -> ShowS
[CookieMismatch] -> ShowS
CookieMismatch -> String
(Int -> CookieMismatch -> ShowS)
-> (CookieMismatch -> String)
-> ([CookieMismatch] -> ShowS)
-> Show CookieMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CookieMismatch] -> ShowS
$cshowList :: [CookieMismatch] -> ShowS
show :: CookieMismatch -> String
$cshow :: CookieMismatch -> String
showsPrec :: Int -> CookieMismatch -> ShowS
$cshowsPrec :: Int -> CookieMismatch -> ShowS
Show

instance Exception CookieMismatch