Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Created repository.

  • Loading branch information...
commit e4400e2209ceb23564da1144d79a06f59f04aa88 0 parents
Gregory Crosswhite authored
4 .gitignore
@@ -0,0 +1,4 @@
+*.o
+*.hi
+Setup
+dist
58 Control/Monad/BinaryProtocol.hs
@@ -0,0 +1,58 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 file handle.
+-- | PLEASE NOTE: The handle is essentially consumed by this function, so it should not be used afterward.
+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 the connection.
+flush :: BinaryProtocol ()
+flush = do
+ (_,write_handle,_) <- get
+ liftIO . hFlush $ write_handle
26 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.
24 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 ()
21 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 <gcross@phys.washington.edu>
+Homepage: http://github.com/gcross/binary-protocol
+Synopsis: Monad to ease implementing a binary network protocol.
+Build-Type: Simple
+
+Library
+ Build-Depends: base >= 4,
+ binary >= 0.5,
+ bytestring >= 0.9.1,
+ mtl >= 1.1
+ Hs-Source-Dirs: .
+ Exposed-Modules: Control.Monad.BinaryProtocol
+ GHC-Options: -Wall
68 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
Please sign in to comment.
Something went wrong with that request. Please try again.