binary-protocol-zmq (empty) → 0.1

raw patch · 6 files changed

+371/−0 lines, 6 filesdep +HUnitdep +basedep +binarysetup-changed

Dependencies added: HUnit, base, binary, bytestring, mtl, test-framework, test-framework-hunit, zeromq-haskell

Files

Control/Monad/BinaryProtocol/ZMQ.hs +83/−0
LICENSE +26/−0
README.rst +14/−0
Setup.lhs +57/−0
Test.hs +115/−0
binary-protocol-zmq.cabal +76/−0

+ Control/Monad/BinaryProtocol/ZMQ.hs view

@@ -0,0 +1,83 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.BinaryProtocol.ZMQ+-- Copyright   :  (c) 2010 Nicolas Trangez+-- License     :  BSD3+-- +-- Maintainer  :  Nicolas Trangez <eikke@eikke.com>+-- Stability   :  experimental+--+-- Monad to ease implementing a binary network protocol over ZeroMQ+--+-----------------------------------------------------------------------------++module Control.Monad.BinaryProtocol.ZMQ+    (+      BinaryProtocol+    , runProtocol+    , receive+    , receive'+    , send+    , send'+    , flush+    ) where++import qualified Control.Monad.Reader as R+import qualified Control.Monad.Trans as T++import qualified Data.Binary as B+import qualified Data.Binary.Get as BG++import qualified Data.ByteString.Lazy as LB++import qualified System.ZMQ as ZMQ++-- | Action type definition. @a@ is the type of the reader ZeroMQ socket,+--   @b@ is the type of the writer ZeroMQ socket, and @c@ is the return type of+--   the action.+newtype BinaryProtocol a b c = BP {+    runBP :: R.ReaderT (ZMQ.Socket a, ZMQ.Socket b) IO c+} deriving (Monad, T.MonadIO, R.MonadReader (ZMQ.Socket a, ZMQ.Socket b))++-- | Take a @BinaryProtocol@ action and run it on the given ZeroMQ sockets for+--   respectively reading and writing. The two given handles are allowed to be+--   the same if the same handle is used for reading and writing.+runProtocol :: BinaryProtocol a b c -> ZMQ.Socket a -> ZMQ.Socket b -> IO c+runProtocol p a b = R.runReaderT (runBP p) (a, b)++-- | Read in a value of type @c@ from the connection; @c@ must be an instance+--   of the @Binary@ class. This is a wrapper around @receive'@, not passing+--   any flags.+receive :: B.Binary c => BinaryProtocol a b c+receive = receive' []++-- | Read in a value of type @c@ from the connection; @c@ must be an instance+--   of the @Binary@ class. A list of @Flag@s can be given.+receive' :: B.Binary c => [ZMQ.Flag] -> BinaryProtocol a b c+receive' flags =+    R.ask >>= \(sock, _) ->+    T.liftIO $ ZMQ.receive sock flags >>= \msg ->+    return $ BG.runGet B.get $ LB.fromChunks [msg]++-- | Send a value of type @c@ down the connection; @c@ must be an instance of+--   the @Binary@ class. This is a wrapper aroung @send'@, not passing any+--   flags.+send :: B.Binary c => c -> BinaryProtocol a b ()+send = send' []++-- | Send a value of type @c@ down the connection; @c@ must be an instance of+--   the @Binary@ class. A list of @Flag@s can be given.+send' :: B.Binary c => [ZMQ.Flag] -> c -> BinaryProtocol a b ()+send' flags value =+    R.ask >>= \(_, sock) ->+    T.liftIO $ ZMQ.send' sock msg flags+  where msg = B.encode value++-- | Flush connections+--+--   Note: this is a no-op, provided for API compatibility with the+--   @Control.Monad.BinaryProtocol@ package.+flush :: BinaryProtocol a b ()+flush = return ()

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright (c) 2009 Gregory M. Crosswhite+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.

+ README.rst view

