diff --git a/erlang.cabal b/erlang.cabal --- a/erlang.cabal +++ b/erlang.cabal @@ -1,5 +1,5 @@ name: erlang -version: 0.2 +version: 0.2.1 stability: alpha description: Speaks the Erlang network protocol and impersonates an Erlang node diff --git a/src/Foreign/Erlang.hs b/src/Foreign/Erlang.hs --- a/src/Foreign/Erlang.hs +++ b/src/Foreign/Erlang.hs @@ -23,13 +23,9 @@ , module Foreign.Erlang.Utilities ) where -import Foreign.Erlang.Network hiding (toNetwork) +import Foreign.Erlang.Network hiding (toNetwork, erlConnect) import Foreign.Erlang.OTP import Foreign.Erlang.Processes import Foreign.Erlang.Utilities -import Foreign.Erlang.Types hiding ( - getA, getC, getErl, getN, geta, getn - , putA, putC, putErl, putN, puta, putn - , tag - ) +import Foreign.Erlang.Types (Erlang(..), ErlType(..), nth) diff --git a/src/Foreign/Erlang/Network.hs b/src/Foreign/Erlang/Network.hs --- a/src/Foreign/Erlang/Network.hs +++ b/src/Foreign/Erlang/Network.hs @@ -19,7 +19,7 @@ , ErlSend -- ** Representation of Erlang nodes , Name - , Ip + , HostName , Node(..) , erlConnect , toNetwork @@ -34,7 +34,7 @@ import Data.List (unfoldr) import Data.Word import Foreign.Erlang.Types -import Network (PortID(..), connectTo, withSocketsDo) +import Network import System.Directory (getHomeDirectory) import System.FilePath (()) import System.IO @@ -137,13 +137,10 @@ -- | Name of an Erlang node. type Name = String --- | Ip address of a remote Erlang node. -type Ip = String - -- | Representation of an Erlang node on the network. data Node = Short Name -- ^ Local Erlang node. - | Long Name Ip -- ^ Remote Erlang node. + | Long Name HostName -- ^ Remote Erlang node. deriving (Eq,Show) instance Erlang Node where @@ -209,7 +206,7 @@ let reply = take 16 . tail . map (fromIntegral . ord) . B.unpack $ msg assert (digest == reply) $ return () -epmdLocal :: String +epmdLocal :: HostName epmdLocal = "127.0.0.1" epmdPort :: PortID diff --git a/src/Foreign/Erlang/Processes.hs b/src/Foreign/Erlang/Processes.hs --- a/src/Foreign/Erlang/Processes.hs +++ b/src/Foreign/Erlang/Processes.hs @@ -55,6 +55,7 @@ genRef nodename id = ErlNewRef (ErlAtom nodename) 1 . toNetwork 4 . fromIntegral $ id -- | Instantiate a Haskell node. This initializes the FFI. +-- Node name should be a \'long name\' e.g. @\"haskell\@localhost\"@. createSelf :: String -> IO Self createSelf nodename = do inbox <- newEmptyMVar @@ -172,7 +173,7 @@ mboxRef :: MBox -> IO ErlType mboxRef mbox@(MBox pid _ self) = send self (ErlGenRef pid) >> mboxRecv mbox --- | Send an arbitrary message to the specified node and process. In Erlang equivalent to +-- | Send an arbitrary message to the specified node and process. It is equivalent in Erlang to -- -- > {Node, Pid} ! Msg. diff --git a/src/Foreign/Erlang/Types.hs b/src/Foreign/Erlang/Types.hs --- a/src/Foreign/Erlang/Types.hs +++ b/src/Foreign/Erlang/Types.hs @@ -39,6 +39,12 @@ import qualified Data.ByteString.Lazy.Char8 as C import Data.ByteString.Lazy.Builder +import qualified Data.ByteString as Byte +import Data.ByteString (ByteString) +import Control.Applicative +import Data.Bits(shiftL,complement,(.|.)) + + nth :: Erlang a => Int -> ErlType -> a nth i (ErlTuple lst) = fromErlang $ lst !! i @@ -65,7 +71,10 @@ fromErlang = Prelude.id instance Erlang Int where - toErlang x = ErlInt x + toErlang x + | abs x <= 0x7FFFFFFF = ErlInt x + | otherwise = ErlBigInt (fromIntegral x) -- Haskell Int (might) use 64 bits whether erlang's small Int use only 32 bit + fromErlang (ErlInt x) = x fromErlang (ErlBigInt x) = fromIntegral x @@ -136,6 +145,15 @@ putErl (ErlList val) = tag 'l' <> putN (length val) <> val' <> putErl ErlNull where val' = mconcat . map putErl $ val putErl (ErlBinary val) = tag 'm' <> putN (length val) <> (lazyByteString . B.pack) val + +putErl (ErlBigInt x) + | len > 255 = tag 'o' <> putN len <> byteString val + | otherwise = tag 'n' <> putC len <> byteString val + where + val = integerToBytes x + len = Byte.length val -1 + + putErl (ErlRef node id creation) = tag 'e' <> putErl node <> @@ -154,8 +172,17 @@ getErl = do tag <- liftM chr getC case tag of + 'a' -> liftM ErlInt getC - 'b' -> liftM ErlInt getN + + 'b' -> do x <- getN + + let valFrom32 + | x > 0x7FFFFFFF = x .|. complement 0xFFFFFFFF + | otherwise = x + + return (ErlInt valFrom32) + 'd' -> getn >>= liftM ErlAtom . getA 'e' -> do node <- getErl @@ -188,13 +215,47 @@ null <- getErl assert (null == ErlNull) $ return list 'm' -> getN >>= liftM ErlBinary . geta + + 'n' -> do len <- getC + raw <- getByteString (len+1) + ErlBigInt <$> bytesToInteger raw + + 'o' -> do len <- getN + raw <- getByteString (len+1) + ErlBigInt <$> bytesToInteger raw + 'r' -> do len <- getn node <- getErl creation <- getC id <- forM [1..4*len] (const getWord8) return $ ErlNewRef node creation id - x -> error [x] + + x -> fail $ "Unsupported serialization code: " ++ show (ord x) + + +bytesToInteger :: ByteString -> Get Integer +bytesToInteger bts = case Byte.unpack bts of + 0 : bts' -> return $ foldr step 0 bts' + 1 : bts' -> return . negate $ foldr step 0 bts' + x : _ -> fail $ "Unexpected sign byte: " ++ show x + _ -> fail $ "Unexpected end of input at function 'bytesToInteger'" + where + step next acc = shiftL acc 8 + fromIntegral next + + +integerToBytes :: Integer -> ByteString +integerToBytes int = Byte.pack + . fmap (fromIntegral.snd) + . takeWhile not_zero + $ iterate ((`divMod`256).fst) (abs int,sigByte) + + where + not_zero (a,b) = a + b /= 0 + sigByte | int > 0 = 0 + | otherwise = 1 + + tag :: Char -> Builder tag = charUtf8 diff --git a/src/Foreign/Erlang/Utilities.hs b/src/Foreign/Erlang/Utilities.hs --- a/src/Foreign/Erlang/Utilities.hs +++ b/src/Foreign/Erlang/Utilities.hs @@ -21,7 +21,7 @@ -- MicroSeconds}. Luckily though, Erlang uses the same epoch, so no -- further conversion is necessary. --- | Convert a tuple (from erlang:now()) to seconds from Jan 1, 1970. +-- | Convert a tuple (from @erlang:now()@) to seconds from Jan 1, 1970. erlangTimeToSeconds :: Integral a => ErlType -> a erlangTimeToSeconds (ErlTuple [ErlInt ms, ErlInt s, _]) =