packages feed

binary-protocol (empty) → 1.0

raw patch · 6 files changed

+210/−0 lines, 6 filesdep +basedep +binarydep +bytestringsetup-changedbinary-added

Dependencies added: base, binary, bytestring, mtl

Files

+ Control/Monad/BinaryProtocol.hs view
@@ -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
+ 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.
+ Setup.hs view
@@ -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 ()
+ binary-protocol.cabal view
@@ -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 && < 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
+ tests/._runtests.hs view

binary file changed (absent → 82 bytes)

+ tests/runtests.hs view
@@ -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