diff --git a/README b/README --- a/README +++ b/README @@ -4,6 +4,8 @@ probe - Extracts configuration and probed signals from ECU. canview - View CAN traffic. cansend - Send CAN message. +decomp - Decomposes J1939 messages from canview. +parsedbc - Parses *.dbc files. ccp - CAN Configuration Protocol master. toesb - Converts s-record ECU images to the Eaton Standard Binary format. git2cc - Bridge Git repositories to ClearCase. diff --git a/ecu.cabal b/ecu.cabal --- a/ecu.cabal +++ b/ecu.cabal @@ -1,5 +1,5 @@ name: ecu -version: 0.0.5 +version: 0.0.6 category: Embedded, Utils @@ -33,10 +33,16 @@ vcd >= 0.2.0 && < 0.3.0 ghc-options: -W +executable decomp + hs-source-dirs: src + main-is: CANViewDecompose.hs + build-depends: base >= 4.0 && < 5, + bytestring >= 0.9.1 && < 0.9.2 + ghc-options: -W + executable cansend hs-source-dirs: src main-is: CANSend.hs - other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib build-depends: base >= 4.0 && < 5 @@ -46,7 +52,6 @@ executable canview hs-source-dirs: src main-is: CANView.hs - other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib build-depends: base >= 4.0 && < 5 @@ -56,7 +61,6 @@ 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 @@ -66,7 +70,6 @@ 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.0 && < 5, @@ -81,6 +84,12 @@ build-depends: base >= 4.0 && < 5, bytestring >= 0.9.1 && < 0.9.2, digest >= 0.0.0.8 && < 0.0.1 + ghc-options: -W + +executable parsedbc + hs-source-dirs: src + main-is: CANDBParser.hs + build-depends: base >= 4.0 && < 5 ghc-options: -W executable commit diff --git a/src/CAN.hs b/src/CAN.hs deleted file mode 100644 --- a/src/CAN.hs +++ /dev/null @@ -1,157 +0,0 @@ -module CAN - ( Msg (..) - , BusType (..) - , Bus - , initCAN - , openBus - , closeBus - , recvMsg - , recvMsgWait - , sendMsg - , busTime - , busTime' - , testBusStatus - , testIFStatus - , sendUntil - , toWord64 - , fromWord64 - , toWord32 - , fromWord32 - , toPayload - , fromPayload - , flushRxQueue - ) where - -import Data.Bits -import Data.Char -import Data.Word -import Text.Printf - -foreign import ccall unsafe initCAN :: IO () -foreign import ccall unsafe canOpenExt_ :: Int -> IO Int -foreign import ccall unsafe canOpenStd_ :: Int -> IO Int ---foreign import ccall unsafe canOpenVirtual_ :: Int -> IO Int -foreign import ccall unsafe canClose_ :: Int -> IO () ---foreign import ccall unsafe canRead_ :: Int -> IO Int -foreign import ccall unsafe canReadWait_ :: Int -> Int -> IO Int -foreign import ccall unsafe canReadId_ :: IO Int -foreign import ccall unsafe canReadTime_ :: IO Int -foreign import ccall unsafe canReadMsgLen_ :: IO Int -foreign import ccall unsafe canReadMsg_ :: Int -> IO Char -foreign import ccall unsafe canWriteByte_ :: Char -> Int -> IO () -foreign import ccall unsafe canWrite_ :: Int -> Int -> Int -> IO () -foreign import ccall unsafe canReadTimer_ :: Int -> IO Int -foreign import ccall unsafe canFlushReceiveQueue_ :: Int -> IO Int - -newtype Bus = Bus Int - -openBus :: Int -> BusType -> IO Bus -openBus channel busType = do - h <- case busType of - Standard -> canOpenStd_ channel - Extended -> canOpenExt_ channel - return $ Bus h - -closeBus :: Bus -> IO () -closeBus (Bus h) = canClose_ h - --- | Receive a message if a message is available. Includes receive time (ms). -recvMsg :: Bus -> IO (Maybe (Int, Msg)) -recvMsg b = recvMsgWait b 0 - --- | Waits a number of ms to receive a message. Includes receive time (ms). -recvMsgWait :: Bus -> Int -> IO (Maybe (Int, Msg)) -recvMsgWait (Bus h) wait = do - status <- canReadWait_ h wait - id <- canReadId_ - if status /= 0 || id == 0 then return Nothing else do - len <- canReadMsgLen_ - msg <- mapM canReadMsg_ [0 .. len - 1] - t <- canReadTime_ - return $ Just (t, Msg (fromIntegral id) (map (fromIntegral . ord) msg)) - --- | Send a message. -sendMsg :: Bus -> Msg -> IO () -sendMsg (Bus h) (Msg id payload') = do - mapM_ (\ (b, i) -> canWriteByte_ (chr $ fromIntegral b) i) $ zip payload [0..] - canWrite_ h (fromIntegral id) $ length payload - where - payload = take 8 payload' - -flushRxQueue :: Bus -> IO () -flushRxQueue (Bus h) = do - canFlushReceiveQueue_ h - return () - --- | Current driver time (ms). -busTime :: Bus -> IO (Maybe Int) -busTime (Bus h) = do - status <- canReadTimer_ h - if status /= 0 then return Nothing else do - t <- canReadTime_ - return $ Just t - -busTime' :: Bus -> IO Int -busTime' bus = do - t <- busTime bus - case t of - Nothing -> busTime' bus - Just t -> return t - -testBusStatus :: Bus -> IO Int -testBusStatus (Bus h) = do - status <- canReadWait_ h 500 - return status - -testIFStatus :: Bus -> IO Int -testIFStatus (Bus h) = do - status <- canReadTimer_ h - return status - --- | Send a message periodically (in ms) until a certain message is received. -sendUntil :: Bus -> Int -> Msg -> (Msg -> Bool) -> IO Msg -sendUntil bus retryTime msg isAck = getStartTime >>= f1 - where - f1 startTime = sendMsg bus msg >> f2 startTime startTime - f2 startTime currentTime | currentTime - startTime > retryTime = f1 currentTime - f2 startTime currentTime = do - m <- recvMsgWait bus $ max 0 $ retryTime - (currentTime - startTime) - case m of - Nothing -> f1 currentTime - Just (t, m) | isAck m -> return m - | otherwise -> f2 startTime t - - getStartTime = do - m <- recvMsg bus - case m of - Nothing -> getStartTime - Just (t, _) -> return t - - -data Msg = Msg Word32 [Word8] deriving (Eq, Ord) - -data BusType = Extended | Standard - -instance Show Msg where show (Msg id payload) = printf "0x%08X 0x%s" id $ concatMap formatByte payload - -formatByte :: Word8 -> String -formatByte b = printf "%02X" b - -toWord64 :: [Word8] -> Word64 -toWord64 a = foldl1 (.|.) [ shiftL (fromIntegral a) $ i * 8 | (a, i) <- zip (a ++ [0..]) $ reverse [0..7] ] - -fromWord64 :: Word64 -> [Word8] -fromWord64 a = [ fromIntegral ((shiftR a $ i * 8) .&. 0xFF) | i <- reverse [0..7] ] - -toWord32 :: [Word8] -> Word32 -toWord32 a = foldl1 (.|.) [ shiftL (fromIntegral a) $ i * 8 | (a, i) <- zip (a ++ [0..]) $ reverse [0..3] ] - -fromWord32 :: Word32 -> [Word8] -fromWord32 a = [ fromIntegral ((shiftR a $ i * 8) .&. 0xFF) | i <- reverse [0..3] ] - -toPayload :: Word64 -> [Word8] -toPayload payload = [ fromIntegral (shiftR payload (b * 8) .&. 0xFF) | b <- reverse [0..7] ] - -fromPayload :: [Word8] -> Word64 -fromPayload payload = foldr1 (.|.) [ shiftL (fromIntegral x .&. 0xFF) (b * 8) | (x, b) <- zip payload (reverse [0..7]) ] - diff --git a/src/CANDBParser.hs b/src/CANDBParser.hs new file mode 100644 --- /dev/null +++ b/src/CANDBParser.hs @@ -0,0 +1,288 @@ +module Main (main) where + +import Data.Bits +import Data.Char +import Data.List +import Data.Word +import Text.Printf +import System.Environment + +import CANData + +main :: IO () +main = do + args <- getArgs + case args of + ["-h"] -> help + ["--help"] -> help + [ file ] -> do + dbc <- readFile file + let candb = mkCANDB dbc + writeCANDB candb + _ -> help + +help :: IO () +help = putStrLn $ unlines + [ "" + , "NAME" + , " parsedbc - create CANDB.hs from dbc file" + , "" + , "SYNOPSIS" + , " parsedbc FILE.dbc" + , "" + ] + +writeCANDB :: CANDB -> IO () +writeCANDB candb = writeFile "CANDB.hs" $ concat + [ "{- Generated file. Do not modify -}\n" + , "module CANDB\n" + , " ( canDB\n" + , " ) where\n" + , "\n" + , "import CANData\n" + , "\n" + , "canDB :: CANDB\n" + , "canDB = CANDB\n" + , showCANDB candb + , "\n" + ] + +mkCANDB :: String -> CANDB +mkCANDB s = mkCANDB' nodes groups types attrs (CANDB name nodes []) + where + canLines = filter notBlank (lines s) + name = getName canLines + groups = getGroups canLines + nodes = getNodes canLines + types = getTypes canLines + attrs = getMsgAttrs canLines + +mkCANDB' :: [String] -> [[String]] -> [(Word32,String,CANSignalType)] -> [(Word32,CANMsgAttr)] -> CANDB -> CANDB +mkCANDB' _ [] _ _ canDb = canDb +mkCANDB' nodes (group0:groups) types attrs canDb = mkCANDB' nodes groups types attrs (fillDB group0 types attrs canDb) + +fillDB :: [String] -> [(Word32,String,CANSignalType)] -> [(Word32,CANMsgAttr)] -> CANDB -> CANDB +fillDB group0 types attrs canDB = getSignals types (tail group0) (getMessage (head group0) attrs canDB) + +getMessage :: String -> [(Word32,CANMsgAttr)] -> CANDB -> CANDB +getMessage s attrs (CANDB dbname nodes msgs) = CANDB dbname nodes newMessages + where + newMessages = (msg:msgs) + msg = CANMsg + { canMsgId = id0 + , canMsgName = init c + , canMsgDlc = read d + , canMsgTxNode = e + , canMsgAttrs = map (\ (_,a) -> a) (filter (\ (i,_) -> i == id0) attrs) + , canMsgSignals = [] + } + id0 = readId b + (_:b:c:d:e:_) = words s + +getSignals :: [(Word32,String,CANSignalType)] -> [String] -> CANDB -> CANDB +--getSignals _ [] (CANDB dbname nodes (msg:msgs)) = CANDB dbname nodes ((sortByStartBit msg):msgs) +getSignals _ [] canDb = canDb +getSignals types (l:ls) canDb = sortByStartBit (getSignal types l (getSignals types ls canDb)) + +sortByStartBit :: CANDB -> CANDB +sortByStartBit (CANDB dbname nodes []) = CANDB dbname nodes [] +sortByStartBit (CANDB dbname nodes (msg:msgs)) = CANDB dbname nodes (newMsg:msgs) + where + newMsg = msg { canMsgSignals = sortBy comparingStartBit (canMsgSignals msg) } + comparingStartBit :: CANSignal -> CANSignal -> Ordering + comparingStartBit a b = compare (canSignalStartBit a) (canSignalStartBit b) + +getSignal :: [(Word32,String,CANSignalType)] -> String -> CANDB -> CANDB +getSignal _ [] canDb = canDb +getSignal _ _ (CANDB _ _ []) = error "CANDBParser.getSignal" +getSignal types l (CANDB dbname nodes (msg:msgs)) = CANDB dbname nodes (newMsg:msgs) + where + msgId = canMsgId msg + newMsg = msg { canMsgSignals = newSignal:(canMsgSignals msg) } + newSignal = CANSignal + { canSignalName = name + , canSignalStartBit = (read startBitStr) + , canSignalBitLength = (read bitLengthStr) + , canSignalEndian = if bigEndianStr == '0' then CANBigEndian else CANLittleEndian + , canSignalSign = if signedStr == '-' then CANSigned else CANUnsigned + , canSignalFactor = (read (drop 1 (takeWhile (/= ',') e))) + , canSignalOffset = (read (takeWhile (/= ')') (drop 1 (dropWhile (/= ',') e)))) + , canSignalMin = (read (drop 1 (takeWhile (/= '|') f))) + , canSignalMax = (read (takeWhile (/= ']') (drop 1 (dropWhile (/= '|') f)))) + , canSignalUnit = unit + , canSignalRxNodes = rx + , canSignalType = matchTypes msgId name types + , canSignalMux = mux + } + startBitStr = takeWhile (/= '|') d + bitLengthStr = drop 1 (dropWhile (/= '|') (takeWhile (/= '@') d)) + bigEndianStr = head (drop 1 (dropWhile (/= '@') d)) + signedStr = last d + (_:name:maybeMux) = takeWhile (/= ":") (words l) + mux = case maybeMux of + [] -> CANSignalMuxNone + ["M"] -> CANSignalMuxer + [('m':muxVal)] -> CANSignalMuxed (read muxVal) + _ -> error "CANDBParser.getSignal: error parsing \" SG_ ...\" line" + (_:d:e:f:_) = dropWhile (/= ":") (words l) + unitAndRx = dropWhile (/= '"') l + unit = (takeWhile (/= '"') (drop 1 unitAndRx)) + rxlist = head (words (drop 1 (dropWhile (/= '"') (drop 1 unitAndRx)))) + rx = wordsBy ',' rxlist + matchTypes :: Word32 -> String -> [(Word32,String,CANSignalType)] -> CANSignalType + matchTypes _ _ [] = CANSignalTypeNormal + matchTypes msgId0 sigName ((id0,name0,typ):types0) = + if (msgId0 == id0 && sigName == name0) + then typ + else matchTypes msgId0 sigName types0 + wordsBy :: Char -> [Char] -> [String] + wordsBy sep s = case dropWhile (== sep) s of + "" -> [] + s' -> w : wordsBy ',' s'' + where + (w, s'') = break (== sep) s' + +getName :: [String] -> String +getName [] = [] +getName (l:ls) = + if isPrefixOf "BA_ \"DBName\" " l + then (takeWhile (/= '"') (drop 1 c)) + else getName ls + where + (_:_:c:_) = words l + +getNodes :: [String] -> [String] +getNodes (l:ls) = + if isPrefixOf "BU_: " l + then (words (drop 5 l)) + else getNodes ls +getNodes [] = [] + +getTypes :: [String] -> [(Word32,String,CANSignalType)] +getTypes ls = getTypes' ls [] + +getTypes' :: [String] -> [(Word32,String,CANSignalType)] -> [(Word32,String,CANSignalType)] +getTypes' [] types = types +getTypes' (l:ls) types = + if isPrefixOf "SIG_VALTYPE_ " l + then getTypes' ls ((id0,name,typ):types) + else getTypes' ls types + where + typ = if typChar == '1' then CANSignalTypeFloat else CANSignalTypeDouble + typChar = head e + id0 = read b + name = c + (_:b:c:_:e:_) = words l + +getMsgAttrs :: [String] -> [(Word32,CANMsgAttr)] +getMsgAttrs ls = getMsgAttrs' ls [] + +getMsgAttrs' :: [String] -> [(Word32,CANMsgAttr)] -> [(Word32,CANMsgAttr)] +getMsgAttrs' [] attrs = attrs +getMsgAttrs' (l:ls) attrs = + if isPrefixOf "BA_ " l && length (words l) == 5 + then + if c == "BO_" + then getMsgAttrs' ls ((id0,attr):attrs) + else getMsgAttrs' ls attrs + else getMsgAttrs' ls attrs + where + id0 = readId d + attr = (tail (init b), init e) + (_:b:c:d:e:_) = words l + +getGroups :: [String] -> [[String]] +getGroups ls = groupMessages ls [[]] + +groupMessages :: [String] -> [[String]] -> [[String]] +groupMessages [] [] = [[]] +groupMessages [] sofar = map reverse sofar +groupMessages (l:ls) ([]:[]) = case take 4 l of + "BO_ " -> groupMessages ls [[l]] + _ -> groupMessages ls [[]] +groupMessages (l:ls) ((s:ss):gs) = case (take 4 l) of + "BO_ " -> groupMessages ls ([l]:(s:ss):gs) + " SG_" -> groupMessages ls ((l:s:ss):gs) + _ -> reverse (map reverse ((s:ss):gs)) +groupMessages _ [] = error "CANDBParser.groupMessages" +groupMessages _ ([]:_) = error "CANDBParser.groupMessages" + +notBlank :: String -> Bool +notBlank a = not (and (map isSpace a)) + +readId :: String -> Word32 +readId str = (read str) .&. 0x7FFFFFFF + +showCANDB :: CANDB -> String +showCANDB candb = concat + [ " { canDbName = " ++ show (canDbName candb) ++ "\n" + , " , canDbNodes =\n" + , " [" ++ (drop 7 (concatMap showNode (canDbNodes candb))) + , " ]\n" + , " , canDbMsgs =\n" + , " [" ++ (drop 7 (concatMap showMsg (canDbMsgs candb))) + , " ]\n" + , " }\n" + ] + +showNode :: String -> String +showNode x = " , " ++ show x ++ "\n" + +showMsg :: CANMsg -> String +showMsg msg = concat + [ " , CANMsg\n" + , " { canMsgId = " ++ (printf "0x%08X" (canMsgId msg)) ++ "\n" + , " , canMsgName = " ++ show (canMsgName msg) ++ "\n" + , " , canMsgDlc = " ++ show (canMsgDlc msg) ++ "\n" + , " , canMsgTxNode = " ++ show (canMsgTxNode msg) ++ "\n" + , " , canMsgAttrs =\n" + , " [" ++ showMsgAttrs (canMsgAttrs msg) + , " ]\n" + , " , canMsgSignals =\n" + , " [" ++ showMsgSignals (canMsgSignals msg) ++ "\n" + , " ]\n" + , " }\n" + ] + +showMsgAttrs :: [CANMsgAttr] -> String +showMsgAttrs attrs = case attrs of + [] -> "" + x -> drop 15 (concatMap showMsgAttr x) + +showMsgAttr :: CANMsgAttr -> String +showMsgAttr (a , b) = " , (" ++ show a ++ ", " ++ show b ++ ")\n" + +showMsgSignals :: [CANSignal] -> String +showMsgSignals signals = case signals of + [] -> "" + x -> drop 15 (concatMap showMsgSignal x) + +showMsgSignal :: CANSignal -> String +showMsgSignal signal = concat + [ " , CANSignal\n" + , " { canSignalName = " ++ show (canSignalName signal) ++ "\n" + , " , canSignalStartBit = " ++ show (canSignalStartBit signal) ++ "\n" + , " , canSignalBitLength = " ++ show (canSignalBitLength signal) ++ "\n" + , " , canSignalEndian = " ++ show (canSignalEndian signal) ++ "\n" + , " , canSignalSign = " ++ show (canSignalSign signal) ++ "\n" + , " , canSignalFactor = " ++ show (canSignalFactor signal) ++ "\n" + , " , canSignalOffset = " ++ show (canSignalOffset signal) ++ "\n" + , " , canSignalMin = " ++ show (canSignalMin signal) ++ "\n" + , " , canSignalMax = " ++ show (canSignalMax signal) ++ "\n" + , " , canSignalUnit = " ++ show (canSignalUnit signal) ++ "\n" + , " , canSignalRxNodes =\n" + , " [" ++ showCANSignalRxNodes (canSignalRxNodes signal) + , " ]\n" + , " , canSignalType = " ++ show (canSignalType signal) ++ "\n" + , " , canSignalMux = " ++ show (canSignalMux signal) ++ "\n" + , " }\n" + ] + +showCANSignalRxNodes :: [String] -> String +showCANSignalRxNodes nodes = case nodes of + [] -> "" + x -> drop 23 (concatMap showCANSignalRxNode x) + +showCANSignalRxNode :: String -> String +showCANSignalRxNode x = " , " ++ show x ++ "\n" + diff --git a/src/CANViewDecompose.hs b/src/CANViewDecompose.hs new file mode 100644 --- /dev/null +++ b/src/CANViewDecompose.hs @@ -0,0 +1,273 @@ +module Main (main) where + +import qualified Data.ByteString.Char8 as BS +import Data.Bits +import Data.Char +import Data.List +import Data.Word +import Text.Printf +import System.Environment + +import CANData +import CANDB +import J1939Data + +data J1939Info = J1939Info + { msg_id :: Word32 + , priority :: Word8 + , edp :: Word8 + , dp :: Word8 + , pf :: Word8 + , ge :: Word8 + , pgn :: Word32 + , sa :: Word8 + , da :: Word8 + } deriving (Show, Ord, Eq) + +main :: IO () +main = do + args <- getArgs + case args of + ["-h"] -> help + ["--help"] -> help + [] -> processCANViewLine + _ -> help + +help :: IO () +help = putStrLn $ unlines + [ "" + , "NAME" + , " decomp - decompose J1939 messages from 'canview'" + , "" + , "EXAMPLE" + , " canview | decomp" + , " OR" + , " decomp < canview.log" + , "" + ] + +processCANViewLine :: IO () +processCANViewLine = do + line <- BS.getLine + decomposeLine line + processCANViewLine + +decomposeLine :: BS.ByteString -> IO () +decomposeLine line = do + BS.putStrLn line + printTime (getTime line) + printMsgInfo msgInfo + decomposePayload msgInfo (getPayload line) + BS.putStrLn (BS.pack "") + where + msgInfo = getInfo (getID line) + +decomposePayload :: J1939Info -> [Word8] -> IO () +--decomposePayload _ payload = printBytes payload +decomposePayload info payload = case (getCANMsg info) of + Nothing -> BS.putStrLn bs0 + where + bs0 = BS.pack $ concat + [ ":" + , concatMap formatHexBytes payload + ] + Just thisMsg -> do + BS.putStrLn bs0 + mapM_ (decomposeSignal payload) (canMsgSignals thisMsg) + where + bs0 = BS.pack $ concat + [ printf "%s:" messageName + , concatMap formatHexBytes payload + ] + messageName = canMsgName thisMsg + +formatHexBytes :: Word8 -> String +formatHexBytes x = printf " %02X" x + +decomposeSignal :: [Word8] -> CANSignal -> IO () +decomposeSignal payload thisSignal = BS.putStrLn bs0 + where + bs0 = BS.pack (printf (" %s: " ++ numberFmt) name signal) + name = canSignalName thisSignal + signal = decodeSignal payload thisSignal + numberFmt = case (canSignalFactor thisSignal) of + 1.0 -> "%.0f" + _ -> "%f" + +decodeSignal :: [Word8] -> CANSignal -> Float +decodeSignal payload signal = (fromIntegral binaryValue) * factor + offset + where + binaryValue = case (canSignalEndian signal) of + CANBigEndian -> getBinaryValueBE word64 signal + CANLittleEndian -> getBinaryValueLE word64 signal + factor = canSignalFactor signal + offset = canSignalOffset signal + word64 = toWord64 payload + +getBinaryValueLE :: Word64 -> CANSignal -> Word64 +getBinaryValueLE word64 signal = tmp2 .&. mask + where + tmp = shiftR word64 ((7 - endByte) * 8) + tmp1 = rearrangeBytesLEtoBE tmp numBytes + tmp2 = shiftR tmp1 (mod startBit 8) + mask = (shiftL 1 bitLength) - 1 + numBytes = 1 + (endByte - startByte) + startByte = div startBit 8 + endByte = div (startBit + bitLength -1) 8 + bitLength = fromIntegral $ canSignalBitLength signal + startBit = fromIntegral $ canSignalStartBit signal + +getBinaryValueBE :: Word64 -> CANSignal -> Word64 +getBinaryValueBE word64 signal = shiftedValue .&. mask + where + shiftedValue = shiftR word64 (getShiftAmount signal) + mask = (shiftL 1 bitLength) - 1 + bitLength = fromIntegral $ canSignalBitLength signal + +getShiftAmount :: CANSignal -> Int +getShiftAmount signal = 64 - bitLength - ((div startBit 8) * 8 + (7 - (mod startBit 8))) + where + bitLength = fromIntegral $ canSignalBitLength signal + startBit = fromIntegral $ canSignalStartBit signal + +rearrangeBytesLEtoBE :: Word64 -> Int -> Word64 +rearrangeBytesLEtoBE word64 numBytes = toWord64 rearranged + where + desiredBytes = drop (8 - numBytes) (fromWord64 word64) + numDontCare = 8 - numBytes + rearranged = (replicate numDontCare 0xFF) ++ (reverse desiredBytes) + +getCANMsg :: J1939Info -> Maybe CANMsg +getCANMsg info = find (isSamePGN (msg_id info)) (canDbMsgs canDB) + +isSamePGN :: Word32 -> CANMsg -> Bool +isSamePGN matchID thisMsg = matchPGN == thisPGN + where + thisPGN = getParameterGroupNumber thisID + matchPGN = getParameterGroupNumber matchID + thisID = canMsgId thisMsg + +--printBytes :: [Word8] -> IO () +--printBytes payload = do +-- BS.putStrLn bs0 +-- mapM_ printByte (zip [ 1 .. ] payload) +-- where +-- bs0 = BS.pack (printf " Payload:") +-- +--printByte :: (Int, Word8) -> IO () +--printByte (index, byte) = BS.putStrLn bs0 +-- where +-- bs0 = BS.pack (printf " Byte%d: %02X" index byte) + +getInfo :: Word32 -> J1939Info +getInfo x = J1939Info + { msg_id = x + , priority = getPriority x + , edp = getExtendedDataPage x + , dp = getDataPage x + , pf = pduFormat + , ge = globalExtension + , pgn = getParameterGroupNumber x + , sa = getSourceAddress x + , da = getDestinationAddress x + } + where + pduFormat = getPDUFormat x + globalExtension = getGlobalExtension x + +getPriority :: Word32 -> Word8 +getPriority x = fromIntegral $ (shiftR x 26) .&. 0x7 + +getExtendedDataPage :: Word32 -> Word8 +getExtendedDataPage x = fromIntegral $ (shiftR x 25) .&. 0x1 + +getDataPage :: Word32 -> Word8 +getDataPage x = fromIntegral $ (shiftR x 24) .&. 0x1 + +getPDUFormat :: Word32 -> Word8 +getPDUFormat x = fromIntegral $ (shiftR x 16) .&. 0xFF + +getGlobalExtension :: Word32 -> Word8 +getGlobalExtension x = fromIntegral $ (shiftR x 8) .&. 0xFF + +getSourceAddress :: Word32 -> Word8 +getSourceAddress x = fromIntegral $ x .&. 0xFF + +getParameterGroupNumber :: Word32 -> Word32 +getParameterGroupNumber x = if (getPDUFormat x) < 240 + then (shiftR x 8) .&. 0x3FF00 + else (shiftR x 8) .&. 0x3FFFF + +getDestinationAddress :: Word32 -> Word8 +getDestinationAddress x = if (getPDUFormat x) < 240 + then (getGlobalExtension x) + else 0xFE + +getItems :: [BS.ByteString] -> BS.ByteString -> [BS.ByteString] +getItems bss bs = case BS.null bs of + True -> bss + False -> getItems (bss ++ [nextItem]) rest + where + (nextItem, rest) = BS.span (not . isSpace) noLeadingSpace + noLeadingSpace = BS.dropWhile isSpace bs + +getTime :: BS.ByteString -> Word32 +getTime bs = read (BS.unpack (items !! 0)) + where + items = getItems [] bs + +getID :: BS.ByteString -> Word32 +getID bs = read (BS.unpack (items !! 1)) + where + items = getItems [] bs + +getPayload :: BS.ByteString -> [Word8] +getPayload bs = map read (map BS.unpack hexBytes) + where + hexBytes = map (BS.append searchPrefix) (hexPairs hexBS) + hexBS = case (BS.isPrefixOf searchPrefix payloadBS) of + True -> BS.drop 2 payloadBS + False -> payloadBS + searchPrefix = BS.pack "0x" + payloadBS = items !! 2 + items = getItems [] bs + +hexPairs :: BS.ByteString -> [BS.ByteString] +hexPairs bs + | BS.null bs = [] + | otherwise = BS.take 2 bs : hexPairs (BS.drop 2 bs) + +printTime :: Word32 -> IO () +printTime time = BS.putStrLn bs + where + bs = BS.pack (printf "Time: %9.3f" ms) + ms = ((fromIntegral time) :: Double) / 1000.0 + +printMsgInfo :: J1939Info -> IO () +printMsgInfo info = do + BS.putStrLn bs0 + BS.putStrLn bs1 + BS.putStrLn bs2 + BS.putStrLn bs3 + BS.putStrLn bs4 + BS.putStrLn bs5 + BS.putStrLn bs6 + BS.putStrLn bs7 + BS.putStrLn bs8 + where + bs0 = BS.pack (printf "Msg ID: 0x%08X" (msg_id info)) + bs1 = BS.pack (printf " Priority: %d" (priority info)) + bs2 = BS.pack (printf " ExtendedDataPage: %d" (edp info)) + bs3 = BS.pack (printf " DataPage: %d" (dp info)) + bs4 = BS.pack (printf " PDU Format: %d" (pf info)) + bs5 = BS.pack (printf " Global Extension: %d" (ge info)) + bs6 = BS.pack (printf " PGN: 0x%06X" (pgn info)) + bs7 = BS.pack (printf " Source Address: %d (%s)" (sa info) saName) + bs8 = BS.pack (printf " Destination Address: %d (%s)" (da info) daName) + saName = case (lookup (sa info) sourceAddressTable) of + Nothing -> error (printf "couldn't find name for source address 0x%02x" (sa info)) + Just name -> name + daName = case (lookup (da info) sourceAddressTable) of + Nothing -> error (printf "couldn't find name for destination address 0x%02x" (da info)) + Just name -> name +