diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | LICENSE | 27 | ||||
| -rw-r--r-- | Network/EBus/Layer2.hs | 162 | ||||
| -rw-r--r-- | Test.hs | 136 | ||||
| -rw-r--r-- | ebus.cabal | 47 |
5 files changed, 373 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ @@ -0,0 +1,27 @@ +Copyright (c) 2011, Yves Fischer + +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 REGENTS AND 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/Network/EBus/Layer2.hs b/Network/EBus/Layer2.hs new file mode 100644 index 0000000..496e9b1 --- /dev/null +++ b/Network/EBus/Layer2.hs @@ -0,0 +1,162 @@ +import Control.Applicative +import Data.Attoparsec +import Data.Attoparsec.Enumerator (iterParser) +import Data.Attoparsec.Combinator as C +import Data.ByteString (ByteString) +import Data.Enumerator +import Data.Enumerator.Binary (enumHandle) +import Data.Word (Word8) +import System.IO (hSetBinaryMode,stdin) + +-- ebus :: Parser EbusPacket +-- ebus = do{ skipMany1 $ char '\xaa' +-- ; source <- anyChar +-- ; destination <- anyChar +-- ; primaryCommand <- anyChar +-- ; secondaryCommand <- anyChar +-- ; payloadLength <- anyChar +-- ; payload <- count (fromEnum payloadLength) ebusPayload +-- ; followup <- +-- if destination == '\xfe' then +-- -- Broadcast - no further data +-- do{ crc <- anyChar +-- ; syn <- char '\xaa' +-- ; return "broadcast" +-- <|> fail "Failed to parse Broadcast Packet" +-- } +-- else +-- try( -- Master-Master - no further data +-- do{ crc <- anyChar +-- ; ack <- char '\x00' -- ACK OK +-- ; syn <- char '\xaa' +-- ; return "master-master" +-- }) +-- <|> +-- try( -- Master Slave +-- do{ crc <- anyChar +-- ; ack <- char '\x00' +-- ; payloadSlaveLength <- anyChar +-- ; payloadSlave <- count (fromEnum payloadSlaveLength) ebusPayload +-- ; crcSlave <- anyChar +-- ; ackSlave <- char '\x00' +-- ; synSlave <- char '\xaa' +-- ; return "master-slave" +-- }) +-- <|> fail "Failed to parse Master-Master/Master-Slave Packet" +-- ; return $ EbusPacket +-- source destination +-- primaryCommand secondaryCommand +-- payloadLength followup [] +-- } + + +-- | Ebus Layer2 Constants +ebusConstant :: String -> Word8 +ebusConstant "SYN" = 0xaa +ebusConstant "ACK" = 0x00 +ebusConstant "BROADCAST" = 0xff +ebusConstant "ESCAPE" = 0xa9 +ebusConstant "ESCAPE_ESCAPE" = 0x00 +ebusConstant "ESCAPE_SYN" = 0x01 +ebusConstant _ = 0x00 + +-- | Ebus Packet Types +data EbusType = EbusBroadcast + | EbusMasterMaster + | EbusMasterSlave + deriving (Show) + +-- | Ebus Packet representation +data EbusPacket = EbusPacket { + ebusPacketType :: EbusType, + ebusPacketSource :: Word8, + ebusPacketDestination :: Word8, + ebusPacketPrimaryCommand :: Word8, + ebusPacketSecondaryCommand :: Word8, + ebusPacketPayloadLength :: Word8, + ebusPacketPayload :: [Word8], + ebusPacketPayloadSlave :: Maybe [Word8] + } deriving (Show) + +parserPayload :: Parser Word8 +parserPayload = do{ word8 $ ebusConstant "ESCAPE" + ; word8 $ ebusConstant "ESCAPE_ESCAPE" + ; return $ ebusConstant "ESCAPE"} + <|> + do{ word8 $ ebusConstant "ESCAPE" + ; word8 $ ebusConstant "ESCAPE_SYN" + ; return $ ebusConstant "SYN"} + <|> + anyWord8; + +parser :: Parser EbusPacket +parser = do{ + C.skipMany $ word8 $ ebusConstant "SYN" + ; source <- anyWord8 + ; destination <- anyWord8 + ; primaryCommand <- anyWord8 + ; secondaryCommand <- anyWord8 + ; payloadLength <- anyWord8 + ; payload <- C.count (fromIntegral payloadLength) parserPayload + ; followup <- + if destination == 0xfe then + -- Broadcast + do{ crc <- anyWord8 + ; {- syn -} word8 $ ebusConstant "SYN" + ; return (EbusBroadcast, crc, Nothing)} + <|> + fail "Failed to parse Broadcast Paket" + else + -- Master-Master + try( + do{ crc <- anyWord8 + ; {- ack -} word8 $ ebusConstant "ACK" + ; {- syn -} word8 $ ebusConstant "SYN" + ; return (EbusMasterMaster, crc, Nothing)}) + <|> + -- Master Slave + try( + do{ crc <- anyWord8 + ; {- ack -} word8 $ ebusConstant "ACK" + ; payloadSlaveLength <- anyWord8 + ; payloadSlave <- C.count (fromIntegral payloadSlaveLength) parserPayload + ; crcSlave <- anyWord8 + ; {- ackSlave -} word8 $ ebusConstant "ACK" + ; {- synSlave -} word8 $ ebusConstant "SYN" + ; return (EbusMasterSlave, crc, (Just (payloadSlave, crcSlave)))}) + <|> + fail "Failed to parse Master-Master/Master-Slave Packet" + ; do { + if True then --CHECK CRC + return $ EbusPacket EbusMasterMaster source destination primaryCommand secondaryCommand payloadLength payload (Just []) + else + fail "CRC Check failed"} + <|> fail "Failed to parse packet" + } + +main = do + -- * Select binary mode (True) or text mode (False) on a open handle. (See also openBinaryFile.) + hSetBinaryMode stdin True + -- * run + -- Run an iteratee until it finishes, and return either the final value (if it succeeded) or the error (if it failed). + -- * run_ + -- Like run, except errors are converted to exceptions and thrown. Primarily useful for small scripts or other simple cases. + + maybePacket <- run( enumSource $$ runParser ) + case maybePacket of + Right result -> print result + Left error -> print error + + maybePacket <- run( enumSource $$ runParser ) + case maybePacket of + Right result -> print result + Left error -> print error + + +enumSource :: Enumerator ByteString IO a +enumSource = enumHandle 1 stdin + +runParser :: Iteratee ByteString IO EbusPacket +runParser = do + p <- iterParser parser + return p @@ -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 diff --git a/ebus.cabal b/ebus.cabal new file mode 100644 index 0000000..0a160f7 --- /dev/null +++ b/ebus.cabal @@ -0,0 +1,47 @@ +Name: ebus +Version: 0.1 +Synopsis: eBus Reader Library +Description: Library for parsing eBus datapackets +License: BSD3 +Stability: alpha +License-file: LICENSE +Author: Yves Fischer +Category: Network +Maintainer: Yves Fischer <yvesf-haskell@xapek.org> +Build-Type: Simple +Homepage: http://www.example.com +Cabal-Version: >=1.2 + + +-- Extra-source-files: examples/ExampleConsumer.hs, +-- examples/ExampleProducer.hs + +-- Source-Repository head +-- Type: git +-- Location: git://github.com/NicolasT/binary-protocol-zmq.git +-- branch: master + +Library + Build-Depends: base >=4 && < 5, attoparsec >= 0.10.1.1, bytestring + GHC-Options: -Wall + Exposed-modules: Network.EBus.Layer2 +-- Other-modules: Network.AMQP.Generated, Network.AMQP.Helpers, Network.AMQP.Protocol + +-- 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
\ No newline at end of file |