diff --git a/Control/Monad/BinaryProtocol.hs b/Control/Monad/BinaryProtocol.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/BinaryProtocol.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.BinaryProtocol +-- Copyright : (c) Gregory Crosswhite +-- License : BSD-style +-- +-- Maintainer : gcrosswhite@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Monad to ease writing a binary network protocol. +-- +----------------------------------------------------------------------------- + +module Control.Monad.BinaryProtocol where + +import Control.Monad.State +import Data.Binary (Binary) +import qualified Data.Binary as B +import Data.Binary.Get (runGetState) +import qualified Data.ByteString.Lazy as L +import System.IO + +type BinaryProtocol = StateT (Handle,Handle,L.ByteString) IO + +-- | Take a BinaryProtocol monad and run it on the given handles 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.) +-- +-- Note: We run L.hGetContents on the read handle, so don't expect to +-- be able to use it after you have called this function. +runProtocol :: BinaryProtocol a -> Handle -> Handle -> IO a +runProtocol protocol read_handle write_handle = do + input <- L.hGetContents read_handle + result <- evalStateT protocol (read_handle,write_handle,input) +-- Note that we deliberately do NOT close the read_handle since result +-- is lazy and hence might need to read more data from the read_handle +-- at a later point. It will be closed automatically on this side +-- anyway once all of the data has been read. + if (read_handle /= write_handle) + then hClose write_handle + else hFlush write_handle + return result + +-- | Read in a value of type @a@ from the connection; @a@ must be an +-- instance of the @Binary@ class. +receive :: Binary a => BinaryProtocol a +receive = do + (read_handle,write_handle,input) <- get + let (value,remaining_input,_) = runGetState B.get input 0 + put (read_handle,write_handle,remaining_input) + return value + +-- | Send a value of type @a@ down the connection; @a@ must be an +-- instance of the @Binary@ class. +send :: Binary a => a -> BinaryProtocol () +send value = do + (_,write_handle,_) <- get + liftIO $ L.hPut write_handle (B.encode value) + +-- | Flush buffered send data down the connection. +-- +-- Note: You need to make sure to call this between sending requests +-- and receiving responses in order to ensure that the request has +-- actually been sent down the connection; otherwise you might get +-- stuck waiting for a response that will not come. +flush :: BinaryProtocol () +flush = do + (_,write_handle,_) <- get + liftIO . hFlush $ write_handle diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,24 @@ +import Control.Monad +import Distribution.Simple +import System.Exit +import System.IO +import System.Process +import Text.Printf + +main = defaultMainWithHooks (simpleUserHooks {runTests = runzeTests}) + +runzeTests _ _ _ _= do + putStrLn "Checking for required modules..." + found <- forM ["test-framework","test-framework-hunit"] $ \package_name -> do + putStr $ printf "Checking for package %s... " package_name + hFlush stdout + error_code <- system $ printf "ghc-pkg field %s version" package_name + return (error_code == ExitSuccess) + when ((not.and) found) $ do + putStrLn "One or more packages needed for testing was not found." + exitWith $ ExitFailure 1 + putStrLn "" + putStrLn "Running tests..." + putStrLn "" + system "runhaskell -i. -i./tests tests/runtests.hs" + return () diff --git a/binary-protocol.cabal b/binary-protocol.cabal new file mode 100644 --- /dev/null +++ b/binary-protocol.cabal @@ -0,0 +1,21 @@ +Name: binary-protocol +Description: Monad to ease implementing a binary network protocol. +Version: 1.0 +Category: Data +Cabal-Version: >= 1.2 +License: BSD3 +License-File: LICENSE +Author: Gregory Crosswhite +Maintainer: Gregory Crosswhite +Homepage: http://github.com/gcross/binary-protocol +Synopsis: Monad to ease implementing a binary network protocol. +Build-Type: Simple + +Library + Build-Depends: base >= 4 && < 5, + binary >= 0.5 && < 0.6, + bytestring >= 0.9.1 && < 1, + mtl >= 1.1 && < 2 + Hs-Source-Dirs: . + Exposed-Modules: Control.Monad.BinaryProtocol + GHC-Options: -Wall diff --git a/tests/._runtests.hs b/tests/._runtests.hs new file mode 100644 Binary files /dev/null and b/tests/._runtests.hs differ diff --git a/tests/runtests.hs b/tests/runtests.hs new file mode 100644 --- /dev/null +++ b/tests/runtests.hs @@ -0,0 +1,68 @@ +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Trans + +import System.IO +import System.Posix.IO + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + +import Control.Monad.BinaryProtocol + +makePipe :: IO (Handle,Handle) +makePipe = do + (read_fd, write_fd) <- createPipe + read_handle <- fdToHandle read_fd + write_handle <- fdToHandle write_fd + return (read_handle, write_handle) + +makeSendTest value = do + (read_handle,write_handle) <- makePipe + result <- runProtocol ( do + send value + flush + receive + ) read_handle write_handle + assertEqual "Was the correct value received?" value result + +test_send_unit = makeSendTest () +test_send_number = makeSendTest (3 :: Int) +test_send_list_of_numbers = makeSendTest [(3 :: Int),4,5,6] + +makeExchangeTest correct_result protocol1 protocol2 = do + result_mvar <- newEmptyMVar + (read_handle_1,write_handle_2) <- makePipe + (read_handle_2,write_handle_1) <- makePipe + forkIO $ runProtocol (protocol1 result_mvar) read_handle_1 write_handle_1 + forkIO $ runProtocol (protocol2 result_mvar) read_handle_2 write_handle_2 + result <- readMVar result_mvar + assertEqual "Was the correct result computed?" correct_result result + +test_addition = makeExchangeTest (3 :: Int) + (\result_mvar -> do + send (1 :: Int) + flush + receive >>= liftIO . putMVar result_mvar + ) + (\_ -> do + a <- receive + send (a + (2 :: Int)) + ) + +tests = + [ testGroup "unidirectional communications" + [ testCase "send unit" test_send_unit + , testCase "send number" test_send_number + , testCase "send list of numbers" test_send_list_of_numbers + ] + , testGroup "bidirectional communications" + [ testCase "addition" test_addition + ] + ] + +main = defaultMain tests