{-# LANGUAGE NamedFieldPuns #-}

module Network.Mux.Codec where

import Data.Binary.Get qualified as Bin
import Data.Binary.Put qualified as Bin
import Data.Bits
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                                |
-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
-- > |M|    conversation id          |              length           |
-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
--
-- All fields are in big endian byte order.
--
encodeSDU :: SDU -> BL.ByteString
encodeSDU :: SDU -> ByteString
encodeSDU SDU
sdu =
  let hdr :: ByteString
hdr = Put -> ByteString
Bin.runPut Put
enc in
  ByteString -> ByteString -> ByteString
BL.append ByteString
hdr (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SDU -> ByteString
msBlob SDU
sdu
  where
    enc :: Put
enc = do
        Word32 -> Put
Bin.putWord32be (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ RemoteClockModel -> Word32
unRemoteClockModel (RemoteClockModel -> Word32) -> RemoteClockModel -> Word32
forall a b. (a -> b) -> a -> b
$ SDU -> RemoteClockModel
msTimestamp SDU
sdu
        Word16 -> Put
Bin.putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ MiniProtocolNum -> MiniProtocolDir -> Word16
putNumAndMode (SDU -> MiniProtocolNum
msNum SDU
sdu) (SDU -> MiniProtocolDir
msDir SDU
sdu)
        Word16 -> Put
Bin.putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ 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 =
    case Get SDUHeader
-> ByteString
-> Either
     (ByteString, Int64, String) (ByteString, Int64, SDUHeader)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
Bin.runGetOrFail Get SDUHeader
dec ByteString
buf of
         Left  (ByteString
_, Int64
_, String
e)  -> 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
e
         Right (ByteString
_, Int64
_, SDUHeader
h) ->
             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
h
                 , msBlob :: ByteString
msBlob   = ByteString
BL.empty
                 }
  where
    dec :: Get SDUHeader
dec = do
        mhTimestamp <- Word32 -> RemoteClockModel
RemoteClockModel (Word32 -> RemoteClockModel) -> Get Word32 -> Get RemoteClockModel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
Bin.getWord32be
        a <- Bin.getWord16be
        mhLength <- Bin.getWord16be
        let mhDir  = Word16 -> MiniProtocolDir
forall {a}. (Bits a, Num a) => a -> MiniProtocolDir
getDir Word16
a
            mhNum  = Word16 -> MiniProtocolNum
MiniProtocolNum (Word16
a Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x7fff)
        return $ SDUHeader {
            mhTimestamp,
            mhNum,
            mhDir,
            mhLength
          }

    getDir :: a -> MiniProtocolDir
getDir a
mid =
        if a
mid a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x8000 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then MiniProtocolDir
InitiatorDir
                               else MiniProtocolDir
ResponderDir