-- | -- Module : Foreign.Erlang.Network -- Copyright : (c) Eric Sessoms, 2008 -- (c) Artúr Poór, 2015 -- (c) Arnold Szederjesi-Dragomir, 2021 -- License : GPL3 -- -- Maintainer : szederjesiarnold@gmail.com -- Stability : experimental -- Portability : portable -- module Foreign.Erlang.Network ( -- * Low-level communication with the Erlang Port-Mapper Daemon epmdGetNames , epmdGetPort , epmdGetPortR4 , ErlRecv , ErlSend -- ** Representation of Erlang nodes , Name , HostName , Node(..) , erlConnect , toNetwork ) where import Control.Exception (assert, bracketOnError) import Control.Monad (liftM) import Data.Binary.Get import Data.Bits ((.|.)) import Data.Char (chr, ord) import Data.Hash.MD5 (md5i, Str(..)) import Data.List (unfoldr) import Data.Word import Foreign.Erlang.Types import System.Directory (getHomeDirectory) import System.FilePath (()) import System.IO import System.Random (randomIO) import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Builder import Data.Monoid ((<>),mempty) import Network.Socket erlangVersion :: Int erlangVersion = 5 erlangProtocolVersion :: Int erlangProtocolVersion = 131 passThrough :: Char passThrough = 'p' flagPublished = 0x01 flagAtomCache = 0x02 flagExtendedReferences = 0x04 flagDistMonitor = 0x08 flagFunTags = 0x10 flagDistMonitorName = 0x20 flagHiddenAtomCache = 0x40 flagNewFunTags = 0x80 flagExtendedPidsPorts = 0x100 flagUTF8Atoms = 0x10000 flagExtendedReferences :: Word32 flagExtendedPidsPorts :: Word32 flagUTF8Atoms :: Word32 getUserCookie :: IO String getUserCookie = do home <- getHomeDirectory withFile (home ".erlang.cookie") ReadMode $ \h -> do eof <- hIsEOF h if eof then return "" else hGetLine h toNetwork :: Int -> Integer -> [Word8] toNetwork b n = reverse . take b $ unfoldr toNetwork' n ++ repeat 0 where toNetwork' 0 = Nothing toNetwork' n = let (b, a) = n `divMod` 256 in Just (fromIntegral a, b) erlDigest :: String -> Word32 -> [Word8] erlDigest cookie challenge = let n = fromIntegral . md5i . Str $ cookie ++ show challenge in toNetwork 16 n packn, packN :: Builder -> Builder packn msg = putn (B.length msg') <> msg where msg' = toLazyByteString msg packN msg = putN (B.length msg') <> msg where msg' = toLazyByteString msg sendMessage :: (Builder -> Builder) -> (Builder -> IO ()) -> Builder -> IO () sendMessage pack out = out . pack recvMessage :: Int -> (Int -> IO B.ByteString) -> IO B.ByteString recvMessage hdrlen inf = (liftM (unpack hdrlen) $ inf hdrlen) >>= inf where unpack 2 = runGet getn unpack 4 = runGet getN type ErlSend = (Maybe ErlType, Maybe ErlType) -> IO () type ErlRecv = IO (Maybe ErlType, Maybe ErlType) erlSend :: (Builder -> IO ()) -> ErlSend erlSend send (Nothing, _) = send . lazyByteString $ B.empty erlSend send (Just ctl, msg) = send $ tag passThrough <> putMsg ctl <> maybe mempty putMsg msg where putMsg msg = putC erlangProtocolVersion <> putErl msg erlRecv :: IO B.ByteString -> ErlRecv erlRecv recv = do bytes <- recv return . flip runGet bytes $ do empty <- isEmpty if empty then return (Nothing, Nothing) else do pt <- getC assert (chr pt == passThrough) $ return () ctl <- getMsg empty <- isEmpty if empty then return (Just ctl, Nothing) else case ctl of ErlTuple (ErlInt n:_) | n `elem` [2, 6] -> do msg <- getMsg return (Just ctl, Just msg) _ -> return (Just ctl, Nothing) where getMsg = do ver <- getC assert (ver == erlangProtocolVersion) $ getErl -- | Name of an Erlang node. type Name = String -- | Representation of an Erlang node on the network. data Node = Short Name -- ^ Local Erlang node. | Long Name HostName -- ^ Remote Erlang node. deriving (Eq,Show) instance Erlang Node where toErlang (Short name) = ErlString name toErlang (Long name ip) = ErlString name fromErlang = undefined erlConnect :: String -> Node -> IO (ErlSend, ErlRecv) erlConnect self node = withSocketsDo $ do port <- epmdGetPort node let port' = fromIntegral $ port withNode epmd port' $ \h -> do let out = sendMessage packn (hPutBuilder h) let inf = recvMessage 2 (B.hGet h) handshake out inf self let out' = sendMessage packN (hPutBuilder h) let inf' = recvMessage 4 (B.hGet h) return (erlSend out', erlRecv inf') where epmd = case node of Short _ -> epmdLocal Long _ ip -> ip handshake :: (Builder -> IO ()) -> IO B.ByteString -> String -> IO () handshake out inf self = do cookie <- getUserCookie sendName recvStatus challenge <- recvChallenge let reply = erlDigest cookie challenge challenge' <- liftM fromIntegral (randomIO :: IO Int) challengeReply reply challenge' recvChallengeAck cookie challenge' where sendName = out $ tag 'n' <> putn erlangVersion <> putN (flagExtendedReferences .|. flagExtendedPidsPorts .|. flagUTF8Atoms .|. flagNewFunTags) <> putA self recvStatus = do msg <- inf assert ("sok" == B.unpack msg) $ return () recvChallenge = do msg <- inf return . flip runGet msg $ do _tag <- getC _version <- getn _flags <- getN challenge <- getWord32be return challenge challengeReply reply challenge = out $ tag 'r' <> word32BE challenge <> puta reply recvChallengeAck cookie challenge = do let digest = erlDigest cookie challenge msg <- inf let reply = take 16 . tail . map (fromIntegral . ord) . B.unpack $ msg assert (digest == reply) $ return () epmdLocal :: HostName epmdLocal = "127.0.0.1" epmdPort :: PortNumber --epmdPort = Service "epmd" epmdPort = 4369 withNode :: String -> PortNumber -> (Handle -> IO a) -> IO a withNode epmd port = withSocketsDo . bracketOnError (connectTo epmd port) hClose withEpmd :: String -> (Handle -> IO a) -> IO a withEpmd epmd = withSocketsDo . bracketOnError (connectTo epmd epmdPort) hClose epmdSend :: String -> String -> IO B.ByteString epmdSend epmd msg = withEpmd epmd $ \hdl -> do let out = putn (length msg) <> putA msg hPutBuilder hdl out hFlush hdl B.hGetContents hdl -- | Return the names and addresses of registered local Erlang nodes. epmdGetNames :: IO [String] epmdGetNames = do reply <- epmdSend epmdLocal "n" let txt = runGet (getN >> liftM B.unpack getRemainingLazyByteString) reply return . lines $ txt -- | Return the port address of a named Erlang node. epmdGetPort :: Node -> IO Int epmdGetPort node = do reply <- epmdSend epmd $ 'z' : nodeName return $ flip runGet reply $ do _ <- getC res <- getC if res == 0 then getn else error $ "epmdGetPort: node not found: " ++ show node where (nodeName, epmd) = case node of Short name -> (name, epmdLocal) Long name ip -> (name, ip) -- | Returns (port, nodeType, protocol, vsnMax, vsnMin, name, extra) epmdGetPortR4 :: String -> String -> IO (Int, Int, Int, Int, Int, String, String) epmdGetPortR4 epmd name = do reply <- epmdSend epmd $ 'z' : name return $ flip runGet reply $ do _ <- getn port <- getn nodeType <- getC protocol <- getC vsnMax <- getn vsnMin <- getn name <- getn >>= getA extra <- liftM B.unpack getRemainingLazyByteString return (port, nodeType, protocol, vsnMax, vsnMin, name, extra) connectTo :: HostName -> PortNumber -> IO Handle connectTo hostname port = do let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } addr <- head <$> getAddrInfo (Just hints) (Just hostname) (Just $ show port) bracketOnError (openSocket addr) (close) -- only done if there's an error (\sock -> do connect sock (addrAddress addr) socketToHandle sock ReadWriteMode )