layer2 works somehow

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 @@
+*~
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..3de659c
--- /dev/null
+++ b/LICENSE
@@ -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
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
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