{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}

-- |
-- Module:      SwiftNav.SBP.Types
-- Copyright:   Copyright (C) 2015-2021 Swift Navigation, Inc.
-- License:     MIT
-- Contact:     https://support.swiftnav.com
-- Stability:   experimental
-- Portability: portable
--
-- Common SBP type requirements, containers, and serialization
-- utilities.
--

module SwiftNav.SBP.Types
  ( module SwiftNav.SBP.Types
  ) where

import BasicPrelude
import Control.Lens             hiding ((.=))
import Data.Aeson
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString.Base64   as Base64
import Data.ByteString.Builder
import Data.Text.Encoding
import Data.Text.Encoding.Error
import SwiftNav.CRC16

-- | Denotes the start of frame transmission. For v1.0, always 0x55.
msgSBPPreamble :: Word8
msgSBPPreamble :: Word8
msgSBPPreamble = Word8
0x55

-- | Default sender ID. Intended for messages sent from the host to
-- the device.
defaultSender :: Word16
defaultSender :: Word16
defaultSender = Word16
0x42

-- | Wrapper around ByteString for *JSON and Binary typeclass instances.
newtype Bytes = Bytes
  { Bytes -> ByteString
unBytes :: ByteString
  } deriving ( Int -> Bytes -> ShowS
[Bytes] -> ShowS
Bytes -> String
(Int -> Bytes -> ShowS)
-> (Bytes -> String) -> ([Bytes] -> ShowS) -> Show Bytes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bytes] -> ShowS
$cshowList :: [Bytes] -> ShowS
show :: Bytes -> String
$cshow :: Bytes -> String
showsPrec :: Int -> Bytes -> ShowS
$cshowsPrec :: Int -> Bytes -> ShowS
Show, ReadPrec [Bytes]
ReadPrec Bytes
Int -> ReadS Bytes
ReadS [Bytes]
(Int -> ReadS Bytes)
-> ReadS [Bytes]
-> ReadPrec Bytes
-> ReadPrec [Bytes]
-> Read Bytes
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Bytes]
$creadListPrec :: ReadPrec [Bytes]
readPrec :: ReadPrec Bytes
$creadPrec :: ReadPrec Bytes
readList :: ReadS [Bytes]
$creadList :: ReadS [Bytes]
readsPrec :: Int -> ReadS Bytes
$creadsPrec :: Int -> ReadS Bytes
Read, Bytes -> Bytes -> Bool
(Bytes -> Bytes -> Bool) -> (Bytes -> Bytes -> Bool) -> Eq Bytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bytes -> Bytes -> Bool
$c/= :: Bytes -> Bytes -> Bool
== :: Bytes -> Bytes -> Bool
$c== :: Bytes -> Bytes -> Bool
Eq )

-- | 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
  { Msg -> Word16
_msgSBPType    :: !Word16
    -- ^ Uniquely identifies the type of the payload contents
  , Msg -> Word16
_msgSBPSender  :: !Word16
    -- ^ A unique identifier of the sending hardware. For v1.0,
    -- set to the 2 least significant bytes of the device serial
    -- number
  , Msg -> Word8
_msgSBPLen     :: !Word8
    -- ^ Byte-length of the payload field
  , Msg -> Bytes
_msgSBPPayload :: !Bytes
    -- ^ 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)
  , Msg -> Word16
_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 ( Int -> Msg -> ShowS
[Msg] -> ShowS
Msg -> String
(Int -> Msg -> ShowS)
-> (Msg -> String) -> ([Msg] -> ShowS) -> Show Msg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Msg] -> ShowS
$cshowList :: [Msg] -> ShowS
show :: Msg -> String
$cshow :: Msg -> String
showsPrec :: Int -> Msg -> ShowS
$cshowsPrec :: Int -> Msg -> ShowS
Show, ReadPrec [Msg]
ReadPrec Msg
Int -> ReadS Msg
ReadS [Msg]
(Int -> ReadS Msg)
-> ReadS [Msg] -> ReadPrec Msg -> ReadPrec [Msg] -> Read Msg
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Msg]
$creadListPrec :: ReadPrec [Msg]
readPrec :: ReadPrec Msg
$creadPrec :: ReadPrec Msg
readList :: ReadS [Msg]
$creadList :: ReadS [Msg]
readsPrec :: Int -> ReadS Msg
$creadsPrec :: Int -> ReadS Msg
Read, Msg -> Msg -> Bool
(Msg -> Msg -> Bool) -> (Msg -> Msg -> Bool) -> Eq Msg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Msg -> Msg -> Bool
$c/= :: Msg -> Msg -> Bool
== :: Msg -> Msg -> Bool
$c== :: Msg -> Msg -> Bool
Eq )

$(makeClassy ''Msg)

instance Binary Msg where
  get :: Get Msg
get = do
    Word16
_msgSBPType    <- Get Word16
getWord16le
    Word16
_msgSBPSender  <- Get Word16
getWord16le
    Word8
_msgSBPLen     <- Get Word8
getWord8
    Bytes
_msgSBPPayload <- (ByteString -> Bytes) -> Get ByteString -> Get Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Bytes
Bytes (Get ByteString -> Get Bytes) -> Get ByteString -> Get Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
_msgSBPLen
    Word16
_msgSBPCrc     <- Get Word16
getWord16le
    Msg -> Get Msg
