packages feed

hinterface (empty) → 0.5.0.0

raw patch · 24 files changed

+3600/−0 lines, 24 filesdep +QuickCheckdep +arraydep +asyncsetup-changed

Dependencies added: QuickCheck, array, async, base, binary, bytestring, containers, cryptonite, exceptions, hinterface, hspec, lifted-async, lifted-base, memory, monad-control, monad-logger, mtl, network, random, resourcet, safe-exceptions, stm, text, transformers, transformers-base, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hinterface.cabal view
@@ -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
+ src/Foreign/Erlang/Connection.hs view
@@ -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
+ src/Foreign/Erlang/ControlMessage.hs view
@@ -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+                      ]
+ src/Foreign/Erlang/Digest.hs view
@@ -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
+ src/Foreign/Erlang/Epmd.hs view
@@ -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
+ src/Foreign/Erlang/Handshake.hs view
@@ -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
+ src/Foreign/Erlang/LocalNode.hs view
@@ -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)
+ src/Foreign/Erlang/Mailbox.hs view
@@ -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)
+ src/Foreign/Erlang/NodeData.hs view
@@ -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
+ src/Foreign/Erlang/NodeState.hs view
@@ -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
+ src/Foreign/Erlang/Term.hs view
@@ -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
+ src/Network/BufferedSocket.hs view
@@ -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
+ src/Util/Binary.hs view
@@ -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
+ src/Util/BufferedIOx.hs view
@@ -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
+ src/Util/FloatCast.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy      #-}++-- | This module was written based on+--   <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.+--+--   Implements casting via a 1-elemnt STUArray, as described in+--   <http://stackoverflow.com/a/7002812/263061>.+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 #-}
+ src/Util/IOExtra.hs view
@@ -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)
+ src/Util/Socket.hs view
@@ -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
+ test/Foreign/Erlang/ControlMessageSpec.hs view
@@ -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+            ]
+ test/Foreign/Erlang/HandshakeSpec.hs view
@@ -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), ()))
+ test/Foreign/Erlang/NodeDataSpec.hs view
@@ -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]
+ test/Foreign/Erlang/TermSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}