@@ -0,0 +1,14 @@+binary-protocol-zmq+===================+This package contains a monad to ease development of binary network protocols+on top of ZeroMQ_ sockets.++The protocol should be implemented using messages implementing the Binary_+class. This code is heavily based on the binary-protocol_ package by+Gregory Crosswhite, and mimicks its API.++You can build the API documentation using `cabal haddock`.++.. _ZeroMQ: http://www.zeromq.org+.. _Binary: http://hackage.haskell.org/package/binary+.. _binary-protocol: http://hackage.haskell.org/package/binary-protocol

+ Setup.lhs view

@@ -0,0 +1,57 @@+#!/usr/bin/env runhaskell+\begin{code}++import Control.Monad (unless)++import Data.Maybe (listToMaybe, fromMaybe)++import System.Directory (doesDirectoryExist, setCurrentDirectory)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.Process (system)++import Distribution.PackageDescription+    (  BuildInfo, PackageDescription, buildable, buildInfo+     , exeName, executables)+import Distribution.Simple+    (Args, UserHooks, defaultMainWithHooks, simpleUserHooks, runTests)+import Distribution.Simple.Build (build)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir))+import Distribution.Simple.PreProcess (knownSuffixHandlers)+import Distribution.Simple.Setup (defaultBuildFlags)++main :: IO ()+main = defaultMainWithHooks hooks++hooks :: UserHooks+hooks = simpleUserHooks { runTests = testHook }++testBinaryProtocolZMQ :: a -> (BuildInfo -> a) -> PackageDescription -> a+testBinaryProtocolZMQ dflt f pd =+    fromMaybe dflt $ listToMaybe+        [ f (buildInfo exe)+        | exe <- executables pd+        , exeName exe == "test-binary-protocol-zmq"+        ]++testHook :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+testHook _ _ pd lbi = do+    let testDir = buildDir lbi </> "test-binary-protocol-zmq"++    t <- doesDirectoryExist testDir++    unless t $ do+        unless (testBinaryProtocolZMQ False buildable pd) $+            fail $ "Reconfigure with 'cabal configure -ftests' or " +++                "'cabal install -ftests' and try again"+        putStrLn "Building tests"+        build pd lbi defaultBuildFlags knownSuffixHandlers+        putStrLn "Tests built"++    setCurrentDirectory testDir++    exitcode <- system "./test-binary-protocol-zmq"+    unless (exitcode == ExitSuccess) $+        fail "Test failed"++\end{code}

+ Test.hs view

