diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Timo Koepke (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Timo Koepke nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hinterface.cabal b/hinterface.cabal new file mode 100644 --- /dev/null +++ b/hinterface.cabal @@ -0,0 +1,89 @@ +name: hinterface +version: 0.5.0.0 +synopsis: Haskell / Erlang interoperability library +description: Please see README.md +homepage: https://github.com/LTI2000/hinterface +license: BSD3 +license-file: LICENSE +author: Timo Koepke, Sven Heyll +maintainer: timo.koepke@googlemail.com, sven.heyll@gmail.com +copyright: 2016 Timo Koepke, Sven Heyll +category: Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Util.IOExtra + , Util.BufferedIOx + , Util.Socket + , Network.BufferedSocket + , Util.Binary + , Util.FloatCast + , Foreign.Erlang.NodeState + , Foreign.Erlang.NodeData + , Foreign.Erlang.Epmd + , Foreign.Erlang.Digest + , Foreign.Erlang.Handshake + , Foreign.Erlang.Term + , Foreign.Erlang.LocalNode + , Foreign.Erlang.ControlMessage + , Foreign.Erlang.Mailbox + , Foreign.Erlang.Connection + default-extensions: OverloadedStrings + , NamedFieldPuns + , FlexibleContexts + ghc-options: -Wall -O2 -funbox-strict-fields + build-depends: QuickCheck >= 2.8 && < 3 + , array + , async >= 2.1 && < 2.2 + , base >= 4.9 && < 5 + , binary + , bytestring + , containers + , cryptonite + , exceptions >= 0.8 && < 0.9 + , lifted-async >= 0.9 && < 1.0 + , lifted-base >= 0.2 && < 0.3 + , memory + , monad-control >= 1.0 && < 1.1 + , monad-logger >= 0.3 && < 0.4 + , mtl + , network + , random + , resourcet >= 1 && < 2 + , safe-exceptions >= 0.1 && < 0.2 + , stm + , text >= 1.2 && < 1.3 + , transformers + , transformers-base >= 0.4 && < 0.5 + , vector + + default-language: Haskell2010 + +test-suite hinterface-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: QuickCheck + , async >= 2.1 && < 2.2 + , base >= 4.9 && < 5 + , binary + , bytestring + , hinterface + , hspec + , monad-logger >= 0.3 && < 0.4 + , transformers + other-modules: Foreign.Erlang.NodeDataSpec + , Foreign.Erlang.HandshakeSpec + , Foreign.Erlang.ControlMessageSpec + , Foreign.Erlang.TermSpec + default-extensions: OverloadedStrings + , NamedFieldPuns + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/LTI2000/hinterface.git diff --git a/src/Foreign/Erlang/Connection.hs b/src/Foreign/Erlang/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Connection.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE Strict #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wno-unused-do-bind #-} + +module Foreign.Erlang.Connection + ( Connection(closeConnection) + , newConnection + , sendControlMessage + ) where + +import Control.Monad +import Control.Concurrent.STM +import qualified Control.Concurrent.Async as A +import Util.BufferedIOx +import Util.IOExtra +import Foreign.Erlang.NodeState +import Foreign.Erlang.Term +import Foreign.Erlang.ControlMessage +import Foreign.Erlang.Mailbox + +-------------------------------------------------------------------------------- +data Connection = MkConnection { sendQueue :: TQueue ControlMessage + , closeConnection :: IO () + } + +-------------------------------------------------------------------------------- +newConnection :: (MonadLoggerIO m, MonadMask m, MonadBaseControl IO m, BufferedIOx s) + => s + -> NodeState Pid Term Mailbox Connection + -> Term + -> m Connection +newConnection sock nodeState name = do + sendQueue <- liftIO newTQueueIO + forkTransmitter sendQueue + where + forkTransmitter sendQueue = do + s <- async newSender + r <- async newReceiver + registerConnection s r + where + newSender = sendLoop sock sendQueue + newReceiver = recvLoop sock sendQueue nodeState + registerConnection s r = do + let connection = MkConnection sendQueue stopTransmitter + liftIO (putConnectionForNode nodeState name connection) + async awaitStopAndCleanup + return connection + where + stopTransmitter = void (A.concurrently (A.cancel s) (A.cancel r)) + awaitStopAndCleanup = do + (_ :: Either SomeException ()) <- waitCatch r + cancel s + tryAndLogAll (liftIO (closeBuffered sock)) + liftIO (removeConnectionForNode nodeState name) + +-- liftIO $ +-- getConnectionForNode nodeState name >>= +-- mapM_ closeConnection +sendControlMessage :: MonadIO m => ControlMessage -> Connection -> m () +sendControlMessage controlMessage MkConnection{sendQueue} = + liftIO $ + atomically $ writeTQueue sendQueue controlMessage + +sendLoop :: (MonadCatch m, MonadLoggerIO m, BufferedIOx s) + => s + -> TQueue ControlMessage + -> m () +sendLoop sock sendQueue = + forever (tryAndLogIO send) + where + send = liftIO $ do + controlMessage <- atomically $ readTQueue sendQueue + runPutBuffered sock controlMessage + +recvLoop :: (MonadLoggerIO m, MonadCatch m, BufferedIOx s, MonadMask m) + => s + -> TQueue ControlMessage + -> NodeState Pid Term Mailbox Connection + -> m () +recvLoop sock sendQueue nodeState = + forever (recv `catchAll` + (\x -> do + logErrorShow (x, nodeState) + throwM x)) + where + recv = runGetBuffered sock >>= liftIO . deliver + deliver controlMessage = + case controlMessage of + TICK -> atomically $ writeTQueue sendQueue TICK + LINK fromPid toPid -> do + mailbox <- getMailboxForPid nodeState toPid + mapM_ (`deliverLink` fromPid) mailbox + SEND toPid message -> do + mailbox <- getMailboxForPid nodeState toPid + mapM_ (`deliverSend` message) mailbox + EXIT fromPid toPid reason -> do + mailbox <- getMailboxForPid nodeState toPid + mapM_ (\mb -> deliverExit mb fromPid reason) mailbox + UNLINK fromPid toPid -> do + mailbox <- getMailboxForPid nodeState toPid + mapM_ (`deliverUnlink` fromPid) mailbox + NODE_LINK -> + -- FIXME + return () + REG_SEND fromPid toName message -> do + mailbox <- getMailboxForName nodeState toName + mapM_ (\mb -> deliverRegSend mb fromPid message) mailbox + GROUP_LEADER fromPid toPid -> do + mailbox <- getMailboxForPid nodeState toPid + mapM_ (`deliverGroupLeader` fromPid) mailbox + EXIT2 fromPid toPid reason -> do + mailbox <- getMailboxForPid nodeState toPid + mapM_ (\mb -> deliverExit2 mb fromPid reason) mailbox diff --git a/src/Foreign/Erlang/ControlMessage.hs b/src/Foreign/Erlang/ControlMessage.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/ControlMessage.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} + +module Foreign.Erlang.ControlMessage ( ControlMessage(..) ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Maybe +import Foreign.Erlang.Term +import Prelude hiding (length) +import Test.QuickCheck +import Util.Binary + +-------------------------------------------------------------------------------- +data ControlMessage = TICK + | LINK Pid Pid -- FromPid ToPid + | SEND Pid Term -- ToPid Message + | EXIT Pid Pid Term -- FromPid ToPid Reason + | UNLINK Pid Pid -- FromPid ToPid + | NODE_LINK -- + | REG_SEND Pid Term Term -- FromPid ToName Message + | GROUP_LEADER Pid Pid -- FromPid ToPid + | EXIT2 Pid Pid Term -- FromPid ToPid Reason + deriving (Eq, Show) + +instance Binary ControlMessage where + put TICK = putWord32be 0 + put controlMessage = putWithLength32be $ do + putWord8 pass_through + put' controlMessage + where + put' TICK = fail "Unreachable code" + + put' (LINK fromPid toPid) = do + putTerm (linkTag, fromPid, toPid) + + put' (SEND toPid message) = do + putTerm (sendTag, unused, toPid) + putTerm message + + put' (EXIT fromPid toPid reason) = do + putTerm (exitTag, fromPid, toPid, reason) + + put' (UNLINK fromPid toPid) = do + putTerm (unlinkTag, fromPid, toPid) + + put' NODE_LINK = do + putTerm (Tuple1 nodeLinkTag) + + put' (REG_SEND fromPid toName message) = do + putTerm (regSendTag, fromPid, unused, toName) + putTerm message + + put' (GROUP_LEADER fromPid toPid) = do + putTerm (groupLeaderTag, fromPid, toPid) + + put' (EXIT2 fromPid toPid reason) = do + putTerm (exit2Tag, fromPid, toPid, reason) + get = do + expectedLen <- getWord32be + if expectedLen == 0 + then return TICK + else do + pos0 <- bytesRead + matchWord8 pass_through + controlMessage <- get' + pos1 <- bytesRead + let actualLen = pos1 - pos0 + if (fromIntegral expectedLen) == actualLen + then do + return controlMessage + else do + fail "Bad control message length" + where + badControlMsg term = fail ("Bad control message: " ++ show term) + get' = do + term <- getTerm + res <- runMaybeT $ get'' term + maybe (badControlMsg term) return res + where + get'' :: Term -> MaybeT Get ControlMessage + get'' term = getLINK + <|> getSEND + <|> getEXIT + <|> getUNLINK + <|> getNODE_LINK + <|> getREG_SEND + <|> getGROUP_LEADER + <|> getEXIT2 + where + getLINK = do + (_ :: TlinkTag, p2, p3) <- fromTermA term + return (LINK p2 p3) + getSEND = do + (_ :: TsendTag, _ :: Term, p1) <- fromTermA term + message <- lift getTerm + return (SEND p1 message) + getEXIT = do + (_ :: TexitTag, p2, p3, p4) <- fromTermA term + return (EXIT p2 p3 p4) + getUNLINK = do + (_ :: TunlinkTag, p2, p3) <- fromTermA term + return (UNLINK p2 p3) + getNODE_LINK = do + (_ :: Tuple1 TnodeLinkTag) <- fromTermA term + return NODE_LINK + getREG_SEND = do + (_ :: TregSendTag, p2, _p3 :: Term, p4) <- fromTermA term + message <- lift getTerm + return (REG_SEND p2 p4 message) + getGROUP_LEADER = do + (_ :: TgroupLeaderTag, p2, p3) <- fromTermA term + return (GROUP_LEADER p2 p3) + getEXIT2 = do + (_ :: Texit2Tag, p2, p3, p4) <- fromTermA term + return (EXIT2 p2 p3 p4) + +-------------------------------------------------------------------------------- +pass_through :: Word8 +pass_through = 112 + +type TlinkTag = SInteger 1 + +linkTag :: TlinkTag +linkTag = SInteger + +type TsendTag = SInteger 2 + +sendTag :: TsendTag +sendTag = SInteger + +type TexitTag = SInteger 3 + +exitTag :: TexitTag +exitTag = SInteger + +type TunlinkTag = SInteger 4 + +unlinkTag :: TunlinkTag +unlinkTag = SInteger + +type TnodeLinkTag = SInteger 5 + +nodeLinkTag :: TnodeLinkTag +nodeLinkTag = SInteger + +type TregSendTag = SInteger 6 + +regSendTag :: TregSendTag +regSendTag = SInteger + +type TgroupLeaderTag = SInteger 7 + +groupLeaderTag :: TgroupLeaderTag +groupLeaderTag = SInteger + +type Texit2Tag = SInteger 8 + +exit2Tag :: Texit2Tag +exit2Tag = SInteger + +unused :: Term +unused = atom "" + +instance Arbitrary ControlMessage where + arbitrary = oneof [ pure TICK + , LINK <$> arbitrary <*> arbitrary + , SEND <$> arbitrary <*> arbitrary + , EXIT <$> arbitrary <*> arbitrary <*> arbitrary + , UNLINK <$> arbitrary <*> arbitrary + , pure NODE_LINK + , REG_SEND <$> arbitrary <*> arbitrary <*> arbitrary + , GROUP_LEADER <$> arbitrary <*> arbitrary + , EXIT2 <$> arbitrary <*> arbitrary <*> arbitrary + ] diff --git a/src/Foreign/Erlang/Digest.hs b/src/Foreign/Erlang/Digest.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Digest.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE Strict #-} + +module Foreign.Erlang.Digest + ( genChallenge + , genDigest + ) where + +import "cryptonite" Crypto.Hash (MD5 (MD5), hashFinalize, + hashInitWith, hashUpdate) +import Data.ByteArray (convert) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CS +import Data.Word +import System.Random (randomIO) + +genChallenge :: IO Word32 +genChallenge = randomIO + +genDigest :: Word32 -> BS.ByteString -> BS.ByteString +genDigest challenge cookie = + let ctx0 = hashInitWith MD5 + ctx1 = hashUpdate ctx0 cookie + ctx2 = hashUpdate ctx1 (CS.pack (show challenge)) + digest = hashFinalize ctx2 + in + convert digest diff --git a/src/Foreign/Erlang/Epmd.hs b/src/Foreign/Erlang/Epmd.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Epmd.hs @@ -0,0 +1,179 @@ +module Foreign.Erlang.Epmd + ( -- * List registered nodes + epmdNames + , NamesResponse(..) + -- * Looking up nodes + , lookupNode + -- * Registering nodes + , registerNode + , NodeRegistration(nr_creation) + ) where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as CL +import Data.Maybe + +import Foreign.Erlang.NodeData +import Network.BufferedSocket +import Util.Binary +import Util.BufferedIOx +import Util.IOExtra +import Util.Socket + +-------------------------------------------------------------------------------- +epmdPort :: Word16 +epmdPort = 4369 + +-------------------------------------------------------------------------------- +names_req, port_please2_req, port_please2_resp, alive2_req, alive2_resp :: Word8 +names_req = 110 + +port_please2_req = 122 + +port_please2_resp = 119 + +alive2_req = 120 + +alive2_resp = 121 + +-------------------------------------------------------------------------------- +data NamesRequest = NamesRequest + deriving (Eq, Show) + +instance Binary NamesRequest where + put _ = putWithLength16be $ + putWord8 names_req + get = undefined + +data NodeInfo = NodeInfo String Word16 + deriving (Eq, Show) + +data NamesResponse = NamesResponse Word16 [NodeInfo] + deriving (Eq, Show) + +instance Binary NamesResponse where + put _ = undefined + get = do + epmdPortNo <- getWord32be + nodeInfos <- getRemainingLazyByteString + return $ + NamesResponse (fromIntegral epmdPortNo) + (catMaybes (map nodeInfo (CL.lines nodeInfos))) + where + nodeInfo :: CL.ByteString -> Maybe NodeInfo + nodeInfo cl = do + [ "name", name, "at", "port", portString ] <- Just $ CL.split ' ' cl + (port, "") <- CL.readInt portString + return $ NodeInfo (CL.unpack name) (fromIntegral port) + +-- | List all registered nodes +epmdNames :: (MonadMask m, MonadResource m, MonadLogger m) + => BS.ByteString -- ^ hostname + -> m NamesResponse +epmdNames hostName = withBufferedSocket hostName (sendRequest NamesRequest) + +-------------------------------------------------------------------------------- +newtype LookupNodeRequest = LookupNodeRequest BS.ByteString + deriving (Eq, Show) + +instance Binary LookupNodeRequest where + put (LookupNodeRequest alive) = + putWithLength16be $ do + putWord8 port_please2_req + putByteString alive + get = undefined + +newtype LookupNodeResponse = + LookupNodeResponse { fromLookupNodeResponse :: Maybe NodeData } + deriving (Eq, Show) + +instance Binary LookupNodeResponse where + put _ = undefined + get = LookupNodeResponse <$> do + matchWord8 port_please2_resp + result <- getWord8 + if result > 0 + then return Nothing + else Just <$> get + +-- | Lookup a node +lookupNode :: (MonadMask m, MonadResource m, MonadLogger m) + => BS.ByteString -- ^ alive + -> BS.ByteString -- ^ hostname + -> m (Maybe NodeData) +lookupNode alive hostName = + fromLookupNodeResponse <$> withBufferedSocket hostName + (sendRequest + (LookupNodeRequest alive)) + +-------------------------------------------------------------------------------- +data RegisterNodeRequest = RegisterNodeRequest NodeData + deriving (Eq, Show) + +instance Binary RegisterNodeRequest where + put (RegisterNodeRequest node) = + putWithLength16be $ do + putWord8 alive2_req + put node + get = undefined + +data RegisterNodeResponse = RegisterNodeResponse (Maybe Word16) + deriving (Eq, Show) + +instance Binary RegisterNodeResponse where + put _ = undefined + get = RegisterNodeResponse <$> do + matchWord8 alive2_resp + result <- getWord8 + if result > 0 + then return Nothing + else Just <$> getWord16be + +newtype NodeRegistration = NodeRegistration { nr_creation :: Word16 } + +newtype NodeAlreadyRegistered = NodeAlreadyRegistered NodeData + deriving (Show) + +instance Exception NodeAlreadyRegistered + +-- | Register a node with an epmd; as long as the TCP connection is open, the +-- registration is considered valid. +registerNode :: (MonadResource m, MonadLogger m, MonadMask m) + => NodeData -- ^ node + -> BS.ByteString -- ^ hostName + -> (NodeRegistration -> m a) -- ^ action to execute while the TCP connection is alive + -> m a +registerNode node hostName action = + withBufferedSocket hostName go + where + go sock = do + r@(RegisterNodeResponse mr) <- sendRequest (RegisterNodeRequest node) + sock + logInfoShow r + when (isNothing mr) (throwM (NodeAlreadyRegistered node)) + action (NodeRegistration (fromJust mr)) + +sendRequest :: (MonadLogger m, MonadMask m, MonadIO m, BufferedIOx s, Binary a, Binary b) + => a + -> s + -> m b +sendRequest req sock = do + liftIO $ runPutBuffered sock req + runGetBuffered sock + +withBufferedSocket :: (MonadIO m, MonadMask m) + => BS.ByteString -- ^ hostName + -> (BufferedSocket -> m b) + -> m b +withBufferedSocket hostName = + bracket (liftIO $ connectBufferedSocket hostName) (liftIO . closeBuffered) + +connectBufferedSocket :: (MonadIO m) + => BS.ByteString -- ^ hostName + -> m BufferedSocket +connectBufferedSocket hostName = + liftIO $ + connectSocket hostName epmdPort >>= makeBuffered diff --git a/src/Foreign/Erlang/Handshake.hs b/src/Foreign/Erlang/Handshake.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Handshake.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Strict #-} + +module Foreign.Erlang.Handshake + ( HandshakeData(..) + , doConnect + , doAccept + , Name(..) + , Status(..) + , Challenge(..) + , ChallengeReply(..) + , ChallengeAck(..) + ) where + +import Control.Monad ( unless, when ) +import Util.IOExtra +import Data.Ix ( inRange ) + +import qualified Data.ByteString as BS +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Util.Binary +import Foreign.Erlang.Digest +import Foreign.Erlang.NodeData + +data HandshakeData = HandshakeData { name :: Name + , nodeData :: NodeData + , cookie :: BS.ByteString + } + +nodeTypeR6, challengeStatus, challengeReply, challengeAck :: Char +nodeTypeR6 = 'n' + +challengeStatus = 's' + +challengeReply = 'r' + +challengeAck = 'a' + +data Name = Name { n_distVer :: DistributionVersion + , n_distFlags :: DistributionFlags + , n_nodeName :: BS.ByteString + } + deriving (Eq, Show) + +instance Binary Name where + put Name{n_distVer,n_distFlags,n_nodeName} = + putWithLength16be $ do + putChar8 nodeTypeR6 + put n_distVer + put n_distFlags + putByteString n_nodeName + get = do + len <- getWord16be + (((), n_distVer, n_distFlags), l) <- getWithLength16be $ + (,,) <$> matchChar8 nodeTypeR6 + <*> get + <*> get + n_nodeName <- getByteString (fromIntegral (len - l)) + return Name { n_distVer, n_distFlags, n_nodeName } + +data Status = Ok | OkSimultaneous | Nok | NotAllowed | Alive + deriving (Eq, Show, Bounded, Enum) + +instance Binary Status where + put status = putWithLength16be $ do + putChar8 challengeStatus + case status of + Ok -> putByteString "ok" + OkSimultaneous -> putByteString "ok_simultaneous" + Nok -> putByteString "nok" + NotAllowed -> putByteString "not_allowed" + Alive -> putByteString "alive" + get = do + len <- getWord16be + ((), l) <- getWithLength16be $ matchChar8 challengeStatus + status <- getByteString (fromIntegral (len - l)) + case status of + "ok" -> return Ok + "ok_simultaneous" -> return OkSimultaneous + "nok" -> return Nok + "not_allowed" -> return NotAllowed + "alive" -> return Alive + _ -> fail $ "Bad status: " ++ show status + +data Challenge = Challenge { c_distVer :: DistributionVersion + , c_distFlags :: DistributionFlags + , c_challenge :: Word32 + , c_nodeName :: BS.ByteString + } + deriving (Eq, Show) + +instance Binary Challenge where + put Challenge{c_distVer,c_distFlags,c_challenge,c_nodeName} = + putWithLength16be $ do + putChar8 nodeTypeR6 + put c_distVer + put c_distFlags + putWord32be c_challenge + putByteString c_nodeName + get = do + len <- getWord16be + (((), c_distVer, c_distFlags, c_challenge), l) <- getWithLength16be $ + (,,,) <$> matchChar8 nodeTypeR6 + <*> get + <*> get + <*> getWord32be + c_nodeName <- getByteString (fromIntegral (len - l)) + return Challenge { c_distVer, c_distFlags, c_challenge, c_nodeName } + +data ChallengeReply = ChallengeReply { cr_challenge :: Word32 + , cr_digest :: BS.ByteString + } + deriving (Eq, Show) + +instance Binary ChallengeReply where + put ChallengeReply{cr_challenge,cr_digest} = + putWithLength16be $ do + putChar8 challengeReply + putWord32be cr_challenge + putByteString cr_digest + get = do + len <- getWord16be + (((), cr_challenge), l) <- getWithLength16be $ + (,) <$> matchChar8 challengeReply + <*> getWord32be + cr_digest <- getByteString (fromIntegral (len - l)) + return ChallengeReply { cr_challenge, cr_digest } + +data ChallengeAck = ChallengeAck { ca_digest :: BS.ByteString } + deriving (Eq, Show) + +instance Binary ChallengeAck where + put ChallengeAck{ca_digest} = + putWithLength16be $ do + putChar8 challengeAck + putByteString ca_digest + get = do + len <- getWord16be + ((), l) <- getWithLength16be $ matchChar8 challengeAck + ca_digest <- getByteString (fromIntegral (len - l)) + return ChallengeAck { ca_digest } + +doConnect :: (MonadCatch m, MonadIO m) + => (forall o. Binary o => o -> m ()) + -> (forall i. (Binary i) => m i) + -> HandshakeData + -> m () +doConnect send recv HandshakeData{name,nodeData = NodeData{loVer,hiVer},cookie} = do + send name + do + her_status <- recv + when (her_status /= Ok) (throwM (BadHandshakeStatus her_status)) + + Challenge{c_distVer = her_distVer,c_challenge = her_challenge} <- recv + checkVersionRange her_distVer loVer hiVer + + our_challenge <- liftIO genChallenge + send ChallengeReply { cr_challenge = our_challenge + , cr_digest = genDigest her_challenge cookie + } + ChallengeAck{ca_digest = her_digest} <- recv + checkCookie her_digest our_challenge cookie + +newtype BadHandshakeStatus = BadHandshakeStatus Status + deriving Show + +instance Exception BadHandshakeStatus + +doAccept :: (MonadCatch m, MonadIO m) + => (forall o. Binary o => o -> m ()) -- TODO + -> (forall i. (Binary i) => m i) + -> HandshakeData + -> m BS.ByteString +doAccept send recv HandshakeData{name = Name{n_distFlags,n_nodeName},nodeData = NodeData{loVer,hiVer},cookie} = do + Name{n_distVer = her_distVer,n_nodeName = her_nodeName} <- recv + checkVersionRange her_distVer loVer hiVer + + send Ok + + our_challenge <- liftIO genChallenge + send Challenge { c_distVer = R6B + , c_distFlags = n_distFlags + , c_challenge = our_challenge + , c_nodeName = n_nodeName + } + + ChallengeReply{cr_challenge = her_challenge,cr_digest = her_digest} <- recv + checkCookie her_digest our_challenge cookie + + send ChallengeAck { ca_digest = genDigest her_challenge cookie } + return her_nodeName + +checkVersionRange :: MonadThrow m + => DistributionVersion + -> DistributionVersion + -> DistributionVersion + -> m () +checkVersionRange herVersion lowVersion highVersion = + unless (inRange (lowVersion, highVersion) herVersion) + (throwM DistributionVersionMismatch { herVersion + , lowVersion + , highVersion + }) + +checkCookie :: MonadThrow m => BS.ByteString -> Word32 -> BS.ByteString -> m () +checkCookie her_digest our_challenge cookie = + unless (her_digest == genDigest our_challenge cookie) + (throwM CookieMismatch) + +data DistributionVersionMismatch = + DistributionVersionMismatch { herVersion :: DistributionVersion + , lowVersion :: DistributionVersion + , highVersion :: DistributionVersion + } + deriving Show + +instance Exception DistributionVersionMismatch + +data CookieMismatch = CookieMismatch + deriving Show + +instance Exception CookieMismatch diff --git a/src/Foreign/Erlang/LocalNode.hs b/src/Foreign/Erlang/LocalNode.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/LocalNode.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Foreign.Erlang.LocalNode + ( LocalNode() + , NodeT() + , LocalNodeConfig(..) + , askCreation + , askNodeName + , askNodeState + , askNodeRegistration + , askLocalNode + , runNodeT + , make_pid + , make_ref + , make_port + , make_mailbox + , register_pid + , send + , sendReg + ) where + +-- , closeLocalNode +import Prelude hiding ( id ) + +import Control.Monad +import Control.Monad.Reader +import Control.Concurrent.STM +import Control.Monad.Base +import qualified Data.ByteString.Char8 as CS +import Data.Word + +import Util.IOExtra +import Util.BufferedIOx +import Util.Socket +import Network.BufferedSocket + +import Foreign.Erlang.ControlMessage ( ControlMessage(..) ) +import Foreign.Erlang.NodeState +import Foreign.Erlang.NodeData +import Foreign.Erlang.Epmd +import Foreign.Erlang.Handshake +import Foreign.Erlang.Term +import Foreign.Erlang.Connection +import Foreign.Erlang.Mailbox + +data LocalNodeConfig = LocalNodeConfig { aliveName :: String + , hostName :: String + , cookie :: String + } + deriving Show + +newtype NodeT m a = NodeT { unNodeT :: ReaderT RegisteredNode m a } + deriving (Functor, Applicative, Monad, MonadCatch, MonadThrow, MonadMask, MonadLogger, MonadIO) + +deriving instance (MonadBase IO (NodeT m), MonadResource m) => + MonadResource (NodeT m) + +deriving instance MonadLoggerIO m => MonadLoggerIO (NodeT m) + +deriving instance MonadBase b m => MonadBase b (NodeT m) + +instance (MonadBaseControl b m) => + MonadBaseControl b (NodeT m) where + type StM (NodeT m) a = StM m a + liftBaseWith k = NodeT (liftBaseWith (\run -> k (run . unNodeT))) + restoreM = NodeT . restoreM + +data LocalNode = LocalNode { handshakeData :: HandshakeData + , nodeState :: NodeState Pid Term Mailbox Connection + , acceptorSocket :: Socket + } + +data RegisteredNode = RegisteredNode { localNode :: LocalNode + , nodeRegistration :: NodeRegistration + } + +askLocalNode :: Monad m => NodeT m LocalNode +askLocalNode = NodeT (asks localNode) + +askNodeRegistration :: Monad m => NodeT m NodeRegistration +askNodeRegistration = NodeT (asks nodeRegistration) + +askCreation :: Monad m => NodeT m Word8 +askCreation = fromIntegral . nr_creation <$> askNodeRegistration + +askNodeState :: Monad m => NodeT m (NodeState Pid Term Mailbox Connection) +askNodeState = nodeState <$> askLocalNode + +askNodeName :: Monad m => NodeT m CS.ByteString +askNodeName = n_nodeName . name . handshakeData <$> askLocalNode + +make_pid :: MonadIO m => NodeT m Pid +make_pid = do + name <- askNodeName + state <- askNodeState + (id, serial) <- liftIO (new_pid state) + cr <- askCreation + return (pid name id serial cr) + +register_pid :: (MonadIO m) => Term -> Pid -> NodeT m Bool +register_pid name pid' = do + state <- askNodeState + liftIO (do + mbox <- getMailboxForPid state pid' + mapM_ (putMailboxForName state name) mbox + return (isJust mbox)) + +make_ref :: (MonadIO m) => NodeT m Term +make_ref = do + state <- askNodeState + name <- askNodeName + (refId0, refId1, refId2) <- liftIO (new_ref state) + cr <- askCreation + return (ref name cr [ refId0, refId1, refId2 ]) + +make_port :: (MonadIO m) => NodeT m Term +make_port = do + name <- askNodeName + state <- askNodeState + id <- liftIO (new_port state) + cr <- askCreation + return $ port name id cr + +runNodeT :: forall m a. + (MonadResource m, MonadThrow m, MonadMask m, MonadLogger m, MonadLoggerIO m, MonadBaseControl IO m) + => LocalNodeConfig + -> NodeT m a + -> m a +runNodeT LocalNodeConfig{aliveName,hostName,cookie} NodeT{unNodeT} = do + requireM "(aliveName /= \"\")" (aliveName /= "") + requireM "(hostName /= \"\")" (hostName /= "") + bracket setupAcceptorSock stopAllConnections acceptRegisterAndRun + where + setupAcceptorSock = do + let nodeNameBS = CS.pack (aliveName ++ "@" ++ hostName) + (_, (acceptorSocket, portNo)) <- allocate (serverSocket (CS.pack hostName)) + (closeSock . fst) + let dFlags = DistributionFlags [ EXTENDED_REFERENCES + , FUN_TAGS + , NEW_FUN_TAGS + , EXTENDED_PIDS_PORTS + , BIT_BINARIES + , NEW_FLOATS + ] + name = Name { n_distVer = R6B + , n_distFlags = dFlags + , n_nodeName = nodeNameBS + } + nodeData = NodeData { portNo = portNo + , nodeType = HiddenNode + , protocol = TcpIpV4 + , hiVer = R6B + , loVer = R6B + , aliveName = CS.pack aliveName + , extra = "" + } + handshakeData = HandshakeData { name + , nodeData + , cookie = CS.pack cookie + } + nodeState <- liftIO newNodeState + return LocalNode { acceptorSocket, handshakeData, nodeState } + + acceptRegisterAndRun localNode@LocalNode{acceptorSocket,handshakeData = hsn@HandshakeData{nodeData},nodeState} = + withAsync accept (\accepted -> link accepted >> registerAndRun) + where + accept = forever (bracketOnErrorLog (liftIO (acceptSocket acceptorSocket >>= + makeBuffered)) + (liftIO . closeBuffered) + onConnect) + where + onConnect sock = tryAndLogAll (doAccept (runPutBuffered sock) + (runGetBuffered sock) + hsn) + >>= maybe (return ()) + (void . newConnection sock nodeState . atom) + + + registerAndRun = registerNode nodeData (CS.pack hostName) go + where + go nodeRegistration = do + let env = RegisteredNode { localNode, nodeRegistration } + result <- runReaderT unNodeT env + return result + + stopAllConnections LocalNode{nodeState} = do + cs <- liftIO $ getConnectedNodes nodeState + mapM_ (liftIO . closeConnection . snd) cs + +make_mailbox :: (MonadResource m) => NodeT m Mailbox +make_mailbox = do + self <- make_pid + msgQueue <- liftIO newTQueueIO + let mailbox = MkMailbox { self, msgQueue } + nodeState <- askNodeState + liftIO (putMailboxForPid nodeState self mailbox) + return mailbox + +send :: (MonadMask m, MonadBaseControl IO m, MonadResource m, MonadLoggerIO m) + => Pid + -> Term + -> NodeT m () +send toPid message = getOrCreateConnection (atom_name (node (toTerm toPid))) + >>= maybe (return ()) (sendControlMessage (SEND toPid message)) + +sendReg :: (MonadMask m, MonadBaseControl IO m, MonadResource m, MonadLoggerIO m) + => Mailbox + -> Term + -> Term + -> Term + -> NodeT m () +sendReg MkMailbox{self} regName nodeName message = + getOrCreateConnection (atom_name nodeName) >>= + maybe (return ()) (sendControlMessage (REG_SEND self regName message)) + +splitNodeName :: CS.ByteString -> (CS.ByteString, CS.ByteString) +splitNodeName a = case CS.split '@' a of + [ alive, host ] -> (alive, host) + _ -> error $ "Illegal node name: " ++ show a + +getOrCreateConnection :: (MonadMask m, MonadBaseControl IO m, MonadResource m, MonadLoggerIO m) + => CS.ByteString + -> NodeT m (Maybe Connection) +getOrCreateConnection remoteName = + getExistingConnection >>= maybe lookupAndConnect (return . Just) + where + getExistingConnection = do + nodeName <- atom <$> askNodeName + nodeState <- askNodeState + getConnectionForNode nodeState nodeName + + lookupAndConnect = lookupNode remoteAlive remoteHost >>= + maybe warnNotFound connect + where + (remoteAlive, remoteHost) = + splitNodeName remoteName + warnNotFound = do + logWarnStr (printf "Connection failed: Node '%s' not found on '%s'." + (CS.unpack remoteAlive) + (CS.unpack remoteHost)) + return Nothing + connect NodeData{portNo = remotePort} = + bracketOnErrorLog (liftIO (connectSocket remoteHost remotePort >>= + makeBuffered)) + cleanup + go + where + cleanup sock = do + liftIO (closeBuffered sock) + return Nothing + go sock = Just <$> do + nodeState <- askNodeState + LocalNode{handshakeData} <- askLocalNode + doConnect (runPutBuffered sock) + (runGetBuffered sock) + handshakeData + newConnection sock nodeState (atom remoteName) diff --git a/src/Foreign/Erlang/Mailbox.hs b/src/Foreign/Erlang/Mailbox.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Mailbox.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Strict #-} + +module Foreign.Erlang.Mailbox + ( Mailbox(..) + , deliverLink + , deliverSend + , deliverExit + , deliverUnlink + , deliverRegSend + , deliverGroupLeader + , deliverExit2 + , receive + ) where + +import Foreign.Erlang.Term +import Control.Concurrent.STM + +data Mailbox = MkMailbox { self :: Pid + , msgQueue :: TQueue Term + } + +deliverLink :: Mailbox -> Pid -> IO () +deliverLink = undefined + +deliverSend :: Mailbox -> Term -> IO () +deliverSend MkMailbox{msgQueue} = + atomically . writeTQueue msgQueue + +deliverExit :: Mailbox -> Pid -> Term -> IO () +deliverExit = + undefined + +deliverUnlink :: Mailbox -> Pid -> IO () +deliverUnlink = + undefined + +deliverRegSend :: Mailbox -> Pid -> Term -> IO () +deliverRegSend MkMailbox{msgQueue} _fromPid message = + atomically $ writeTQueue msgQueue message + +deliverGroupLeader :: Mailbox -> Pid -> IO () +deliverGroupLeader = + undefined + +deliverExit2 :: Mailbox -> Pid -> Term -> IO () +deliverExit2 = + undefined + +receive :: Mailbox -> IO Term +receive MkMailbox{msgQueue} = + atomically (readTQueue msgQueue) diff --git a/src/Foreign/Erlang/NodeData.hs b/src/Foreign/Erlang/NodeData.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/NodeData.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE Strict #-} + +module Foreign.Erlang.NodeData + ( DistributionVersion(..) + , matchDistributionVersion + , DistributionFlag(..) + , DistributionFlags(..) + , NodeType(..) + , NodeProtocol(..) + , NodeData(..) + ) where + +import qualified Data.ByteString as BS +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import Data.Bits +import Data.Ix + +import Util.Binary + +-------------------------------------------------------------------------------- +data DistributionVersion = Zero | R4 | NeverUsed | R5C | R6 | R6B + deriving (Eq, Show, Enum, Bounded, Ord, Ix) + +instance Binary DistributionVersion where + put = putWord16be . fromIntegral . fromEnum + get = do + c <- getWord16be + return $ toEnum $ fromIntegral c + +-------------------------------------------------------------------------------- +matchDistributionVersion :: NodeData -> NodeData -> Maybe DistributionVersion +matchDistributionVersion NodeData{protocol = localProto,hiVer = localHi,loVer = localLo} NodeData{protocol = remoteProto,hiVer = remoteHi,loVer = remoteLo} + | localProto /= remoteProto = + Nothing + | localHi < remoteLo = Nothing + | localLo > remoteHi = Nothing + | otherwise = Just (max localHi remoteHi) + +-------------------------------------------------------------------------------- +data DistributionFlag = PUBLISHED -- The node should be published and part of the global namespace + | ATOM_CACHE -- The node implements an atom cache (obsolete) + | EXTENDED_REFERENCES -- The node implements extended (3 * 32 bits) references. This is required today. If not present connection will be refused. + | DIST_MONITOR -- The node implements distributed process monitoring. + | FUN_TAGS -- The node uses separate tag for fun's (lambdas) in the distribution protocol. + | DIST_MONITOR_NAME -- The node implements distributed named process monitoring. + | HIDDEN_ATOM_CACHE -- The (hidden) node implements atom cache (obsolete) + | NEW_FUN_TAGS -- The node understand new fun-tags + | EXTENDED_PIDS_PORTS -- The node is capable of handling extended pids and ports. This is required today. If not present connection will be refused. + | EXPORT_PTR_TAG + | BIT_BINARIES + | NEW_FLOATS -- The node understands new float format + | UNICODE_IO + | DIST_HDR_ATOM_CACHE -- The node implements atom cache in distribution header. + | SMALL_ATOM_TAGS -- The node understand the SMALL_ATOM_EXT tag + | UTF8_ATOMS -- The node understand UTF-8 encoded atoms + deriving (Eq, Show, Enum, Bounded, Ord) + +newtype DistributionFlags = DistributionFlags [DistributionFlag] + deriving (Eq, Show) + +instance Binary DistributionFlags where + put (DistributionFlags flags) = do + putWord32be $ toBits flags + where + toBits :: [DistributionFlag] -> Word32 + toBits = foldl (flip $ (.|.) . toBit) 0 + get = do + (DistributionFlags . fromBits) <$> getWord32be + where + fromBits :: Word32 -> [DistributionFlag] + fromBits bits = [ flag + | flag <- [minBound .. maxBound] + , bits .&. toBit flag /= 0 ] + +toBit :: DistributionFlag -> Word32 +toBit PUBLISHED = 0x00001 +toBit ATOM_CACHE = 0x00002 +toBit EXTENDED_REFERENCES = + 0x00004 +toBit DIST_MONITOR = 0x00008 +toBit FUN_TAGS = 0x00010 +toBit DIST_MONITOR_NAME = + 0x00020 -- NOT USED +toBit HIDDEN_ATOM_CACHE = + 0x00040 -- NOT SUPPORTED +toBit NEW_FUN_TAGS = 0x00080 +toBit EXTENDED_PIDS_PORTS = + 0x00100 +toBit EXPORT_PTR_TAG = 0x00200 -- NOT SUPPORTED +toBit BIT_BINARIES = 0x00400 +toBit NEW_FLOATS = 0x00800 +toBit UNICODE_IO = 0x01000 +toBit DIST_HDR_ATOM_CACHE = + 0x02000 +toBit SMALL_ATOM_TAGS = 0x04000 +toBit UTF8_ATOMS = 0x10000 + +-------------------------------------------------------------------------------- +data NodeType = NormalNode | HiddenNode + deriving (Eq, Show, Enum, Bounded) + +instance Binary NodeType where + put NormalNode = putWord8 77 + put HiddenNode = putWord8 72 + get = do + nodeType <- getWord8 + case nodeType of + 77 -> return NormalNode + 72 -> return HiddenNode + _ -> fail $ "Bad node type: " ++ show nodeType + +-------------------------------------------------------------------------------- +data NodeProtocol = TcpIpV4 + deriving (Eq, Show, Enum, Bounded) + +instance Binary NodeProtocol where + put = putWord8 . fromIntegral . fromEnum + get = do + c <- getWord8 + return $ toEnum $ fromIntegral c + +-------------------------------------------------------------------------------- +data NodeData = NodeData { portNo :: Word16 + , nodeType :: NodeType + , protocol :: NodeProtocol + , hiVer :: DistributionVersion + , loVer :: DistributionVersion + , aliveName :: BS.ByteString + , extra :: BS.ByteString + } + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +instance Binary NodeData where + put NodeData{portNo,nodeType,protocol,hiVer,loVer,aliveName,extra} = do + putWord16be portNo + put nodeType + put protocol + put hiVer + put loVer + putLength16beByteString aliveName + putLength16beByteString extra + get = do + NodeData <$> getWord16be + <*> get + <*> get + <*> get + <*> get + <*> getLength16beByteString + <*> getLength16beByteString diff --git a/src/Foreign/Erlang/NodeState.hs b/src/Foreign/Erlang/NodeState.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/NodeState.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Strict #-} +module Foreign.Erlang.NodeState + ( NodeState() + , newNodeState + , new_pid + , new_port + , new_ref + , putMailboxForPid + , getMailboxForPid + , putMailboxForName + , getMailboxForName + , putConnectionForNode + , getConnectionForNode + , removeConnectionForNode + , getConnectedNodes + ) where + +import Control.Concurrent.STM +import Control.Monad (void, when) +import Util.IOExtra + +import qualified Data.Map.Strict as M +import Data.Word + +-- import Util.IOExtra + +-------------------------------------------------------------------------------- +data NodeState p n mb c = + NodeState { serial :: TVar Word32 + , pidId :: TVar Word32 + , portId :: TVar Word32 + , refId0 :: TVar Word32 + , refId1 :: TVar Word32 + , refId2 :: TVar Word32 + , pid2Mbox :: TVar (M.Map p mb) + , name2Mbox :: TVar (M.Map n mb) + , node2Conn :: TVar (M.Map n c) + } + +instance Show (NodeState p n mb c) where + show _ = "#NodeState<>" + +-------------------------------------------------------------------------------- + +newNodeState :: IO (NodeState p n mb c) +newNodeState = + NodeState <$> newTVarIO 0 + <*> -- serial + newTVarIO 1 + <*> -- pidId + newTVarIO 1 + <*> -- portId + newTVarIO 0 + <*> -- refId0 + newTVarIO 0 + <*> -- refId1 + newTVarIO 0 + <*> -- refId2 + newTVarIO M.empty + <*> -- pid2Mbox + newTVarIO M.empty + <*> -- name2MBox + newTVarIO M.empty -- name2Conn + +-------------------------------------------------------------------------------- +new_pid :: NodeState p n mb c -> IO (Word32, Word32) +new_pid NodeState{serial,pidId} = + atomically $ do + let p = (,) <$> readTVar pidId <*> readTVar serial + + whenM (inc pidId _15bits) $ + void (inc serial _13bits) + + p + +-------------------------------------------------------------------------------- +new_port :: NodeState p n mb c -> IO Word32 +new_port NodeState{portId} = + atomically $ do + let p = readTVar portId + + void (inc portId _28bits) + + p + +-------------------------------------------------------------------------------- +new_ref :: NodeState p n mb c -> IO (Word32, Word32, Word32) +new_ref NodeState{refId0,refId1,refId2} = + atomically $ do + let r = (,,) <$> readTVar refId0 <*> readTVar refId1 <*> readTVar refId2 + + whenM (inc refId0 _18bits) $ + whenM (inc refId1 _32bits) $ + void (inc refId2 _32bits) + + r + +-------------------------------------------------------------------------------- +putMailboxForPid :: (Ord p) => NodeState p n mb c -> p -> mb -> IO () +putMailboxForPid NodeState{pid2Mbox} pid mbox = + atomically $ modifyTVar' pid2Mbox (M.insert pid mbox) + +getMailboxForPid :: (Ord p) => NodeState p n mb c -> p -> IO (Maybe mb) +getMailboxForPid NodeState{pid2Mbox} pid = M.lookup pid <$> atomically (readTVar pid2Mbox) + +-------------------------------------------------------------------------------- +putMailboxForName :: (Ord n) => NodeState p n mb c -> n -> mb -> IO () +putMailboxForName NodeState{name2Mbox} name mbox = + atomically $ modifyTVar' name2Mbox (M.insert name mbox) + +getMailboxForName :: (Ord n) => NodeState p n mb c -> n -> IO (Maybe mb) +getMailboxForName NodeState{name2Mbox} name = + M.lookup name <$> atomically (readTVar name2Mbox) + +-------------------------------------------------------------------------------- +putConnectionForNode :: (Ord n) => NodeState p n mb c -> n -> c -> IO () +putConnectionForNode NodeState{node2Conn} name conn = + atomically $ modifyTVar' node2Conn (M.insert name conn) + +getConnectionForNode :: (MonadIO m, Ord n) => NodeState p n mb c -> n -> m (Maybe c) +getConnectionForNode NodeState{node2Conn} name = + M.lookup name <$> liftIO (atomically (readTVar node2Conn)) + +removeConnectionForNode :: (Ord n) => NodeState p n mb c -> n -> IO () +removeConnectionForNode NodeState{node2Conn} name = + atomically $ modifyTVar' node2Conn (M.delete name) + +getConnectedNodes :: NodeState p n mb c -> IO [(n, c)] +getConnectedNodes NodeState{node2Conn} = + M.toList <$> atomically (readTVar node2Conn) + +-------------------------------------------------------------------------------- +_13bits, _15bits, _18bits, _28bits, _32bits :: Word32 +_13bits = 0x00001fff + +_15bits = 0x00007fff + +_18bits = 0x0003ffff + +_28bits = 0x0fffffff + +_32bits = 0xffffffff + +inc :: TVar Word32 -> Word32 -> STM Bool +inc tV maxV = do + modifyTVar' tV (+ 1) + v <- readTVar tV + if v > maxV + then do + writeTVar tV 0 + return True + else do + return False + +whenM :: Monad m => m Bool -> m () -> m () +whenM mt mc = do + t <- mt + when t mc diff --git a/src/Foreign/Erlang/Term.hs b/src/Foreign/Erlang/Term.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Erlang/Term.hs @@ -0,0 +1,816 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Foreign.Erlang.Term + ( -- * External Term Format + Term() + , putTerm + , getTerm + -- ** Conversion to and from External Term Format + , ToTerm(..) + , FromTerm(..) + , fromTermA + -- ** Constructors + , integer + -- *** Static numbers + , SInteger(..) + , float + , atom + -- *** Static atoms + , SAtom(..) + , port + , pid + , Pid(..) + , tuple + , Tuple1(..) + , string + , list + , improperList + , ref + -- ** Recognizers + , is_integer + , is_float + , is_atom + , is_reference + , is_port + , is_pid + , is_tuple + , is_map + , is_list + , is_binary + -- ** Accessors + , node + , atom_name + , length + , element + , to_string + , to_integer + -- ** Matchers + , match_atom + , match_tuple + ) where + +import GHC.TypeLits +import Prelude hiding ( id, length ) +import qualified Prelude as P ( id ) +import Control.Applicative ( Alternative(..) ) +import Control.Category ( (>>>) ) +import Control.Monad as M ( replicateM ) +import Data.String +import Data.ByteString ( ByteString ) +import Data.ByteString.Char8 ( unpack ) +import qualified Data.ByteString as BS ( head, length, tail, unpack, foldr' ) +import qualified Data.ByteString.Char8 as CS ( ByteString, pack, unpack ) +import Data.Vector ( (!), Vector, fromList, toList ) +import qualified Data.Vector as V ( length, replicateM, tail ) +import qualified Data.List as L ( length, unfoldr, length ) +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get hiding ( getBytes ) +import Util.Binary +import Test.QuickCheck +import Data.Int +import Data.Bits (shiftR, (.&.)) + +-------------------------------------------------------------------------------- +data Term = Integer Integer + | Float Double + | Atom ByteString + | Reference ByteString Word32 Word8 + | Port ByteString Word32 Word8 + | Pid ByteString Word32 Word32 Word8 + | Tuple (Vector Term) + | Map (Vector MapEntry) + | Nil + | String ByteString + | List (Vector Term) Term + | Binary ByteString + | NewReference ByteString Word8 [Word32] + deriving (Eq) + +data MapEntry = MapEntry { key :: Term + , value :: Term + } + deriving (Eq) + +-- number < atom < reference < fun < port < pid < tuple < map < nil < list < bit string +instance Ord Term where + (Integer i) `compare` (Integer i') = + i `compare` i' + (Integer i) `compare` (Float d') = + (fromIntegral i) `compare` d' + (Integer _) `compare` _ = + LT + + (Float d) `compare` (Float d') = + d `compare` d' + (Float d) `compare` (Integer i') = + d `compare` (fromIntegral i') + (Float _) `compare` _ = LT + + (Atom a) `compare` (Atom a') = + a `compare` a' + (Atom _) `compare` _ = LT + + (Reference node' id creation) `compare` (Reference node'' id' creation') = + (node', id, creation) `compare` (node'', id', creation') + (Reference _ _ _) `compare` _ = + LT + + (NewReference node' creation ids) `compare` (NewReference node'' creation' ids') = + (node', creation, ids) `compare` (node'', creation', ids') + (NewReference _ _ _) `compare` _ = + LT + + (Port node' id creation) `compare` (Port node'' id' creation') = + (node', id, creation) `compare` (node'', id', creation') + (Port _ _ _) `compare` _ = + LT + + (Pid node' id serial creation) `compare` (Pid node'' id' serial' creation') = + (node', id, serial, creation) `compare` (node'', id', serial', creation') + (Pid _ _ _ _) `compare` _ = + LT + + (Tuple v) `compare` (Tuple v') = + v `compare` v' + (Tuple _) `compare` _ = LT + + (Map e) `compare` (Map e') = + e `compare` e' + (Map _) `compare` _ = LT + + Nil `compare` Nil = EQ + Nil `compare` _ = LT + + (String s) `compare` (String s') = + s `compare` s' + (String s) `compare` (List v' t') = + (toVector s, Nil) `compare` (v', t') + (String _) `compare` _ = + LT + + (List v t) `compare` (List v' t') = + (v, t) `compare` (v', t') + (List v t) `compare` (String s') = + (v, t) `compare` (toVector s', Nil) + (List _ _) `compare` _ = + LT + + (Binary b) `compare` (Binary b') = + b `compare` b' + (Binary _) `compare` _ = + LT + +toVector :: ByteString -> Vector Term +toVector = BS.unpack >>> map (fromIntegral >>> Integer) >>> fromList + +instance Ord MapEntry where + MapEntry{key = k,value = v} `compare` MapEntry{key = k',value = v'} = + (k, v) `compare` (k', v') -- FIXME integer keys are less than float keys + +instance Show Term where + show (Integer i) = show i + show (Float d) = show d + show (Atom a) = "'" ++ unpack a ++ "'" + show (Reference nodeName id _creation) = + "#Ref<" ++ unpack nodeName ++ "." ++ show id ++ ">" + show (Port nodeName id _creation) = + "#Port<" ++ unpack nodeName ++ "." ++ show id ++ ">" + show (Pid nodeName id serial _creation) = + "#Pid<" ++ unpack nodeName ++ "." ++ show id ++ "." ++ show serial ++ ">" + show (Tuple v) = "{" ++ showVectorAsList v ++ "}" + show (Map e) = "#{" ++ showVectorAsList e ++ "}" + show Nil = "[]" + show (String s) = show s + show (List v Nil) = "[" ++ showVectorAsList v ++ "]" + show (List v t) = "[" ++ showVectorAsList v ++ "|" ++ show t ++ "]" + show (Binary b) = "<<" ++ showByteStringAsIntList b ++ ">>" + show (NewReference nodeName _creation ids) = + "#Ref<" ++ unpack nodeName ++ concat (map (\id -> "." ++ show id) ids) ++ ">" + +instance Show MapEntry where + show MapEntry{key,value} = + show key ++ " => " ++ show value + +showVectorAsList :: Show a => (Vector a) -> String +showVectorAsList v + | V.length v == 0 = "" + | V.length v == 1 = show (v ! 0) + | otherwise = show (v ! 0) ++ concat (map (\t -> "," ++ show t) $ toList $ V.tail v) + +showByteStringAsIntList :: ByteString -> String +showByteStringAsIntList b + | BS.length b == 0 = "" + | BS.length b == 1 = show (BS.head b) + | otherwise = show (BS.head b) ++ concat (map (\t -> "," ++ show t) $ BS.unpack $ BS.tail b) + +instance IsString Term where + fromString = atom . CS.pack + +instance FromTerm Term where + fromTerm = Just + +instance ToTerm Term where + toTerm = P.id + +-------------------------------------------------------------------------------- +class ToTerm a where + toTerm :: a -> Term + +class FromTerm a where + fromTerm :: Term -> Maybe a + +fromTermA :: (FromTerm a, Alternative m) => Term -> m a +fromTermA t = + case fromTerm t of + Just x -> pure x + Nothing -> empty + +instance FromTerm () where + fromTerm (Tuple ts) | V.length ts == 0 = Just () + fromTerm _ = Nothing + +instance (FromTerm a) => FromTerm (Tuple1 a) where + fromTerm (Tuple ts) | V.length ts == 1 = Tuple1 <$> fromTerm (ts ! 0) + fromTerm _ = Nothing + +instance (FromTerm a, FromTerm b) => FromTerm (a, b) where + fromTerm (Tuple ts) | V.length ts == 2 = (,) <$> fromTerm (ts ! 0) <*> fromTerm (ts ! 1) + fromTerm _ = Nothing + +instance (FromTerm a, FromTerm b, FromTerm c) => FromTerm (a, b, c) where + fromTerm (Tuple ts) | V.length ts == 3 = (,,) <$> fromTerm (ts ! 0) <*> fromTerm (ts ! 1) <*> fromTerm (ts ! 2) + fromTerm _ = Nothing + +instance (FromTerm a, FromTerm b, FromTerm c, FromTerm d) => FromTerm (a, b, c, d) where + fromTerm (Tuple ts) | V.length ts == 4 = (,,,) <$> fromTerm (ts ! 0) + <*> fromTerm (ts ! 1) + <*> fromTerm (ts ! 2) + <*> fromTerm (ts ! 3) + fromTerm _ = Nothing + +instance (FromTerm a, FromTerm b, FromTerm c, FromTerm d, FromTerm e) => FromTerm (a, b, c, d, e) where + fromTerm (Tuple ts) | V.length ts == 5 = (,,,,) <$> fromTerm (ts ! 0) + <*> fromTerm (ts ! 1) + <*> fromTerm (ts ! 2) + <*> fromTerm (ts ! 3) + <*> fromTerm (ts ! 4) + fromTerm _ = Nothing + +instance ToTerm () where + toTerm () = tuple [] + +instance (ToTerm a) => ToTerm (Tuple1 a) where + toTerm (Tuple1 a) = tuple [ toTerm a ] + +instance (ToTerm a, ToTerm b) => ToTerm (a, b) where + toTerm (a, b) = tuple [ toTerm a, toTerm b ] + +instance (ToTerm a, ToTerm b, ToTerm c) => ToTerm (a, b, c) where + toTerm (a, b, c) = tuple [ toTerm a, toTerm b, toTerm c ] + +instance (ToTerm a, ToTerm b, ToTerm c, ToTerm d) => ToTerm (a, b, c, d) where + toTerm (a, b, c, d) = tuple [ toTerm a, toTerm b, toTerm c, toTerm d ] + +instance (ToTerm a, ToTerm b, ToTerm c, ToTerm d, ToTerm e) => ToTerm (a, b, c, d, e) where + toTerm (a, b, c, d, e) = + tuple [ toTerm a, toTerm b, toTerm c, toTerm d, toTerm e ] + +instance FromTerm Integer where + fromTerm (Integer i) = Just i + fromTerm _ = Nothing + +instance ToTerm Integer where + toTerm = Integer + +instance FromTerm String where + fromTerm (String s) = Just (CS.unpack s) + fromTerm _ = Nothing + +instance ToTerm String where + toTerm = String . CS.pack + +-------------------------------------------------------------------------------- +-- | Construct an integer +integer :: Integer -- ^ Int + -> Term +integer = Integer + +-- | A static/constant number. +data SInteger (n :: Nat) = SInteger + +instance (KnownNat n) => Show (SInteger n) where + showsPrec d s = + showParen (d > 10) (showString "SInteger '" . showsPrec 11 (natVal s) . showChar '\'') + +instance forall (n :: Nat) . (KnownNat n) => FromTerm (SInteger n) where + fromTerm (Integer n') = let sn = SInteger + sn :: SInteger n + in + if n' == natVal sn then Just sn else Nothing + fromTerm _ = Nothing + +instance forall (n :: Nat) . (KnownNat n) => ToTerm (SInteger n) where + toTerm = integer . natVal + +-- | Construct a float +float :: Double -- ^ IEEE float + -> Term +float = Float + +-- | Construct an atom +atom :: ByteString -- ^ AtomName + -> Term +atom = Atom + +-- | A static/constant atom. +data SAtom (atom :: Symbol) = SAtom + +instance (KnownSymbol atom) => Show (SAtom atom) where + showsPrec d s = + showParen (d > 10) (showString "SAtom '" . showString (symbolVal s) . showChar '\'') + +instance forall (atom :: Symbol) . (KnownSymbol atom) => FromTerm (SAtom atom) where + fromTerm (Atom atom') = if atom' == CS.pack (symbolVal (SAtom :: SAtom atom)) then Just SAtom else Nothing + fromTerm _ = Nothing + +instance forall (atom :: Symbol) . (KnownSymbol atom) => ToTerm (SAtom atom) where + toTerm = atom . CS.pack . symbolVal + +-- reference +-- | Construct a port +port :: ByteString -- ^ Node name + -> Word32 -- ^ ID + -> Word8 -- ^ Creation + -> Term +port = Port + +pid :: ByteString -- ^ Node name + -> Word32 -- ^ ID + -> Word32 -- ^ Serial + -> Word8 -- ^ Creation + -> Pid +pid = ((.) . (.) . (.) . (.)) MkPid Pid + +newtype Pid = MkPid Term + deriving (ToTerm, FromTerm, Eq, Ord) + +instance Show Pid where + show (MkPid p) = show p + +-- | Construct a tuple +tuple :: [Term] -- ^ Elements + -> Term +tuple = Tuple . fromList + +newtype Tuple1 a = Tuple1 a + deriving (Eq, Ord) + +instance (Show a) => Show (Tuple1 a) where + show (Tuple1 a) = "{" ++ show a ++ "}" + +-- map +-- | Construct a list +string :: ByteString -- ^ Characters + -> Term +string = String + +-- | Construct a list +list :: [Term] -- ^ Elements + -> Term +list [] = Nil +list ts = improperList ts Nil + +-- | Construct an improper list (if Tail is not Nil) +improperList :: [Term] -- ^ Elements + -> Term -- ^ Tail + -> Term +improperList [] _ = error "Illegal improper list" +improperList ts t = List (fromList ts) t -- FIXME could check if is string + +-- binary +-- | Construct a new reference +ref :: ByteString -- ^ Node name + -> Word8 -- ^ Creation + -> [Word32] -- ^ ID ... + -> Term +ref = NewReference + +-------------------------------------------------------------------------------- +is_integer, is_float, is_atom, is_reference, is_port, is_pid, is_tuple, is_map, is_list, is_binary :: Term -> Bool +-- | Test if term is an integer +is_integer (Integer _) = + True +is_integer _ = False + +-- | Test if term is a float +is_float (Float _) = True +is_float _ = False + +-- | Test if term is an atom +is_atom (Atom _) = True +is_atom _ = False + +-- | Test if term is a reference +is_reference (Reference _ _ _) = + True +is_reference (NewReference _ _ _) = + True +is_reference _ = False + +-- | Test if term is a port +is_port (Port _ _ _) = True +is_port _ = False + +-- | Test if term is a pid +is_pid (Pid _ _ _ _) = True +is_pid _ = False + +-- | Test if term is a tuple +is_tuple (Tuple _) = True +is_tuple _ = False + +-- | Test if term is a map +is_map (Map _) = True +is_map _ = False + +-- | Test if term is a list +is_list Nil = True +is_list (String _) = True +is_list (List _ _) = True +is_list _ = False + +-- | Test if term is a binary +is_binary (Binary _) = True +is_binary _ = False + +-------------------------------------------------------------------------------- +node :: Term -> Term +node (Reference nodeName _id _creation) = + atom nodeName +node (Port nodeName _id _creation) = + atom nodeName +node (Pid nodeName _id _serial _creation) = + atom nodeName +node (NewReference nodeName _creation _ids) = + atom nodeName +node term = error $ "Bad arg for node: " ++ show term + +atom_name :: Term -> ByteString +atom_name (Atom name) = name +atom_name term = error $ "Bad arg for atom_name: " ++ show term + +length :: Term -> Int +length (Tuple v) = V.length v +length (String bs) = BS.length bs +length (List v Nil) = V.length v +length term = error $ "Bad arg for length: " ++ show term + +element :: Int -> Term -> Term +element n (Tuple v) = v ! (n - 1) +element _ term = error $ "Not a tuple: " ++ show term + +to_string :: Term -> Maybe ByteString +to_string (String bs) = Just bs +to_string _ = Nothing + +to_integer :: Term -> Maybe Integer +to_integer (Integer i) = + Just i +to_integer _ = Nothing + +match_tuple :: Term -> Maybe [Term] +match_tuple (Tuple v) = Just (toList v) +match_tuple _ = Nothing + +match_atom :: Term -> ByteString -> Maybe ByteString +match_atom (Atom n) m + | m == n = Just n + | otherwise = Nothing +match_atom _ _ = Nothing + +-------------------------------------------------------------------------------- +instance Binary Term where + put (Integer i) + | i >= 0x00 && i <= 0xFF = do + putWord8 small_integer_ext + putWord8 (fromIntegral i) + | i >= -0x80000000 && i <= 0x7FFFFFFF = do + putWord8 integer_ext + putWord32be (fromIntegral i) + | otherwise = + -- NOTE: the biggest number presentable is 2^maxBits bits long where + -- maxBits = 2^32 * 8 = 2^35 - OTOH addressable main memory: 2^64 * + -- 8 bits = 2^67 bits, even with tomorrows 2048 bit address buses + -- for 256 bit words this would be at most 2^2056 addressable bits. + -- large_big_ext allows 2^(2^35) = 2^34359738368 addressable bits .. + -- hence YES by all practical means 'otherwise' is the correct + -- function clause guard. + do let digits = L.unfoldr takeLSB (abs i) + where takeLSB x + | x == 0 = Nothing + | otherwise = Just (fromIntegral (x Data.Bits..&. 0xff), x `shiftR` 8) + if L.length digits < 256 + then do putWord8 small_big_ext + putWord8 (fromIntegral (L.length digits)) + else do putWord8 large_big_ext + putWord32be (fromIntegral (L.length digits)) + putWord8 (if i >= 0 then 0 else 1) + mapM_ putWord8 digits + + put (Float d) = do + putWord8 new_float_ext + putDoublebe d + + put (Atom n) = do + putAtom n + + put (Reference nodeName id creation) = do + putWord8 reference_ext + putAtom nodeName + putWord32be id + putWord8 creation + + put (Port nodeName id creation) = do + putWord8 port_ext + putAtom nodeName + putWord32be id + putWord8 creation + + put (Pid nodeName id serial creation) = do + putWord8 pid_ext + putAtom nodeName + putWord32be id + putWord32be serial + putWord8 creation + + put (Tuple v) + | (V.length v) < 256 = do + putWord8 small_tuple_ext + putWord8 $ fromIntegral (V.length v) + mapM_ put v + | otherwise = do + putWord8 large_tuple_ext + putWord32be $ fromIntegral (V.length v) + mapM_ put v + + put (Map e) = do + putWord8 map_ext + putWord32be $ fromIntegral (V.length e) + mapM_ put e + + put Nil = do + putWord8 nil_ext + + put (String s) = do + putWord8 string_ext + putLength16beByteString s + + put (List v t) = do + putWord8 list_ext + putWord32be $ fromIntegral (V.length v) + mapM_ put v + put t + + put (Binary b) = do + putWord8 binary_ext + putLength16beByteString b + + put (NewReference node' creation ids) = do + putWord8 new_reference_ext + putWord16be $ fromIntegral (L.length ids) + putAtom node' + putWord8 creation + mapM_ putWord32be ids + get = do + lookAhead getWord8 >>= get' + where + get' :: Word8 -> Get Term + get' tag + | tag == small_integer_ext = + getSmallInteger (Integer . fromIntegral) + | tag == integer_ext = getInteger (Integer . toInteger . (fromIntegral :: Word32 -> Int32)) + | tag == small_big_ext = getWord8 *> getWord8 >>= getBigInteger . fromIntegral + | tag == large_big_ext = getWord8 *> getWord32be >>= getBigInteger . fromIntegral + | tag == atom_ext = getAtom Atom + | tag == port_ext = getPort Port + | tag == pid_ext = getPid Pid + | tag == small_tuple_ext = + getSmallTuple Tuple + | tag == large_tuple_ext = + getLargeTuple Tuple + | tag == map_ext = getMap Map + | tag == nil_ext = getNil (const Nil) + | tag == string_ext = getString String + | tag == list_ext = getList List + | tag == binary_ext = getBinary Binary + | tag == new_reference_ext = + getNewReference NewReference + | tag == small_atom_ext = getSmallAtom Atom + | tag == new_float_ext = getNewFloat Float + | otherwise = fail $ "Unsupported tag: " ++ show tag + +instance Binary MapEntry where + put MapEntry{key,value} = do + put key + put value + get = do + MapEntry <$> get <*> get + +-------------------------------------------------------------------------------- +putTerm :: (ToTerm t) => t -> Put +putTerm t = do + putWord8 magicVersion + put (toTerm t) + +putAtom :: ByteString -> Put +putAtom a = do + putWord8 atom_ext + putLength16beByteString a + +-------------------------------------------------------------------------------- +getTerm :: Get Term +getTerm = do + matchWord8 magicVersion + get + +getSmallInteger :: (Word8 -> a) -> Get a +getSmallInteger f = do + matchWord8 small_integer_ext + f <$> getWord8 + +getInteger :: (Word32 -> a) -> Get a +getInteger f = do + matchWord8 integer_ext + f <$> getWord32be + +getBigInteger :: Int -> Get Term +getBigInteger len = mkBigInteger <$> getWord8 <*> getByteString len + where mkBigInteger signByte bs = Integer ((if signByte == 0 then 1 else (-1)) * absInt) + where absInt = BS.foldr' (\ b acc -> 256 * acc + fromIntegral b) 0 bs + +getAtom :: (ByteString -> a) -> Get a +getAtom f = do + matchWord8 atom_ext + f <$> getLength16beByteString + +getPort :: (ByteString -> Word32 -> Word8 -> a) -> Get a +getPort f = do + matchWord8 port_ext + f <$> getAtom P.id <*> getWord32be <*> getWord8 + +getPid :: (ByteString -> Word32 -> Word32 -> Word8 -> a) -> Get a +getPid f = do + matchWord8 pid_ext + f <$> getAtom P.id <*> getWord32be <*> getWord32be <*> getWord8 + +getSmallTuple :: (Vector Term -> a) -> Get a +getSmallTuple f = do + matchWord8 small_tuple_ext + f <$> (getWord8 >>= _getVector . fromIntegral) + +getLargeTuple :: (Vector Term -> a) -> Get a +getLargeTuple f = do + matchWord8 large_tuple_ext + f <$> (getWord32be >>= _getVector . fromIntegral) + +getMap :: (Vector MapEntry -> a) -> Get a +getMap f = do + matchWord8 map_ext + f <$> (getWord32be >>= _getVector . fromIntegral) + +getNil :: (() -> a) -> Get a +getNil f = do + f <$> matchWord8 nil_ext + +getString :: (ByteString -> a) -> Get a +getString f = do + matchWord8 string_ext + f <$> getLength16beByteString + +getList :: (Vector Term -> Term -> a) -> Get a +getList f = do + matchWord8 list_ext + f <$> (getWord32be >>= _getVector . fromIntegral) <*> get + +getBinary :: (ByteString -> a) -> Get a +getBinary f = do + matchWord8 binary_ext + f <$> getLength32beByteString + +getNewReference :: (ByteString -> Word8 -> [Word32] -> a) -> Get a +getNewReference f = do + matchWord8 new_reference_ext + len <- getWord16be + f <$> getAtom P.id <*> getWord8 <*> _getList (fromIntegral len) + +getSmallAtom :: (ByteString -> a) -> Get a +getSmallAtom f = do + matchWord8 small_atom_ext + f <$> getLength8ByteString + +getNewFloat :: (Double -> a) -> Get a +getNewFloat f = do + matchWord8 new_float_ext + f <$> getDoublebe + +-------------------------------------------------------------------------------- +_getVector :: Binary a => Int -> Get (Vector a) +_getVector len = V.replicateM len get + +_getList :: Binary a => Int -> Get [a] +_getList len = M.replicateM len get + +-------------------------------------------------------------------------------- +magicVersion :: Word8 +magicVersion = 131 + +small_integer_ext, integer_ext, float_ext, atom_ext, reference_ext, port_ext, pid_ext :: Word8 +small_tuple_ext, large_tuple_ext, map_ext, nil_ext, string_ext, list_ext, binary_ext :: Word8 +small_big_ext, large_big_ext, new_reference_ext, small_atom_ext, fun_ext, new_fun_ext :: Word8 +export_ext, bit_binary_ext, new_float_ext, atom_utf8_ext, small_atom_utf8_ext :: Word8 +small_integer_ext = 97 + +integer_ext = 98 + +float_ext = 99 + +atom_ext = 100 + +reference_ext = 101 + +port_ext = 102 + +pid_ext = 103 + +small_tuple_ext = 104 + +large_tuple_ext = 105 + +map_ext = 116 + +nil_ext = 106 + +string_ext = 107 + +list_ext = 108 + +binary_ext = 109 + +small_big_ext = 110 + +large_big_ext = 111 + +new_reference_ext = 114 + +small_atom_ext = 115 + +fun_ext = 117 + +new_fun_ext = 112 + +export_ext = 113 + +bit_binary_ext = 77 + +new_float_ext = 70 + +atom_utf8_ext = 118 + +small_atom_utf8_ext = 119 + +instance Arbitrary Term where + arbitrary = oneof [ atom <$> scale (`div` 2) arbitraryUnquotedAtom + , tuple <$> scale (`div` 2) arbitrary + , string <$> scale (`div` 2) arbitraryUnquotedAtom + , sized $ + \qcs -> if qcs > 1 + then improperList <$> (getNonEmpty <$> scale (`div` 2) arbitrary) + <*> scale (`div` 2) arbitrary + else list <$> scale (`div` 2) arbitrary + , ref <$> scale smaller arbitraryUnquotedAtom + <*> scale smaller arbitrary + <*> scale smaller arbitrary + , (toTerm :: Pid -> Term) <$> scale smaller arbitrary + , float <$> scale smaller arbitrary + , (toTerm :: Integer -> Term) <$> scale smaller arbitrary + ] + +smaller :: (Eq a, Num a) => a -> a +smaller 0 = 0 +smaller n = n - 1 + +arbitraryUnquotedAtom :: Gen CS.ByteString +arbitraryUnquotedAtom = CS.pack <$> (listOf1 (elements (['a' .. 'z'] ++ [ '_' ] ++ ['0' .. '9']))) + +instance Arbitrary Pid where + arbitrary = pid <$> scale smaller arbitraryUnquotedAtom + <*> scale smaller arbitrary + <*> scale smaller arbitrary + <*> scale smaller arbitrary diff --git a/src/Network/BufferedSocket.hs b/src/Network/BufferedSocket.hs new file mode 100644 --- /dev/null +++ b/src/Network/BufferedSocket.hs @@ -0,0 +1,64 @@ +module Network.BufferedSocket + ( BufferedSocket() + , makeBuffered + , socketPort + ) where + +import Control.Monad ( unless ) +import Control.Monad.IO.Class ( MonadIO(..), liftIO ) +import qualified Data.ByteString as BS ( ByteString, append, empty, length, null, splitAt ) +import qualified Data.ByteString.Lazy as LBS ( ByteString ) +import Data.IORef ( IORef, atomicModifyIORef', newIORef, writeIORef ) +import qualified Network.Socket as S ( PortNumber, Socket, close, socketPort ) +import qualified Network.Socket.ByteString as NBS ( recv ) +import qualified Network.Socket.ByteString.Lazy as NBL ( sendAll ) +import Util.BufferedIOx + +-------------------------------------------------------------------------------- +newtype BufferedSocket = BufferedSocket (S.Socket, IORef BS.ByteString) + +instance BufferedIOx BufferedSocket where + readBuffered a = liftIO . socketRecv a + unreadBuffered a = liftIO . pushback a + writeBuffered a = liftIO . socketSend a + closeBuffered = liftIO . socketClose + +makeBuffered :: S.Socket -> IO BufferedSocket +makeBuffered sock = do + bufIO <- newIORef BS.empty + return $ BufferedSocket (sock, bufIO) + +socketPort :: BufferedSocket -> IO S.PortNumber +socketPort (BufferedSocket (sock, _)) = + S.socketPort sock + +socketRecv :: BufferedSocket -> Int -> IO BS.ByteString +socketRecv (BufferedSocket (sock, bufIO)) len + | len < 0 = error $ "Bad length: " ++ show len + | len == 0 = return BS.empty + | otherwise = do + atomicModifyIORef' bufIO + (\buf -> if BS.null buf + then (BS.empty, Nothing) + else let bufLen = BS.length buf + in + if len > bufLen + then (BS.empty, (Just buf)) + else let (buf0, buf1) = BS.splitAt len buf + in + (buf1, Just buf0)) >>= + maybe (NBS.recv sock len) (return) + +pushback :: BufferedSocket -> BS.ByteString -> IO () +pushback (BufferedSocket (_, bufIO)) bytes = do + unless (BS.null bytes) $ do + atomicModifyIORef' bufIO (\buf -> (buf `BS.append` bytes, ())) + +socketSend :: BufferedSocket -> LBS.ByteString -> IO () +socketSend (BufferedSocket (sock, _)) bl = do + NBL.sendAll sock bl + +socketClose :: BufferedSocket -> IO () +socketClose (BufferedSocket (sock, bufIO)) = do + writeIORef bufIO BS.empty + S.close sock diff --git a/src/Util/Binary.hs b/src/Util/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Util/Binary.hs @@ -0,0 +1,210 @@ +module Util.Binary + ( runGetA + , BinaryGetError(..) + , runPutA + , putFloatbe + , putFloatle + , putFloathost + , putDoublebe + , putDoublele + , putDoublehost + , putLength16beByteString + , putLength32beByteString + , putWithLength16be + , putWithLength32be + , putChar8 + , getChar8 + , getFloatbe + , getFloatle + , getFloathost + , getDoublebe + , getDoublele + , getDoublehost + , getLength8ByteString + , getLength16beByteString + , getLength32beByteString + , getWithLength16be + , matchWord8 + , matchChar8 + ) where + +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Char +import Data.Int (Int64) +import Data.Word + +import Util.FloatCast +import Util.IOExtra + +-------------------------------------------------------------------------------- +runGetA :: (Monad m) + => (Int -> m BS.ByteString) + -> (BS.ByteString -> m ()) + -> Get a + -> m (Either BinaryGetError a) +runGetA readA unreadA getA = + feed (runGetIncremental getA) (readA 2048) + where + feed (Done unused _pos output) _input = do + unreadA unused + return $ Right output + feed (Fail unused pos msg) _input = do + unreadA unused + return $ Left $ BinaryGetError pos msg + feed (Partial k) input = do + chunk <- input + if BS.null chunk then feed (k Nothing) input else feed (k (Just chunk)) input + +data BinaryGetError = BinaryGetError { position :: Int64 + , message :: String + } + deriving Show + +instance Exception BinaryGetError + +runPutA :: (LBS.ByteString -> m ()) -> Put -> m () +runPutA = (. runPut) + +-------------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Floats/Doubles +-- | Write a 'Float' in big endian IEEE-754 format. +putFloatbe :: Float -> Put +putFloatbe = putWord32be . floatToWord + +{-# INLINE putFloatbe #-} + +-- | Write a 'Float' in little endian IEEE-754 format. +putFloatle :: Float -> Put +putFloatle = putWord32le . floatToWord + +{-# INLINE putFloatle #-} + +-- | Write a 'Float' in native in IEEE-754 format and host endian. +putFloathost :: Float -> Put +putFloathost = putWord32host . floatToWord + +{-# INLINE putFloathost #-} + +-- | Write a 'Double' in big endian IEEE-754 format. +putDoublebe :: Double -> Put +putDoublebe = putWord64be . doubleToWord + +{-# INLINE putDoublebe #-} + +-- | Write a 'Double' in little endian IEEE-754 format. +putDoublele :: Double -> Put +putDoublele = putWord64le . doubleToWord + +{-# INLINE putDoublele #-} + +-- | Write a 'Double' in native in IEEE-754 format and host endian. +putDoublehost :: Double -> Put +putDoublehost = putWord64host . doubleToWord + +{-# INLINE putDoublehost #-} + +-------------------------------------------------------------------------------- +putLength16beByteString :: BS.ByteString -> Put +putLength16beByteString bs = do + putWord16be (fromIntegral (BS.length bs)) + putByteString bs + +putLength32beByteString :: BS.ByteString -> Put +putLength32beByteString bs = do + putWord32be (fromIntegral (BS.length bs)) + putByteString bs + +-------------------------------------------------------------------------------- +putWithLength16be :: Put -> Put +putWithLength16be putA = do + let bl = runPut putA + len = LBS.length bl + putWord16be (fromIntegral len) + putLazyByteString bl + +putWithLength32be :: Put -> Put +putWithLength32be putA = do + let bl = runPut putA + len = LBS.length bl + putWord32be (fromIntegral len) + putLazyByteString bl + +-------------------------------------------------------------------------------- +putChar8 :: Char -> Put +putChar8 c = do + putWord8 $ fromIntegral $ ord c + +getChar8 :: Get Char +getChar8 = (chr . fromIntegral) <$> getWord8 + +------------------------------------------------------------------------ +-- Double/Float reads +-- | Read a 'Float' in big endian IEEE-754 format. +getFloatbe :: Get Float +getFloatbe = wordToFloat <$> getWord32be + +{-# INLINE getFloatbe #-} + +-- | Read a 'Float' in little endian IEEE-754 format. +getFloatle :: Get Float +getFloatle = wordToFloat <$> getWord32le + +{-# INLINE getFloatle #-} + +-- | Read a 'Float' in IEEE-754 format and host endian. +getFloathost :: Get Float +getFloathost = wordToFloat <$> getWord32host + +{-# INLINE getFloathost #-} + +-- | Read a 'Double' in big endian IEEE-754 format. +getDoublebe :: Get Double +getDoublebe = wordToDouble <$> getWord64be + +{-# INLINE getDoublebe #-} + +-- | Read a 'Double' in little endian IEEE-754 format. +getDoublele :: Get Double +getDoublele = wordToDouble <$> getWord64le + +{-# INLINE getDoublele #-} + +-- | Read a 'Double' in IEEE-754 format and host endian. +getDoublehost :: Get Double +getDoublehost = wordToDouble <$> getWord64host + +{-# INLINE getDoublehost #-} + +-------------------------------------------------------------------------------- +getLength8ByteString :: Get BS.ByteString +getLength8ByteString = getWord8 >>= getByteString . fromIntegral + +getLength16beByteString :: Get BS.ByteString +getLength16beByteString = + getWord16be >>= getByteString . fromIntegral + +getLength32beByteString :: Get BS.ByteString +getLength32beByteString = + getWord32be >>= getByteString . fromIntegral + +-------------------------------------------------------------------------------- +getWithLength16be :: Get a -> Get (a, Word16) +getWithLength16be getA = do + pos0 <- bytesRead + res <- getA + pos1 <- bytesRead + return (res, fromIntegral (pos1 - pos0)) + +-------------------------------------------------------------------------------- +matchWord8 :: Word8 -> Get () +matchWord8 expected = do + actual <- getWord8 + if expected == actual then return () else fail $ "expected " ++ show expected ++ ", actual " ++ show actual + +matchChar8 :: Char -> Get () +matchChar8 expected = do + matchWord8 $ fromIntegral $ ord expected diff --git a/src/Util/BufferedIOx.hs b/src/Util/BufferedIOx.hs new file mode 100644 --- /dev/null +++ b/src/Util/BufferedIOx.hs @@ -0,0 +1,27 @@ +-- FIXME rename module +module Util.BufferedIOx + ( BufferedIOx(..) + , runGetBuffered + , runPutBuffered + , module Util.Binary + ) where + +import Control.Monad.IO.Class +import Data.Binary +import qualified Data.ByteString as BS ( ByteString ) +import qualified Data.ByteString.Lazy as LBS ( ByteString ) +import Util.Binary +import Util.IOExtra + +class BufferedIOx a where + readBuffered :: (MonadIO m) => a -> Int -> m BS.ByteString + unreadBuffered :: (MonadIO m) => a -> BS.ByteString -> m () + writeBuffered :: (MonadIO m) => a -> LBS.ByteString -> m () + closeBuffered :: (MonadIO m) => a -> m () + +runGetBuffered :: (MonadIO m, BufferedIOx s, Binary a, MonadMask m, MonadLogger m) => s -> m a +runGetBuffered s = + throwLeftM (runGetA (liftIO . readBuffered s) (liftIO . unreadBuffered s) get) + +runPutBuffered :: (MonadIO m, BufferedIOx s, Binary a) => s -> a -> m () +runPutBuffered s = runPutA (liftIO . writeBuffered s) . put diff --git a/src/Util/FloatCast.hs b/src/Util/FloatCast.hs new file mode 100644 --- /dev/null +++ b/src/Util/FloatCast.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} + +-- | This module was written based on +-- . +-- +-- Implements casting via a 1-elemnt STUArray, as described in +-- . +module Util.FloatCast + ( floatToWord + , wordToFloat + , doubleToWord + , wordToDouble + ) where + +import Data.Word ( Word32, Word64 ) +import Data.Array.ST ( MArray, STUArray, newArray, readArray ) +import Data.Array.Unsafe ( castSTUArray ) +import GHC.ST ( ST, runST ) + +-- | Reinterpret-casts a `Float` to a `Word32`. +floatToWord :: Float -> Word32 +floatToWord x = runST (cast x) + +{-# INLINE floatToWord #-} + +-- | Reinterpret-casts a `Word32` to a `Float`. +wordToFloat :: Word32 -> Float +wordToFloat x = runST (cast x) + +{-# INLINE wordToFloat #-} + +-- | Reinterpret-casts a `Double` to a `Word64`. +doubleToWord :: Double -> Word64 +doubleToWord x = runST (cast x) + +{-# INLINE doubleToWord #-} + +-- | Reinterpret-casts a `Word64` to a `Double`. +wordToDouble :: Word64 -> Double +wordToDouble x = runST (cast x) + +{-# INLINE wordToDouble #-} + +cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b +cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 + +{-# INLINE cast #-} diff --git a/src/Util/IOExtra.hs b/src/Util/IOExtra.hs new file mode 100644 --- /dev/null +++ b/src/Util/IOExtra.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} + +module Util.IOExtra + ( requireM + , tryAndLogIO + , tryAndLogAll + , catchAndLogIO + , catchAndLogAll + , onExceptionLog + , bracketOnErrorLog + , handleAndLogAll + , catchAndLog + , handleAndLog + , logWarnStr + , logInfoStr + , logErrorStr + , logAndThrow + , logInfoShow + , logErrorShow + , throwLeftM + , throwNothingM + , ErrMsg(..) + , OneBillionDollarBug(..) + , module X + ) where + +import Control.Monad as X ( unless, void, when ) +import Data.Maybe as X ( fromJust, isJust ) +import Control.Exception as X ( AssertionFailed(..) + , Exception(..) + , SomeException(..) ) +import Control.Monad.Catch as X +import Control.Monad.IO.Class as X +import Control.Monad.Logger as X ( LoggingT + , MonadLogger + , MonadLoggerIO + , logErrorCS + , logInfoCS + , logWarnCS + , runLoggingT ) +import Control.Monad.Logger.CallStack as X ( logError, logInfo ) +import Control.Monad.Trans.Control as X +import Control.Monad.Trans.Resource as X +import Control.Concurrent.Lifted as X +import Control.Concurrent.Async.Lifted as X +import Text.Printf as X +import Data.Text ( Text, pack ) +import GHC.Stack + +requireM :: (HasCallStack, MonadCatch m, MonadLogger m) + => String + -> Bool + -> m () +requireM = requireMCS callStack + +requireMCS :: (MonadCatch m, MonadLogger m) + => CallStack + -> String + -> Bool + -> m () +requireMCS cs title predicate = + let e = AssertionFailed title + in + unless predicate (logShow logErrorCS cs (ErrMsg title e) >> throwM e) + +catchAndLogIO :: (HasCallStack, MonadCatch m, MonadLogger m) + => m a + -> (IOError -> m a) + -> m a +catchAndLogIO = catchAndLog + +catchAndLogAll :: (HasCallStack, MonadCatch m, MonadLogger m) + => m a + -> (SomeException -> m a) + -> m a +catchAndLogAll = catchAndLog + +bracketOnErrorLog :: (HasCallStack, MonadMask m, MonadLogger m) + => m a + -> (a -> m b) + -> (a -> m c) + -> m c +bracketOnErrorLog acquire emergencyCleanup use = + mask $ + \unmasked -> do + resource <- acquire + unmasked (use resource) `onExceptionLog` emergencyCleanup resource + +onExceptionLog :: (HasCallStack, MonadCatch m, MonadLogger m) + => m a + -> m b + -> m a +onExceptionLog action handler = + action `catchAndLogAll` handler' + where + handler' e = void handler >> throwM e + +handleAndLogAll :: (HasCallStack, MonadCatch m, MonadLogger m) + => (SomeException -> m a) + -> m a + -> m a +handleAndLogAll = handleAndLog + +logWarnStr :: (HasCallStack, MonadLogger m) => String -> m () +logWarnStr = logWarnCS callStack . pack + +logInfoStr :: (HasCallStack, MonadLogger m) => String -> m () +logInfoStr = logInfoCS callStack . pack + +logErrorStr :: (HasCallStack, MonadLogger m) => String -> m () +logErrorStr = logErrorCS callStack . pack + +catchAndLog :: (HasCallStack, MonadCatch m, MonadLogger m, Exception e) + => m a + -> (e -> m a) + -> m a +catchAndLog action handler = + handle (\e -> logErrorCS callStack (pack $ displayException e) >> handler e) + action + +handleAndLog :: (HasCallStack, MonadCatch m, MonadLogger m, Exception e) + => (e -> m a) + -> m a + -> m a +handleAndLog = flip catchAndLog + +tryAndLogIO :: (HasCallStack, MonadCatch m, MonadLogger m) => m a -> m (Maybe a) +tryAndLogIO = flip catchAndLogIO (const (pure Nothing)) . fmap Just + +tryAndLogAll :: forall a m. + (HasCallStack, MonadCatch m, MonadLogger m) + => m a + -> m (Maybe a) +tryAndLogAll = flip catchAndLog + (const (return Nothing) :: SomeException -> m (Maybe a)) . + fmap Just + +logAndThrow :: (HasCallStack, MonadMask m, MonadLogger m, Exception e) + => e + -> m a +logAndThrow e = logShow logErrorCS callStack e >> throwM e + +logShow :: (Show s) => (CallStack -> Text -> m ()) -> CallStack -> s -> m () +logShow f cs = f cs . pack . show + +logInfoShow :: (HasCallStack, Show s, MonadLogger m) => s -> m () +logInfoShow = logShow logInfoCS callStack + +logErrorShow :: (HasCallStack, Show s, MonadLogger m) => s -> m () +logErrorShow = logShow logErrorCS callStack + +throwLeftM :: (HasCallStack, MonadMask m, MonadLogger m, Exception e) + => m (Either e r) + -> m r +throwLeftM = (>>= either logAndThrow return) + +throwNothingM :: (HasCallStack, MonadLogger m, MonadCatch m) + => m (Maybe r) + -> m r +throwNothingM mmr = do + mr <- mmr + requireMCS callStack (show OneBillionDollarBug) (isJust mr) + return (fromJust mr) + +data OneBillionDollarBug = OneBillionDollarBug + deriving Show + +instance Exception OneBillionDollarBug + +data ErrMsg a = ErrMsg String a + +instance Show a => + Show (ErrMsg a) where + show (ErrMsg title a) = title ++ ": " ++ show a + +instance Exception a => + Exception (ErrMsg a) diff --git a/src/Util/Socket.hs b/src/Util/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Util/Socket.hs @@ -0,0 +1,64 @@ +module Util.Socket + ( connectSocket + , serverSocket + , acceptSocket + , closeSock + , Socket() + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CS +import Data.Word +import Network.Socket hiding (recv, recvFrom, send, sendTo) +import Util.IOExtra + +-------------------------------------------------------------------------------- +connectSocket :: BS.ByteString -> Word16 -> IO Socket +connectSocket hostName portNumber = do + (sock, sa) <- createSocket hostName (Just portNumber) + handleAll (\e -> closeSock sock >> throwM e) $ do + setSocketOption sock NoDelay 1 + connect sock sa + return sock + +serverSocket :: BS.ByteString -> IO (Socket, Word16) +serverSocket hostName = do + (sock, sa) <- createSocket hostName Nothing + handleAll (\e -> closeSock sock >> throwM e) $ do + bind sock sa + listen sock 5 + port <- socketPort sock + return (sock, fromIntegral port) + +acceptSocket :: Socket -> IO Socket +acceptSocket sock = do + (sock', _sa) <- accept sock + handleAll (\e -> closeSock sock' >> throwM e) $ do + setSocketOption sock' NoDelay 1 + return sock' + +closeSock :: Socket -> IO () +closeSock = close + +createSocket :: MonadIO m + => BS.ByteString + -> Maybe Word16 + -> m (Socket, SockAddr) +createSocket hostName portNumber = + liftIO $ do + ai <- addrInfo + sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) + return (sock, addrAddress ai) + where + addrInfo = do + let hints = defaultHints { addrFlags = [ AI_CANONNAME + , AI_NUMERICSERV + , AI_ADDRCONFIG + ] + , addrFamily = AF_INET + , addrSocketType = Stream + } + (ai : _) <- getAddrInfo (Just hints) + (Just (CS.unpack hostName)) + (show <$> portNumber) + return ai diff --git a/test/Foreign/Erlang/ControlMessageSpec.hs b/test/Foreign/Erlang/ControlMessageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/Erlang/ControlMessageSpec.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Foreign.Erlang.ControlMessageSpec ( spec ) where + +import Test.Hspec +import Test.QuickCheck + +import qualified Data.ByteString.Lazy as LBS +import Data.Binary ( decode, encode ) + +import Foreign.Erlang.ControlMessage +import Foreign.Erlang.Term + +spec :: Spec +spec = describe "ControlMessage" $ do + it "decode . encode = id" $ + property $ + \(a :: ControlMessage) -> (decode . encode) a `shouldBe` a + it "TICK encodes as expected" $ + LBS.unpack (encode TICK) `shouldBe` [ 0, 0, 0, 0 ] + it "LINK encodes as expected" $ + LBS.unpack (encode (LINK (pid "from" 1 2 3) (pid "to" 4 5 6))) `shouldBe` + [ 0 + , 0 + , 0 + , 38 + , 112 + , 131 + , 104 + , 3 + , 97 + , 1 + , 103 + , 100 + , 0 + , 4 + , 102 + , 114 + , 111 + , 109 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 2 + , 3 + , 103 + , 100 + , 0 + , 2 + , 116 + , 111 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 5 + , 6 + ] + it "SEND encodes as expected" $ + LBS.unpack (encode (SEND (pid "to" 4 5 6) (atom "hello"))) `shouldBe` + [ 0 + , 0 + , 0 + , 33 + , 112 + , 131 + , 104 + , 3 + , 97 + , 2 + , 100 + , 0 + , 0 + , 103 + , 100 + , 0 + , 2 + , 116 + , 111 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 5 + , 6 + , 131 + , 100 + , 0 + , 5 + , 104 + , 101 + , 108 + , 108 + , 111 + ] + it "EXIT encodes as expected" $ + LBS.unpack (encode (EXIT (pid "from" 1 2 3) (pid "to" 4 5 6) (atom "normal"))) `shouldBe` + [ 0 + , 0 + , 0 + , 47 + , 112 + , 131 + , 104 + , 4 + , 97 + , 3 + , 103 + , 100 + , 0 + , 4 + , 102 + , 114 + , 111 + , 109 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 2 + , 3 + , 103 + , 100 + , 0 + , 2 + , 116 + , 111 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 5 + , 6 + , 100 + , 0 + , 6 + , 110 + , 111 + , 114 + , 109 + , 97 + , 108 + ] + it "UNLINK encodes as expected" $ + LBS.unpack (encode (UNLINK (pid "from" 1 2 3) (pid "to" 4 5 6))) `shouldBe` + [ 0 + , 0 + , 0 + , 38 + , 112 + , 131 + , 104 + , 3 + , 97 + , 4 + , 103 + , 100 + , 0 + , 4 + , 102 + , 114 + , 111 + , 109 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 2 + , 3 + , 103 + , 100 + , 0 + , 2 + , 116 + , 111 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 5 + , 6 + ] + it "NODE_LINK encodes as expected" $ + LBS.unpack (encode NODE_LINK) `shouldBe` [ 0, 0, 0, 6, 112, 131, 104, 1, 97, 5 ] + it "REG_SEND encodes as expected" $ + LBS.unpack (encode (REG_SEND (pid "from" 1 2 3) (atom "to") (atom "hello"))) `shouldBe` + [ 0 + , 0 + , 0 + , 40 + , 112 + , 131 + , 104 + , 4 + , 97 + , 6 + , 103 + , 100 + , 0 + , 4 + , 102 + , 114 + , 111 + , 109 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 2 + , 3 + , 100 + , 0 + , 0 + , 100 + , 0 + , 2 + , 116 + , 111 + , 131 + , 100 + , 0 + , 5 + , 104 + , 101 + , 108 + , 108 + , 111 + ] + it "GROUP_LEADER encodes as expected" $ + LBS.unpack (encode (GROUP_LEADER (pid "from" 1 2 3) (pid "to" 4 5 6))) `shouldBe` + [ 0 + , 0 + , 0 + , 38 + , 112 + , 131 + , 104 + , 3 + , 97 + , 7 + , 103 + , 100 + , 0 + , 4 + , 102 + , 114 + , 111 + , 109 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 2 + , 3 + , 103 + , 100 + , 0 + , 2 + , 116 + , 111 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 5 + , 6 + ] + it "EXIT2 encodes as expected" $ + LBS.unpack (encode (EXIT2 (pid "from" 1 2 3) (pid "to" 4 5 6) (atom "normal"))) `shouldBe` + [ 0 + , 0 + , 0 + , 47 + , 112 + , 131 + , 104 + , 4 + , 97 + , 8 + , 103 + , 100 + , 0 + , 4 + , 102 + , 114 + , 111 + , 109 + , 0 + , 0 + , 0 + , 1 + , 0 + , 0 + , 0 + , 2 + , 3 + , 103 + , 100 + , 0 + , 2 + , 116 + , 111 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 5 + , 6 + , 100 + , 0 + , 6 + , 110 + , 111 + , 114 + , 109 + , 97 + , 108 + ] diff --git a/test/Foreign/Erlang/HandshakeSpec.hs b/test/Foreign/Erlang/HandshakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/Erlang/HandshakeSpec.hs @@ -0,0 +1,204 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} + +module Foreign.Erlang.HandshakeSpec ( spec ) where + +import Test.Hspec +import Test.QuickCheck +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CS +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import Data.Binary +import Data.List ( nub, sort ) +import Util.IOExtra +import Util.BufferedIOx +import Foreign.Erlang.NodeData +import Foreign.Erlang.Handshake +import Control.Monad.Logger ( MonadLogger(monadLoggerLog) + , runStderrLoggingT ) + +spec :: Spec +spec = do + describe "Name" $ do + it "decode . encode = id" $ + property $ do + v <- arbitraryBoundedEnum + f <- (DistributionFlags . nub . sort) <$> listOf arbitraryBoundedEnum + n <- BS.pack <$> listOf arbitrary + let a = Name v f n + return $ (decode . encode) a `shouldBe` a + it "encodes as expected" $ + encode (Name R6B (DistributionFlags []) "name") `shouldBe` + withLength16 ("n" `LBS.append` LBS.pack [ 0, 5, 0, 0, 0, 0 ] `LBS.append` + "name") + + describe "Status" $ do + it "decode . encode = id" $ + property $ do + a <- arbitraryBoundedEnum :: Gen Status + return $ (decode . encode) a `shouldBe` a + it "Ok encodes to \"ok\"" $ + encode Ok `shouldBe` withLength16 ("s" `LBS.append` "ok") + it "OkSimlutaneous encodes to \"ok_simultaneous\"" $ + encode OkSimultaneous `shouldBe` + withLength16 ("s" `LBS.append` "ok_simultaneous") + it "Nok encodes to \"nok\"" $ + encode Nok `shouldBe` withLength16 ("s" `LBS.append` "nok") + it "NotAllowed encodes to \"not_allowed\"" $ + encode NotAllowed `shouldBe` + withLength16 ("s" `LBS.append` "not_allowed") + it "Alive encodes to \"alive\"" $ + encode Alive `shouldBe` withLength16 ("s" `LBS.append` "alive") + + describe "Challenge" $ do + it "decode . encode = id" $ + property $ do + v <- arbitraryBoundedEnum + f <- (DistributionFlags . nub . sort) <$> listOf arbitraryBoundedEnum + c <- arbitrary + n <- BS.pack <$> listOf arbitrary + let a = Challenge v f c n + return $ (decode . encode) a `shouldBe` a + + describe "ChallengeReply" $ do + it "decode . encode = id" $ + property $ do + c <- arbitrary + d <- BS.pack <$> listOf arbitrary + let a = ChallengeReply c d + return $ (decode . encode) a `shouldBe` a + + describe "ChallengeAck" $ do + it "decode . encode = id" $ + property $ do + d <- BS.pack <$> listOf arbitrary + let a = ChallengeAck d + return $ (decode . encode) a `shouldBe` a + + describe "doConnect and doAccept work together" $ do + it "correct cookie is accepted" $ do + let name = Name { n_distVer = R6B + , n_distFlags = DistributionFlags [] + , n_nodeName = "alive@localhost.localdomain" + } + nodeData = NodeData { portNo = 50000 + , nodeType = HiddenNode + , protocol = TcpIpV4 + , hiVer = R6B + , loVer = R6B + , aliveName = "alive" + , extra = "" + } + handshakeData = HandshakeData { name + , nodeData + , cookie = "cookie" + } + + her_nodeName <- do + buffer0 <- newBuffer + buffer1 <- newBuffer + + _ <- fork $ + doConnect (runPutBuffered buffer0) + (runGetBuffered buffer1) + handshakeData + doAccept (runPutBuffered buffer1) + (runGetBuffered buffer0) + handshakeData + her_nodeName `shouldBe` + "alive@localhost.localdomain" + + it "wrong cookie is rejected" $ do + let name1 = Name { n_distVer = R6B + , n_distFlags = DistributionFlags [] + , n_nodeName = "alive1@localhost.localdomain" + } + nodeData1 = NodeData { portNo = 50001 + , nodeType = HiddenNode + , protocol = TcpIpV4 + , hiVer = R6B + , loVer = R6B + , aliveName = "alive1" + , extra = "" + } + handshakeData1 = HandshakeData { name = name1 + , nodeData = nodeData1 + , cookie = "cookie1" + } + name2 = Name { n_distVer = R6B + , n_distFlags = DistributionFlags [] + , n_nodeName = "alive2@localhost.localdomain" + } + nodeData2 = NodeData { portNo = 50002 + , nodeType = HiddenNode + , protocol = TcpIpV4 + , hiVer = R6B + , loVer = R6B + , aliveName = "alive2" + , extra = "" + } + handshakeData2 = HandshakeData { name = name2 + , nodeData = nodeData2 + , cookie = "cookie2" + } + error_message <- (do + buffer0 <- newBuffer + buffer1 <- newBuffer + + _ <- fork $ + doConnect (runPutBuffered buffer0) + (runGetBuffered buffer1) + handshakeData1 + doAccept (runPutBuffered buffer1) + (runGetBuffered buffer0) + handshakeData2) `catch` + (return . + CS.pack . + (displayException :: SomeException + -> String)) + error_message `shouldBe` + "CookieMismatch" + +instance MonadLogger IO where + monadLoggerLog _a _b _c _d = + runStderrLoggingT $ monadLoggerLog _a _b _c _d + +withLength16 :: LBS.ByteString -> LBS.ByteString +withLength16 bytes = encode (fromIntegral (LBS.length bytes) :: Word16) `LBS.append` + bytes + +newtype Buffer = Buffer { bufIO :: IORef BS.ByteString } + +instance BufferedIOx Buffer where + readBuffered a = liftIO . readBuffer a + unreadBuffered a = liftIO . writeBuffer a . LBS.fromStrict + writeBuffered a = liftIO . writeBuffer a + closeBuffered = const (return ()) + +newBuffer :: IO Buffer +newBuffer = Buffer <$> newIORef BS.empty + +readBuffer :: Buffer -> Int -> IO BS.ByteString +readBuffer buffer@Buffer{bufIO} len + | len < 0 = error $ "Bad length: " ++ show len + | len == 0 = return BS.empty + | otherwise = do + atomicModifyIORef' bufIO + (\buf -> if BS.null buf + then (BS.empty, Nothing) + else let bufLen = BS.length buf + in + if len > bufLen + then (BS.empty, (Just buf)) + else let (buf0, buf1) = BS.splitAt len + buf + in + (buf1, Just buf0)) >>= + maybe (readBuffer buffer len) (return) + +writeBuffer :: Buffer -> LBS.ByteString -> IO () +writeBuffer Buffer{bufIO} bytes = do + atomicModifyIORef' bufIO + (\buf -> (buf `BS.append` (LBS.toStrict bytes), ())) diff --git a/test/Foreign/Erlang/NodeDataSpec.hs b/test/Foreign/Erlang/NodeDataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/Erlang/NodeDataSpec.hs @@ -0,0 +1,91 @@ +module Foreign.Erlang.NodeDataSpec ( spec ) where + +import Test.Hspec +--import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Data.Word +import Data.List ( nub, sort ) +import Data.Binary ( decode, encode ) + +import Foreign.Erlang.NodeData + +spec :: Spec +spec = do + describe "NodeType" $ do + it "decode . encode = id" $ + property $ do + a <- arbitraryBoundedEnum :: Gen NodeType + return $ (decode . encode) a `shouldBe` a + it "NormalNode encodes to 77" $ + encode NormalNode `shouldBe` encode (77 :: Word8) + it "HiddenNode encodes to 72" $ + encode HiddenNode `shouldBe` encode (72 :: Word8) + + + describe "NodeProtocol" $ do + it "decode . encode = id" $ + property $ do + a <- arbitraryBoundedEnum :: Gen NodeProtocol + return $ (decode . encode) a `shouldBe` a + it "TcpIpV4 encodes to 0" $ + encode TcpIpV4 `shouldBe` encode (0 :: Word8) + + describe "DistributionVersion" $ do + it "decode . encode = id" $ + property $ do + a <- arbitraryBoundedEnum :: Gen DistributionVersion + return $ (decode . encode) a `shouldBe` a + it "R4 encodes to 1" $ + encode R4 `shouldBe` encode (1 :: Word16) + it "R5C encodes to 3" $ + encode R5C `shouldBe` encode (3 :: Word16) + it "R6 encodes to 4" $ + encode R6 `shouldBe` encode (4 :: Word16) + it "R6B encodes to 5" $ + encode R6B `shouldBe` encode (5 :: Word16) + + describe "DistributionFlags" $ do + it "decode . encode = id" $ + property $ do + a <- (DistributionFlags . nub . sort) <$> listOf arbitraryBoundedEnum :: Gen DistributionFlags + return $ (decode . encode) a `shouldBe` a + it "[] encodes to 0x00000" $ + encode (DistributionFlags []) `shouldBe` encode (0x00000 :: Word32) + it "[PUBLISHED] encodes to 0x00001" $ + encode (DistributionFlags [ PUBLISHED ]) `shouldBe` encode (0x00001 :: Word32) + it "[ATOM_CACHE] encodes to 0x00002" $ + encode (DistributionFlags [ ATOM_CACHE ]) `shouldBe` encode (0x00002 :: Word32) + it "[EXTENDED_REFERENCES] encodes to 0x00004" $ + encode (DistributionFlags [ EXTENDED_REFERENCES ]) `shouldBe` encode (0x00004 :: Word32) + it "[DIST_MONITOR] encodes to 0x00008" $ + encode (DistributionFlags [ DIST_MONITOR ]) `shouldBe` encode (0x00008 :: Word32) + it "[FUN_TAGS] encodes to 0x00010" $ + encode (DistributionFlags [ FUN_TAGS ]) `shouldBe` encode (0x00010 :: Word32) + it "[DIST_MONITOR_NAME] encodes to 0x00020" $ + encode (DistributionFlags [ DIST_MONITOR_NAME ]) `shouldBe` encode (0x00020 :: Word32) + it "[HIDDEN_ATOM_CACHE] encodes to 0x00040" $ + encode (DistributionFlags [ HIDDEN_ATOM_CACHE ]) `shouldBe` encode (0x00040 :: Word32) + it "[NEW_FUN_TAGS] encodes to 0x00080" $ + encode (DistributionFlags [ NEW_FUN_TAGS ]) `shouldBe` encode (0x00080 :: Word32) + it "[EXTENDED_PIDS_PORTS] encodes to 0x00100" $ + encode (DistributionFlags [ EXTENDED_PIDS_PORTS ]) `shouldBe` encode (0x00100 :: Word32) + it "[EXPORT_PTR_TAG] encodes to 0x00200" $ + encode (DistributionFlags [ EXPORT_PTR_TAG ]) `shouldBe` encode (0x00200 :: Word32) + it "[BIT_BINARIES] encodes to 0x00400" $ + encode (DistributionFlags [ BIT_BINARIES ]) `shouldBe` encode (0x00400 :: Word32) + it "[NEW_FLOATS] encodes to 0x00800" $ + encode (DistributionFlags [ NEW_FLOATS ]) `shouldBe` encode (0x00800 :: Word32) + it "[UNICODE_IO] encodes to 0x01000" $ + encode (DistributionFlags [ UNICODE_IO ]) `shouldBe` encode (0x01000 :: Word32) + it "[DIST_HDR_ATOM_CACHE] encodes to 0x02000" $ + encode (DistributionFlags [ DIST_HDR_ATOM_CACHE ]) `shouldBe` encode (0x02000 :: Word32) + it "[SMALL_ATOM_TAGS] encodes to 0x04000" $ + encode (DistributionFlags [ SMALL_ATOM_TAGS ]) `shouldBe` encode (0x04000 :: Word32) + it "[UTF8_ATOMS] encodes to 0x10000" $ + encode (DistributionFlags [ UTF8_ATOMS ]) `shouldBe` encode (0x10000 :: Word32) + it "[minBound .. maxBound] encodes to 0x17FFF" $ + encode (DistributionFlags [minBound .. maxBound]) `shouldBe` encode (0x17FFF :: Word32) + it "0xFFFFFFFF decodes to [minBound .. maxBound]" $ + (decode . encode) (0xFFFFFFFF :: Word32) `shouldBe` + DistributionFlags [minBound .. maxBound] diff --git a/test/Foreign/Erlang/TermSpec.hs b/test/Foreign/Erlang/TermSpec.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/Erlang/TermSpec.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Foreign.Erlang.TermSpec ( spec ) where + +import Data.Binary (decode, encode) +import Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as B +import Data.Word () +import Foreign.Erlang.Term +import Test.Hspec +import Test.QuickCheck + +spec :: Spec +spec = do + describe "Pid" + $ do it "has a Binary instance such that decode is the inverse of encode" + $ property + $ \ (p :: Pid) -> + fromTerm (decode (encode (toTerm p))) `shouldBe` (Just p) + it "represents all valid Erlang pids" + $ property + $ \ x y z -> + let p = pid "nodename" x y z + in fromTerm (decode (encode (toTerm p))) `shouldBe` (Just p) + describe "Integer" + $ it "has a Binary instance such that decode is the inverse of encode" + $ property + $ \ (i :: Integer) -> + fromTerm (decode (encode (integer i))) `shouldBe` (Just i) + describe "The largest small_big_ext Integer" + $ do let i = 2^(8 * 255) - 1 + it "has a Binary instance such that decode is the inverse of encode" + $ fromTerm (decode (encode (integer i))) `shouldBe` (Just i) + it "is converted to a valid erlang binary" + $ B.unpack (encode (integer i)) `shouldBe` + [110,255,0 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255,255,255,255,255,255,255,255,255,255,255,255 + ,255,255,255] + describe "The smallest large_big_ext Integer" + $ it "has a Binary instance such that decode is the inverse of encode" + $ let i = 2^(8 * 255) + in fromTerm (decode (encode (integer i))) `shouldBe` (Just i) + describe "Term" + $ it "has a Binary instance such that decode is the inverse of encode" + $ property + $ \ (t :: Term) -> + decode (encode t) `shouldBe` t diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}