diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# network-can + +[![GitHub Workflow Status](https://img.shields.io/github/actions/workflow/status/DistRap/network-can/ci.yaml?branch=main)](https://github.com/DistRap/network-can/actions/workflows/ci.yaml) +[![Hackage version](https://img.shields.io/hackage/v/network-can.svg?color=success)](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 +``` diff --git a/app/CANBridge.hs b/app/CANBridge.hs new file mode 100644 --- /dev/null +++ b/app/CANBridge.hs @@ -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 + ) diff --git a/app/CANDump.hs b/app/CANDump.hs new file mode 100644 --- /dev/null +++ b/app/CANDump.hs @@ -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 diff --git a/app/SLCANSerial.hs b/app/SLCANSerial.hs new file mode 100644 --- /dev/null +++ b/app/SLCANSerial.hs @@ -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 diff --git a/app/SLCANUDP.hs b/app/SLCANUDP.hs new file mode 100644 --- /dev/null +++ b/app/SLCANUDP.hs @@ -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 diff --git a/network-can.cabal b/network-can.cabal new file mode 100644 --- /dev/null +++ b/network-can.cabal @@ -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 diff --git a/src/Network/CAN.hs b/src/Network/CAN.hs new file mode 100644 --- /dev/null +++ b/src/Network/CAN.hs @@ -0,0 +1,7 @@ +module Network.CAN + ( module Network.CAN.Class + , module Network.CAN.Types + ) where + +import Network.CAN.Class +import Network.CAN.Types diff --git a/src/Network/CAN/Class.hs b/src/Network/CAN/Class.hs new file mode 100644 --- /dev/null +++ b/src/Network/CAN/Class.hs @@ -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) diff --git a/src/Network/CAN/Types.hs b/src/Network/CAN/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/CAN/Types.hs @@ -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 + } diff --git a/src/Network/SLCAN.hs b/src/Network/SLCAN.hs new file mode 100644 --- /dev/null +++ b/src/Network/SLCAN.hs @@ -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 diff --git a/src/Network/SLCAN/Builder.hs b/src/Network/SLCAN/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Network/SLCAN/Builder.hs @@ -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 diff --git a/src/Network/SLCAN/Parser.hs b/src/Network/SLCAN/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/SLCAN/Parser.hs @@ -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 diff --git a/src/Network/SLCAN/Types.hs b/src/Network/SLCAN/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/SLCAN/Types.hs @@ -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 + } diff --git a/src/Network/SocketCAN.hs b/src/Network/SocketCAN.hs new file mode 100644 --- /dev/null +++ b/src/Network/SocketCAN.hs @@ -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 diff --git a/src/Network/SocketCAN/Bindings.hsc b/src/Network/SocketCAN/Bindings.hsc new file mode 100644 --- /dev/null +++ b/src/Network/SocketCAN/Bindings.hsc @@ -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 +#include + +-- | 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 diff --git a/src/Network/SocketCAN/Example.hs b/src/Network/SocketCAN/Example.hs new file mode 100644 --- /dev/null +++ b/src/Network/SocketCAN/Example.hs @@ -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 diff --git a/src/Network/SocketCAN/LowLevel.hs b/src/Network/SocketCAN/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src/Network/SocketCAN/LowLevel.hs @@ -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 diff --git a/src/Network/SocketCAN/Translate.hs b/src/Network/SocketCAN/Translate.hs new file mode 100644 --- /dev/null +++ b/src/Network/SocketCAN/Translate.hs @@ -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 diff --git a/test/SLCANSpec.hs b/test/SLCANSpec.hs new file mode 100644 --- /dev/null +++ b/test/SLCANSpec.hs @@ -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 diff --git a/test/Samples.hs b/test/Samples.hs new file mode 100644 --- /dev/null +++ b/test/Samples.hs @@ -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 + ] diff --git a/test/SocketCANSpec.hs b/test/SocketCANSpec.hs new file mode 100644 --- /dev/null +++ b/test/SocketCANSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}