> module Foreign.Erlang.Network (
>
> epmdGetNames
> , epmdGetPort
> , epmdGetPortR4
>
> , ErlRecv
> , ErlSend
> , erlConnect
> , toNetwork
> ) where
> import Control.Exception (assert, bracketOnError)
> import Control.Monad (liftM)
> import Data.Binary (decode, encode)
> import Data.Binary.Get
> import Data.Binary.Put
> import Data.Bits ((.|.))
> import Data.Char (chr, ord)
> import Data.Digest.OpenSSL.MD5 (md5sum)
> import Data.List (unfoldr)
> import Data.Word
> import Foreign.Erlang.Types
> import Network (PortID(..), connectTo, withSocketsDo)
> import Network.Socket (PortNumber(..))
> import Numeric (readHex)
> import System.Directory (getHomeDirectory)
> import System.FilePath ((</>))
> import System.IO
> import System.IO.Unsafe (unsafePerformIO)
> import System.Random (randomIO)
> import qualified Data.ByteString.Char8 as C
> import qualified Data.ByteString.Lazy.Char8 as B
> erlangVersion = 5
> erlangProtocolVersion = 131
> passThrough = 'p'
> flagPublished = 0x01
> flagAtomCache = 0x02
> flagExtendedReferences = 0x04
> flagDistMonitor = 0x08
> flagFunTags = 0x10
> flagDistMonitorName = 0x20
> flagHiddenAtomCache = 0x40
> flagNewFunTags = 0x80
> flagExtendedPidsPorts = 0x100
> getUserCookie = do
> home <- getHomeDirectory
> readFile $ home </> ".erlang.cookie"
> 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)
> ntohs n = let (b, a) = n `divMod` 256 in 256*a + b
> erlDigest :: String -> Word32 -> [Word8]
> erlDigest cookie challenge = let
> [(n, _)] = readHex . md5sum . C.pack $ cookie ++ show challenge
> in toNetwork 16 n
> packn, packN :: B.ByteString -> Put
> packn msg = putn (fromIntegral . B.length $ msg) >> putLazyByteString msg
> packN msg = putN (fromIntegral . B.length $ msg) >> putLazyByteString msg
> sendMessage :: (B.ByteString -> Put) -> (B.ByteString -> IO ()) -> B.ByteString -> IO ()
> sendMessage pack out = out . runPut . 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 :: (B.ByteString -> IO ()) -> ErlSend
> erlSend send (Nothing, _) = send B.empty
> erlSend send (Just ctl, msg) = send . runPut $ do
> tag passThrough
> putMsg ctl
> maybe (return ()) putMsg msg
> where
> putMsg msg = do
> 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
> erlConnect :: String -> String -> IO (ErlSend, ErlRecv)
> erlConnect self node = withSocketsDo $ do
> port <- epmdGetPort node
> let port' = PortNumber (PortNum . fromIntegral . ntohs $ port)
> bracketOnError
> (connectTo epmdHost port' >>= \h -> hSetBuffering h NoBuffering >> return h)
> hClose $ \h -> do
> let out = sendMessage packn (B.hPut h)
> let inf = recvMessage 2 (B.hGet h)
> handshake out inf self
> let out' = sendMessage packN (\s -> B.hPut h s >> hFlush h)
> let inf' = recvMessage 4 (B.hGet h)
> return (erlSend out', erlRecv inf')
> handshake :: (B.ByteString -> 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 . runPut $ do
> tag 'n'
> putn erlangVersion
> putN $ flagExtendedReferences .|. flagExtendedPidsPorts
> 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 . runPut $ do
> tag 'r'
> putWord32be challenge
> puta reply
> recvChallengeAck cookie challenge = do
> let digest = erlDigest cookie challenge
> msg <- inf
> let reply = take 16 . drop 1 . map (fromIntegral . ord) . B.unpack $ msg
> assert (digest == reply) $ return ()
> epmdHost = "127.0.0.1"
> epmdPort = Service "epmd"
> withEpmd = withSocketsDo . bracketOnError
> (connectTo epmdHost epmdPort >>= \h -> hSetBuffering h NoBuffering >> return h)
> hClose
> epmdSend :: String -> IO B.ByteString
> epmdSend msg = withEpmd $ \hdl -> do
> let out = runPut $ putn (length msg) >> putA msg
> B.hPut hdl out
> hFlush hdl
> B.hGetContents hdl
>
> epmdGetNames :: IO [String]
> epmdGetNames = do
> reply <- epmdSend "n"
> let txt = runGet (getN >> liftM B.unpack getRemainingLazyByteString) reply
> return . lines $ txt
>
> epmdGetPort :: String -> IO Int
> epmdGetPort name = do
> reply <- epmdSend $ 'p' : name
> return $ runGet getn reply
>
> epmdGetPortR4 :: String -> IO (Int, Int, Int, Int, Int, String, String)
> epmdGetPortR4 name = do
> reply <- epmdSend $ '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)