{-# 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
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]
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
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
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]
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
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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Bytes
Bytes forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
_msgSBPLen
    Word16
_msgSBPCrc     <- Get Word16
getWord16le
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ByteString" (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"msg_type"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sender"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"length"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"payload"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"crc"
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON Bytes where
  toJSON :: Bytes -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON 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 forall a b. OnError a b
ignore 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 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word8
msgSBPPreamble
    , Key
"msg_type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word16
_msgSBPType
    , Key
"sender"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word16
_msgSBPSender
    , Key
"length"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word8
_msgSBPLen
    , Key
"payload"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bytes
_msgSBPPayload
    , Key
"crc"      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 forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$
    Word16 -> Builder
word16LE Word16
_msgSBPType   forall a. Semigroup a => a -> a -> a
<>
    Word16 -> Builder
word16LE Word16
_msgSBPSender forall a. Semigroup a => a -> a -> a
<>
    Word8 -> Builder
word8 Word8
_msgSBPLen       forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
byteString (Bytes -> ByteString
unBytes Bytes
_msgSBPPayload)