@@ -0,0 +1,115 @@+module Main (main) where++import Test.Framework+import qualified Test.Framework as TF+import Test.Framework.Providers.HUnit+import Test.HUnit++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)+import Control.Exception (finally)+import Control.Monad (forM_)+import Control.Monad.Trans (liftIO)++import System.IO (hPutStrLn, stderr)++import qualified Data.Binary as B++import qualified System.ZMQ as ZMQ++import Control.Monad.BinaryProtocol.ZMQ+    (BinaryProtocol, runProtocol, send, receive, flush)++main :: IO ()+main = defaultMain tests++tests :: [TF.Test]+tests =+    [ testGroup "unidirectional communications"+      [ testCase "send unit" testSendUnit+      , testCase "send number" testSendNumber+      , testCase "send list of numbers" testSendListOfNumbers+      ]++    , testGroup "bidirectional communications"+      [ testCase "addition" testAddition+      ]+    ]++makeChannels :: ZMQ.Context -> String -> IO (ZMQ.Socket ZMQ.Up,+                    ZMQ.Socket ZMQ.Down)+makeChannels ctx address = do+    chan1 <- ZMQ.socket ctx ZMQ.Up+    chan2 <- ZMQ.socket ctx ZMQ.Down++    ZMQ.bind chan1 address+    ZMQ.connect chan2 address++    return (chan1, chan2)++makeSendTest :: (B.Binary a, Eq a, Show a) => a -> IO ()+makeSendTest value = do+    ctx <- ZMQ.init 1+    (chan_in, chan_out) <- makeChannels ctx "inproc://pipe"++    result <- runProtocol actions chan_in chan_out `finally` do+        ZMQ.close chan_out+        ZMQ.close chan_in+        ZMQ.term ctx++    assertEqual "Was the correct value received?" value result+  where actions = do+            send value+            flush+            receive++testSendUnit :: IO ()+testSendUnit = makeSendTest ()++testSendNumber :: IO ()+testSendNumber = makeSendTest (3 :: Int)++testSendListOfNumbers :: IO ()+testSendListOfNumbers = makeSendTest [3 :: Int, 4, 5, 6]+++makeExchangeTest :: (B.Binary a, Show a, Eq a) =>+    a ->+    (MVar a -> BinaryProtocol ZMQ.Up ZMQ.Down ()) ->+    (MVar a -> BinaryProtocol ZMQ.Up ZMQ.Down ()) ->+    IO ()+makeExchangeTest correct_result protocol1 protocol2 = do+    resultMVar <- newEmptyMVar++    ctx <- ZMQ.init 1+    (chan_in1, chan_out2) <- makeChannels ctx address1+    (chan_in2, chan_out1) <- makeChannels ctx address2++    forkIO $ runProtocol (protocol1 resultMVar) chan_in1 chan_out1+    forkIO $ runProtocol (protocol2 resultMVar) chan_in2 chan_out2++    result <- readMVar resultMVar `finally` do+        forM_ [chan_in1, chan_in2] ZMQ.close+        forM_ [chan_out1, chan_out2] ZMQ.close+        ZMQ.term ctx++    assertEqual "Was the correct result computed?" correct_result result++  where address1 = "inproc://pipe1"+        address2 = "inproc://pipe2"++testAddition :: IO ()+testAddition = do+    hPutStrLn stderr+        "Warning: this test locks up sometimes, needs investigation"+    makeExchangeTest (3 :: Int)+        (\resultMVar -> do+             send (1 :: Int)+             flush+             receive >>= liftIO . putMVar resultMVar+        )+        (\_ -> do+             a <- receive+             send (a + (2 :: Int))+             flush+        )

+ binary-protocol-zmq.cabal view

@@ -0,0 +1,76 @@+Name:          binary-protocol-zmq+Version:       0.1+Stability:     Experimental++Synopsis:      Monad to ease implementing a binary network protocol over ZeroMQ+Description:+ The monad provided in this package provides an easy way to implement servers+ and clients which exchange messages (types which are instances of+ @Data.Binary.Binary@) over ZeroMQ sockets.+ .+ This is heavily based on the @Control.Monad.BinaryProtocol@ package by Gregory+ Crosswhite.+Category:      Data, Network++Author:        Nicolas Trangez+Copyright:     (c) 2010 Nicolas Trangez+Maintainer:    Nicolas Trangez <eikke@eikke.com>+Homepage:      http://github.com/NicolasT/binary-protocol-zmq++License:       BSD3+License-File:  LICENSE++Cabal-Version: >= 1.6+Build-Type:    Simple++Extra-Source-Files:+  README.rst++Source-Repository head+  Type:     git+  Location: git://github.com/NicolasT/binary-protocol-zmq.git+  branch:   master++Flag tests+  Description: Build the tests+  Default:     False++Flag optimize+  Description: Enable optimizations for the library+  Default:     True++Library+  Build-Depends:+    base >=4 && < 5,+    binary,+    bytestring,+    mtl,+    zeromq-haskell++  Exposed-Modules:+    Control.Monad.BinaryProtocol.ZMQ++  Hs-Source-Dirs: .++  GHC-Options:    -Wall -fno-warn-unused-binds+  if flag(optimize)+    GHC-Options:  -funbox-strict-fields -O2 -fspec-constr -fdicts-cheap++Executable test-binary-protocol-zmq+  Main-Is:     Test.hs++  if !flag(tests)+    Buildable: False+  else+    Build-Depends:+      base >= 4 && < 5,+      test-framework,+      test-framework-hunit,+      HUnit++    Other-Modules:+      Control.Monad.BinaryProtocol.ZMQ++    GHC-Options:   -Wall -fno-warn-unused-binds -threaded+    if flag(optimize)+      GHC-Options: -funbox-strict-fields -O2 -fspec-constr -fdicts-cheap