{-# LANGUAGE NamedFieldPuns #-}

module Network.Mux.Codec where

import Data.Bits
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as Bld
import Data.ByteString.Builder.Extra qualified as Bld
import Data.ByteString.Lazy qualified as BL
import Data.Word

import Network.Mux.Trace
import Network.Mux.Types


-- | Encode a 'SDU' as a 'ByteString'.
--
-- > Binary format used by 'encodeSDU' and 'decodeSDUHeader'
-- >  0                   1                   2                   3
-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
-- > |                        transmission time                      |
-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
-- > |d|    mini-protocol number     |             length            |
-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
--
-- All fields are in big endian byte order.
--
-- * transmission time: time when the SDU was sent
-- * @d@: mini-protocol direction (`MiniProtocolDir`):
--
--     * 1 - initiator direction
--     * 0 - responder direction
--
-- * mini-protocol number (`MiniProtocolNum`)
-- * length: length of the payload
--
encodeSDU :: SDU -> BL.ByteString
encodeSDU :: SDU -> ByteString
encodeSDU SDU
sdu =
    AllocationStrategy -> ByteString -> Builder -> ByteString
Bld.toLazyByteStringWith
      (Int -> Int -> AllocationStrategy
Bld.untrimmedStrategy Int
hdrLength Int
hdrLength)
      (SDU -> ByteString
msBlob SDU
sdu) Builder
hdr
  where
    hdrLength :: Int
hdrLength = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
msHeaderLength

    hdr :: Builder
hdr = Word32 -> Builder
Bld.word32BE (RemoteClockModel -> Word32
unRemoteClockModel (SDU -> RemoteClockModel
msTimestamp SDU
sdu))
       Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
Bld.word16BE (MiniProtocolNum -> MiniProtocolDir -> Word16
putNumAndMode (SDU -> MiniProtocolNum
msNum SDU
sdu) (SDU -> MiniProtocolDir
msDir SDU
sdu))
       Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
Bld.word16BE (Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
BL.length (SDU -> ByteString
msBlob SDU
sdu)))

    putNumAndMode :: MiniProtocolNum -> MiniProtocolDir -> Word16
    putNumAndMode :: MiniProtocolNum -> MiniProtocolDir -> Word16
putNumAndMode (MiniProtocolNum Word16
n) MiniProtocolDir
InitiatorDir = Word16
n
    putNumAndMode (MiniProtocolNum Word16
n) MiniProtocolDir
ResponderDir = Word16
n Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
0x8000


-- | Decode a 'MuSDU' header.  A left inverse of 'encodeSDU'.
--
decodeSDU :: BL.ByteString -> Either Error SDU
decodeSDU :: ByteString -> Either Error SDU
decodeSDU ByteString
buf
    | ByteString -> Int64
BL.length ByteString
buf Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
msHeaderLength
    = Error -> Either Error SDU
forall a b. a -> Either a b
Left (Error -> Either Error SDU) -> Error -> Either Error SDU
forall a b. (a -> b) -> a -> b
$ String -> Error
SDUDecodeError String
"not enough bytes"
    | Word16
mhLength Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0
    = SDU -> Either Error SDU
forall a b. b -> Either a b
Right (SDU -> Either Error SDU) -> SDU -> Either Error SDU
forall a b. (a -> b) -> a -> b
$ SDU {
          msHeader :: SDUHeader
msHeader = SDUHeader {
              RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp,
              MiniProtocolNum
mhNum :: MiniProtocolNum
mhNum :: MiniProtocolNum
mhNum,
              MiniProtocolDir
mhDir :: MiniProtocolDir
mhDir :: MiniProtocolDir
mhDir,
              Word16
mhLength :: Word16
mhLength :: Word16
mhLength
            }
        , msBlob :: ByteString
msBlob   = ByteString
BL.empty
        }
    | Bool
otherwise
    = Error -> Either Error SDU
forall a b. a -> Either a b
Left (Error -> Either Error SDU) -> Error -> Either Error SDU
forall a b. (a -> b) -> a -> b
$ String -> Error
SDUDecodeError String
"short SDU"
  where
    hdr :: StrictByteString
hdr = ByteString -> StrictByteString
BL.toStrict (ByteString -> StrictByteString) -> ByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BL.take Int64
msHeaderLength ByteString
buf

    byte :: Int -> Word32
    byte :: Int -> Word32
byte Int
i = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> Word8 -> Word32
forall a b. (a -> b) -> a -> b
$ HasCallStack => StrictByteString -> Int -> Word8
StrictByteString -> Int -> Word8
BS.index StrictByteString
hdr Int
i

    mhTimestamp :: RemoteClockModel
mhTimestamp = Word32 -> RemoteClockModel
RemoteClockModel (Word32 -> RemoteClockModel) -> Word32 -> RemoteClockModel
forall a b. (a -> b) -> a -> b
$
                      Int -> Word32
byte Int
0 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24
                  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
byte Int
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16
                  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
byte Int
2 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL`  Int
8
                  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
byte Int
3
    a :: Word16
a           = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16) -> Word32 -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Word32
byte Int
4 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
byte Int
5 :: Word16
    mhLength :: Word16
mhLength    = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16) -> Word32 -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Word32
byte Int
6 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
byte Int
7
    mhNum :: MiniProtocolNum
mhNum       = Word16 -> MiniProtocolNum
MiniProtocolNum (Word16 -> MiniProtocolNum) -> Word16 -> MiniProtocolNum
forall a b. (a -> b) -> a -> b
$ Word16
a Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x7fff
    mhDir :: MiniProtocolDir
mhDir       = if Word16
a Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x8000 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 then MiniProtocolDir
InitiatorDir
                                       else MiniProtocolDir
ResponderDir