erlang 0.1 → 0.2

raw patch · 19 files changed

+911/−767 lines, 19 filesdep +MissingHdep −nano-md5dep ~basesetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: MissingH

Dependencies removed: nano-md5

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Setup.hs +3/−0
• Setup.lhs +0/−3
• erlang.cabal +9/−6
• src/Foreign/Erlang.hs +35/−0
• src/Foreign/Erlang.lhs +0/−36
• src/Foreign/Erlang/Network.hs +270/−0
• src/Foreign/Erlang/Network.lhs +0/−213
• src/Foreign/Erlang/OTP.hs +18/−0
• src/Foreign/Erlang/OTP.lhs +0/−7
• src/Foreign/Erlang/OTP/GenServer.hs +47/−0
• src/Foreign/Erlang/OTP/GenServer.lhs +0/−35
• src/Foreign/Erlang/OTP/Mnesia.hs +58/−0
• src/Foreign/Erlang/OTP/Mnesia.lhs +0/−46
• src/Foreign/Erlang/Processes.hs +206/−0
• src/Foreign/Erlang/Processes.lhs +0/−198
• src/Foreign/Erlang/Types.hs +230/−0
• src/Foreign/Erlang/Types.lhs +0/−199
• src/Foreign/Erlang/Utilities.hs +35/−0
• src/Foreign/Erlang/Utilities.lhs +0/−24

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain

@@ -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 <nubgames@gmail.com>-maintainer:          nubgames@gmail.com-homepage:            http://github.com/esessoms/haskell-interface+maintainer:          Artúr Poór <gombocarti@gmail.com>+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

@@ -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+  )

@@ -1,36 +0,0 @@-> ------------------------------------------------------------------------------> -- |-> -- Module      : Foreign.Erlang-> -- Copyright   : Eric Sessoms-> -- License     : GPL3 (see COPYING)-> -- -> -- Maintainer  : Eric Sessoms <nubgames@gmail.com>-> -- 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->   )

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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]

@@ -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]

@@ -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 _ = "<function>"++-- | 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

@@ -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 _ = "<function>"--> -- | 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

@@ -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

@@ -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

@@ -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

@@ -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