forall (f :: * -> *) a. Applicative f => a -> f a
pure Msg :: Word16 -> Word16 -> Word8 -> Bytes -> Word16 -> Msg
Msg {Word8
Word16
Bytes
_msgSBPCrc :: Word16
_msgSBPPayload :: Bytes
_msgSBPLen :: Word8
_msgSBPSender :: Word16
_msgSBPType :: Word16
_msgSBPCrc :: Word16
_msgSBPPayload :: Bytes
_msgSBPLen :: Word8
_msgSBPSender :: Word16
_msgSBPType :: Word16
..}

  put :: Msg -> Put
put Msg {Word8
Word16
Bytes
_msgSBPCrc :: Word16
_msgSBPPayload :: Bytes
_msgSBPLen :: Word8
_msgSBPSender :: Word16
_msgSBPType :: Word16
_msgSBPCrc :: Msg -> Word16
_msgSBPPayload :: Msg -> Bytes
_msgSBPLen :: Msg -> Word8
_msgSBPSender :: Msg -> Word16
_msgSBPType :: Msg -> Word16
..} = do
    Word16 -> Put
putWord16le   Word16
_msgSBPType
    Word16 -> Put
putWord16le   Word16
_msgSBPSender
    Word8 -> Put
putWord8      Word8
_msgSBPLen
    ByteString -> Put
putByteString (Bytes -> ByteString
unBytes Bytes
_msgSBPPayload)
    Word16 -> Put
putWord16le   Word16
_msgSBPCrc

instance FromJSON Bytes where
  parseJSON :: Value -> Parser Bytes
parseJSON = String -> (Text -> Parser Bytes) -> Value -> Parser Bytes
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ByteString" (Bytes -> Parser Bytes
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Parser Bytes) -> (Text -> Bytes) -> Text -> Parser Bytes
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Bytes
Bytes (ByteString -> Bytes) -> (Text -> ByteString) -> Text -> Bytes
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
Base64.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
encodeUtf8)

instance FromJSON Msg where
  parseJSON :: Value -> Parser Msg
parseJSON (Object Object
v) =
    Word16 -> Word16 -> Word8 -> Bytes -> Word16 -> Msg
Msg (Word16 -> Word16 -> Word8 -> Bytes -> Word16 -> Msg)
-> Parser Word16
-> Parser (Word16 -> Word8 -> Bytes -> Word16 -> Msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Word16
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"msg_type"
        Parser (Word16 -> Word8 -> Bytes -> Word16 -> Msg)
-> Parser Word16 -> Parser (Word8 -> Bytes -> Word16 -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Word16
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sender"
        Parser (Word8 -> Bytes -> Word16 -> Msg)
-> Parser Word8 -> Parser (Bytes -> Word16 -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Word8
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"length"
        Parser (Bytes -> Word16 -> Msg)
-> Parser Bytes -> Parser (Word16 -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Bytes
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"payload"
        Parser (Word16 -> Msg) -> Parser Word16 -> Parser Msg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Word16
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"crc"
  parseJSON Value
_ = Parser Msg
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON Bytes where
  toJSON :: Bytes -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Bytes -> Text) -> Bytes -> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
forall a b. OnError a b
ignore (ByteString -> Text) -> (Bytes -> ByteString) -> Bytes -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> (Bytes -> ByteString) -> Bytes -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bytes -> ByteString
unBytes

instance ToJSON Msg where
  toJSON :: Msg -> Value
toJSON Msg {Word8
Word16
Bytes
_msgSBPCrc :: Word16
_msgSBPPayload :: Bytes
_msgSBPLen :: Word8
_msgSBPSender :: Word16
_msgSBPType :: Word16
_msgSBPCrc :: Msg -> Word16
_msgSBPPayload :: Msg -> Bytes
_msgSBPLen :: Msg -> Word8
_msgSBPSender :: Msg -> Word16
_msgSBPType :: Msg -> Word16
..} = [Pair] -> Value
object
    [ Key
"preamble" Key -> Word8 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word8
msgSBPPreamble
    , Key
"msg_type" Key -> Word16 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word16
_msgSBPType
    , Key
"sender"   Key -> Word16 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word16
_msgSBPSender
    , Key
"length"   Key -> Word8 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word8
_msgSBPLen
    , Key
"payload"  Key -> Bytes -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bytes
_msgSBPPayload
    , Key
"crc"      Key -> Word16 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word16
_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

checkCrc :: Msg -> Word16
checkCrc :: Msg -> Word16
checkCrc Msg {Word8
Word16
Bytes
_msgSBPCrc :: Word16
_msgSBPPayload :: Bytes
_msgSBPLen :: Word8
_msgSBPSender :: Word16
_msgSBPType :: Word16
_msgSBPCrc :: Msg -> Word16
_msgSBPPayload :: Msg -> Bytes
_msgSBPLen :: Msg -> Word8
_msgSBPSender :: Msg -> Word16
_msgSBPType :: Msg -> Word16
..} =
  ByteString -> Word16
crc16 (ByteString -> Word16) -> ByteString -> Word16
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
    Word16 -> Builder
word16LE Word16
_msgSBPType   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Word16 -> Builder
word16LE Word16
_msgSBPSender Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Word8 -> Builder
word8 Word8
_msgSBPLen       Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
byteString (Bytes -> ByteString
unBytes Bytes
_msgSBPPayload)