layer2 works somehow

1 files changed, 136 insertions, 0 deletions

diff --git a/Test.hs b/Test.hs
new file mode 100644
index 0000000..c658e08
--- /dev/null
+++ b/Test.hs
@@ -0,0 +1,136 @@
+module Main (main) where
+
+import Test.Framework
+import qualified Test.Framework as TF
+import Test.Framework.Providers.HUnit
+import Test.HUnit
+
+import Control.Concurrent (forkOS)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)
+import Control.Exception (finally)
+import Control.Monad.Trans (liftIO)
+
+import qualified Data.Binary as B
+
+import Network.EBus.Layer2 as L2
+
+
+-- 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
+
+--     lock1 <- newEmptyMVar
+--     lock2 <- newEmptyMVar
+
+--     -- ZeroMQ sockets can only be used in the thread which created them.
+--     -- We need some magic to get this right.
+--     f $ forkOS $ runProtocol' address1 address2 ctx lock1 lock2
+--         (protocol1 resultMVar)
+--     f $ forkOS $ runProtocol' address2 address1 ctx lock2 lock1
+--         (protocol2 resultMVar)
+
+--     result <- readMVar resultMVar `finally` ZMQ.term ctx
+
+--     assertEqual "Was the correct result computed?" correct_result result
+
+--   where address1 = "inproc://pipe1"
+--         address2 = "inproc://pipe2"
+
+--         f :: IO a -> IO ()
+--         f a = a >> return ()
+
+--         runProtocol' :: String -> String -> ZMQ.Context ->
+--             MVar () -> MVar () ->
+--             BinaryProtocol ZMQ.Up ZMQ.Down () -> IO ()
+--         runProtocol' a1 a2 ctx l1 l2 p = do
+--             chan_in <- ZMQ.socket ctx ZMQ.Up
+--             chan_out <- ZMQ.socket ctx ZMQ.Down
+
+--             ZMQ.bind chan_in a1
+--             putMVar l1 ()
+
+--             f $ readMVar l2
+--             ZMQ.connect chan_out a2
+
+--             runProtocol p chan_in chan_out `finally` do
+--                 ZMQ.close chan_in
+--                 ZMQ.close chan_out
+
+
+-- testAddition :: IO ()
+-- testAddition =
+--     makeExchangeTest (3 :: Int)
+--         (\resultMVar -> do
+--              send (1 :: Int)
+--              flush
+--              receive >>= liftIO . putMVar resultMVar
+--         )
+--         (\_ -> do
+--              a <- receive
+--              send (a + (2 :: Int))
+--              flush
+--         )
\ No newline at end of file