diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,113 @@ +import BasicPrelude +import Criterion.Main +import qualified Data.Aeson as A +import qualified Data.Binary as B +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Lazy as LBS +import SwiftNav.SBP + +-- | Message length and dispatch overhead for SBP serialization and +-- deserialization (on local developer Macbook Pro). +-- +-- benchmarking JSON encoding/Encode short message (acq) +-- time 3.711 μs (3.538 μs .. 4.015 μs) +-- benchmarking JSON encoding/Encode wrapped message +-- time 7.883 μs (7.607 μs .. 8.135 μs) +-- benchmarking JSON encoding/Encode longer message (obs) +-- time 15.04 μs (14.59 μs .. 15.45 μs) +-- benchmarking JSON encoding/Encode longer wrapped message +-- time 20.90 μs (20.49 μs .. 21.40 μs) +-- benchmarking JSON encoding/Encode longer message (base) +-- time 3.762 μs (3.511 μs .. 4.082 μs) +-- benchmarking JSON encoding/Encode longer wrapped message +-- time 6.746 μs (6.564 μs .. 7.059 μs) +-- benchmarking Binary encoding/Encode short message (acq) +-- time 4.913 μs (4.425 μs .. 5.342 μs) +-- benchmarking Binary encoding/Encode wrapped message +-- time 6.213 μs (5.495 μs .. 7.044 μs) +-- benchmarking Binary encoding/Encode longer message (obs) +-- time 5.055 μs (4.596 μs .. 5.542 μs) +-- benchmarking Binary encoding/Encode longer wrapped message +-- time 5.200 μs (4.733 μs .. 5.698 μs) +-- benchmarking Binary encoding/Encode longer message (base) +-- time 6.353 μs (6.058 μs .. 6.676 μs) +-- benchmarking Binary encoding/Encode longer wrapped message +-- time 4.585 μs (4.146 μs .. 5.081 μs) +-- benchmarking Binary decoding/Decode short message +-- time 1.008 μs (976.0 ns .. 1.046 μs) +-- benchmarking Binary decoding/Decode longer message +-- time 3.211 μs (2.989 μs .. 3.449 μs) + +msgToEncode :: MsgAcqResult +msgToEncode = MsgAcqResult 2 2 2 3 + +msgToEncode' :: SBPMsg +msgToEncode' = SBPMsgAcqResult msgToEncode (toSBP msgToEncode defaultSender) + +msgToEncode1 :: MsgBaselineNed +msgToEncode1 = MsgBaselineNed 100000 1 1 1 1 1 1 1 + +msgToEncode1' :: SBPMsg +msgToEncode1' = SBPMsgBaselineNed msgToEncode1 (toSBP msgToEncode1 defaultSender) + +longMsgToEncode :: MsgObs +longMsgToEncode = MsgObs (ObservationHeader (ObsGPSTime 100000 1024) 4) + [ PackedObsContent 222222 (CarrierPhase 22 22) 2 2 0 + , PackedObsContent 222222 (CarrierPhase 22 22) 2 2 1 + , PackedObsContent 222222 (CarrierPhase 22 22) 2 2 2 + , PackedObsContent 222222 (CarrierPhase 22 22) 2 2 3 + ] + +longMsgToEncode' :: SBPMsg +longMsgToEncode' = SBPMsgObs longMsgToEncode (toSBP longMsgToEncode defaultSender) + +binaryToDecode :: ByteString +binaryToDecode = Base64.decodeLenient "VRUAwwQNzcx0QQAgQ0TkSpRFDhdL" + +longBinaryToDecode :: ByteString +longBinaryToDecode = Base64.decodeLenient "VUYAwwSwAAAAAAAATb4AAAAAAHpTwAAAAAAA6\ + \W5AAAAAAAA8z74AAAAAABzePgAAAAAAgHg+AA\ + \AAAAAAbD4K5reM1uYyPjZWxKT8Cv8/AAAAJPe\ + \/gD8AAKAFwSG0QLqKUYFY7wFAXtJ4qmoZQb5n\ + \1SCb48Lgv5wvaF1lN+8/xFNk/jM2BL4AAAAAM\ + \vI0PwAAAAAAAHK9AAAAAAAAAAAAAAAAgAwZQS\ + \4HAAAAAIAMGUEuBwEBHgCqIQ==" + +jsonEncode :: Benchmark +jsonEncode = do + bgroup "JSON encoding" + [ bench "Encode short message (acq)" $ nf A.encode msgToEncode + , bench "Encode wrapped message" $ nf A.encode msgToEncode' + , bench "Encode longer message (obs)" $ nf A.encode longMsgToEncode + , bench "Encode longer wrapped message" $ nf A.encode longMsgToEncode' + , bench "Encode longer message (base)" $ nf A.encode msgToEncode1 + , bench "Encode longer wrapped message" $ nf A.encode msgToEncode1' + ] + +binaryEncode :: Benchmark +binaryEncode = do + bgroup "Binary encoding" + [ bench "Encode short message (acq)" $ nf B.encode msgToEncode + , bench "Encode wrapped message" $ nf B.encode msgToEncode' + , bench "Encode longer message (obs)" $ nf B.encode longMsgToEncode + , bench "Encode longer wrapped message" $ nf B.encode longMsgToEncode' + , bench "Encode longer message (base)" $ nf B.encode msgToEncode1 + , bench "Encode longer wrapped message" $ nf B.encode msgToEncode1' + ] + +decodeSBP :: LBS.ByteString -> SBPMsg +decodeSBP x = B.decode x + +binaryDecode :: Benchmark +binaryDecode = do + bgroup "Binary decoding" + [ bench "Decode short message" $ whnf decodeSBP (LBS.fromStrict binaryToDecode) + , bench "Decode longer message" $ whnf decodeSBP (LBS.fromStrict longBinaryToDecode) + ] + +main :: IO () +main = do + defaultMain [ jsonEncode + , binaryEncode + , binaryDecode + ] diff --git a/sbp.cabal b/sbp.cabal --- a/sbp.cabal +++ b/sbp.cabal @@ -1,5 +1,5 @@ name: sbp -version: 0.50.9 +version: 0.51.1 synopsis: SwiftNav's SBP Library homepage: https://github.com/swift-nav/libsbp license: LGPL-3 @@ -38,6 +38,8 @@ , SwiftNav.SBP.System , SwiftNav.SBP.Tracking , SwiftNav.SBP.Encoding + , SwiftNav.SBP.Types + other-modules: SwiftNav.SBP.TH default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-imports -fno-warn-orphans @@ -51,6 +53,7 @@ , data-binary-ieee754 , lens , monad-loops + , template-haskell , text , unordered-containers default-extensions: RecordWildCards @@ -58,6 +61,23 @@ NoImplicitPrelude OverloadedStrings +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: aeson + , base + , base64-bytestring + , basic-prelude + , binary + , bytestring + , criterion + , sbp + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + OverloadedStrings + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test @@ -77,6 +97,7 @@ , Test.SwiftNav.SBP.Utils build-depends: aeson , base + , base64-bytestring , basic-prelude , bytestring , QuickCheck diff --git a/src/SwiftNav/SBP.hs b/src/SwiftNav/SBP.hs --- a/src/SwiftNav/SBP.hs +++ b/src/SwiftNav/SBP.hs @@ -9,10 +9,8 @@ -- SBP message containers. module SwiftNav.SBP - ( Msg (..) - , SBPMsg (..) - , msgSBPPreamble - , defaultSender + ( SBPMsg (..) + , module SwiftNav.SBP.Types , module SwiftNav.SBP.Acquisition , module SwiftNav.SBP.Bootload , module SwiftNav.SBP.ExtEvents @@ -49,88 +47,9 @@ import SwiftNav.SBP.Settings import SwiftNav.SBP.System import SwiftNav.SBP.Tracking +import SwiftNav.SBP.Types --- | Denotes the start of frame transmission. For v1.0, always 0x55. -msgSBPPreamble :: Word8 -msgSBPPreamble = 0x55 --- | Default sender ID. Intended for messages sent from the host to --- the device. -defaultSender :: Word16 -defaultSender = 0x42 - --- | Packet structure for Swift Navigation Binary Protocol (SBP). --- --- Definition of the over-the-wire message framing format and packet --- structure for Swift Navigation Binary Protocol (SBP), a minimal --- binary protocol for communicating with Swift devices. It is used --- to transmit solutions, observations, status and debugging --- messages, as well as receive messages from the host operating --- system. -data Msg = Msg - { _msgSBPType :: Word16 - -- ^ Uniquely identifies the type of the payload contents - , _msgSBPSender :: Word16 - -- ^ A unique identifier of the sending hardware. For v1.0, - -- set to the 2 least significant bytes of the device serial - -- number - , _msgSBPLen :: Word8 - -- ^ Byte-length of the payload field - , _msgSBPPayload :: !ByteString - -- ^ Binary data of the message, as identified by Message Type and - -- Length. Usually contains the in-memory binary representation of - -- a C struct (see documentation on individual message types) - , _msgSBPCrc :: Word16 - -- ^ Cyclic Redundancy Check (CRC) of the packet's binary data from - -- the Message Type up to the end of Payload (does not include the - -- Preamble) - } deriving ( Show, Read, Eq ) - -$(makeLenses ''Msg) - -instance Binary Msg where - get = do - _msgSBPType <- getWord16le - _msgSBPSender <- getWord16le - _msgSBPLen <- getWord8 - _msgSBPPayload <- getByteString $ fromIntegral _msgSBPLen - _msgSBPCrc <- getWord16le - return Msg {..} - - put Msg {..} = do - putWord16le _msgSBPType - putWord16le _msgSBPSender - putWord8 _msgSBPLen - putByteString _msgSBPPayload - putWord16le _msgSBPCrc - -checkCrc :: Msg -> Word16 -checkCrc Msg {..} = - crc16 $ toLazyByteString $ - word16LE _msgSBPType <> - word16LE _msgSBPSender <> - word8 _msgSBPLen <> - byteString _msgSBPPayload - -instance FromJSON Msg where - parseJSON (Object v) = do - Msg <$> v .: "msg_type" - <*> v .: "sender" - <*> v .: "length" - <*> v .: "payload" - <*> v .: "crc" - parseJSON _ = mzero - -instance ToJSON Msg where - toJSON Msg {..} = object - [ "preamble" .= msgSBPPreamble - , "msg_type" .= _msgSBPType - , "sender" .= _msgSBPSender - , "length" .= _msgSBPLen - , "payload" .= _msgSBPPayload - , "crc" .= _msgSBPCrc - ] - -- | An SBP message ADT composed of all defined SBP messages. -- -- Includes SBPMsgUnknown for valid SBP messages with undefined message @@ -141,6 +60,7 @@ | SBPMsgAlmanac MsgAlmanac Msg | SBPMsgBasePos MsgBasePos Msg | SBPMsgBaselineEcef MsgBaselineEcef Msg + | SBPMsgBaselineHeading MsgBaselineHeading Msg | SBPMsgBaselineNed MsgBaselineNed Msg | SBPMsgBootloaderHandshakeDepA MsgBootloaderHandshakeDepA Msg | SBPMsgBootloaderHandshakeReq MsgBootloaderHandshakeReq Msg @@ -219,6 +139,7 @@ | _msgSBPType == msgAlmanac = SBPMsgAlmanac (decode (fromStrict _msgSBPPayload)) sbp | _msgSBPType == msgBasePos = SBPMsgBasePos (decode (fromStrict _msgSBPPayload)) sbp | _msgSBPType == msgBaselineEcef = SBPMsgBaselineEcef (decode (fromStrict _msgSBPPayload)) sbp + | _msgSBPType == msgBaselineHeading = SBPMsgBaselineHeading (decode (fromStrict _msgSBPPayload)) sbp | _msgSBPType == msgBaselineNed = SBPMsgBaselineNed (decode (fromStrict _msgSBPPayload)) sbp | _msgSBPType == msgBootloaderHandshakeDepA = SBPMsgBootloaderHandshakeDepA (decode (fromStrict _msgSBPPayload)) sbp | _msgSBPType == msgBootloaderHandshakeReq = SBPMsgBootloaderHandshakeReq (decode (fromStrict _msgSBPPayload)) sbp @@ -291,6 +212,7 @@ encode' (SBPMsgAlmanac _ sbp) = sbp encode' (SBPMsgBasePos _ sbp) = sbp encode' (SBPMsgBaselineEcef _ sbp) = sbp + encode' (SBPMsgBaselineHeading _ sbp) = sbp encode' (SBPMsgBaselineNed _ sbp) = sbp encode' (SBPMsgBootloaderHandshakeDepA _ sbp) = sbp encode' (SBPMsgBootloaderHandshakeReq _ sbp) = sbp @@ -353,7 +275,7 @@ encode' (SBPMsgVelEcef _ sbp) = sbp encode' (SBPMsgVelNed _ sbp) = sbp encode' (SBPMsgUnknown sbp) = sbp - encode' (SBPMsgBadCrc sbp) = sbp + encode' (SBPMsgBadCrc sbp) = sbp instance FromJSON SBPMsg where parseJSON obj@(Object o) = do @@ -365,6 +287,7 @@ | msgType == msgAlmanac = SBPMsgAlmanac <$> parseJSON obj <*> parseJSON obj | msgType == msgBasePos = SBPMsgBasePos <$> parseJSON obj <*> parseJSON obj | msgType == msgBaselineEcef = SBPMsgBaselineEcef <$> parseJSON obj <*> parseJSON obj + | msgType == msgBaselineHeading = SBPMsgBaselineHeading <$> parseJSON obj <*> parseJSON obj | msgType == msgBaselineNed = SBPMsgBaselineNed <$> parseJSON obj <*> parseJSON obj | msgType == msgBootloaderHandshakeDepA = SBPMsgBootloaderHandshakeDepA <$> parseJSON obj <*> parseJSON obj | msgType == msgBootloaderHandshakeReq = SBPMsgBootloaderHandshakeReq <$> parseJSON obj <*> parseJSON obj @@ -441,6 +364,7 @@ toJSON (SBPMsgAlmanac msg sbp) = toJSON msg `merge` toJSON sbp toJSON (SBPMsgBasePos msg sbp) = toJSON msg `merge` toJSON sbp toJSON (SBPMsgBaselineEcef msg sbp) = toJSON msg `merge` toJSON sbp + toJSON (SBPMsgBaselineHeading msg sbp) = toJSON msg `merge` toJSON sbp toJSON (SBPMsgBaselineNed msg sbp) = toJSON msg `merge` toJSON sbp toJSON (SBPMsgBootloaderHandshakeDepA msg sbp) = toJSON msg `merge` toJSON sbp toJSON (SBPMsgBootloaderHandshakeReq msg sbp) = toJSON msg `merge` toJSON sbp diff --git a/src/SwiftNav/SBP/Acquisition.hs b/src/SwiftNav/SBP/Acquisition.hs --- a/src/SwiftNav/SBP/Acquisition.hs +++ b/src/SwiftNav/SBP/Acquisition.hs @@ -23,6 +23,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgAcqResult :: Word16 msgAcqResult = 0x0014 @@ -61,6 +63,8 @@ putFloat32le _msgAcqResult_cf putWord32le _msgAcqResult_sid +$(deriveSBP 'msgAcqResult ''MsgAcqResult) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgAcqResult_" . stripPrefix "_msgAcqResult_"} ''MsgAcqResult) $(makeLenses ''MsgAcqResult) @@ -97,6 +101,8 @@ putFloat32le _msgAcqResultDepA_cp putFloat32le _msgAcqResultDepA_cf putWord8 _msgAcqResultDepA_prn + +$(deriveSBP 'msgAcqResultDepA ''MsgAcqResultDepA) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgAcqResultDepA_" . stripPrefix "_msgAcqResultDepA_"} ''MsgAcqResultDepA) diff --git a/src/SwiftNav/SBP/Bootload.hs b/src/SwiftNav/SBP/Bootload.hs --- a/src/SwiftNav/SBP/Bootload.hs +++ b/src/SwiftNav/SBP/Bootload.hs @@ -26,6 +26,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgBootloaderHandshakeReq :: Word16 msgBootloaderHandshakeReq = 0x00B3 @@ -45,6 +47,8 @@ put MsgBootloaderHandshakeReq = return () +$(deriveSBP 'msgBootloaderHandshakeReq ''MsgBootloaderHandshakeReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBootloaderHandshakeReq_" . stripPrefix "_msgBootloaderHandshakeReq_"} ''MsgBootloaderHandshakeReq) $(makeLenses ''MsgBootloaderHandshakeReq) @@ -75,6 +79,8 @@ putWord32le _msgBootloaderHandshakeResp_flags putByteString _msgBootloaderHandshakeResp_version +$(deriveSBP 'msgBootloaderHandshakeResp ''MsgBootloaderHandshakeResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBootloaderHandshakeResp_" . stripPrefix "_msgBootloaderHandshakeResp_"} ''MsgBootloaderHandshakeResp) $(makeLenses ''MsgBootloaderHandshakeResp) @@ -98,6 +104,8 @@ put MsgBootloaderJumpToApp {..} = do putWord8 _msgBootloaderJumpToApp_jump +$(deriveSBP 'msgBootloaderJumpToApp ''MsgBootloaderJumpToApp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBootloaderJumpToApp_" . stripPrefix "_msgBootloaderJumpToApp_"} ''MsgBootloaderJumpToApp) $(makeLenses ''MsgBootloaderJumpToApp) @@ -122,6 +130,8 @@ put MsgNapDeviceDnaReq = return () +$(deriveSBP 'msgNapDeviceDnaReq ''MsgNapDeviceDnaReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgNapDeviceDnaReq_" . stripPrefix "_msgNapDeviceDnaReq_"} ''MsgNapDeviceDnaReq) $(makeLenses ''MsgNapDeviceDnaReq) @@ -150,6 +160,8 @@ put MsgNapDeviceDnaResp {..} = do mapM_ putWord8 _msgNapDeviceDnaResp_dna +$(deriveSBP 'msgNapDeviceDnaResp ''MsgNapDeviceDnaResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgNapDeviceDnaResp_" . stripPrefix "_msgNapDeviceDnaResp_"} ''MsgNapDeviceDnaResp) $(makeLenses ''MsgNapDeviceDnaResp) @@ -172,6 +184,8 @@ put MsgBootloaderHandshakeDepA {..} = do mapM_ putWord8 _msgBootloaderHandshakeDepA_handshake + +$(deriveSBP 'msgBootloaderHandshakeDepA ''MsgBootloaderHandshakeDepA) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBootloaderHandshakeDepA_" . stripPrefix "_msgBootloaderHandshakeDepA_"} ''MsgBootloaderHandshakeDepA) diff --git a/src/SwiftNav/SBP/ExtEvents.hs b/src/SwiftNav/SBP/ExtEvents.hs --- a/src/SwiftNav/SBP/ExtEvents.hs +++ b/src/SwiftNav/SBP/ExtEvents.hs @@ -24,6 +24,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgExtEvent :: Word16 msgExtEvent = 0x0101 @@ -61,6 +63,8 @@ putWord32le $ fromIntegral _msgExtEvent_ns putWord8 _msgExtEvent_flags putWord8 _msgExtEvent_pin + +$(deriveSBP 'msgExtEvent ''MsgExtEvent) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgExtEvent_" . stripPrefix "_msgExtEvent_"} ''MsgExtEvent) diff --git a/src/SwiftNav/SBP/FileIo.hs b/src/SwiftNav/SBP/FileIo.hs --- a/src/SwiftNav/SBP/FileIo.hs +++ b/src/SwiftNav/SBP/FileIo.hs @@ -30,6 +30,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgFileioReadReq :: Word16 msgFileioReadReq = 0x00A8 @@ -39,7 +41,10 @@ -- The file read message reads a certain length (up to 255 bytes) from a given -- offset into a file, and returns the data in a MSG_FILEIO_READ_RESP message -- where the message length field indicates how many bytes were succesfully --- read.The sequence number in the request will be returned in the response. +-- read.The sequence number in the request will be returned in the response. If +-- the message is invalid, a followup MSG_PRINT message will print "Invalid +-- fileio read message". A device will only respond to this message when it is +-- received from sender ID 0x42. data MsgFileioReadReq = MsgFileioReadReq { _msgFileioReadReq_sequence :: Word32 -- ^ Read sequence number @@ -65,6 +70,8 @@ putWord8 _msgFileioReadReq_chunk_size putByteString _msgFileioReadReq_filename +$(deriveSBP 'msgFileioReadReq ''MsgFileioReadReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioReadReq_" . stripPrefix "_msgFileioReadReq_"} ''MsgFileioReadReq) $(makeLenses ''MsgFileioReadReq) @@ -95,6 +102,8 @@ putWord32le _msgFileioReadResp_sequence mapM_ putWord8 _msgFileioReadResp_contents +$(deriveSBP 'msgFileioReadResp ''MsgFileioReadResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioReadResp_" . stripPrefix "_msgFileioReadResp_"} ''MsgFileioReadResp) $(makeLenses ''MsgFileioReadResp) @@ -109,7 +118,9 @@ -- first n elements of the file list. Returns a MSG_FILEIO_READ_DIR_RESP -- message containing the directory listings as a NULL delimited list. The -- listing is chunked over multiple SBP packets. The sequence number in the --- request will be returned in the response. +-- request will be returned in the response. If message is invalid, a followup +-- MSG_PRINT message will print "Invalid fileio read message". A device will +-- only respond to this message when it is received from sender ID 0x42. data MsgFileioReadDirReq = MsgFileioReadDirReq { _msgFileioReadDirReq_sequence :: Word32 -- ^ Read sequence number @@ -131,6 +142,8 @@ putWord32le _msgFileioReadDirReq_offset putByteString _msgFileioReadDirReq_dirname +$(deriveSBP 'msgFileioReadDirReq ''MsgFileioReadDirReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioReadDirReq_" . stripPrefix "_msgFileioReadDirReq_"} ''MsgFileioReadDirReq) $(makeLenses ''MsgFileioReadDirReq) @@ -162,6 +175,8 @@ putWord32le _msgFileioReadDirResp_sequence mapM_ putWord8 _msgFileioReadDirResp_contents +$(deriveSBP 'msgFileioReadDirResp ''MsgFileioReadDirResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioReadDirResp_" . stripPrefix "_msgFileioReadDirResp_"} ''MsgFileioReadDirResp) $(makeLenses ''MsgFileioReadDirResp) @@ -171,7 +186,10 @@ -- | SBP class for message MSG_FILEIO_REMOVE (0x00AC). -- --- The file remove message deletes a file from the file system. +-- The file remove message deletes a file from the file system. If the message +-- is invalid, a followup MSG_PRINT message will print "Invalid fileio remove +-- message". A device will only process this message when it is received from +-- sender ID 0x42. data MsgFileioRemove = MsgFileioRemove { _msgFileioRemove_filename :: ByteString -- ^ Name of the file to delete @@ -185,6 +203,8 @@ put MsgFileioRemove {..} = do putByteString _msgFileioRemove_filename +$(deriveSBP 'msgFileioRemove ''MsgFileioRemove) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioRemove_" . stripPrefix "_msgFileioRemove_"} ''MsgFileioRemove) $(makeLenses ''MsgFileioRemove) @@ -197,7 +217,10 @@ -- The file write message writes a certain length (up to 255 bytes) of data to -- a file at a given offset. Returns a copy of the original -- MSG_FILEIO_WRITE_RESP message to check integrity of the write. The sequence --- number in the request will be returned in the response. +-- number in the request will be returned in the response. If message is +-- invalid, a followup MSG_PRINT message will print "Invalid fileio write +-- message". A device will only process this message when it is received from +-- sender ID 0x42. data MsgFileioWriteReq = MsgFileioWriteReq { _msgFileioWriteReq_sequence :: Word32 -- ^ Write sequence number @@ -223,6 +246,8 @@ putByteString _msgFileioWriteReq_filename mapM_ putWord8 _msgFileioWriteReq_data +$(deriveSBP 'msgFileioWriteReq ''MsgFileioWriteReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioWriteReq_" . stripPrefix "_msgFileioWriteReq_"} ''MsgFileioWriteReq) $(makeLenses ''MsgFileioWriteReq) @@ -248,6 +273,8 @@ put MsgFileioWriteResp {..} = do putWord32le _msgFileioWriteResp_sequence + +$(deriveSBP 'msgFileioWriteResp ''MsgFileioWriteResp) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFileioWriteResp_" . stripPrefix "_msgFileioWriteResp_"} ''MsgFileioWriteResp) diff --git a/src/SwiftNav/SBP/Flash.hs b/src/SwiftNav/SBP/Flash.hs --- a/src/SwiftNav/SBP/Flash.hs +++ b/src/SwiftNav/SBP/Flash.hs @@ -27,6 +27,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgFlashProgram :: Word16 msgFlashProgram = 0x00E6 @@ -63,6 +65,8 @@ putWord8 _msgFlashProgram_addr_len mapM_ putWord8 _msgFlashProgram_data +$(deriveSBP 'msgFlashProgram ''MsgFlashProgram) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFlashProgram_" . stripPrefix "_msgFlashProgram_"} ''MsgFlashProgram) $(makeLenses ''MsgFlashProgram) @@ -89,6 +93,8 @@ put MsgFlashDone {..} = do putWord8 _msgFlashDone_response +$(deriveSBP 'msgFlashDone ''MsgFlashDone) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFlashDone_" . stripPrefix "_msgFlashDone_"} ''MsgFlashDone) $(makeLenses ''MsgFlashDone) @@ -125,6 +131,8 @@ mapM_ putWord8 _msgFlashReadReq_addr_start putWord8 _msgFlashReadReq_addr_len +$(deriveSBP 'msgFlashReadReq ''MsgFlashReadReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFlashReadReq_" . stripPrefix "_msgFlashReadReq_"} ''MsgFlashReadReq) $(makeLenses ''MsgFlashReadReq) @@ -161,6 +169,8 @@ mapM_ putWord8 _msgFlashReadResp_addr_start putWord8 _msgFlashReadResp_addr_len +$(deriveSBP 'msgFlashReadResp ''MsgFlashReadResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFlashReadResp_" . stripPrefix "_msgFlashReadResp_"} ''MsgFlashReadResp) $(makeLenses ''MsgFlashReadResp) @@ -191,6 +201,8 @@ putWord8 _msgFlashErase_target putWord32le _msgFlashErase_sector_num +$(deriveSBP 'msgFlashErase ''MsgFlashErase) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgFlashErase_" . stripPrefix "_msgFlashErase_"} ''MsgFlashErase) $(makeLenses ''MsgFlashErase) @@ -215,6 +227,8 @@ put MsgStmFlashLockSector {..} = do putWord32le _msgStmFlashLockSector_sector +$(deriveSBP 'msgStmFlashLockSector ''MsgStmFlashLockSector) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgStmFlashLockSector_" . stripPrefix "_msgStmFlashLockSector_"} ''MsgStmFlashLockSector) $(makeLenses ''MsgStmFlashLockSector) @@ -239,6 +253,8 @@ put MsgStmFlashUnlockSector {..} = do putWord32le _msgStmFlashUnlockSector_sector +$(deriveSBP 'msgStmFlashUnlockSector ''MsgStmFlashUnlockSector) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgStmFlashUnlockSector_" . stripPrefix "_msgStmFlashUnlockSector_"} ''MsgStmFlashUnlockSector) $(makeLenses ''MsgStmFlashUnlockSector) @@ -261,6 +277,8 @@ put MsgStmUniqueIdReq = return () +$(deriveSBP 'msgStmUniqueIdReq ''MsgStmUniqueIdReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgStmUniqueIdReq_" . stripPrefix "_msgStmUniqueIdReq_"} ''MsgStmUniqueIdReq) $(makeLenses ''MsgStmUniqueIdReq) @@ -286,6 +304,8 @@ put MsgStmUniqueIdResp {..} = do mapM_ putWord8 _msgStmUniqueIdResp_stm_id +$(deriveSBP 'msgStmUniqueIdResp ''MsgStmUniqueIdResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgStmUniqueIdResp_" . stripPrefix "_msgStmUniqueIdResp_"} ''MsgStmUniqueIdResp) $(makeLenses ''MsgStmUniqueIdResp) @@ -309,6 +329,8 @@ put MsgM25FlashWriteStatus {..} = do mapM_ putWord8 _msgM25FlashWriteStatus_status + +$(deriveSBP 'msgM25FlashWriteStatus ''MsgM25FlashWriteStatus) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgM25FlashWriteStatus_" . stripPrefix "_msgM25FlashWriteStatus_"} ''MsgM25FlashWriteStatus) diff --git a/src/SwiftNav/SBP/Logging.hs b/src/SwiftNav/SBP/Logging.hs --- a/src/SwiftNav/SBP/Logging.hs +++ b/src/SwiftNav/SBP/Logging.hs @@ -24,6 +24,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgLog :: Word16 msgLog = 0x0401 @@ -50,6 +52,8 @@ putWord8 _msgLog_level putByteString _msgLog_text +$(deriveSBP 'msgLog ''MsgLog) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgLog_" . stripPrefix "_msgLog_"} ''MsgLog) $(makeLenses ''MsgLog) @@ -73,6 +77,8 @@ put MsgTweet {..} = do putByteString _msgTweet_tweet +$(deriveSBP 'msgTweet ''MsgTweet) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgTweet_" . stripPrefix "_msgTweet_"} ''MsgTweet) $(makeLenses ''MsgTweet) @@ -95,6 +101,8 @@ put MsgPrintDep {..} = do putByteString _msgPrintDep_text + +$(deriveSBP 'msgPrintDep ''MsgPrintDep) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgPrintDep_" . stripPrefix "_msgPrintDep_"} ''MsgPrintDep) diff --git a/src/SwiftNav/SBP/Navigation.hs b/src/SwiftNav/SBP/Navigation.hs --- a/src/SwiftNav/SBP/Navigation.hs +++ b/src/SwiftNav/SBP/Navigation.hs @@ -31,6 +31,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgGpsTime :: Word16 msgGpsTime = 0x0100 @@ -72,6 +74,8 @@ putWord32le $ fromIntegral _msgGpsTime_ns putWord8 _msgGpsTime_flags +$(deriveSBP 'msgGpsTime ''MsgGpsTime) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgGpsTime_" . stripPrefix "_msgGpsTime_"} ''MsgGpsTime) $(makeLenses ''MsgGpsTime) @@ -116,6 +120,8 @@ putWord16le _msgDops_hdop putWord16le _msgDops_vdop +$(deriveSBP 'msgDops ''MsgDops) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgDops_" . stripPrefix "_msgDops_"} ''MsgDops) $(makeLenses ''MsgDops) @@ -169,6 +175,8 @@ putWord8 _msgPosEcef_n_sats putWord8 _msgPosEcef_flags +$(deriveSBP 'msgPosEcef ''MsgPosEcef) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgPosEcef_" . stripPrefix "_msgPosEcef_"} ''MsgPosEcef) $(makeLenses ''MsgPosEcef) @@ -226,6 +234,8 @@ putWord8 _msgPosLlh_n_sats putWord8 _msgPosLlh_flags +$(deriveSBP 'msgPosLlh ''MsgPosLlh) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgPosLlh_" . stripPrefix "_msgPosLlh_"} ''MsgPosLlh) $(makeLenses ''MsgPosLlh) @@ -276,6 +286,8 @@ putWord8 _msgBaselineEcef_n_sats putWord8 _msgBaselineEcef_flags +$(deriveSBP 'msgBaselineEcef ''MsgBaselineEcef) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBaselineEcef_" . stripPrefix "_msgBaselineEcef_"} ''MsgBaselineEcef) $(makeLenses ''MsgBaselineEcef) @@ -332,6 +344,8 @@ putWord8 _msgBaselineNed_n_sats putWord8 _msgBaselineNed_flags +$(deriveSBP 'msgBaselineNed ''MsgBaselineNed) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBaselineNed_" . stripPrefix "_msgBaselineNed_"} ''MsgBaselineNed) $(makeLenses ''MsgBaselineNed) @@ -381,6 +395,8 @@ putWord8 _msgVelEcef_n_sats putWord8 _msgVelEcef_flags +$(deriveSBP 'msgVelEcef ''MsgVelEcef) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgVelEcef_" . stripPrefix "_msgVelEcef_"} ''MsgVelEcef) $(makeLenses ''MsgVelEcef) @@ -434,6 +450,47 @@ putWord8 _msgVelNed_n_sats putWord8 _msgVelNed_flags +$(deriveSBP 'msgVelNed ''MsgVelNed) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgVelNed_" . stripPrefix "_msgVelNed_"} ''MsgVelNed) $(makeLenses ''MsgVelNed) + +msgBaselineHeading :: Word16 +msgBaselineHeading = 0x0207 + +-- | SBP class for message MSG_BASELINE_HEADING (0x0207). +-- +-- This message reports the baseline heading pointing from the base station to +-- the rover relative to North. The full GPS time is given by the preceding +-- MSG_GPS_TIME with the matching time-of-week (tow). +data MsgBaselineHeading = MsgBaselineHeading + { _msgBaselineHeading_tow :: Word32 + -- ^ GPS Time of Week + , _msgBaselineHeading_heading :: Word32 + -- ^ Heading + , _msgBaselineHeading_n_sats :: Word8 + -- ^ Number of satellites used in solution + , _msgBaselineHeading_flags :: Word8 + -- ^ Status flags + } deriving ( Show, Read, Eq ) + +instance Binary MsgBaselineHeading where + get = do + _msgBaselineHeading_tow <- getWord32le + _msgBaselineHeading_heading <- getWord32le + _msgBaselineHeading_n_sats <- getWord8 + _msgBaselineHeading_flags <- getWord8 + return MsgBaselineHeading {..} + + put MsgBaselineHeading {..} = do + putWord32le _msgBaselineHeading_tow + putWord32le _msgBaselineHeading_heading + putWord8 _msgBaselineHeading_n_sats + putWord8 _msgBaselineHeading_flags + +$(deriveSBP 'msgBaselineHeading ''MsgBaselineHeading) + +$(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBaselineHeading_" . stripPrefix "_msgBaselineHeading_"} + ''MsgBaselineHeading) +$(makeLenses ''MsgBaselineHeading) diff --git a/src/SwiftNav/SBP/Observation.hs b/src/SwiftNav/SBP/Observation.hs --- a/src/SwiftNav/SBP/Observation.hs +++ b/src/SwiftNav/SBP/Observation.hs @@ -23,6 +23,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types -- | ObsGPSTime. -- @@ -44,7 +46,6 @@ put ObsGPSTime {..} = do putWord32le _obsGPSTime_tow putWord16le _obsGPSTime_wn - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_obsGPSTime_" . stripPrefix "_obsGPSTime_"} ''ObsGPSTime) $(makeLenses ''ObsGPSTime) @@ -70,7 +71,6 @@ put CarrierPhase {..} = do putWord32le $ fromIntegral _carrierPhase_i putWord8 _carrierPhase_f - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_carrierPhase_" . stripPrefix "_carrierPhase_"} ''CarrierPhase) $(makeLenses ''CarrierPhase) @@ -95,7 +95,6 @@ put ObservationHeader {..} = do put _observationHeader_t putWord8 _observationHeader_n_obs - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_observationHeader_" . stripPrefix "_observationHeader_"} ''ObservationHeader) $(makeLenses ''ObservationHeader) @@ -135,7 +134,6 @@ putWord8 _packedObsContent_cn0 putWord16le _packedObsContent_lock putWord32le _packedObsContent_sid - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_packedObsContent_" . stripPrefix "_packedObsContent_"} ''PackedObsContent) $(makeLenses ''PackedObsContent) @@ -166,6 +164,8 @@ put _msgObs_header mapM_ put _msgObs_obs +$(deriveSBP 'msgObs ''MsgObs) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgObs_" . stripPrefix "_msgObs_"} ''MsgObs) $(makeLenses ''MsgObs) @@ -200,6 +200,8 @@ putFloat64le _msgBasePos_lon putFloat64le _msgBasePos_height +$(deriveSBP 'msgBasePos ''MsgBasePos) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgBasePos_" . stripPrefix "_msgBasePos_"} ''MsgBasePos) $(makeLenses ''MsgBasePos) @@ -344,6 +346,8 @@ putWord16le _msgEphemeris_iodc putWord32le _msgEphemeris_reserved +$(deriveSBP 'msgEphemeris ''MsgEphemeris) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgEphemeris_" . stripPrefix "_msgEphemeris_"} ''MsgEphemeris) $(makeLenses ''MsgEphemeris) @@ -471,6 +475,8 @@ putWord8 _msgEphemerisDepA_healthy putWord8 _msgEphemerisDepA_prn +$(deriveSBP 'msgEphemerisDepA ''MsgEphemerisDepA) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgEphemerisDepA_" . stripPrefix "_msgEphemerisDepA_"} ''MsgEphemerisDepA) $(makeLenses ''MsgEphemerisDepA) @@ -602,6 +608,8 @@ putWord8 _msgEphemerisDepB_prn putWord8 _msgEphemerisDepB_iode +$(deriveSBP 'msgEphemerisDepB ''MsgEphemerisDepB) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgEphemerisDepB_" . stripPrefix "_msgEphemerisDepB_"} ''MsgEphemerisDepB) $(makeLenses ''MsgEphemerisDepB) @@ -639,7 +647,6 @@ putWord8 _packedObsContentDepA_cn0 putWord16le _packedObsContentDepA_lock putWord8 _packedObsContentDepA_prn - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_packedObsContentDepA_" . stripPrefix "_packedObsContentDepA_"} ''PackedObsContentDepA) $(makeLenses ''PackedObsContentDepA) @@ -666,6 +673,8 @@ put MsgObsDepA {..} = do put _msgObsDepA_header mapM_ put _msgObsDepA_obs + +$(deriveSBP 'msgObsDepA ''MsgObsDepA) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgObsDepA_" . stripPrefix "_msgObsDepA_"} ''MsgObsDepA) diff --git a/src/SwiftNav/SBP/Piksi.hs b/src/SwiftNav/SBP/Piksi.hs --- a/src/SwiftNav/SBP/Piksi.hs +++ b/src/SwiftNav/SBP/Piksi.hs @@ -26,6 +26,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgAlmanac :: Word16 msgAlmanac = 0x0069 @@ -44,6 +46,8 @@ put MsgAlmanac = return () +$(deriveSBP 'msgAlmanac ''MsgAlmanac) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgAlmanac_" . stripPrefix "_msgAlmanac_"} ''MsgAlmanac) $(makeLenses ''MsgAlmanac) @@ -65,6 +69,8 @@ put MsgSetTime = return () +$(deriveSBP 'msgSetTime ''MsgSetTime) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSetTime_" . stripPrefix "_msgSetTime_"} ''MsgSetTime) $(makeLenses ''MsgSetTime) @@ -85,6 +91,8 @@ put MsgReset = return () +$(deriveSBP 'msgReset ''MsgReset) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgReset_" . stripPrefix "_msgReset_"} ''MsgReset) $(makeLenses ''MsgReset) @@ -107,6 +115,8 @@ put MsgCwResults = return () +$(deriveSBP 'msgCwResults ''MsgCwResults) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgCwResults_" . stripPrefix "_msgCwResults_"} ''MsgCwResults) $(makeLenses ''MsgCwResults) @@ -129,6 +139,8 @@ put MsgCwStart = return () +$(deriveSBP 'msgCwStart ''MsgCwStart) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgCwStart_" . stripPrefix "_msgCwStart_"} ''MsgCwStart) $(makeLenses ''MsgCwStart) @@ -153,6 +165,8 @@ put MsgResetFilters {..} = do putWord8 _msgResetFilters_filter +$(deriveSBP 'msgResetFilters ''MsgResetFilters) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgResetFilters_" . stripPrefix "_msgResetFilters_"} ''MsgResetFilters) $(makeLenses ''MsgResetFilters) @@ -176,6 +190,8 @@ put MsgInitBase = return () +$(deriveSBP 'msgInitBase ''MsgInitBase) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgInitBase_" . stripPrefix "_msgInitBase_"} ''MsgInitBase) $(makeLenses ''MsgInitBase) @@ -210,6 +226,8 @@ putWord16le _msgThreadState_cpu putWord32le _msgThreadState_stack_free +$(deriveSBP 'msgThreadState ''MsgThreadState) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgThreadState_" . stripPrefix "_msgThreadState_"} ''MsgThreadState) $(makeLenses ''MsgThreadState) @@ -250,7 +268,6 @@ putWord16le _uARTChannel_io_error_count putWord8 _uARTChannel_tx_buffer_level putWord8 _uARTChannel_rx_buffer_level - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_uARTChannel_" . stripPrefix "_uARTChannel_"} ''UARTChannel) $(makeLenses ''UARTChannel) @@ -285,7 +302,6 @@ putWord32le $ fromIntegral _latency_lmin putWord32le $ fromIntegral _latency_lmax putWord32le $ fromIntegral _latency_current - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_latency_" . stripPrefix "_latency_"} ''Latency) $(makeLenses ''Latency) @@ -325,6 +341,8 @@ put _msgUartState_uart_ftdi put _msgUartState_latency +$(deriveSBP 'msgUartState ''MsgUartState) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgUartState_" . stripPrefix "_msgUartState_"} ''MsgUartState) $(makeLenses ''MsgUartState) @@ -350,6 +368,8 @@ put MsgIarState {..} = do putWord32le _msgIarState_num_hyps +$(deriveSBP 'msgIarState ''MsgIarState) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgIarState_" . stripPrefix "_msgIarState_"} ''MsgIarState) $(makeLenses ''MsgIarState) @@ -377,6 +397,8 @@ put MsgMaskSatellite {..} = do putWord8 _msgMaskSatellite_mask putWord32le _msgMaskSatellite_sid + +$(deriveSBP 'msgMaskSatellite ''MsgMaskSatellite) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgMaskSatellite_" . stripPrefix "_msgMaskSatellite_"} ''MsgMaskSatellite) diff --git a/src/SwiftNav/SBP/Settings.hs b/src/SwiftNav/SBP/Settings.hs --- a/src/SwiftNav/SBP/Settings.hs +++ b/src/SwiftNav/SBP/Settings.hs @@ -28,6 +28,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgSettingsSave :: Word16 msgSettingsSave = 0x00A1 @@ -46,6 +48,8 @@ put MsgSettingsSave = return () +$(deriveSBP 'msgSettingsSave ''MsgSettingsSave) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsSave_" . stripPrefix "_msgSettingsSave_"} ''MsgSettingsSave) $(makeLenses ''MsgSettingsSave) @@ -55,11 +59,12 @@ -- | SBP class for message MSG_SETTINGS_WRITE (0x00A0). -- --- The setting message writes the device's configuration. +-- The setting message writes the device configuration. data MsgSettingsWrite = MsgSettingsWrite { _msgSettingsWrite_setting :: ByteString -- ^ A NULL-terminated and delimited string with contents [SECTION_SETTING, - -- SETTING, VALUE]. + -- SETTING, VALUE]. A device will only process to this message when it is + -- received from sender ID 0x42. } deriving ( Show, Read, Eq ) instance Binary MsgSettingsWrite where @@ -70,6 +75,8 @@ put MsgSettingsWrite {..} = do putByteString _msgSettingsWrite_setting +$(deriveSBP 'msgSettingsWrite ''MsgSettingsWrite) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsWrite_" . stripPrefix "_msgSettingsWrite_"} ''MsgSettingsWrite) $(makeLenses ''MsgSettingsWrite) @@ -79,11 +86,12 @@ -- | SBP class for message MSG_SETTINGS_READ_REQ (0x00A4). -- --- The setting message reads the device's configuration. +-- The setting message reads the devices configuration. data MsgSettingsReadReq = MsgSettingsReadReq { _msgSettingsReadReq_setting :: ByteString -- ^ A NULL-terminated and delimited string with contents [SECTION_SETTING, - -- SETTING]. + -- SETTING]. A device will only respond to this message when it is received + -- from sender ID 0x42. } deriving ( Show, Read, Eq ) instance Binary MsgSettingsReadReq where @@ -94,6 +102,8 @@ put MsgSettingsReadReq {..} = do putByteString _msgSettingsReadReq_setting +$(deriveSBP 'msgSettingsReadReq ''MsgSettingsReadReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsReadReq_" . stripPrefix "_msgSettingsReadReq_"} ''MsgSettingsReadReq) $(makeLenses ''MsgSettingsReadReq) @@ -103,7 +113,7 @@ -- | SBP class for message MSG_SETTINGS_READ_RESP (0x00A5). -- --- The setting message reads the device's configuration. +-- The setting message reads the devices configuration. data MsgSettingsReadResp = MsgSettingsReadResp { _msgSettingsReadResp_setting :: ByteString -- ^ A NULL-terminated and delimited string with contents [SECTION_SETTING, @@ -118,6 +128,8 @@ put MsgSettingsReadResp {..} = do putByteString _msgSettingsReadResp_setting +$(deriveSBP 'msgSettingsReadResp ''MsgSettingsReadResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsReadResp_" . stripPrefix "_msgSettingsReadResp_"} ''MsgSettingsReadResp) $(makeLenses ''MsgSettingsReadResp) @@ -129,7 +141,8 @@ -- -- The settings message for iterating through the settings values. It will read -- the setting at an index, returning a NULL-terminated and delimited string --- with contents [SECTION_SETTING, SETTING, VALUE]. +-- with contents [SECTION_SETTING, SETTING, VALUE]. A device will only respond +-- to this message when it is received from sender ID 0x42. data MsgSettingsReadByIndexReq = MsgSettingsReadByIndexReq { _msgSettingsReadByIndexReq_index :: Word16 -- ^ An index into the device settings, with values ranging from 0 to @@ -144,6 +157,8 @@ put MsgSettingsReadByIndexReq {..} = do putWord16le _msgSettingsReadByIndexReq_index +$(deriveSBP 'msgSettingsReadByIndexReq ''MsgSettingsReadByIndexReq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsReadByIndexReq_" . stripPrefix "_msgSettingsReadByIndexReq_"} ''MsgSettingsReadByIndexReq) $(makeLenses ''MsgSettingsReadByIndexReq) @@ -175,6 +190,8 @@ putWord16le _msgSettingsReadByIndexResp_index putByteString _msgSettingsReadByIndexResp_setting +$(deriveSBP 'msgSettingsReadByIndexResp ''MsgSettingsReadByIndexResp) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsReadByIndexResp_" . stripPrefix "_msgSettingsReadByIndexResp_"} ''MsgSettingsReadByIndexResp) $(makeLenses ''MsgSettingsReadByIndexResp) @@ -194,6 +211,8 @@ put MsgSettingsReadByIndexDone = return () + +$(deriveSBP 'msgSettingsReadByIndexDone ''MsgSettingsReadByIndexDone) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgSettingsReadByIndexDone_" . stripPrefix "_msgSettingsReadByIndexDone_"} ''MsgSettingsReadByIndexDone) diff --git a/src/SwiftNav/SBP/System.hs b/src/SwiftNav/SBP/System.hs --- a/src/SwiftNav/SBP/System.hs +++ b/src/SwiftNav/SBP/System.hs @@ -23,6 +23,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types msgStartup :: Word16 msgStartup = 0xFF00 @@ -45,6 +47,8 @@ put MsgStartup {..} = do putWord32le _msgStartup_reserved +$(deriveSBP 'msgStartup ''MsgStartup) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgStartup_" . stripPrefix "_msgStartup_"} ''MsgStartup) $(makeLenses ''MsgStartup) @@ -73,6 +77,8 @@ put MsgHeartbeat {..} = do putWord32le _msgHeartbeat_flags + +$(deriveSBP 'msgHeartbeat ''MsgHeartbeat) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgHeartbeat_" . stripPrefix "_msgHeartbeat_"} ''MsgHeartbeat) diff --git a/src/SwiftNav/SBP/TH.hs b/src/SwiftNav/SBP/TH.hs new file mode 100644 --- /dev/null +++ b/src/SwiftNav/SBP/TH.hs @@ -0,0 +1,31 @@ +-- | +-- Module: SwiftNav.SBP.TH +-- Copyright: Copyright (C) 2015 Swift Navigation, Inc. +-- License: LGPL-3 +-- Maintainer: Mark Fine +-- Stability: experimental +-- Portability: portable +-- +-- Templated generation of SBP interfaces. + +module SwiftNav.SBP.TH where + +import BasicPrelude +import Control.Lens +import Data.Binary +import Data.ByteString +import Data.ByteString.Lazy hiding ( ByteString ) +import Data.Word +import Language.Haskell.TH +import SwiftNav.SBP.Types + +-- | Derive ToSBP typeclass, given an SBP message type name and the +-- name of the implemented type. +deriveSBP :: Name -> Name -> Q [Dec] +deriveSBP msgType name = [d|instance ToSBP $(conT name) where + toSBP msg senderID = encoded & msgSBPCrc .~ checkCrc encoded + where + payload = toStrict $ encode msg + len = fromIntegral $ Data.ByteString.length payload + encoded = Msg $(varE msgType) senderID len payload 0 + |] diff --git a/src/SwiftNav/SBP/Tracking.hs b/src/SwiftNav/SBP/Tracking.hs --- a/src/SwiftNav/SBP/Tracking.hs +++ b/src/SwiftNav/SBP/Tracking.hs @@ -23,6 +23,8 @@ import Data.Int import Data.Word import SwiftNav.SBP.Encoding +import SwiftNav.SBP.TH +import SwiftNav.SBP.Types -- | TrackingChannelState. -- @@ -50,7 +52,6 @@ putWord8 _trackingChannelState_state putWord32le _trackingChannelState_sid putFloat32le _trackingChannelState_cn0 - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_trackingChannelState_" . stripPrefix "_trackingChannelState_"} ''TrackingChannelState) $(makeLenses ''TrackingChannelState) @@ -76,6 +77,8 @@ put MsgTrackingState {..} = do mapM_ put _msgTrackingState_states +$(deriveSBP 'msgTrackingState ''MsgTrackingState) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgTrackingState_" . stripPrefix "_msgTrackingState_"} ''MsgTrackingState) $(makeLenses ''MsgTrackingState) @@ -99,7 +102,6 @@ put TrackingChannelCorrelation {..} = do putWord32le $ fromIntegral _trackingChannelCorrelation_I putWord32le $ fromIntegral _trackingChannelCorrelation_Q - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_trackingChannelCorrelation_" . stripPrefix "_trackingChannelCorrelation_"} ''TrackingChannelCorrelation) $(makeLenses ''TrackingChannelCorrelation) @@ -134,6 +136,8 @@ putWord32le _msgTrackingIq_sid mapM_ put _msgTrackingIq_corrs +$(deriveSBP 'msgTrackingIq ''MsgTrackingIq) + $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgTrackingIq_" . stripPrefix "_msgTrackingIq_"} ''MsgTrackingIq) $(makeLenses ''MsgTrackingIq) @@ -161,7 +165,6 @@ putWord8 _trackingChannelStateDepA_state putWord8 _trackingChannelStateDepA_prn putFloat32le _trackingChannelStateDepA_cn0 - $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_trackingChannelStateDepA_" . stripPrefix "_trackingChannelStateDepA_"} ''TrackingChannelStateDepA) $(makeLenses ''TrackingChannelStateDepA) @@ -184,6 +187,8 @@ put MsgTrackingStateDepA {..} = do mapM_ put _msgTrackingStateDepA_states + +$(deriveSBP 'msgTrackingStateDepA ''MsgTrackingStateDepA) $(deriveJSON defaultOptions {fieldLabelModifier = fromMaybe "_msgTrackingStateDepA_" . stripPrefix "_msgTrackingStateDepA_"} ''MsgTrackingStateDepA) diff --git a/src/SwiftNav/SBP/Types.hs b/src/SwiftNav/SBP/Types.hs new file mode 100644 --- /dev/null +++ b/src/SwiftNav/SBP/Types.hs @@ -0,0 +1,111 @@ +-- | +-- Module: SwiftNav.SBP.Types +-- Copyright: Copyright (C) 2015 Swift Navigation, Inc. +-- License: LGPL-3 +-- Maintainer: Mark Fine +-- Stability: experimental +-- Portability: portable +-- +-- Common SBP type requirements, containers, and serialization +-- utilities. + +module SwiftNav.SBP.Types where + +import BasicPrelude hiding (lookup) +import Control.Lens hiding ((.=)) +import Data.Aeson hiding (decode, decode') +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Lazy hiding (ByteString) +import Data.ByteString.Builder +import SwiftNav.CRC16 +import SwiftNav.SBP.Encoding + +-- | Denotes the start of frame transmission. For v1.0, always 0x55. +msgSBPPreamble :: Word8 +msgSBPPreamble = 0x55 + +-- | Default sender ID. Intended for messages sent from the host to +-- the device. +defaultSender :: Word16 +defaultSender = 0x42 + +-- | Packet structure for Swift Navigation Binary Protocol (SBP). +-- +-- Definition of the over-the-wire message framing format and packet +-- structure for Swift Navigation Binary Protocol (SBP), a minimal +-- binary protocol for communicating with Swift devices. It is used +-- to transmit solutions, observations, status and debugging +-- messages, as well as receive messages from the host operating +-- system. +data Msg = Msg + { _msgSBPType :: Word16 + -- ^ Uniquely identifies the type of the payload contents + , _msgSBPSender :: Word16 + -- ^ A unique identifier of the sending hardware. For v1.0, + -- set to the 2 least significant bytes of the device serial + -- number + , _msgSBPLen :: Word8 + -- ^ Byte-length of the payload field + , _msgSBPPayload :: !ByteString + -- ^ Binary data of the message, as identified by Message Type and + -- Length. Usually contains the in-memory binary representation of + -- a C struct (see documentation on individual message types) + , _msgSBPCrc :: Word16 + -- ^ Cyclic Redundancy Check (CRC) of the packet's binary data from + -- the Message Type up to the end of Payload (does not include the + -- Preamble) + } deriving ( Show, Read, Eq ) + +$(makeLenses ''Msg) + +instance Binary Msg where + get = do + _msgSBPType <- getWord16le + _msgSBPSender <- getWord16le + _msgSBPLen <- getWord8 + _msgSBPPayload <- getByteString $ fromIntegral _msgSBPLen + _msgSBPCrc <- getWord16le + return Msg {..} + + put Msg {..} = do + putWord16le _msgSBPType + putWord16le _msgSBPSender + putWord8 _msgSBPLen + putByteString _msgSBPPayload + putWord16le _msgSBPCrc + +checkCrc :: Msg -> Word16 +checkCrc Msg {..} = + crc16 $ toLazyByteString $ + word16LE _msgSBPType <> + word16LE _msgSBPSender <> + word8 _msgSBPLen <> + byteString _msgSBPPayload + +instance FromJSON Msg where + parseJSON (Object v) = do + Msg <$> v .: "msg_type" + <*> v .: "sender" + <*> v .: "length" + <*> v .: "payload" + <*> v .: "crc" + parseJSON _ = mzero + +instance ToJSON Msg where + toJSON Msg {..} = object + [ "preamble" .= msgSBPPreamble + , "msg_type" .= _msgSBPType + , "sender" .= _msgSBPSender + , "length" .= _msgSBPLen + , "payload" .= _msgSBPPayload + , "crc" .= _msgSBPCrc + ] + +-- | Class of generic representation of specialized SBP messages into +-- SBP message frames. +class Binary a => ToSBP a where + -- | Convert an SBP message record that is serializable and a two-byte + -- senderID to a binary into an SBP message frame. + toSBP :: a -> Word16 -> Msg