diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/erlang.cabal b/erlang.cabal --- a/erlang.cabal +++ b/erlang.cabal @@ -1,5 +1,5 @@ name: erlang -version: 0.1 +version: 0.2 stability: alpha description: Speaks the Erlang network protocol and impersonates an Erlang node @@ -10,20 +10,23 @@ license: GPL license-file: COPYING author: Eric Sessoms -maintainer: nubgames@gmail.com -homepage: http://github.com/esessoms/haskell-interface +maintainer: Artúr Poór +homepage: http://github.com/gombocarti/erlang-ffi category: Foreign synopsis: FFI interface to Erlang. -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Simple +source-repository head + type: git + location: https://github.com/gombocarti/erlang-ffi.git library - build-depends: base, + build-depends: base >= 4 && < 5, binary >= 0.4.4, bytestring, directory, filepath, - nano-md5 >= 0.1.2, + MissingH, network >= 2.2.0.1, random >= 1.0.0.1 exposed-modules: Foreign.Erlang diff --git a/src/Foreign/Erlang.hs b/src/Foreign/Erlang.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang.hs @@ -0,0 +1,35 @@ +-- | +-- Module : Foreign.Erlang +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Speaks the Erlang network protocol and impersonates an Erlang node +-- on the network. Fully capable of bi-directional communication with +-- Erlang. Erlang types are, as far as reasonable, mapped to Haskell +-- types. Messages to Erlang are just function calls in Haskell, and +-- messages from Erlang are delivered to MVars. +-- + +module Foreign.Erlang ( + module Foreign.Erlang.Network + , module Foreign.Erlang.OTP + , module Foreign.Erlang.Processes + , module Foreign.Erlang.Types + , module Foreign.Erlang.Utilities + ) where + +import Foreign.Erlang.Network hiding (toNetwork) +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 + ) diff --git a/src/Foreign/Erlang.lhs b/src/Foreign/Erlang.lhs deleted file mode 100644 --- a/src/Foreign/Erlang.lhs +++ /dev/null @@ -1,36 +0,0 @@ -> ----------------------------------------------------------------------------- -> -- | -> -- Module : Foreign.Erlang -> -- Copyright : Eric Sessoms -> -- License : GPL3 (see COPYING) -> -- -> -- Maintainer : Eric Sessoms -> -- Stability : alpha -> -- Portability : portable -> -- -> -- Speaks the Erlang network protocol and impersonates an Erlang node -> -- on the network. Fully capable of bi-directional communication with -> -- Erlang. Erlang types are, as far as reasonable, mapped to Haskell -> -- types. Messages to Erlang are just function calls in Haskell, and -> -- messages from Erlang are delivered to MVars. -> -- -> ----------------------------------------------------------------------------- - -> module Foreign.Erlang ( -> module Foreign.Erlang.Network -> , module Foreign.Erlang.OTP -> , module Foreign.Erlang.Processes -> , module Foreign.Erlang.Types -> , module Foreign.Erlang.Utilities -> ) where - -> import Foreign.Erlang.Network hiding (toNetwork) -> 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 -> ) diff --git a/src/Foreign/Erlang/Network.hs b/src/Foreign/Erlang/Network.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Network.hs @@ -0,0 +1,270 @@ +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@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 + , Ip + , 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 Network (PortID(..), connectTo, withSocketsDo) +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) + +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 + +flagExtendedReferences :: Word16 +flagExtendedPidsPorts :: Word16 + +getUserCookie :: IO String +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) + +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 + +-- | 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. + 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' = PortNumber . 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) <> + 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 :: String +epmdLocal = "127.0.0.1" + +epmdPort :: PortID +--epmdPort = Service "epmd" +epmdPort = PortNumber 4369 + +withNode :: String -> PortID -> (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) diff --git a/src/Foreign/Erlang/Network.lhs b/src/Foreign/Erlang/Network.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/Network.lhs +++ /dev/null @@ -1,213 +0,0 @@ -> module Foreign.Erlang.Network ( -> -- * Low-level communication with the Erlang Port-Mapper Daemon. -> 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 - -> -- | Return the names and addresses of all registered Erlang nodes. -> epmdGetNames :: IO [String] -> epmdGetNames = do -> reply <- epmdSend "n" -> let txt = runGet (getN >> liftM B.unpack getRemainingLazyByteString) reply -> return . lines $ txt - -> -- | Return the port address of a named Erlang node. -> epmdGetPort :: String -> IO Int -> epmdGetPort name = do -> reply <- epmdSend $ 'p' : name -> return $ runGet getn reply - -> -- | Returns (port, nodeType, protocol, vsnMax, vsnMin, name, extra) -> 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) diff --git a/src/Foreign/Erlang/OTP.hs b/src/Foreign/Erlang/OTP.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/OTP.hs @@ -0,0 +1,18 @@ +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- + +module Foreign.Erlang.OTP ( + module Foreign.Erlang.OTP.GenServer + , module Foreign.Erlang.OTP.Mnesia + ) where + +import Foreign.Erlang.OTP.GenServer +import Foreign.Erlang.OTP.Mnesia diff --git a/src/Foreign/Erlang/OTP.lhs b/src/Foreign/Erlang/OTP.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/OTP.lhs +++ /dev/null @@ -1,7 +0,0 @@ -> module Foreign.Erlang.OTP ( -> module Foreign.Erlang.OTP.GenServer -> , module Foreign.Erlang.OTP.Mnesia -> ) where - -> import Foreign.Erlang.OTP.GenServer -> import Foreign.Erlang.OTP.Mnesia diff --git a/src/Foreign/Erlang/OTP/GenServer.hs b/src/Foreign/Erlang/OTP/GenServer.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/OTP/GenServer.hs @@ -0,0 +1,47 @@ +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- + +module Foreign.Erlang.OTP.GenServer ( + -- * High-level communication + genCall + , genCast + , rpcCall + , rpcCast + ) where + +import Foreign.Erlang.Types (Erlang, ErlType(..)) +import Foreign.Erlang.Processes +import Foreign.Erlang.Network (Node) + +-- | gen_server:cast(Pid, Msg) + +genCast :: Erlang a => MBox -> Node -> Pid -> a -> IO () +genCast mbox node pid msg = mboxSend mbox node pid (ErlAtom "$gen_cast", msg) + +-- | gen_server:call(Pid, Msg) + +genCall :: Erlang a => MBox -> Node -> Pid -> a -> IO ErlType +genCall mbox node pid msg = do + ref <- mboxRef mbox + mboxSend mbox node pid (ErlAtom "$gen_call", (mboxSelf mbox, ref), msg) + mboxRecv' mbox ref + +-- | rpc:cast(Node, Module, Function, Arguments) + +rpcCast :: MBox -> Node -> String -> String -> [ErlType] -> IO () +rpcCast mbox node m f as = genCast mbox node (Right "rex") $ + (ErlAtom "cast", ErlAtom m, ErlAtom f, as, mboxSelf mbox) + +-- | rpc:call(Node, Module, Function, Arguments) + +rpcCall :: MBox -> Node -> String -> String -> [ErlType] -> IO ErlType +rpcCall mbox node m f as = genCall mbox node (Right "rex") $ + (ErlAtom "call", ErlAtom m, ErlAtom f, as, mboxSelf mbox) diff --git a/src/Foreign/Erlang/OTP/GenServer.lhs b/src/Foreign/Erlang/OTP/GenServer.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/OTP/GenServer.lhs +++ /dev/null @@ -1,35 +0,0 @@ -> module Foreign.Erlang.OTP.GenServer ( -> -- * High-level communication. -> genCall -> , genCast -> , rpcCall -> , rpcCast -> ) where - -> import Foreign.Erlang.Types (Erlang, ErlType(..)) -> import Foreign.Erlang.Processes - -> -- | gen_server:cast(Pid, Msg) - -> genCast :: Erlang a => MBox -> Node -> Pid -> a -> IO () -> genCast mbox node pid msg = mboxSend mbox node pid (ErlAtom "$gen_cast", msg) - -> -- | gen_server:call(Pid, Msg) - -> genCall :: Erlang a => MBox -> Node -> Pid -> a -> IO ErlType -> genCall mbox node pid msg = do -> ref <- mboxRef mbox -> mboxSend mbox node pid (ErlAtom "$gen_call", (mboxSelf mbox, ref), msg) -> mboxRecv' mbox ref - -> -- | rpc:cast(Node, Module, Function, Arguments) - -> rpcCast :: MBox -> Node -> String -> String -> [ErlType] -> IO () -> rpcCast mbox node m f as = genCast mbox node (Right "rex") $ -> (ErlAtom "cast", ErlAtom m, ErlAtom f, as, mboxSelf mbox) - -> -- | rpc:call(Node, Module, Function, Arguments) - -> rpcCall :: MBox -> Node -> String -> String -> [ErlType] -> IO ErlType -> rpcCall mbox node m f as = genCall mbox node (Right "rex") $ -> (ErlAtom "call", ErlAtom m, ErlAtom f, as, mboxSelf mbox) diff --git a/src/Foreign/Erlang/OTP/Mnesia.hs b/src/Foreign/Erlang/OTP/Mnesia.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/OTP/Mnesia.hs @@ -0,0 +1,58 @@ +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- + +module Foreign.Erlang.OTP.Mnesia ( + -- * Mnesia database methods + backup + , dirtyAllKeys + , dirtyFirst + , dirtyNext + , dirtyLast + , dirtyPrev + , dirtyMatchObject + , dirtyRead + , dirtySelect + ) where + +import Foreign.Erlang.OTP.GenServer (rpcCall) +import Foreign.Erlang.Processes (MBox) +import Foreign.Erlang.Types (ErlType(..)) +import Foreign.Erlang.Network (Node) + +mnesia :: MBox -> Node -> String -> [ErlType] -> IO ErlType +mnesia mbox node f as = rpcCall mbox node "mnesia" f as + +backup :: MBox -> Node -> String -> IO ErlType +backup mbox node path = mnesia mbox node "backup" [ErlString path] + +dirtyAllKeys :: MBox -> Node -> String -> IO ErlType +dirtyAllKeys mbox node tab = mnesia mbox node "dirty_all_keys" [ErlAtom tab] + +dirtyFirst :: MBox -> Node -> String -> IO ErlType +dirtyFirst mbox node tab = mnesia mbox node "dirty_first" [ErlAtom tab] + +dirtyNext :: MBox -> Node -> String -> ErlType -> IO ErlType +dirtyNext mbox node tab key = mnesia mbox node "dirty_next" [ErlAtom tab, key] + +dirtyLast :: MBox -> Node -> String -> IO ErlType +dirtyLast mbox node tab = mnesia mbox node "dirty_last" [ErlAtom tab] + +dirtyPrev :: MBox -> Node -> String -> ErlType -> IO ErlType +dirtyPrev mbox node tab key = mnesia mbox node "dirty_pref" [ErlAtom tab, key] + +dirtyMatchObject :: MBox -> Node -> ErlType -> IO ErlType +dirtyMatchObject mbox node pat = mnesia mbox node "dirty_match_object" [pat] + +dirtyRead :: MBox -> Node -> String -> ErlType -> IO ErlType +dirtyRead mbox node tab key = mnesia mbox node "dirty_read" [ErlAtom tab, key] + +dirtySelect :: MBox -> Node -> String -> ErlType -> IO ErlType +dirtySelect mbox node tab spec = mnesia mbox node "dirty_select" [spec] diff --git a/src/Foreign/Erlang/OTP/Mnesia.lhs b/src/Foreign/Erlang/OTP/Mnesia.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/OTP/Mnesia.lhs +++ /dev/null @@ -1,46 +0,0 @@ -> module Foreign.Erlang.OTP.Mnesia ( -> -- * Mnesia database methods. -> backup -> , dirtyAllKeys -> , dirtyFirst -> , dirtyNext -> , dirtyLast -> , dirtyPrev -> , dirtyMatchObject -> , dirtyRead -> , dirtySelect -> ) where - -> import Foreign.Erlang.OTP.GenServer (rpcCall) -> import Foreign.Erlang.Processes (MBox, Node) -> import Foreign.Erlang.Types (ErlType(..)) - -> mnesia :: MBox -> Node -> String -> [ErlType] -> IO ErlType -> mnesia mbox node f as = rpcCall mbox node "mnesia" f as - -> backup :: MBox -> String -> String -> IO ErlType -> backup mbox node path = mnesia mbox node "backup" [ErlString path] - -> dirtyAllKeys :: MBox -> String -> String -> IO ErlType -> dirtyAllKeys mbox node tab = mnesia mbox node "dirty_all_keys" [ErlAtom tab] - -> dirtyFirst :: MBox -> String -> String -> IO ErlType -> dirtyFirst mbox node tab = mnesia mbox node "dirty_first" [ErlAtom tab] - -> dirtyNext :: MBox -> String -> String -> ErlType -> IO ErlType -> dirtyNext mbox node tab key = mnesia mbox node "dirty_next" [ErlAtom tab, key] - -> dirtyLast :: MBox -> String -> String -> IO ErlType -> dirtyLast mbox node tab = mnesia mbox node "dirty_last" [ErlAtom tab] - -> dirtyPrev :: MBox -> String -> String -> ErlType -> IO ErlType -> dirtyPrev mbox node tab key = mnesia mbox node "dirty_pref" [ErlAtom tab, key] - -> dirtyMatchObject :: MBox -> String -> ErlType -> IO ErlType -> dirtyMatchObject mbox node pat = mnesia mbox node "dirty_match_object" [pat] - -> dirtyRead :: MBox -> String -> String -> ErlType -> IO ErlType -> dirtyRead mbox node tab key = mnesia mbox node "dirty_read" [ErlAtom tab, key] - -> dirtySelect :: MBox -> String -> String -> ErlType -> IO ErlType -> dirtySelect mbox node tab spec = mnesia mbox node "dirty_select" [spec] diff --git a/src/Foreign/Erlang/Processes.hs b/src/Foreign/Erlang/Processes.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Processes.hs @@ -0,0 +1,206 @@ +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- + +module Foreign.Erlang.Processes ( + -- * Low-level communication + -- ** Representation of a Haskell node (program) + Self + , createSelf + -- ** Representation of a Haskell process (thread) + , MBox + , createMBox + , mboxRef + , mboxSelf + -- ** Representation of Erlang nodes and processes + , Pid + -- ** Communication to and from Erlang + , mboxRecv + , mboxRecv' + , mboxSend + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Data.Maybe (fromJust) +import Foreign.Erlang.Network +import Foreign.Erlang.Types + +data ErlMessage = ErlRegister (ErlType -> IO ()) + | ErlGenRef ErlType + | ErlSend Node ErlType ErlType + | ErlRegSend ErlType Node String ErlType + | ErlLink ErlType Node ErlType + | ErlUnlink ErlType Node ErlType + | ErlExit ErlType Node ErlType ErlType + | ErlExit2 ErlType Node ErlType ErlType + | ErlDispatch ErlType ErlType + | ErlStop + deriving Show + +instance Show (a -> b) where + show _ = "" + +-- | Represents a Haskell node. There should be one of these per process. +data Self = Self { send :: ErlMessage -> IO () } + +genPid nodename id = ErlPid (ErlAtom nodename) id 0 1 +genRef nodename id = ErlNewRef (ErlAtom nodename) 1 . toNetwork 4 . fromIntegral $ id + +-- | Instantiate a Haskell node. This initializes the FFI. +createSelf :: String -> IO Self +createSelf nodename = do + inbox <- newEmptyMVar + forkIO $ self nodename inbox + return . Self $ putMVar inbox + +self :: String -> MVar ErlMessage -> IO () +self nodename inbox = loop 1 [] [] + where + loop id mboxes nodes = do + msg <- takeMVar inbox + case msg of + ErlRegister mbox -> do + let pid = genPid nodename id + mbox pid + loop (id+1) ((pid, mbox) : mboxes) nodes + ErlGenRef pid -> do + let ref = genRef nodename id + maybe (return ()) ($ ref) $ lookup pid mboxes + loop (id+1) mboxes nodes + ErlSend node pid msg -> do + let ctl = toErlang (ErlInt 2, ErlAtom "", pid) + (mnode, nodes') <- findNode node nodes + case mnode of + Just n -> n (Just ctl, Just msg) + Nothing -> return () + loop id mboxes nodes' + ErlRegSend from node pid msg -> do + let ctl = toErlang (ErlInt 6, from, ErlAtom "", ErlAtom pid) + (mnode, nodes') <- findNode node nodes + case mnode of + Just n -> n (Just ctl, Just msg) + Nothing -> return () + loop id mboxes nodes' + ErlLink from to pid -> do + let ctl = toErlang (ErlInt 1, from, pid) + (node, nodes') <- findNode to nodes + fromJust node (Just ctl, Nothing) + loop id mboxes nodes' + ErlUnlink from to pid -> do + let ctl = toErlang (ErlInt 4, from, pid) + (node, nodes') <- findNode to nodes + fromJust node (Just ctl, Nothing) + loop id mboxes nodes' + ErlExit from to pid reason -> do + let ctl = toErlang (ErlInt 3, from, to, reason) + (node, nodes') <- findNode to nodes + fromJust node (Just ctl, Nothing) + loop id mboxes nodes' + ErlExit2 from to pid reason -> do + let ctl = toErlang (ErlInt 8, from, to, reason) + (node, nodes') <- findNode to nodes + fromJust node (Just ctl, Nothing) + loop id mboxes nodes' + ErlDispatch ctl msg -> do + case ctl of + ErlTuple [ErlInt 2, _, pid] -> + maybe (return ()) ($ msg) $ lookup pid mboxes + _ -> return () + loop id mboxes nodes + ErlStop -> return () + + findNode to nodes = + case lookup to nodes of + Just node -> return (Just node, nodes) + Nothing -> do + (send, recv) <- erlConnect nodename to + mvar <- newEmptyMVar + forkIO $ nodeSend mvar send + forkIO $ nodeRecv mvar recv inbox + let node = putMVar mvar + return (Just node, ((to, node) : nodes)) + +-- | A `nodeSend` thread is responsible for communication to an Erlang +-- process. It receives messages in an `MVar` and forwards them across +-- the network. + +nodeSend mvar send = loop + where + loop = takeMVar mvar >>= send >> loop + +-- | A `nodeRecv` thread is responsible for communication from an Erlang +-- process. It receives messages from the network and dispatches them as +-- appropriate. + +nodeRecv mvar recv outbox = loop + where + loop = do + (mctl, mmsg) <- recv + case mctl of + -- Nothing is a keepalive. All we want to do is echo it. + Nothing -> putMVar mvar (Nothing, Nothing) + -- A real message goes to self to be dispatched. + Just ctl -> putMVar outbox $ ErlDispatch ctl (fromJust mmsg) + loop + +-- | Haskell threads don't natively have Erlang process IDs. Instead, we +-- use a mailbox abstraction that we can assign PIDs to for communication +-- with Erlang. + +data MBox = MBox ErlType (MVar ErlType) Self + +-- | Represents a foreign (Erlang) process. A process can be identified +-- either by its low-level ID (Left pid) or by its registered name (Right name). + +type Pid = Either ErlType String + +-- | Return the PID of the given mailbox. + +mboxSelf :: MBox -> ErlType +mboxSelf (MBox pid _ _) = pid + +-- | Return a new unique object reference. + +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 +-- +-- > {Node, Pid} ! Msg. + +mboxSend :: Erlang a => MBox -> Node -> Pid -> a -> IO () +mboxSend (MBox _ _ self) node (Left pid) msg = send self $ ErlSend node pid (toErlang msg) +mboxSend (MBox from _ self) node (Right pid) msg = send self $ ErlRegSend from node pid (toErlang msg) + +-- | Receive the next message addressed to this mailbox. + +mboxRecv :: MBox -> IO ErlType +mboxRecv (MBox _ inbox _) = takeMVar inbox + +-- | Receive a reply message. That is, looks for the next message +-- identified by the given reference. + +mboxRecv' :: MBox -> ErlType -> IO ErlType +mboxRecv' mbox ref = do + msg <- mboxRecv mbox + case msg of + ErlTuple [ref', result] | ref' == ref -> return result + _ -> mboxRecv' mbox ref + +-- | Create a new process on the Haskell side. Usually corresponds +-- to a thread but doesn't need to. + +createMBox :: Self -> IO MBox +createMBox self = do + inbox <- newEmptyMVar + send self $ ErlRegister (putMVar inbox) + pid <- takeMVar inbox + return $ MBox pid inbox self diff --git a/src/Foreign/Erlang/Processes.lhs b/src/Foreign/Erlang/Processes.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/Processes.lhs +++ /dev/null @@ -1,198 +0,0 @@ -> module Foreign.Erlang.Processes ( -> -- * Low-level communication. -> -- ** Represents a Haskell node (program). -> Self -> , createSelf -> -- ** Represents a Haskell process (thread). -> , MBox -> , createMBox -> , mboxRef -> , mboxSelf -> -- ** Represents Erlang nodes and processes. -> , Node -> , Pid -> -- ** Communication to/from Erlang. -> , mboxRecv -> , mboxRecv' -> , mboxSend -> ) where - -> import Control.Concurrent (forkIO) -> import Control.Concurrent.MVar -> import Data.Maybe (fromJust) -> import Foreign.Erlang.Network -> import Foreign.Erlang.Types - -> -- | The name of an Erlang node on the network. -> type Node = String - -> data ErlMessage = ErlRegister (ErlType -> IO ()) -> | ErlGenRef ErlType -> | ErlSend String ErlType ErlType -> | ErlRegSend ErlType String String ErlType -> | ErlLink ErlType String ErlType -> | ErlUnlink ErlType String ErlType -> | ErlExit ErlType String ErlType ErlType -> | ErlExit2 ErlType String ErlType ErlType -> | ErlDispatch ErlType ErlType -> | ErlStop -> deriving Show - -> instance Show (a -> b) where -> show _ = "" - -> -- | Represents a Haskell node. There should be one of these per process. -> data Self = Self { send :: ErlMessage -> IO () } - -> genPid nodename id = ErlPid (ErlAtom nodename) id 0 1 -> genRef nodename id = ErlNewRef (ErlAtom nodename) 1 . toNetwork 4 . fromIntegral $ id - -> -- | Instantiate a Haskell node. This initializes the FFI. -> createSelf :: String -> IO Self -> createSelf nodename = do -> inbox <- newEmptyMVar -> forkIO $ self nodename inbox -> return . Self $ putMVar inbox - -> self :: String -> MVar ErlMessage -> IO () -> self nodename inbox = loop 1 [] [] -> where -> loop id mboxes nodes = do -> msg <- takeMVar inbox -> case msg of -> ErlRegister mbox -> do -> let pid = genPid nodename id -> mbox pid -> loop (id+1) ((pid, mbox) : mboxes) nodes -> ErlGenRef pid -> do -> let ref = genRef nodename id -> maybe (return ()) ($ ref) $ lookup pid mboxes -> loop (id+1) mboxes nodes -> ErlSend node pid msg -> do -> let ctl = toErlang (ErlInt 2, ErlAtom "", pid) -> (mnode, nodes') <- findNode node nodes -> case mnode of -> Just n -> n (Just ctl, Just msg) -> Nothing -> return () -> loop id mboxes nodes' -> ErlRegSend from node pid msg -> do -> let ctl = toErlang (ErlInt 6, from, ErlAtom "", ErlAtom pid) -> (mnode, nodes') <- findNode node nodes -> case mnode of -> Just n -> n (Just ctl, Just msg) -> Nothing -> return () -> loop id mboxes nodes' -> ErlLink from to pid -> do -> let ctl = toErlang (ErlInt 1, from, pid) -> (node, nodes') <- findNode to nodes -> fromJust node (Just ctl, Nothing) -> loop id mboxes nodes' -> ErlUnlink from to pid -> do -> let ctl = toErlang (ErlInt 4, from, pid) -> (node, nodes') <- findNode to nodes -> fromJust node (Just ctl, Nothing) -> loop id mboxes nodes' -> ErlExit from to pid reason -> do -> let ctl = toErlang (ErlInt 3, from, to, reason) -> (node, nodes') <- findNode to nodes -> fromJust node (Just ctl, Nothing) -> loop id mboxes nodes' -> ErlExit2 from to pid reason -> do -> let ctl = toErlang (ErlInt 8, from, to, reason) -> (node, nodes') <- findNode to nodes -> fromJust node (Just ctl, Nothing) -> loop id mboxes nodes' -> ErlDispatch ctl msg -> do -> case ctl of -> ErlTuple [ErlInt 2, _, pid] -> -> maybe (return ()) ($ msg) $ lookup pid mboxes -> _ -> return () -> loop id mboxes nodes -> ErlStop -> return () - -> findNode to nodes = -> case lookup to nodes of -> Just node -> return (Just node, nodes) -> Nothing -> do -> (send, recv) <- erlConnect nodename to -> mvar <- newEmptyMVar -> forkIO $ nodeSend mvar send -> forkIO $ nodeRecv mvar recv inbox -> let node = putMVar mvar -> return (Just node, ((to, node) : nodes)) - -A `nodeSend` thread is responsible for communication to an Erlang -process. It receives messages in an `MVar` and forwards them across -the network. - -> nodeSend mvar send = loop -> where -> loop = takeMVar mvar >>= send >> loop - -A `nodeRecv` thread is responsible for communication from an Erlang -process. It receives messages from the network and dispatches them as -appropriate. - -> nodeRecv mvar recv outbox = loop -> where -> loop = do -> (mctl, mmsg) <- recv -> case mctl of -> -- Nothing is a keepalive. All we want to do is echo it. -> Nothing -> putMVar mvar (Nothing, Nothing) -> -- A real message goes to self to be dispatched. -> Just ctl -> putMVar outbox $ ErlDispatch ctl (fromJust mmsg) -> loop - -> -- | Haskell threads don't natively have Erlang process IDs. Instead, we -> -- use a mailbox abstraction that we can assign PIDs to for communication -> -- with Erlang. - -> data MBox = MBox ErlType (MVar ErlType) Self - -> -- | Represents a foreign (Erlang) process. A process can be identified -> -- either by its low-level ID (Left pid) or by its registered name (Right name). - -> type Pid = Either ErlType String - -> -- | Return the PID of the given mailbox. - -> mboxSelf :: MBox -> ErlType -> mboxSelf (MBox pid _ _) = pid - -> -- | Return a new unique object reference. - -> 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. - -> -- | {Node, Pid} ! Msg. -> mboxSend :: Erlang a => MBox -> Node -> Pid -> a -> IO () -> mboxSend (MBox _ _ self) node (Left pid) msg = send self $ ErlSend node pid (toErlang msg) -> mboxSend (MBox from _ self) node (Right pid) msg = send self $ ErlRegSend from node pid (toErlang msg) - -> -- | Receive the next message addressed to this mailbox. - -> mboxRecv :: MBox -> IO ErlType -> mboxRecv (MBox _ inbox _) = takeMVar inbox - -> -- | Receive a reply message. That is, looks for the next message -> -- identified by the given reference. - -> mboxRecv' :: MBox -> ErlType -> IO ErlType -> mboxRecv' mbox ref = do -> msg <- mboxRecv mbox -> case msg of -> ErlTuple [ref', result] | ref' == ref -> return result -> _ -> mboxRecv' mbox ref - -> -- | Create a new process on the Haskell side. Usually corresponds -> -- to a thread but doesn't need to. - -> createMBox :: Self -> IO MBox -> createMBox self = do -> inbox <- newEmptyMVar -> send self $ ErlRegister (putMVar inbox) -> pid <- takeMVar inbox -> return $ MBox pid inbox self diff --git a/src/Foreign/Erlang/Types.hs b/src/Foreign/Erlang/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Types.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -XFlexibleInstances -XTypeSynonymInstances #-} + +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- + +module Foreign.Erlang.Types ( + -- * Native Erlang data types + ErlType(..) + -- ** Conversion between native Haskell types and ErlType + , Erlang(..) + -- ** Easy type-safe access to tuple members + , nth + + -- ** Internal packing functions + , getA, getC, getErl, getN, geta, getn + , putA, putC, putErl, putN, puta, putn + , tag + ) where + +import Prelude hiding (id) +import qualified Prelude (id) +import Control.Exception (assert) +import Control.Monad (forM, liftM) +--import Data.Int (Int64) +import Data.Monoid ((<>),mconcat) +import Data.Binary +import Data.Binary.Get +import Data.Char (chr, ord, isPrint) +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 as C +import Data.ByteString.Lazy.Builder + +nth :: Erlang a => Int -> ErlType -> a +nth i (ErlTuple lst) = fromErlang $ lst !! i + +data ErlType = ErlNull + | ErlInt Int + | ErlBigInt Integer + | ErlString String + | ErlAtom String + | ErlBinary [Word8] + | ErlList [ErlType] + | ErlTuple [ErlType] + | ErlPid ErlType Int Int Int -- node id serial creation + | ErlPort ErlType Int Int -- node id creation + | ErlRef ErlType Int Int -- node id creation + | ErlNewRef ErlType Int [Word8] -- node creation id + deriving (Eq, Show) + +class Erlang a where + toErlang :: a -> ErlType + fromErlang :: ErlType -> a + +instance Erlang ErlType where + toErlang = Prelude.id + fromErlang = Prelude.id + +instance Erlang Int where + toErlang x = ErlInt x + fromErlang (ErlInt x) = x + fromErlang (ErlBigInt x) = fromIntegral x + +instance Erlang Integer where + toErlang x = ErlBigInt x + fromErlang (ErlInt x) = fromIntegral x + fromErlang (ErlBigInt x) = x + +instance Erlang String where + toErlang x = ErlString x + fromErlang ErlNull = "" + fromErlang (ErlString x) = x + fromErlang (ErlAtom x) = x + fromErlang (ErlList xs) = map (chr . fromErlang) xs + fromErlang x = error $ "can't convert to string: " ++ show x + +instance Erlang Bool where + toErlang True = ErlAtom "true" + toErlang False = ErlAtom "false" + fromErlang (ErlAtom "true") = True + fromErlang (ErlAtom "false") = False + +instance Erlang [ErlType] where + toErlang [] = ErlNull + toErlang xs = ErlList xs + fromErlang ErlNull = [] + fromErlang (ErlList xs) = xs + +instance Erlang a => Erlang [a] where + toErlang [] = ErlNull + toErlang xs = ErlList . map toErlang $ xs + fromErlang ErlNull = [] + fromErlang (ErlList xs) = map fromErlang xs + +instance (Erlang a, Erlang b) => Erlang (a, b) where + toErlang (x, y) = ErlTuple [toErlang x, toErlang y] + fromErlang (ErlTuple [x, y]) = (fromErlang x, fromErlang y) + +instance (Erlang a, Erlang b, Erlang c) => Erlang (a, b, c) where + toErlang (x, y, z) = ErlTuple [toErlang x, toErlang y, toErlang z] + fromErlang (ErlTuple [x, y, z]) = (fromErlang x, fromErlang y, fromErlang z) + +instance (Erlang a, Erlang b, Erlang c, Erlang d) => Erlang (a, b, c, d) where + toErlang (x, y, z, w) = ErlTuple [toErlang x, toErlang y, toErlang z, toErlang w] + fromErlang (ErlTuple [x, y, z, w]) = (fromErlang x, fromErlang y, fromErlang z, fromErlang w) + +instance (Erlang a, Erlang b, Erlang c, Erlang d, Erlang e) => Erlang (a, b, c, d, e) where + toErlang (x, y, z, w, a) = ErlTuple [toErlang x, toErlang y, toErlang z, toErlang w, toErlang a] + fromErlang (ErlTuple [x, y, z, w, a]) = (fromErlang x, fromErlang y, fromErlang z, fromErlang w, fromErlang a) + +instance Binary ErlType where + put = undefined + get = getErl + + +putErl :: ErlType -> Builder +putErl (ErlInt val) + | 0 <= val && val < 256 = tag 'a' <> putC val + | otherwise = tag 'b' <> putN val +putErl (ErlAtom val) = tag 'd' <> putn (length val) <> putA val +putErl (ErlTuple val) + | len < 256 = tag 'h' <> putC len <> val' + | otherwise = tag 'i' <> putN len <> val' + where val' = mconcat . map putErl $ val + len = length val +putErl ErlNull = tag 'j' +putErl (ErlString val) = tag 'k' <> putn (length val) <> putA val +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 (ErlRef node id creation) = + tag 'e' <> + putErl node <> + putN id <> + putC creation +putErl (ErlPort node id creation) = tag 'f' <> putErl node <> putN id <> putC creation +putErl (ErlPid node id serial creation) = tag 'g' <> putErl node <> putN id <> putN serial <> putC creation +putErl (ErlNewRef node creation id) = + tag 'r' <> + putn (length id `div` 4) <> + putErl node <> + putC creation <> + (lazyByteString . B.pack) id + +getErl :: Get ErlType +getErl = do + tag <- liftM chr getC + case tag of + 'a' -> liftM ErlInt getC + 'b' -> liftM ErlInt getN + 'd' -> getn >>= liftM ErlAtom . getA + 'e' -> do + node <- getErl + id <- getN + creation <- getC + return $ ErlRef node id creation + 'f' -> do + node <- getErl + id <- getN + creation <- getC + return $ ErlPort node id creation + 'g' -> do + node <- getErl + id <- getN + serial <- getN + creation <- getC + return $ ErlPid node id serial creation + 'h' -> getC >>= \len -> liftM ErlTuple $ forM [1..len] (const getErl) + 'i' -> getN >>= \len -> liftM ErlTuple $ forM [1..len] (const getErl) + 'j' -> return ErlNull + 'k' -> do + len <- getn + list <- getA len + case all isPrint list of + True -> return $ ErlString list + False -> return . ErlList $ map (ErlInt . ord) list + 'l' -> do + len <- getN + list <- liftM ErlList $ forM [1..len] (const getErl) + null <- getErl + assert (null == ErlNull) $ return list + 'm' -> getN >>= liftM ErlBinary . geta + 'r' -> do + len <- getn + node <- getErl + creation <- getC + id <- forM [1..4*len] (const getWord8) + return $ ErlNewRef node creation id + x -> error [x] + +tag :: Char -> Builder +tag = charUtf8 + +putC :: Integral a => a -> Builder +putC = word8 . fromIntegral + +putn :: Integral a => a -> Builder +putn = word16BE . fromIntegral + +putN :: Integral a => a -> Builder +putN = word32BE . fromIntegral + +puta :: [Word8] -> Builder +puta = lazyByteString . B.pack + +putA :: String -> Builder +putA = stringUtf8 + +getC :: Get Int +getC = liftM fromIntegral getWord8 + +getn :: Get Int +getn = liftM fromIntegral getWord16be + +getN :: Get Int +getN = liftM fromIntegral getWord32be + +geta :: Int -> Get [Word8] +geta = liftM B.unpack . getLazyByteString . fromIntegral + +getA :: Int -> Get String +getA = liftM C.unpack . getLazyByteString . fromIntegral diff --git a/src/Foreign/Erlang/Types.lhs b/src/Foreign/Erlang/Types.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/Types.lhs +++ /dev/null @@ -1,199 +0,0 @@ -> {-# LANGUAGE OverlappingInstances #-} -> {-# OPTIONS -XFlexibleInstances -XTypeSynonymInstances #-} - -> module Foreign.Erlang.Types ( -> -- * Native Erlang data types. -> -- ** Haskell representation. -> ErlType(..) -> -- ** Conversion between native Haskell types and ErlType. -> , Erlang -> , fromErlang -> , toErlang -> -- ** Easy type-safe access to tuple members. -> , nth -> -> -- ** Internal packing functions. -> , getA, getC, getErl, getN, geta, getn -> , putA, putC, putErl, putN, puta, putn -> , tag -> ) where - -> import Control.Exception (assert) -> import Control.Monad (forM, liftM) -> import Data.Binary -> import Data.Binary.Get -> import Data.Binary.Put -> import Data.Char (chr, ord) -> import qualified Data.ByteString as B -> import qualified Data.ByteString.Char8 as C - -> nth :: Erlang a => Int -> ErlType -> a -> nth i (ErlTuple lst) = fromErlang $ lst !! i - -> data ErlType = ErlNull -> | ErlInt Int -> | ErlBigInt Integer -> | ErlString String -> | ErlAtom String -> | ErlBinary [Word8] -> | ErlList [ErlType] -> | ErlTuple [ErlType] -> | ErlPid ErlType Int Int Int -- node id serial creation -> | ErlPort ErlType Int Int -- node id creation -> | ErlRef ErlType Int Int -- node id creation -> | ErlNewRef ErlType Int [Word8] -- node creation id -> deriving (Eq, Show) - -> class Erlang a where -> toErlang :: a -> ErlType -> fromErlang :: ErlType -> a - -> instance Erlang ErlType where -> toErlang = id -> fromErlang = id - -> instance Erlang Int where -> toErlang x = ErlInt x -> fromErlang (ErlInt x) = x -> fromErlang (ErlBigInt x) = fromIntegral x - -> instance Erlang Integer where -> toErlang x = ErlBigInt x -> fromErlang (ErlInt x) = fromIntegral x -> fromErlang (ErlBigInt x) = x - -> instance Erlang String where -> toErlang x = ErlString x -> fromErlang ErlNull = "" -> fromErlang (ErlString x) = x -> fromErlang (ErlAtom x) = x -> fromErlang (ErlList xs) = map (chr . fromErlang) xs -> fromErlang x = error $ "can't convert to string: " ++ show x - -> instance Erlang Bool where -> toErlang True = ErlAtom "true" -> toErlang False = ErlAtom "false" -> fromErlang (ErlAtom "true") = True -> fromErlang (ErlAtom "false") = False - -> instance Erlang [ErlType] where -> toErlang [] = ErlNull -> toErlang xs = ErlList xs -> fromErlang ErlNull = [] -> fromErlang (ErlList xs) = xs - -> instance Erlang a => Erlang [a] where -> toErlang [] = ErlNull -> toErlang xs = ErlList . map toErlang $ xs -> fromErlang ErlNull = [] -> fromErlang (ErlList xs) = map fromErlang xs - -> instance (Erlang a, Erlang b) => Erlang (a, b) where -> toErlang (x, y) = ErlTuple [toErlang x, toErlang y] -> fromErlang (ErlTuple [x, y]) = (fromErlang x, fromErlang y) - -> instance (Erlang a, Erlang b, Erlang c) => Erlang (a, b, c) where -> toErlang (x, y, z) = ErlTuple [toErlang x, toErlang y, toErlang z] -> fromErlang (ErlTuple [x, y, z]) = (fromErlang x, fromErlang y, fromErlang z) - -> instance (Erlang a, Erlang b, Erlang c, Erlang d) => Erlang (a, b, c, d) where -> toErlang (x, y, z, w) = ErlTuple [toErlang x, toErlang y, toErlang z, toErlang w] -> fromErlang (ErlTuple [x, y, z, w]) = (fromErlang x, fromErlang y, fromErlang z, fromErlang w) - -> instance (Erlang a, Erlang b, Erlang c, Erlang d, Erlang e) => Erlang (a, b, c, d, e) where -> toErlang (x, y, z, w, a) = ErlTuple [toErlang x, toErlang y, toErlang z, toErlang w, toErlang a] -> fromErlang (ErlTuple [x, y, z, w, a]) = (fromErlang x, fromErlang y, fromErlang z, fromErlang w, fromErlang a) - -> instance Binary ErlType where -> put = putErl -> get = getErl - -> putErl (ErlInt val) -> | 0 <= val && val < 256 = tag 'a' >> putC val -> | otherwise = tag 'b' >> putN val -> putErl (ErlAtom val) = tag 'd' >> putn (length val) >> putA val -> putErl (ErlTuple val) -> | len < 256 = tag 'h' >> putC len >> mapM_ putErl val -> | otherwise = tag 'i' >> putN len >> mapM_ putErl val -> where -> len = length val -> putErl ErlNull = tag 'j' -> putErl (ErlString val) = tag 'k' >> putn (length val) >> putA val -> putErl (ErlList val) = tag 'l' >> putN (length val) >> mapM_ putErl val >> putErl ErlNull -> putErl (ErlBinary val) = tag 'm' >> putN (length val) >> puta val -> putErl (ErlRef node id creation) = do -> tag 'e' -> putErl node -> putN id -> putC creation -> putErl (ErlPort node id creation) = do -> tag 'f' -> putErl node -> putN id -> putC creation -> putErl (ErlPid node id serial creation) = do -> tag 'g' -> putErl node -> putN id -> putN serial -> putC creation -> putErl (ErlNewRef node creation id) = do -> tag 'r' -> putn $ length id `div` 4 -> putErl node -> putC creation -> mapM_ putWord8 id - -> getErl = do -> tag <- liftM chr getC -> case tag of -> 'a' -> liftM ErlInt getC -> 'b' -> liftM ErlInt getN -> 'd' -> getn >>= liftM ErlAtom . getA -> 'e' -> do -> node <- getErl -> id <- getN -> creation <- getC -> return $ ErlRef node id creation -> 'f' -> do -> node <- getErl -> id <- getN -> creation <- getC -> return $ ErlPort node id creation -> 'g' -> do -> node <- getErl -> id <- getN -> serial <- getN -> creation <- getC -> return $ ErlPid node id serial creation -> 'h' -> getC >>= \len -> liftM ErlTuple $ forM [1..len] (const getErl) -> 'i' -> getN >>= \len -> liftM ErlTuple $ forM [1..len] (const getErl) -> 'j' -> return ErlNull -> 'k' -> getn >>= liftM ErlString . getA -> 'l' -> do -> len <- getN -> list <- liftM ErlList $ forM [1..len] (const getErl) -> null <- getErl -> assert (null == ErlNull) $ return list -> 'm' -> getN >>= liftM ErlBinary . geta -> 'r' -> do -> len <- getn -> node <- getErl -> creation <- getC -> id <- forM [1..4*len] (const getWord8) -> return $ ErlNewRef node creation id -> x -> error [x] - -> tag = putC . ord - -> putC = putWord8 . fromIntegral -> putn = putWord16be . fromIntegral -> putN = putWord32be . fromIntegral -> puta = putByteString . B.pack -> putA = putByteString . C.pack - -> getC = liftM fromIntegral getWord8 -> getn = liftM fromIntegral getWord16be -> getN = liftM fromIntegral getWord32be -> geta = liftM B.unpack . getByteString -> getA = liftM C.unpack . getByteString diff --git a/src/Foreign/Erlang/Utilities.hs b/src/Foreign/Erlang/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Utilities.hs @@ -0,0 +1,35 @@ +-- | +-- Module : Foreign.Erlang.OTP +-- Copyright : (c) Eric Sessoms, 2008 +-- (c) Artúr Poór, 2015 +-- License : GPL3 +-- +-- Maintainer : gombocarti@gmail.com +-- Stability : experimental +-- Portability : portable +-- + +module Foreign.Erlang.Utilities ( + -- * Miscellaneous utilities + erlangTimeToSeconds + , secondsToErlangTime + ) where + +import Foreign.Erlang.Types (ErlType(..)) + +-- Erlang's native time format is a tuple: {MegaSeconds, Seconds, +-- 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. + +erlangTimeToSeconds :: Integral a => ErlType -> a +erlangTimeToSeconds (ErlTuple [ErlInt ms, ErlInt s, _]) = + fromIntegral $ 1000000*ms + s + +-- | Convert seconds to an Erlang tuple representing time. + +secondsToErlangTime :: Integral a => a -> ErlType +secondsToErlangTime sec = ErlTuple [ErlInt ms, ErlInt s, ErlInt 0] + where + (ms, s) = fromIntegral sec `divMod` 1000000 diff --git a/src/Foreign/Erlang/Utilities.lhs b/src/Foreign/Erlang/Utilities.lhs deleted file mode 100644 --- a/src/Foreign/Erlang/Utilities.lhs +++ /dev/null @@ -1,24 +0,0 @@ -> module Foreign.Erlang.Utilities ( -> -- * Miscellaneous utilities. -> erlangTimeToSeconds -> , secondsToErlangTime -> ) where - -> import Foreign.Erlang.Types (ErlType(..)) - -Erlang's native time format is a tuple: {MegaSeconds, Seconds, -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. - -> erlangTimeToSeconds :: Integral a => ErlType -> a -> erlangTimeToSeconds (ErlTuple [ErlInt ms, ErlInt s, _]) = -> fromIntegral $ 1000000*ms + s - -> -- | Convert seconds to an Erlang tuple representing time. - -> secondsToErlangTime :: Integral a => a -> ErlType -> secondsToErlangTime sec = ErlTuple [ErlInt ms, ErlInt s, ErlInt 0] -> where -> (ms, s) = fromIntegral sec `divMod` 1000000