network-can (empty) → 0.1.0.0
raw patch · 24 files changed
+1605/−0 lines, 24 filesdep +QuickCheckdep +attoparsecdep +base
Dependencies added: QuickCheck, attoparsec, base, bytestring, containers, data-default-class, hspec, mtl, network, network-can, serialport, transformers, unliftio
Files
- CHANGELOG.md +9/−0
- LICENSE +30/−0
- README.md +29/−0
- app/CANBridge.hs +32/−0
- app/CANDump.hs +22/−0
- app/SLCANSerial.hs +45/−0
- app/SLCANUDP.hs +59/−0
- network-can.cabal +122/−0
- src/Network/CAN.hs +7/−0
- src/Network/CAN/Class.hs +39/−0
- src/Network/CAN/Types.hs +91/−0
- src/Network/SLCAN.hs +193/−0
- src/Network/SLCAN/Builder.hs +146/−0
- src/Network/SLCAN/Parser.hs +179/−0
- src/Network/SLCAN/Types.hs +129/−0
- src/Network/SocketCAN.hs +122/−0
- src/Network/SocketCAN/Bindings.hsc +79/−0
- src/Network/SocketCAN/Example.hs +41/−0
- src/Network/SocketCAN/LowLevel.hs +62/−0
- src/Network/SocketCAN/Translate.hs +77/−0
- test/SLCANSpec.hs +27/−0
- test/Samples.hs +39/−0
- test/SocketCANSpec.hs +25/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Version [0.1.0.0](https://github.com/DistRap/network-can/compare/d50564...0.1.0.0) (2025-05-19)++* Initial release++---++`network-can` uses [PVP Versioning][1].++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright sorki (c) 2024++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,29 @@+# network-can++[](https://github.com/DistRap/network-can/actions/workflows/ci.yaml)+[](https://hackage.haskell.org/package/network-can)++CAN bus networking using Linux SocketCAN or SLCAN backends.++## Usage++```haskell+import qualified Control.Monad+import qualified Control.Monad.IO.Class+import qualified Network.CAN+import qualified Network.SocketCAN++main :: IO ()+main = do+ Network.SocketCAN.runSocketCAN+ (Network.SocketCAN.mkCANInterface "vcan0")+ $ do+ Network.CAN.send+ $ Network.CAN.standardMessage+ 0x123+ [0xDE, 0xAD]++ Control.Monad.forever+ $ Network.CAN.recv+ >>= Control.Monad.IO.Class.liftIO . print+```
+ app/CANBridge.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE LambdaCase #-}+module Main where++import Control.Monad.Trans (MonadTrans(lift))+import Data.Default.Class (Default(def))+import Network.SLCAN (Transport(..))+import System.Hardware.Serialport (CommSpeed(..), SerialPortSettings(..))++import qualified Control.Monad+import qualified Network.CAN+import qualified Network.SocketCAN+import qualified Network.SLCAN+import qualified System.Hardware.Serialport+import qualified UnliftIO.Async++-- | Bridge vcan0 to slcan over /dev/can4discouart serial port+main :: IO ()+main = do+ h <- System.Hardware.Serialport.hOpenSerial+ "/dev/can4discouart"+ (System.Hardware.Serialport.defaultSerialSettings+ { commSpeed = CS115200 }+ )+ Network.SLCAN.runSLCAN (Transport_Handle h) def $ do+ Network.SocketCAN.runSocketCAN (Network.SocketCAN.mkCANInterface "vcan0") $ do+ UnliftIO.Async.race_+ (Control.Monad.forever+ $ Network.CAN.recv >>= lift . Network.CAN.send+ )+ (Control.Monad.forever+ $ lift Network.CAN.recv >>= Network.CAN.send+ )
+ app/CANDump.hs view
@@ -0,0 +1,22 @@+module Main where++import qualified Control.Monad+import qualified Control.Monad.IO.Class+import qualified Network.CAN+import qualified Network.SocketCAN++main :: IO ()+main = do+ Network.SocketCAN.runSocketCAN+ (Network.SocketCAN.mkCANInterface "vcan0")+ (Control.Monad.forever+ $ Network.CAN.recv+ >>= Control.Monad.IO.Class.liftIO . print+ )++-- needs Network.CAN.Pretty or Builder or smthing+-- that does the same ID formatting as SLCAN.Builder:78+-- a la+-- $ candump -e vcan0+-- vcan0 001237E5 [2] 4C EE+-- vcan0 7E5 [2] 4C EE
+ app/SLCANSerial.hs view
@@ -0,0 +1,45 @@+module Main where++import Control.Monad.IO.Class+import Data.Default.Class (Default(def))+import System.Hardware.Serialport (CommSpeed(..), SerialPortSettings(..))+import Network.CAN (MonadCAN)+import Network.SLCAN (Transport(..))++import qualified Control.Monad+import qualified Network.CAN+import qualified Network.SLCAN+import qualified System.Hardware.Serialport++main :: IO ()+main = do+ let+ port = "/dev/can4discouart"++ h <-+ System.Hardware.Serialport.hOpenSerial+ port+ (System.Hardware.Serialport.defaultSerialSettings+ { commSpeed = CS115200 }+ )++ Network.SLCAN.runSLCAN+ (Transport_Handle h)+ def+ act++act+ :: ( MonadCAN m+ , MonadIO m+ )+ => m ()+act = do+ Network.CAN.send+ $ Network.CAN.standardMessage+ -- vendorID SDO+ 0x601+ [0x40, 0x18, 0x10, 0x01, 0x0, 0x0, 0x0, 0x0]++ Control.Monad.forever+ $ Network.CAN.recv+ >>= Control.Monad.IO.Class.liftIO . print
+ app/SLCANUDP.hs view
@@ -0,0 +1,59 @@+module Main where++import Control.Monad.IO.Class+import Data.Default.Class (Default(def))+import Network.CAN (MonadCAN)+import Network.SLCAN (Transport(..))+import Network.Socket (AddrInfo(..), SocketType(Datagram))++import qualified Control.Monad+import qualified Network.CAN+import qualified Network.SLCAN+import qualified Network.Socket++main :: IO ()+main = do+ ourAddrinfos+ <- Network.Socket.getAddrInfo+ Nothing+ Nothing+ (Just "1337")++ targetAddrinfos+ <- Network.Socket.getAddrInfo+ Nothing+ Nothing+ (Just "1338")++ case (ourAddrinfos, targetAddrinfos) of+ (ourAddrinfo:_, targetAddrinfo:_) -> do+ sock <- Network.Socket.socket+ (addrFamily ourAddrinfo)+ Datagram+ Network.Socket.defaultProtocol++ Network.Socket.bind+ sock+ (addrAddress ourAddrinfo)++ Network.SLCAN.runSLCAN+ (Transport_UDP sock (addrAddress targetAddrinfo))+ def+ act++ (_, _) -> error "getAddrInfo fail"++act+ :: ( MonadCAN m+ , MonadIO m+ )+ => m ()+act = do+ Network.CAN.send+ $ Network.CAN.standardMessage+ 0x7E5+ [0x4C]++ Control.Monad.forever+ $ Network.CAN.recv+ >>= Control.Monad.IO.Class.liftIO . print
+ network-can.cabal view
@@ -0,0 +1,122 @@+cabal-version: 2.2+name: network-can+version: 0.1.0.0+synopsis: CAN bus networking+description: Talk to CAN buses using Linux SocketCAN and SLCAN+homepage: https://github.com/DistRap/network-can+license: BSD-3-Clause+license-file: LICENSE+author: sorki+maintainer: srk@48.io+copyright: 2024 sorki+category: Network+build-type: Simple++extra-source-files:+ LICENSE+ README.md++extra-doc-files:+ CHANGELOG.md++flag build-apps+ default:+ False+ description:+ Build example applications++library+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Network.CAN+ Network.CAN.Class+ Network.CAN.Types+ Network.SLCAN+ Network.SLCAN.Builder+ Network.SLCAN.Parser+ Network.SLCAN.Types+ Network.SocketCAN+ Network.SocketCAN.Bindings+ Network.SocketCAN.Example+ Network.SocketCAN.LowLevel+ Network.SocketCAN.Translate++ build-depends: base >= 4.7 && < 5+ , attoparsec >= 0.14+ , bytestring+ , containers+ , data-default-class+ , mtl+ , network >= 3.1+ , QuickCheck+ , transformers+ , unliftio++ build-tool-depends: hsc2hs:hsc2hs+ default-language: Haskell2010++test-suite pure+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Samples+ SLCANSpec+ SocketCANSpec+ build-tool-depends: hspec-discover:hspec-discover+ build-depends: base >= 4.7 && < 5+ , hspec+ , network-can+ default-language: Haskell2010++executable hcandump+ if !flag(build-apps)+ buildable: False+ build-depends: base >=4.7 && <5+ , network-can+ default-language: Haskell2010+ main-is: CANDump.hs+ hs-source-dirs: app+ ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N"++executable hcanbridge+ if !flag(build-apps)+ buildable: False+ build-depends: base >=4.7 && <5+ , network-can+ , data-default-class+ , mtl+ , serialport >= 0.5.5+ , unliftio+ default-language: Haskell2010+ main-is: CANBridge.hs+ hs-source-dirs: app+ ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N"++executable hslcanserial+ if !flag(build-apps)+ buildable: False+ build-depends: base >=4.7 && <5+ , network-can+ , data-default-class+ , serialport >= 0.5.5+ default-language: Haskell2010+ main-is: SLCANSerial.hs+ hs-source-dirs: app+ ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N"++executable hslcanudp+ if !flag(build-apps)+ buildable: False+ build-depends: base >=4.7 && <5+ , network+ , network-can+ , data-default-class+ default-language: Haskell2010+ main-is: SLCANUDP.hs+ hs-source-dirs: app+ ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N"++source-repository head+ type: git+ location: https://github.com/DistRap/network-can
+ src/Network/CAN.hs view
@@ -0,0 +1,7 @@+module Network.CAN+ ( module Network.CAN.Class+ , module Network.CAN.Types+ ) where++import Network.CAN.Class+import Network.CAN.Types
+ src/Network/CAN/Class.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators #-}+module Network.CAN.Class+ ( MonadCAN(..)+ ) where++import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.State (StateT)+import Network.CAN.Types (CANMessage(..))++class Monad m => MonadCAN m where++ send :: CANMessage -> m ()+ default send+ :: ( MonadTrans t+ , MonadCAN m'+ , m ~ t m'+ )+ => CANMessage+ -> m ()+ send = lift . send++ recv :: m CANMessage+ default recv+ :: ( MonadTrans t+ , MonadCAN m'+ , m ~ t m'+ )+ => m CANMessage+ recv = lift recv++instance MonadCAN m => MonadCAN (ExceptT e m)+instance MonadCAN m => MonadCAN (ReaderT r m)+instance MonadCAN m => MonadCAN (StateT s m)
+ src/Network/CAN/Types.hs view
@@ -0,0 +1,91 @@+module Network.CAN.Types+ (+ -- * Arbitration+ CANArbitrationField(..)+ , standardID+ , extendedID+ , setRTR+ -- * Message+ , CANMessage(..)+ , standardMessage+ ) where++import Data.Word (Word8, Word16, Word32)+import Test.QuickCheck (Arbitrary(..))++import qualified Test.QuickCheck++-- * Arbitration++data CANArbitrationField = CANArbitrationField+ { canArbitrationFieldID :: Word32 -- ^ CAN ID+ , canArbitrationFieldExtended :: Bool -- ^ Extended CAN ID+ , canArbitrationFieldRTR :: Bool -- ^ Remote transmission request+ } deriving (Eq, Ord, Show)++instance Arbitrary CANArbitrationField where+ arbitrary = do+ rtr <- arbitrary+ ext <- arbitrary+ cid <-+ if ext+ then Test.QuickCheck.choose (0, 0x3FFFFFFF)+ else Test.QuickCheck.choose (0, 0xFFF)+ pure+ CANArbitrationField+ { canArbitrationFieldID = cid+ , canArbitrationFieldExtended = ext+ , canArbitrationFieldRTR = rtr+ }++-- | Construct standard CAN ID (11 bits)+standardID+ :: Word16+ -> CANArbitrationField+standardID cid = CANArbitrationField+ { canArbitrationFieldID = fromIntegral cid+ , canArbitrationFieldExtended = False+ , canArbitrationFieldRTR = False+ }++-- | Construct extended CAN ID (29 bits)+extendedID+ :: Word32+ -> CANArbitrationField+extendedID cid = CANArbitrationField+ { canArbitrationFieldID = cid+ , canArbitrationFieldExtended = True+ , canArbitrationFieldRTR = False+ }++-- | Set remote transmission request bit+setRTR+ :: CANArbitrationField+ -> CANArbitrationField+setRTR cf = cf { canArbitrationFieldRTR = True }++data CANMessage = CANMessage+ { canMessageArbitrationField :: CANArbitrationField+ , canMessageData :: [Word8]+ } deriving (Eq, Ord, Show)++instance Arbitrary CANMessage where+ arbitrary = do+ arb <- arbitrary+ len <- Test.QuickCheck.choose (0, 8)+ dat <- Test.QuickCheck.vectorOf len arbitrary+ pure+ CANMessage+ { canMessageArbitrationField = arb+ , canMessageData = dat+ }++-- | Create standard CAN message+standardMessage+ :: Word16+ -> [Word8]+ -> CANMessage+standardMessage cid cdata = CANMessage+ { canMessageArbitrationField = standardID cid+ , canMessageData = cdata+ }
+ src/Network/SLCAN.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+module Network.SLCAN+ ( Transport(..)+ , withSLCANTransport+ , sendSLCANMessage+ , sendSLCANControl+ , recvSLCANMessage+ , sendCANMessage+ , module Network.SLCAN.Types+ , SLCANT(..)+ , SLCANException(..)+ , runSLCAN+ ) where++import Control.Exception (Exception)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (MonadReader, ask)+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Trans.Reader (ReaderT(..))++import Network.Socket (Socket, SockAddr)+import Network.CAN (CANMessage, MonadCAN(..))+import Network.SLCAN.Types+import System.IO (Handle)+import UnliftIO (MonadUnliftIO)++import qualified Control.Monad+import qualified Control.Exception+import qualified Data.ByteString+import qualified Data.ByteString.Char8+import qualified System.IO+import qualified Network.SLCAN.Builder+import qualified Network.SLCAN.Parser+import qualified Network.Socket.ByteString+import qualified UnliftIO++data Transport =+ Transport_Handle Handle+ | Transport_UDP Socket SockAddr++withSLCANTransport+ :: Transport+ -> SLCANConfig+ -> (Transport -> IO a)+ -> IO a+withSLCANTransport transport SLCANConfig{..} act = do+ let sendC = sendSLCANControl transport+ Control.Exception.finally+ (do+ sendC SLCANControl_Close+ sendC (SLCANControl_Bitrate slCANConfigBitrate)+ Control.Monad.when+ slCANConfigResetErrors+ (sendC SLCANControl_ResetErrors)+ sendC+ (if slCANConfigListenOnly+ then SLCANControl_ListenOnly+ else SLCANControl_Open+ )++ act transport+ )+ (sendC SLCANControl_Close)++sendSLCANMessage+ :: Transport+ -> SLCANMessage+ -> IO ()+sendSLCANMessage (Transport_Handle handle) msg = do+ Control.Monad.void+ $ Data.ByteString.hPutStr+ handle+ $ Network.SLCAN.Builder.buildSLCANMessage+ msg+ System.IO.hFlush handle+sendSLCANMessage (Transport_UDP socket target) msg = do+ Network.Socket.ByteString.sendAllTo+ socket+ (Network.SLCAN.Builder.buildSLCANMessage msg)+ target++sendSLCANControl+ :: Transport+ -> SLCANControl+ -> IO ()+sendSLCANControl t =+ sendSLCANMessage t+ . SLCANMessage_Control++recvSLCANMessage+ :: Transport+ -> IO (Either String SLCANMessage)+recvSLCANMessage (Transport_Handle handle) = do+ Network.SLCAN.Parser.parseSLCANMessage+ <$> hGetTillCR handle++ where+ hGetTillCR h = do+ msg <-+ Data.ByteString.hGetSome+ h+ 1024+ if Data.ByteString.Char8.last msg == '\r'+ then pure msg+ else hGetTillCR h >>= pure . (msg <>)++recvSLCANMessage (Transport_UDP socket _target) = do+ Network.SLCAN.Parser.parseSLCANMessage+ <$> sockGetTillCR socket+ where+ sockGetTillCR s = do+ (msg, _source) <-+ Network.Socket.ByteString.recvFrom+ s+ 1024+ if Data.ByteString.Char8.last msg == '\r'+ then pure msg+ else sockGetTillCR s >>= pure . (msg <>)++sendCANMessage+ :: Transport+ -> CANMessage+ -> IO ()+sendCANMessage t =+ sendSLCANMessage t+ . SLCANMessage_Data++newtype SLCANT m a = SLCANT+ { _unSLCANT :: ReaderT Transport m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadReader Transport+ , MonadIO+ , MonadUnliftIO+ )++instance MonadTrans SLCANT where+ lift = SLCANT . lift++-- | Run SLCANT transformer+runSLCANT+ :: Monad m+ => Transport+ -> SLCANT m a+ -> m a+runSLCANT t =+ (`runReaderT` t)+ . _unSLCANT++data SLCANException = SLCANException_ParseError String+ deriving Show++instance Exception SLCANException++runSLCAN+ :: ( MonadIO m+ , MonadUnliftIO m+ )+ => Transport+ -> SLCANConfig+ -> SLCANT m a+ -> m a+runSLCAN transport config act = do+ UnliftIO.withRunInIO $ \runInIO ->+ withSLCANTransport+ transport+ config+ (\t -> runInIO (runSLCANT t act))++instance MonadIO m => MonadCAN (SLCANT m) where+ send cm = do+ ask >>= liftIO . flip sendCANMessage cm+ recv = do+ transport <- ask+ liftIO+ (recvSLCANMessage transport)+ >>= \case+ Left e ->+ UnliftIO.throwIO $ SLCANException_ParseError e+ Right (SLCANMessage_Data cm) ->+ pure cm+ Right _other ->+ -- TODO: do something with+ -- SLCANMessage_Error+ -- and SLCANMessage_State+ -- like allow registering handlers for these+ -- or throwIO on _Error one+ recv
+ src/Network/SLCAN/Builder.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Network.SLCAN.Builder+ ( buildSLCANMessage+ ) where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import Data.Set (Set)+import Network.CAN.Types (CANArbitrationField(..), CANMessage(..))+import Network.SLCAN.Types+ ( SLCANMessage(..)+ , SLCANControl(..)+ , SLCANState(..)+ , SLCANCounters(..)+ , SLCANError(..)+ )+import qualified Data.Bits+import qualified Data.Set+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Builder++slCANBuilder+ :: SLCANMessage+ -> Builder+slCANBuilder slcanMsg =+ case slcanMsg of+ SLCANMessage_Control ctrlMsg -> slCANControlBuilder ctrlMsg+ SLCANMessage_Data canMsg -> slCANDataBuilder canMsg+ SLCANMessage_State state counters -> slCANStateBuilder state counters+ SLCANMessage_Error errs -> slCANErrorBuilder errs+ <> Data.ByteString.Builder.char7 '\r'++slCANControlBuilder+ :: SLCANControl+ -> Builder+slCANControlBuilder SLCANControl_Open =+ Data.ByteString.Builder.char7 'O'+slCANControlBuilder SLCANControl_Close =+ Data.ByteString.Builder.char7 'C'+slCANControlBuilder (SLCANControl_Bitrate bitrate) =+ Data.ByteString.Builder.char7 'S'+ <> Data.ByteString.Builder.intDec+ (fromEnum bitrate)+slCANControlBuilder SLCANControl_ResetErrors =+ Data.ByteString.Builder.char7 'F'+slCANControlBuilder SLCANControl_ListenOnly =+ Data.ByteString.Builder.char7 'L'++slCANDataBuilder+ :: CANMessage+ -> Builder+slCANDataBuilder CANMessage{..} =+ arbitrationId canMessageArbitrationField+ <> Data.ByteString.Builder.word8Hex+ (fromIntegral $ length canMessageData)+ <> mconcat+ (map+ Data.ByteString.Builder.word8HexFixed+ canMessageData+ )++arbitrationId+ :: CANArbitrationField+ -> Builder+arbitrationId CANArbitrationField{..} =+ Data.ByteString.Builder.char7+ (case ( canArbitrationFieldExtended+ , canArbitrationFieldRTR+ )+ of+ (False, False) -> 't'+ (False, True) -> 'r'+ (True, False) -> 'T'+ (True, True) -> 'R'+ )+ <> (if canArbitrationFieldExtended+ then Data.ByteString.Builder.word32HexFixed+ else+ (\word11 ->+ Data.ByteString.Builder.word8Hex+ (fromIntegral (word11 `Data.Bits.shiftR` 8))+ <> Data.ByteString.Builder.word8HexFixed+ (fromIntegral word11)+ )+ )+ canArbitrationFieldID++slCANStateBuilder+ :: SLCANState+ -> SLCANCounters+ -> Builder+slCANStateBuilder state SLCANCounters{..} =+ Data.ByteString.Builder.char7 's'+ <> Data.ByteString.Builder.char7+ (case state of+ SLCANState_Active -> 'a'+ SLCANState_Warning -> 'w'+ SLCANState_Passive -> 'p'+ SLCANState_BusOff -> 'b'+ )+ <> word16Dec3 slCANCountersTxErrors+ <> word16Dec3 slCANCountersRxErrors+ where+ -- encode as 3 bytes (maximum of 999 and zero padded)+ word16Dec3 x =+ (case x of+ _ | x < 10 -> Data.ByteString.Builder.string7 "00"+ _ | x < 100 -> Data.ByteString.Builder.char7 '0'+ _ | otherwise -> mempty+ )+ <> Data.ByteString.Builder.word16Dec+ (min 999 x)++slCANErrorBuilder+ :: Set SLCANError+ -> Builder+slCANErrorBuilder errs =+ Data.ByteString.Builder.char7 'e'+ <> Data.ByteString.Builder.word8Hex+ (fromIntegral $ Data.Set.size errs)+ <> mconcat+ (map+ ( Data.ByteString.Builder.char7+ . \case+ SLCANError_Ack -> 'a'+ SLCANError_Bit0 -> 'b'+ SLCANError_Bit1 -> 'B'+ SLCANError_CRC -> 'c'+ SLCANError_Form -> 'f'+ SLCANError_RxOverrun -> 'o'+ SLCANError_TxOverrun -> 'O'+ SLCANError_Stuff -> 's'+ )+ $ Data.Set.toList+ errs+ )++buildSLCANMessage+ :: SLCANMessage+ -> ByteString+buildSLCANMessage =+ Data.ByteString.Lazy.toStrict+ . Data.ByteString.Builder.toLazyByteString+ . slCANBuilder
+ src/Network/SLCAN/Parser.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Network.SLCAN.Parser+ ( parseSLCANMessage+ ) where++import Data.Attoparsec.ByteString.Char8 (Parser)+import Data.Bits (Bits)+import Data.ByteString (ByteString)+import Data.Set (Set)+import Control.Applicative ((<|>))+import Network.CAN.Types (CANArbitrationField(..), CANMessage(..))+import Network.SLCAN.Types+ ( SLCANMessage(..)+ , SLCANControl(..)+ , SLCANBitrate+ , SLCANState(..)+ , SLCANCounters(..)+ , SLCANError(..)+ )++import qualified Data.Attoparsec.ByteString.Char8+import qualified Data.Set+import qualified Control.Monad++slCANParser :: Parser SLCANMessage+slCANParser = do+ Data.Attoparsec.ByteString.Char8.peekChar'+ >>= \case+ c | Data.Attoparsec.ByteString.Char8.inClass "OCSFL" c ->+ (SLCANMessage_Control <$> slCANControlParser)+ c | Data.Attoparsec.ByteString.Char8.inClass "tTrR" c ->+ (SLCANMessage_Data <$> slCANDataParser)+ 's' ->+ Data.Attoparsec.ByteString.Char8.char 's'+ *> (SLCANMessage_State <$> slCANStateParser <*> slCANCountersParser)+ 'e' ->+ Data.Attoparsec.ByteString.Char8.char 'e'+ *> (SLCANMessage_Error <$> slCANErrorParser)+ c | otherwise ->+ fail $ "Unknown SLCAN message type: " <> show c+ <* Data.Attoparsec.ByteString.Char8.char '\r'++slCANControlParser :: Parser SLCANControl+slCANControlParser = do+ Data.Attoparsec.ByteString.Char8.anyChar+ >>= \case+ 'O' -> pure SLCANControl_Open+ 'C' -> pure SLCANControl_Close+ 'S' -> (SLCANControl_Bitrate <$> bitrate)+ 'F' -> pure SLCANControl_ResetErrors+ 'L' -> pure SLCANControl_ListenOnly+ c -> fail $ "Unknown control message char: " <> show c+ where+ bitrate = do+ d <- Data.Attoparsec.ByteString.Char8.decimal+ if d > fromEnum (maxBound :: SLCANBitrate)+ then fail+ $ "Bitrate out of bounds, got "+ <> show d+ <> "but maximum is "+ <> show (fromEnum (maxBound :: SLCANBitrate))+ <> " ("+ <> show (maxBound :: SLCANBitrate)+ <> ")"+ else pure $ toEnum d++slCANDataParser :: Parser CANMessage+slCANDataParser = do+ canMessageArbitrationField <- arbitrationId+ msgLen <- hexadecimalWithLength 1+ canMessageData <-+ Control.Monad.replicateM msgLen (hexadecimalWithLength 2)+ pure CANMessage{..}++-- | Parse arbitration ID+-- * t => 11 bit data frame+-- * r => 11 bit RTR frame+-- * T => 29 bit data frame+-- * R => 29 bit RTR frame+arbitrationId :: Parser CANArbitrationField+arbitrationId = do+ Data.Attoparsec.ByteString.Char8.char 't' *> stdID False+ <|> Data.Attoparsec.ByteString.Char8.char 'r' *> stdID True+ <|> Data.Attoparsec.ByteString.Char8.char 'T' *> extID False+ <|> Data.Attoparsec.ByteString.Char8.char 'R' *> extID True++stdID+ :: Bool+ -> Parser CANArbitrationField+stdID isRTR = do+ canArbitrationFieldID+ <- hexadecimalWithLength 3++ let+ canArbitrationFieldExtended = False+ canArbitrationFieldRTR = isRTR++ pure CANArbitrationField{..}++extID+ :: Bool+ -> Parser CANArbitrationField+extID isRTR = do+ canArbitrationFieldID+ <- hexadecimalWithLength 8++ let+ canArbitrationFieldExtended = True+ canArbitrationFieldRTR = isRTR++ pure CANArbitrationField{..}++hexadecimalWithLength+ :: ( Bits a+ , Integral a+ )+ => Int+ -> Parser a+hexadecimalWithLength len =+ Data.Attoparsec.ByteString.Char8.take len+ >>=+ either+ fail+ pure+ . Data.Attoparsec.ByteString.Char8.parseOnly+ Data.Attoparsec.ByteString.Char8.hexadecimal++slCANStateParser :: Parser SLCANState+slCANStateParser =+ Data.Attoparsec.ByteString.Char8.anyChar+ >>= \case+ 'a' -> pure SLCANState_Active+ 'w' -> pure SLCANState_Warning+ 'p' -> pure SLCANState_Passive+ 'b' -> pure SLCANState_BusOff+ c -> fail $ "Unknown state char: " <> show c++slCANCountersParser :: Parser SLCANCounters+slCANCountersParser = do+ slCANCountersTxErrors <- decimal3+ slCANCountersRxErrors <- decimal3+ pure $ SLCANCounters{..}+ where+ decimal3 =+ Data.Attoparsec.ByteString.Char8.take 3+ >>=+ either+ fail+ pure+ . Data.Attoparsec.ByteString.Char8.parseOnly+ Data.Attoparsec.ByteString.Char8.decimal++slCANErrorParser :: Parser (Set SLCANError)+slCANErrorParser = do+ len <- hexadecimalWithLength 1+ Data.Set.fromList+ <$> Control.Monad.replicateM len errorChar+ where+ errorChar =+ Data.Attoparsec.ByteString.Char8.anyChar+ >>= \case+ 'a' -> pure SLCANError_Ack+ 'b' -> pure SLCANError_Bit0+ 'B' -> pure SLCANError_Bit1+ 'c' -> pure SLCANError_CRC+ 'f' -> pure SLCANError_Form+ 'o' -> pure SLCANError_RxOverrun+ 'O' -> pure SLCANError_TxOverrun+ 's' -> pure SLCANError_Stuff+ c -> fail $ "Unknown error char: " <> show c++parseSLCANMessage+ :: ByteString+ -> Either String SLCANMessage+parseSLCANMessage =+ Data.Attoparsec.ByteString.Char8.parseOnly+ slCANParser
+ src/Network/SLCAN/Types.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE NumericUnderscores #-}+module Network.SLCAN.Types+ ( SLCANMessage(..)+ , SLCANControl(..)+ , SLCANBitrate(..)+ , numericBitrate+ , SLCANState(..)+ , SLCANCounters(..)+ , SLCANError(..)+ , SLCANConfig(..)+ ) where++import Data.Default.Class (Default(def))+import Data.Set (Set)+import Data.Word (Word16)+import Network.CAN.Types (CANMessage)+import Test.QuickCheck (Arbitrary(..))++import qualified Test.QuickCheck++data SLCANMessage+ = SLCANMessage_Control SLCANControl+ | SLCANMessage_Data CANMessage+ | SLCANMessage_State SLCANState SLCANCounters+ | SLCANMessage_Error (Set SLCANError)+ deriving (Eq, Ord, Show)++instance Arbitrary SLCANMessage where+ arbitrary = Test.QuickCheck.oneof+ [ SLCANMessage_Control <$> arbitrary+ , SLCANMessage_Data <$> arbitrary+ , SLCANMessage_State <$> arbitrary <*> arbitrary+ , SLCANMessage_Error <$> arbitrary+ ]++data SLCANControl+ = SLCANControl_Open+ | SLCANControl_Close+ | SLCANControl_Bitrate SLCANBitrate+ | SLCANControl_ResetErrors+ | SLCANControl_ListenOnly+ deriving (Eq, Ord, Show)++instance Arbitrary SLCANControl where+ arbitrary = Test.QuickCheck.oneof+ [ pure SLCANControl_Open+ , pure SLCANControl_Close+ , SLCANControl_Bitrate <$> arbitrary+ , pure SLCANControl_ResetErrors+ , pure SLCANControl_ListenOnly+ ]++data SLCANBitrate+ = SLCANBitrate_10K+ | SLCANBitrate_20K+ | SLCANBitrate_50K+ | SLCANBitrate_100K+ | SLCANBitrate_125K+ | SLCANBitrate_250K+ | SLCANBitrate_500K+ | SLCANBitrate_800K+ | SLCANBitrate_1M+ deriving (Bounded, Eq, Enum, Ord, Show)++instance Arbitrary SLCANBitrate where+ arbitrary = Test.QuickCheck.arbitraryBoundedEnum++instance Default SLCANBitrate where+ def = SLCANBitrate_1M++numericBitrate :: SLCANBitrate -> Int+numericBitrate SLCANBitrate_10K = 10_000+numericBitrate SLCANBitrate_20K = 20_000+numericBitrate SLCANBitrate_50K = 50_000+numericBitrate SLCANBitrate_100K = 100_000+numericBitrate SLCANBitrate_125K = 125_000+numericBitrate SLCANBitrate_250K = 250_000+numericBitrate SLCANBitrate_500K = 500_000+numericBitrate SLCANBitrate_800K = 800_000+numericBitrate SLCANBitrate_1M = 1_000_000++data SLCANState+ = SLCANState_Active+ | SLCANState_Warning+ | SLCANState_Passive+ | SLCANState_BusOff+ deriving (Bounded, Eq, Enum, Ord, Show)++instance Arbitrary SLCANState where+ arbitrary = Test.QuickCheck.arbitraryBoundedEnum++data SLCANCounters = SLCANCounters+ { slCANCountersRxErrors :: Word16+ , slCANCountersTxErrors :: Word16+ } deriving (Eq, Ord, Show)++instance Arbitrary SLCANCounters where+ arbitrary =+ SLCANCounters+ <$> Test.QuickCheck.choose (0, 999)+ <*> Test.QuickCheck.choose (0, 999)++data SLCANError+ = SLCANError_Ack+ | SLCANError_Bit0+ | SLCANError_Bit1+ | SLCANError_CRC+ | SLCANError_Form+ | SLCANError_RxOverrun+ | SLCANError_TxOverrun+ | SLCANError_Stuff+ deriving (Bounded, Eq, Enum, Ord, Show)++instance Arbitrary SLCANError where+ arbitrary = Test.QuickCheck.arbitraryBoundedEnum++data SLCANConfig = SLCANConfig+ { slCANConfigBitrate :: SLCANBitrate+ , slCANConfigResetErrors :: Bool+ , slCANConfigListenOnly :: Bool+ } deriving (Eq, Ord, Show)++instance Default SLCANConfig where+ def =+ SLCANConfig+ { slCANConfigBitrate = def+ , slCANConfigResetErrors = False+ , slCANConfigListenOnly = False+ }
+ src/Network/SocketCAN.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.SocketCAN+ ( withSocketCAN+ , sendCANMessage+ , recvCANMessage+ , Network.Socket.ifNameToIndex+ , SocketCANT+ , CANInterface+ , mkCANInterface+ , NoSuchInterface(..)+ , runSocketCAN+ ) where++import Network.CAN (CANMessage, MonadCAN(..))+import Network.Socket (Socket)+import Network.SocketCAN.Bindings (SockAddrCAN(..))++import Control.Monad.Reader (MonadReader, ask)+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import UnliftIO++import qualified Control.Exception+import qualified Network.Socket (ifNameToIndex)+import qualified Network.SocketCAN.LowLevel+import qualified Network.SocketCAN.Translate++withSocketCAN+ :: Int+ -> (Socket -> IO a)+ -> IO a+withSocketCAN ifaceIdx act = do+ Control.Exception.bracket+ Network.SocketCAN.LowLevel.socket+ Network.SocketCAN.LowLevel.close+ (\canSock -> do+ Network.SocketCAN.LowLevel.bind+ canSock+ $ Network.SocketCAN.Bindings.SockAddrCAN+ $ fromIntegral ifaceIdx+ act canSock+ )++sendCANMessage+ :: Socket+ -> CANMessage+ -> IO ()+sendCANMessage canSock cm =+ Network.SocketCAN.LowLevel.send+ canSock+ (Network.SocketCAN.Translate.toSocketCANFrame cm)++recvCANMessage+ :: Socket+ -> IO CANMessage+recvCANMessage canSock =+ Network.SocketCAN.LowLevel.recv canSock+ >>= pure . Network.SocketCAN.Translate.fromSocketCANFrame++newtype SocketCANT m a = SocketCANT+ { _unSocketCANT :: ReaderT Socket m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadReader Socket+ , MonadIO+ , MonadUnliftIO+ )++instance MonadTrans SocketCANT where+ lift = SocketCANT . lift++-- | Run SocketCANT transformer+runSocketCANT+ :: Monad m+ => Socket+ -> SocketCANT m a+ -> m a+runSocketCANT sock =+ (`runReaderT` sock)+ . _unSocketCANT++newtype CANInterface = CANInterface+ { unCANInterface :: String }+ deriving Eq++instance Show CANInterface where+ show = unCANInterface++mkCANInterface :: String -> CANInterface+mkCANInterface = CANInterface++data NoSuchInterface = NoSuchInterface+ deriving Show++instance Exception NoSuchInterface++runSocketCAN+ :: ( MonadIO m+ , MonadUnliftIO m+ )+ => CANInterface+ -> SocketCANT m a+ -> m a+runSocketCAN interface act = do+ mIdx <-+ liftIO+ $ Network.Socket.ifNameToIndex (unCANInterface interface)++ case mIdx of+ Nothing -> throwIO NoSuchInterface+ Just idx -> withRunInIO $ \runInIO ->+ withSocketCAN idx (\s -> runInIO (runSocketCANT s act))++instance MonadIO m => MonadCAN (SocketCANT m) where+ send cm = do+ canSock <- ask+ liftIO $ sendCANMessage canSock cm+ recv = do+ canSock <- ask+ liftIO $ recvCANMessage canSock
+ src/Network/SocketCAN/Bindings.hsc view
@@ -0,0 +1,79 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.SocketCAN.Bindings+ (+ -- * Network package compatibility+ SockAddrCAN(..)+ , pattern CAN_RAW+ -- * SocketCAN bindings+ , SocketCANArbitrationField(..)+ , SocketCANFrame(..)+ ) where++import Data.Word (Word8, Word16, Word32)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (peekArray, pokeArray)+import Foreign.Ptr (plusPtr)+import Network.Socket.Address (SocketAddress(..))+import Network.Socket (ProtocolNumber)++#include <linux/can.h>+#include <sys/socket.h>++-- | CAN Socket type+newtype SockAddrCAN = SockAddrCAN Word32+ deriving (Eq, Ord)++-- Word16+type CSaFamily = (#type sa_family_t)++instance SocketAddress SockAddrCAN where+ sizeOfSocketAddress (SockAddrCAN _) =+ #const sizeof(struct sockaddr_can)+ peekSocketAddress sap = do+ ifidx <- (#peek struct sockaddr_can, can_ifindex) sap+ return (SockAddrCAN ifidx)+ pokeSocketAddress p (SockAddrCAN ifIndex) = do+ (#poke struct sockaddr_can, can_family) p ((#const AF_CAN) :: CSaFamily)+ (#poke struct sockaddr_can, can_ifindex) p ifIndex++-- | CAN RAW protocol family of PF_CAN+pattern CAN_RAW :: ProtocolNumber+pattern CAN_RAW = #const CAN_RAW++-- | SocketCAN Arbitration field (CAN ID including RTR, EFF, ERR bits)+newtype SocketCANArbitrationField =+ SocketCANArbitrationField { unSocketCANArbitrationField :: Word32 }+ deriving (Eq, Ord, Show, Storable)++data SocketCANFrame = SocketCANFrame+ { socketCANFrameArbitrationField :: SocketCANArbitrationField+ , socketCANFrameLength :: Word8+ , socketCANFrameData :: [Word8]+ } deriving Show++instance Storable SocketCANFrame where+ sizeOf ~_ = #const sizeof(struct can_frame)+ alignment ~_ = #alignment struct can_frame+ peek ptr = do+ socketCANFrameArbitrationField+ <- #{peek struct can_frame, can_id} ptr+ socketCANFrameLength+ <- #{peek struct can_frame, len} ptr+ socketCANFrameData <-+ peekArray+ (fromIntegral socketCANFrameLength)+ (#{ptr struct can_frame, data} ptr)+ pure+ $ SocketCANFrame{..}+ poke ptr SocketCANFrame{..} = do+ #{poke struct can_frame, can_id}+ ptr+ socketCANFrameArbitrationField+ #{poke struct can_frame, len}+ ptr+ socketCANFrameLength+ pokeArray+ (#{ptr struct can_frame, data} ptr)+ socketCANFrameData
+ src/Network/SocketCAN/Example.hs view
@@ -0,0 +1,41 @@+module Network.SocketCAN.Example where++import Control.Monad (forever)+import Network.CAN+import Network.Socket (Socket)+import Network.SocketCAN++import qualified Network.Socket++example :: IO ()+example = do+ let interface = "vcan0"+ mIdx <- Network.Socket.ifNameToIndex interface+ case mIdx of+ Nothing -> error $ "Interface " <> interface <> " not found"+ Just idx ->+ withSocketCAN idx act++act :: Socket -> IO ()+act sock = do+ sendCANMessage+ sock+ $ standardMessage+ 0x123+ [0xDE, 0xAD]++ sendCANMessage+ sock+ $ CANMessage+ (extendedID 0x123456)+ [0xEE]++ sendCANMessage+ sock+ $ CANMessage+ (setRTR $ extendedID 0x123)+ [0xDE, 0xAD, 0x11]++ forever+ $ recvCANMessage sock+ >>= print
+ src/Network/SocketCAN/LowLevel.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TypeApplications #-}+module Network.SocketCAN.LowLevel+ ( socket+ , bind+ , send+ , recv+ , module Network.Socket+ ) where++import Control.Monad (void)+import Foreign.Ptr (Ptr)+import Network.Socket (Family(AF_CAN), Socket, close)+import Network.SocketCAN.Bindings (SockAddrCAN(..), SocketCANFrame)++import qualified Foreign.Ptr+import qualified Foreign.Marshal.Alloc+import qualified Foreign.Storable+import qualified Network.Socket+import qualified Network.Socket.Address+import qualified Network.SocketCAN.Bindings++-- | Create raw CAN socket+socket+ :: IO Socket+socket =+ Network.Socket.socket+ AF_CAN+ Network.Socket.Raw+ Network.SocketCAN.Bindings.CAN_RAW++-- | Bind CAN socket+bind+ :: Socket+ -> SockAddrCAN+ -> IO ()+bind = Network.Socket.Address.bind++send+ :: Socket+ -> SocketCANFrame+ -> IO ()+send canSock cf =+ Foreign.Marshal.Alloc.alloca $ \ptr -> do+ Foreign.Storable.poke ptr cf+ void+ $ Network.Socket.sendBuf+ canSock+ (Foreign.Ptr.castPtr ptr)+ (Foreign.Storable.sizeOf cf)++recv+ :: Socket+ -> IO SocketCANFrame+recv canSock =+ Foreign.Marshal.Alloc.alloca $ \ptr -> do+ (_nBytes, _sockAddr) <-+ Network.Socket.Address.recvBufFrom+ @SockAddrCAN+ canSock+ (ptr :: Ptr SocketCANFrame)+ (Foreign.Storable.sizeOf (undefined :: SocketCANFrame))+ Foreign.Storable.peek ptr >>= pure
+ src/Network/SocketCAN/Translate.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RecordWildCards #-}++-- | Translation between CANMessage and SocketCANFrame++module Network.SocketCAN.Translate+ ( toSocketCANFrame+ , fromSocketCANFrame+ ) where++import Data.Bits ((.&.), (.|.), shiftL)+import Data.Word (Word32)+import Network.CAN.Types (CANArbitrationField(..), CANMessage(..))+import Network.SocketCAN.Bindings (SocketCANArbitrationField(..), SocketCANFrame(..))+import qualified Data.Bool++toSocketCANFrame+ :: CANMessage+ -> SocketCANFrame+toSocketCANFrame CANMessage{..} =+ SocketCANFrame+ { socketCANFrameArbitrationField =+ toSocketCANArbitrationField+ canMessageArbitrationField+ , socketCANFrameLength =+ fromIntegral $ length canMessageData+ , socketCANFrameData = canMessageData+ }++fromSocketCANFrame+ :: SocketCANFrame+ -> CANMessage+fromSocketCANFrame SocketCANFrame{..} =+ CANMessage+ { canMessageArbitrationField =+ fromSocketCANArbitrationField+ socketCANFrameArbitrationField+ , canMessageData = socketCANFrameData+ }++toSocketCANArbitrationField+ :: CANArbitrationField+ -> SocketCANArbitrationField+toSocketCANArbitrationField CANArbitrationField{..} =+ SocketCANArbitrationField+ $ Data.Bool.bool+ id+ (.|. effBit)+ canArbitrationFieldExtended+ $ Data.Bool.bool+ id+ (.|. rtrBit)+ canArbitrationFieldRTR+ $ canArbitrationFieldID++fromSocketCANArbitrationField+ :: SocketCANArbitrationField+ -> CANArbitrationField+fromSocketCANArbitrationField (SocketCANArbitrationField scid) =+ let+ isEff = scid .&. effBit /= 0+ in+ CANArbitrationField+ { canArbitrationFieldID =+ Data.Bool.bool+ (.&. (1 `shiftL` 12 - 1))+ (.&. (1 `shiftL` 30 - 1))+ isEff+ $ scid+ , canArbitrationFieldExtended = isEff+ , canArbitrationFieldRTR = scid .&. rtrBit /= 0+ }++effBit :: Word32+effBit = 1 `shiftL` 31++rtrBit :: Word32+rtrBit = 1 `shiftL` 30
+ test/SLCANSpec.hs view
@@ -0,0 +1,27 @@+module SLCANSpec where++import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.QuickCheck (prop)+import Samples++import Network.SLCAN.Types (SLCANMessage(..))+import qualified Network.SLCAN.Builder+import qualified Network.SLCAN.Parser++spec :: Spec+spec = do+ describe "SLCAN" $ do+ it "roundtrips samples" $ do+ mapM_+ (\x ->+ ( Network.SLCAN.Parser.parseSLCANMessage+ <$> Network.SLCAN.Builder.buildSLCANMessage+ ) (SLCANMessage_Data x)+ `shouldBe` pure (SLCANMessage_Data x)+ ) samples++ prop "roundtrips" $ \x ->+ Network.SLCAN.Parser.parseSLCANMessage+ (Network.SLCAN.Builder.buildSLCANMessage x)+ `shouldBe`+ pure x
+ test/Samples.hs view
@@ -0,0 +1,39 @@+module Samples+ ( samples+ ) where++import Network.CAN++samples :: [CANMessage]+samples =+ [+ -- standard+ standardMessage+ 0x0+ mempty++ , standardMessage+ 0xFFF+ mempty++ , standardMessage+ 0x123+ [0xDE, 0xAD]++ , CANMessage+ (setRTR $ standardID 0x123)+ mempty++ -- extended+ , CANMessage+ (extendedID 0x0)+ mempty++ , CANMessage+ (extendedID 0x123456)+ [0xEE]++ , CANMessage+ (setRTR $ extendedID 0x123456)+ mempty+ ]
+ test/SocketCANSpec.hs view
@@ -0,0 +1,25 @@+module SocketCANSpec where++import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.QuickCheck (prop)+import Samples++import qualified Network.SocketCAN.Translate++spec :: Spec+spec = do+ describe "SocketCAN" $ do+ it "roundtrips samples" $ do+ mapM_+ (\x ->+ ( Network.SocketCAN.Translate.fromSocketCANFrame+ . Network.SocketCAN.Translate.toSocketCANFrame+ ) x+ `shouldBe` x+ ) samples++ prop "roundtrips" $ \x ->+ Network.SocketCAN.Translate.fromSocketCANFrame+ (Network.SocketCAN.Translate.toSocketCANFrame x)+ `shouldBe`+ x
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}