diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +# Version [0.2.0.0](https://github.com/DistRap/network-can/compare/0.1.0.0...0.2.0.0) (2026-04-29) + +* Split `slcan` and `socketcan` into public sublibraries +* Migrate to `io-classes` and switch from `MonadCAN` typeclass + to `CAN` handle (record of functions style): + + ``` + data CAN m = CAN + { canSend :: CANMessage -> m () + , canRecv :: m CANMessage + } + ``` +* Runners renamed + * `runSocketCAN` is now `withSocketCAN` + * `runSLCAN` is now `withSLCAN` + to reflect the handle change + # Version [0.1.0.0](https://github.com/DistRap/network-can/compare/d50564...0.1.0.0) (2025-05-19) * Initial release diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,30 @@ +# 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 Network.CAN +import qualified Network.SocketCAN + +main :: IO () +main = do + Network.SocketCAN.withSocketCAN + (Network.SocketCAN.mkCANInterface "vcan0") + $ \can -> do + Network.CAN.send + can + $ Network.CAN.standardMessage + 0x123 + [0xDE, 0xAD] + + Control.Monad.forever + $ Network.CAN.recv + can + >>= putStrLn . Network.CAN.prettyCANMessage +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,21 +9,22 @@ ```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.withSocketCAN (Network.SocketCAN.mkCANInterface "vcan0") - $ do + $ \can -> do Network.CAN.send + can $ Network.CAN.standardMessage 0x123 [0xDE, 0xAD] Control.Monad.forever $ Network.CAN.recv - >>= Control.Monad.IO.Class.liftIO . print + can + >>= putStrLn . Network.CAN.prettyCANMessage ``` diff --git a/app/CANBridge.hs b/app/CANBridge.hs --- a/app/CANBridge.hs +++ b/app/CANBridge.hs @@ -1,8 +1,8 @@ {-# LANGUAGE LambdaCase #-} module Main where -import Control.Monad.Trans (MonadTrans(lift)) -import Data.Default.Class (Default(def)) +import Control.Monad.Class.MonadAsync (race_) +import Data.Default (Default(def)) import Network.SLCAN (Transport(..)) import System.Hardware.Serialport (CommSpeed(..), SerialPortSettings(..)) @@ -11,7 +11,6 @@ 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 () @@ -21,12 +20,12 @@ (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_ + Network.SLCAN.withSLCAN (Transport_Handle h) def $ \slcan -> do + Network.SocketCAN.withSocketCAN (Network.SocketCAN.mkCANInterface "vcan0") $ \socketcan -> do + race_ (Control.Monad.forever - $ Network.CAN.recv >>= lift . Network.CAN.send + $ Network.CAN.recv slcan >>= Network.CAN.send socketcan ) (Control.Monad.forever - $ lift Network.CAN.recv >>= Network.CAN.send + $ Network.CAN.recv socketcan >>= Network.CAN.send slcan ) diff --git a/app/CANDump.hs b/app/CANDump.hs --- a/app/CANDump.hs +++ b/app/CANDump.hs @@ -1,22 +1,16 @@ 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.withSocketCAN (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 + $ \can -> + (Control.Monad.forever + $ Network.CAN.recv + can + >>= putStrLn . Network.CAN.prettyCANMessage + ) diff --git a/app/SLCANSerial.hs b/app/SLCANSerial.hs --- a/app/SLCANSerial.hs +++ b/app/SLCANSerial.hs @@ -1,9 +1,9 @@ module Main where -import Control.Monad.IO.Class -import Data.Default.Class (Default(def)) +import Control.Monad.Class.MonadSay (MonadSay(say)) +import Data.Default (Default(def)) import System.Hardware.Serialport (CommSpeed(..), SerialPortSettings(..)) -import Network.CAN (MonadCAN) +import Network.CAN (CAN) import Network.SLCAN (Transport(..)) import qualified Control.Monad @@ -23,18 +23,18 @@ { commSpeed = CS115200 } ) - Network.SLCAN.runSLCAN + Network.SLCAN.withSLCAN (Transport_Handle h) def act act - :: ( MonadCAN m - , MonadIO m - ) - => m () -act = do + :: MonadSay m + => CAN m + -> m () +act can = do Network.CAN.send + can $ Network.CAN.standardMessage -- vendorID SDO 0x601 @@ -42,4 +42,5 @@ Control.Monad.forever $ Network.CAN.recv - >>= Control.Monad.IO.Class.liftIO . print + can + >>= say . Network.CAN.prettyCANMessage diff --git a/app/SLCANUDP.hs b/app/SLCANUDP.hs --- a/app/SLCANUDP.hs +++ b/app/SLCANUDP.hs @@ -1,8 +1,8 @@ module Main where -import Control.Monad.IO.Class -import Data.Default.Class (Default(def)) -import Network.CAN (MonadCAN) +import Control.Monad.Class.MonadSay (MonadSay(say)) +import Data.Default (Default(def)) +import Network.CAN (CAN) import Network.SLCAN (Transport(..)) import Network.Socket (AddrInfo(..), SocketType(Datagram)) @@ -36,7 +36,7 @@ sock (addrAddress ourAddrinfo) - Network.SLCAN.runSLCAN + Network.SLCAN.withSLCAN (Transport_UDP sock (addrAddress targetAddrinfo)) def act @@ -44,16 +44,17 @@ (_, _) -> error "getAddrInfo fail" act - :: ( MonadCAN m - , MonadIO m - ) - => m () -act = do + :: MonadSay m + => CAN m + -> m () +act can = do Network.CAN.send + can $ Network.CAN.standardMessage 0x7E5 [0x4C] Control.Monad.forever $ Network.CAN.recv - >>= Control.Monad.IO.Class.liftIO . print + can + >>= say . Network.CAN.prettyCANMessage diff --git a/network-can.cabal b/network-can.cabal --- a/network-can.cabal +++ b/network-can.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: network-can -version: 0.1.0.0 +version: 0.2.0.0 synopsis: CAN bus networking description: Talk to CAN buses using Linux SocketCAN and SLCAN homepage: https://github.com/DistRap/network-can @@ -25,97 +25,141 @@ description: Build example applications +flag build-readme + default: + False + description: + Build readme example + +common commons + ghc-options: -Wall -Wunused-packages + default-language: Haskell2010 + +common execs + ghc-options: -threaded + -rtsopts + "-with-rtsopts -N" + library - ghc-options: -Wall + import: commons hs-source-dirs: src exposed-modules: Network.CAN - Network.CAN.Class Network.CAN.Types - Network.SLCAN + build-depends: base >= 4.7 && < 5 + , QuickCheck + +library slcan + import: commons + visibility: public + hs-source-dirs: src-slcan + exposed-modules: 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 + , data-default + , io-classes , network >= 3.1 + , network-can , QuickCheck - , transformers - , unliftio +library socketcan + import: commons + visibility: public + hs-source-dirs: src-socketcan + exposed-modules: Network.SocketCAN + Network.SocketCAN.Bindings + Network.SocketCAN.Example + Network.SocketCAN.LowLevel + Network.SocketCAN.Translate + build-depends: base >= 4.7 && < 5 + , io-classes + , network >= 3.1 + , network-can 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 + other-modules: CANSpec + Samples SLCANSpec SocketCANSpec build-tool-depends: hspec-discover:hspec-discover build-depends: base >= 4.7 && < 5 , hspec , network-can + , network-can:slcan + , network-can:socketcan default-language: Haskell2010 executable hcandump + import: commons, execs if !flag(build-apps) buildable: False build-depends: base >=4.7 && <5 , network-can - default-language: Haskell2010 + , network-can:socketcan main-is: CANDump.hs hs-source-dirs: app - ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" executable hcanbridge + import: commons, execs if !flag(build-apps) buildable: False build-depends: base >=4.7 && <5 , network-can - , data-default-class - , mtl + , network-can:slcan + , network-can:socketcan + , data-default + , io-classes , 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 + import: commons, execs if !flag(build-apps) buildable: False build-depends: base >=4.7 && <5 , network-can - , data-default-class + , network-can:slcan + , data-default + , io-classes , 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 + import: commons, execs if !flag(build-apps) buildable: False build-depends: base >=4.7 && <5 , network , network-can - , data-default-class - default-language: Haskell2010 + , network-can:slcan + , data-default + , io-classes main-is: SLCANUDP.hs hs-source-dirs: app - ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" + +executable readme + import: commons, execs + if !flag(build-readme) + buildable: False + build-depends: + base >=4.7 && <5 + , network-can + , network-can:socketcan + build-tool-depends: + markdown-unlit:markdown-unlit + main-is: README.lhs + ghc-options: -pgmL markdown-unlit -Wall source-repository head type: git diff --git a/src-slcan/Network/SLCAN.hs b/src-slcan/Network/SLCAN.hs new file mode 100644 --- /dev/null +++ b/src-slcan/Network/SLCAN.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.SLCAN + ( Transport(..) + , withSLCANTransport + , sendSLCANMessage + , sendSLCANControl + , recvSLCANMessage + , sendCANMessage + , module Network.SLCAN.Types + , SLCANException(..) + , withSLCAN + ) where + +import Control.Monad.Class.MonadThrow (Exception(..), MonadThrow(throwIO), finally) +import Control.Monad.IO.Class (MonadIO(..)) + +import Network.Socket (Socket, SockAddr) +import Network.CAN (CANMessage, CAN(..)) +import Network.SLCAN.Types +import System.IO (Handle) + +import qualified Control.Monad +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 + +data Transport = + Transport_Handle Handle + | Transport_UDP Socket SockAddr + +withSLCANTransport + :: ( MonadIO m + , MonadThrow m + ) + => Transport + -> SLCANConfig + -> (Transport -> m a) + -> m a +withSLCANTransport transport SLCANConfig{..} act = do + let sendC = sendSLCANControl transport + 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 + :: MonadIO m + => Transport + -> SLCANMessage + -> m () +sendSLCANMessage (Transport_Handle handle) msg = liftIO $ do + Control.Monad.void + $ Data.ByteString.hPutStr + handle + $ Network.SLCAN.Builder.buildSLCANMessage + msg + System.IO.hFlush handle +sendSLCANMessage (Transport_UDP socket target) msg = + liftIO + $ Network.Socket.ByteString.sendAllTo + socket + (Network.SLCAN.Builder.buildSLCANMessage msg) + target + +sendSLCANControl + :: MonadIO m + => Transport + -> SLCANControl + -> m () +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 + +data SLCANException = SLCANException_ParseError String + deriving Show + +instance Exception SLCANException + +withSLCAN + :: ( MonadIO m + , MonadThrow m + ) + => Transport + -> SLCANConfig + -> (CAN m -> m a) + -> m a +withSLCAN transport config act = do + withSLCANTransport + transport + config + $ \t -> + act + CAN + { canSend = liftIO . sendCANMessage t + , canRecv = + let + recv = + liftIO + (recvSLCANMessage t) + >>= \case + Left e -> + 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 + in recv + } diff --git a/src-slcan/Network/SLCAN/Builder.hs b/src-slcan/Network/SLCAN/Builder.hs new file mode 100644 --- /dev/null +++ b/src-slcan/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-slcan/Network/SLCAN/Parser.hs b/src-slcan/Network/SLCAN/Parser.hs new file mode 100644 --- /dev/null +++ b/src-slcan/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-slcan/Network/SLCAN/Types.hs b/src-slcan/Network/SLCAN/Types.hs new file mode 100644 --- /dev/null +++ b/src-slcan/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 (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-socketcan/Network/SocketCAN.hs b/src-socketcan/Network/SocketCAN.hs new file mode 100644 --- /dev/null +++ b/src-socketcan/Network/SocketCAN.hs @@ -0,0 +1,96 @@ +module Network.SocketCAN + ( withSocket + , sendCANMessage + , recvCANMessage + , Network.Socket.ifNameToIndex + , CANInterface + , mkCANInterface + , NoSuchInterface(..) + , withSocketCAN + ) where + +import Network.CAN (CANMessage, CAN(..)) +import Network.Socket (Socket) +import Network.SocketCAN.Bindings (SockAddrCAN(..)) + +import Control.Monad.Class.MonadThrow (Exception(..), MonadThrow(bracket, throwIO)) +import Control.Monad.IO.Class (MonadIO(..)) + +import qualified Network.Socket (ifNameToIndex) +import qualified Network.SocketCAN.LowLevel +import qualified Network.SocketCAN.Translate + +withSocket + :: ( MonadIO m + , MonadThrow m + ) + => Int + -> (Socket -> m a) + -> m a +withSocket ifaceIdx act = do + bracket + (liftIO Network.SocketCAN.LowLevel.socket) + (liftIO . Network.SocketCAN.LowLevel.close) + (\canSock -> do + liftIO + $ 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 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 + +withSocketCAN + :: ( MonadIO m + , MonadThrow m + ) + => CANInterface + -> (CAN m -> m a) + -> m a +withSocketCAN interface act = do + mIdx <- + liftIO + $ Network.Socket.ifNameToIndex (unCANInterface interface) + + case mIdx of + Nothing -> throwIO NoSuchInterface + Just idx -> + withSocket + idx + $ \sock -> + act + CAN + { canSend = liftIO . sendCANMessage sock + , canRecv = liftIO $ recvCANMessage sock + } diff --git a/src-socketcan/Network/SocketCAN/Bindings.hsc b/src-socketcan/Network/SocketCAN/Bindings.hsc new file mode 100644 --- /dev/null +++ b/src-socketcan/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-socketcan/Network/SocketCAN/Example.hs b/src-socketcan/Network/SocketCAN/Example.hs new file mode 100644 --- /dev/null +++ b/src-socketcan/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 -> + withSocket 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-socketcan/Network/SocketCAN/LowLevel.hs b/src-socketcan/Network/SocketCAN/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src-socketcan/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-socketcan/Network/SocketCAN/Translate.hs b/src-socketcan/Network/SocketCAN/Translate.hs new file mode 100644 --- /dev/null +++ b/src-socketcan/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/src/Network/CAN.hs b/src/Network/CAN.hs --- a/src/Network/CAN.hs +++ b/src/Network/CAN.hs @@ -1,7 +1,24 @@ module Network.CAN - ( module Network.CAN.Class + ( CAN(..) + , send + , recv , module Network.CAN.Types ) where -import Network.CAN.Class import Network.CAN.Types + +data CAN m = CAN + { canSend :: CANMessage -> m () + , canRecv :: m CANMessage + } + +send + :: CAN m + -> CANMessage + -> m () +send = canSend + +recv + :: CAN m + -> m CANMessage +recv = canRecv diff --git a/src/Network/CAN/Class.hs b/src/Network/CAN/Class.hs deleted file mode 100644 --- a/src/Network/CAN/Class.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# 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 --- a/src/Network/CAN/Types.hs +++ b/src/Network/CAN/Types.hs @@ -8,19 +8,21 @@ -- * Message , CANMessage(..) , standardMessage + , prettyCANMessage ) where import Data.Word (Word8, Word16, Word32) import Test.QuickCheck (Arbitrary(..)) import qualified Test.QuickCheck +import qualified Text.Printf -- * Arbitration data CANArbitrationField = CANArbitrationField - { canArbitrationFieldID :: Word32 -- ^ CAN ID - , canArbitrationFieldExtended :: Bool -- ^ Extended CAN ID - , canArbitrationFieldRTR :: Bool -- ^ Remote transmission request + { canArbitrationFieldID :: Word32 -- ^ CAN ID + , canArbitrationFieldExtended :: Bool -- ^ Extended CAN ID + , canArbitrationFieldRTR :: Bool -- ^ Remote transmission request } deriving (Eq, Ord, Show) instance Arbitrary CANArbitrationField where @@ -89,3 +91,40 @@ { canMessageArbitrationField = standardID cid , canMessageData = cdata } + +-- | Pretty print @CANMessage@ similar to candump output +-- +-- > prettyCANMessage (standardMessage 123 [0x13, 0x37]) +-- " 07B [2] 13 37" +-- > prettyCANMessage (CANMessage (extendedID 123) [0x13, 0x37]) +-- "0000007B [2] 13 37" +prettyCANMessage + :: CANMessage + -> String +prettyCANMessage msg = + unwords + $ [ prettyArb + $ canMessageArbitrationField msg + , " [" <> show (length $ canMessageData msg) <> "] " + ] + ++ prettyData + (canArbitrationFieldRTR $ canMessageArbitrationField msg) + (canMessageData msg) + where + prettyArb arb | canArbitrationFieldExtended arb = + hexFixed + 8 + $ canArbitrationFieldID arb + prettyArb arb | otherwise = + replicate 5 ' ' + <> hexFixed + 3 + (canArbitrationFieldID arb) + + prettyData :: Bool -> [Word8] -> [String] + prettyData True _ = pure "remote request" + prettyData _ x = map (hexFixed 2) x + + hexFixed width = + Text.Printf.printf + $ "%0" <> show (width :: Int) <> "X" diff --git a/src/Network/SLCAN.hs b/src/Network/SLCAN.hs deleted file mode 100644 --- a/src/Network/SLCAN.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SLCAN/Builder.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SLCAN/Parser.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SLCAN/Types.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SocketCAN.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SocketCAN/Bindings.hsc +++ /dev/null @@ -1,79 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SocketCAN/Example.hs +++ /dev/null @@ -1,41 +0,0 @@ -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 deleted file mode 100644 --- a/src/Network/SocketCAN/LowLevel.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/SocketCAN/Translate.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# 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/CANSpec.hs b/test/CANSpec.hs new file mode 100644 --- /dev/null +++ b/test/CANSpec.hs @@ -0,0 +1,21 @@ +module CANSpec where + +import Test.Hspec (Spec, describe, it, shouldBe) +import Samples + +import qualified Network.CAN + +spec :: Spec +spec = do + describe "CAN" $ do + it "pretty prints samples" $ + map Network.CAN.prettyCANMessage samples + `shouldBe` + [ " 000 [0] " + , " FFF [0] " + , " 123 [2] DE AD" + , " 123 [0] remote request" + , "00000000 [0] " + , "00123456 [1] EE" + , "00123456 [0] remote request" + ]