diff --git a/README b/README --- a/README +++ b/README @@ -5,6 +5,7 @@ probe - Extracts configuration and probed signals from ECU. canview - View CAN traffic. cansend - Send CAN message. +ccp - CAN Configuration Protocol master. git2cc - Bridge Git repositories to ClearCase. commit - Git commits with ClearQuest activity annotations. diff --git a/ecu.cabal b/ecu.cabal --- a/ecu.cabal +++ b/ecu.cabal @@ -1,7 +1,7 @@ name: ecu -version: 0.0.1 +version: 0.0.2 -category: Utils +category: Embedded, Utils synopsis: Tools for automotive ECU development. @@ -28,9 +28,9 @@ executable tovcd hs-source-dirs: src main-is: ToVCD.hs - build-depends: base >= 4.2 && < 5, + build-depends: base >= 4.0 && < 5, bytestring >= 0.9.1 && < 0.9.2, - vcd >= 0.1.4 && < 2 + vcd >= 0.2.0 && < 0.3.0 ghc-options: -W executable cansend @@ -39,7 +39,7 @@ other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib - build-depends: base >= 4.2 && < 5 + build-depends: base >= 4.0 && < 5 ghc-options: -W extensions: ForeignFunctionInterface @@ -49,26 +49,36 @@ other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib - build-depends: base >= 4.2 && < 5 + build-depends: base >= 4.0 && < 5 ghc-options: -W extensions: ForeignFunctionInterface +executable ccp + hs-source-dirs: src + main-is: CCP.hs + other-modules: CAN + c-sources: src/kvaser.c + extra-libraries: canlib + build-depends: base >= 4.0 && < 5 + ghc-options: -W + extensions: ForeignFunctionInterface + executable probe hs-source-dirs: src main-is: Probe.hs other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib - build-depends: base >= 4.2 && < 5, + build-depends: base >= 4.0 && < 5, digest >= 0.0.0.8 && < 0.0.1, - vcd >= 0.1.4 && < 2 + vcd >= 0.2.0 && < 0.3.0 ghc-options: -W extensions: ForeignFunctionInterface executable toesb hs-source-dirs: src main-is: ToESB.hs - build-depends: base >= 4.2 && < 5, + build-depends: base >= 4.0 && < 5, bytestring >= 0.9.1 && < 0.9.2, digest >= 0.0.0.8 && < 0.0.1 ghc-options: -W @@ -76,13 +86,13 @@ executable commit hs-source-dirs: src main-is: Commit.hs - build-depends: base >= 4.2 && < 5 + build-depends: base >= 4.0 && < 5 ghc-options: -W executable git2cc hs-source-dirs: src main-is: Git2CC.hs - build-depends: base >= 4.2 && < 5, + build-depends: base >= 4.0 && < 5, directory >= 1.0.1 && < 1.1, process >= 1.0.1 && < 1.1 ghc-options: -W diff --git a/src/CCP.hs b/src/CCP.hs new file mode 100644 --- /dev/null +++ b/src/CCP.hs @@ -0,0 +1,73 @@ +module Main (main) where + +import Control.Monad +import Data.Word +import System.Environment +import Text.Printf + +import CAN + +help :: IO () +help = putStrLn $ unlines + [ "" + , "NAME" + , " ccp - a CAN Configuration Protocol master" + , "" + , "SYNOPSIS" + , " ccp command { option } { argument }" + , "" + , "COMMANDS" + , " upload { option } address Upload 4 bytes from the ECU. Address must be 32-bit aligned." + , " upload { option } address length Upload a memory region from the ECU. Address must be 32-bit aligned." + , "" + , "OPTIONS" + , " --std Set to standard CAN with 500K. Default is extended CAN with 250K." + , "" + , "ENVIRONMENT VARIABLES" + , " CCP_ID_MASTER CAN identifier for master device (this configuration tool)." + , " CCP_ID_SLAVE CAN identifier for slave device (ecu)." + , "" + ] + +main :: IO () +main = getArgs >>= f + where + f args = case args of + ["-h"] -> help + ["--help"] -> help + ["upload", addr] -> f ["upload", addr, "4"] + ["upload", "--std", addr] -> f ["upload", "--std", addr, "4"] + ["upload", "--std", addr, size] -> do + initCAN + bus <- openBus 0 Standard + ids <- ids + upload bus ids (read addr) (read size) + closeBus bus + ["upload", addr, size] -> do + initCAN + bus <- openBus 0 Extended + ids <- ids + upload bus ids (read addr) (read size) + closeBus bus + _ -> help + +canview :: Bus -> [Word32] -> IO () +canview bus ids = do + m <- recvMsg bus + case m of + Nothing -> canview bus ids + Just (t, m@(Msg id _)) -> do + when (null ids || elem id ids) $ putStrLn $ printf "%10i " t ++ show m + canview bus ids + +ids :: IO (Word32, Word32) +ids = do + master <- getEnv "CCP_ID_MASTER" + slave <- getEnv "CCP_ID_SLAVE" + return (read master, read slave) + +upload :: Bus -> (Word32, Word32) -> Word32 -> Word32 -> IO () +upload bus (master, slave) address size = do + printf "%08x %08x\n" master slave + return () + diff --git a/src/Probe.hs b/src/Probe.hs --- a/src/Probe.hs +++ b/src/Probe.hs @@ -164,7 +164,7 @@ loop vcd sample lastTime = do m <- recvMsgWait bus 1000 case m of - Just (time, Msg id payload) | id .&. 0x180200EF == 0x180200EF -> do + Just (time, Msg id payload) | id .&. 0xFFFF00FF == 0x180200EF -> do --printf "%-20d %-20d\n" time (time - lastTime) --hFlush stdout sample (fromIntegral $ shiftR id 8 .&. 0xFF) $ fromPayload payload @@ -190,37 +190,37 @@ f2 bit ((name, typ) : probes) = do a <- case typ of Bool -> do - f <- var vcd name False + f <- var vcd [name] False return $ \ a -> f $ testBit a (bit - 1) Int8 -> do - f <- var vcd name (0 :: Int8 ) + f <- var vcd [name] (0 :: Int8 ) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 8 Int16 -> do - f <- var vcd name (0 :: Int16 ) + f <- var vcd [name] (0 :: Int16 ) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 16 Int32 -> do - f <- var vcd name (0 :: Int32 ) + f <- var vcd [name] (0 :: Int32 ) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 32 Int64 -> do - f <- var vcd name (0 :: Int64 ) + f <- var vcd [name] (0 :: Int64 ) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 64 Word8 -> do - f <- var vcd name (0 :: Word8 ) + f <- var vcd [name] (0 :: Word8 ) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 8 Word16 -> do - f <- var vcd name (0 :: Word16) + f <- var vcd [name] (0 :: Word16) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 16 Word32 -> do - f <- var vcd name (0 :: Word32) + f <- var vcd [name] (0 :: Word32) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 32 Word64 -> do - f <- var vcd name (0 :: Word64) + f <- var vcd [name] (0 :: Word64) return $ \ a -> f $ fromIntegral $ shiftR a $ bit - 64 Float -> do - f <- var vcd name (0 :: Float ) + f <- var vcd [name] (0 :: Float ) return $ \ a -> f $ toFloat (fromIntegral $ shiftR a $ bit - 32 :: Word32) Double -> do - f <- var vcd name (0 :: Double) + f <- var vcd [name] (0 :: Double) return $ \ a -> f $ toDouble (fromIntegral $ shiftR a $ bit - 64 :: Word64) b <- f2 (bit - width typ) probes return $ \ p -> a p >> b p diff --git a/src/ToVCD.hs b/src/ToVCD.hs --- a/src/ToVCD.hs +++ b/src/ToVCD.hs @@ -59,10 +59,10 @@ sampleField :: VCDHandle -> Field -> IO (Word64 -> IO ()) sampleField vcd field = case field of Bool name bit -> do - v <- var vcd name False + v <- var vcd [name] False return $ \ payload -> v $ testBit payload $ 64 - bit Float name bit width gain bias -> do - v <- var vcd name (0 :: Float) + v <- var vcd [name] (0 :: Float) return $ \ payload -> v $ fromIntegral (shiftR payload (71 - width - bit) .&. mask width) * gain + bias where mask :: Int -> Word64