{-# LANGUAGE NamedFieldPuns #-}

module Network.Mux.Codec where

import qualified Data.Binary.Get as Bin
import qualified Data.Binary.Put as Bin
import           Data.Bits
import qualified Data.ByteString.Lazy as BL
import           Data.Word

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


-- | Encode a 'MuxSDU' as a 'ByteString'.
--
-- > Binary format used by 'encodeMuxSDU' and 'decodeMuxSDUHeader'
-- >  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 byteorder.
--
encodeMuxSDU :: MuxSDU -> BL.ByteString
encodeMuxSDU :: MuxSDU -> ByteString
encodeMuxSDU MuxSDU
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
$ MuxSDU -> ByteString
msBlob MuxSDU
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
$ MuxSDU -> RemoteClockModel
msTimestamp MuxSDU
sdu
        Word16 -> Put
Bin.putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ MiniProtocolNum -> MiniProtocolDir -> Word16
putNumAndMode (MuxSDU -> MiniProtocolNum
msNum MuxSDU
sdu) (MuxSDU -> MiniProtocolDir
msDir MuxSDU
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
$ MuxSDU -> ByteString
msBlob MuxSDU
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 'encodeMuxSDU'.
--
decodeMuxSDU :: BL.ByteString -> Either MuxError MuxSDU
decodeMuxSDU :: ByteString -> Either MuxError MuxSDU
decodeMuxSDU ByteString
buf =
    case Get MuxSDUHeader
-> ByteString
-> Either
     (ByteString, Int64, String) (ByteString, Int64, MuxSDUHeader)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
Bin.runGetOrFail Get MuxSDUHeader
dec ByteString
buf of
         Left  (ByteString
_, Int64
_, String
e)  -> MuxError -> Either MuxError MuxSDU
forall a b. a -> Either a b
Left (MuxError -> Either MuxError MuxSDU)
-> MuxError -> Either MuxError MuxSDU
forall a b. (a -> b) -> a -> b
$ MuxErrorType -> String -> MuxError
MuxError MuxErrorType
MuxDecodeError String
e
         Right (ByteString
_, Int64
_, MuxSDUHeader
h) ->
             MuxSDU -> Either MuxError MuxSDU
forall a b. b -> Either a b
Right (MuxSDU -> Either MuxError MuxSDU)
-> MuxSDU -> Either MuxError MuxSDU
forall a b. (a -> b) -> a -> b
$ MuxSDU :: MuxSDUHeader -> ByteString -> MuxSDU
MuxSDU {
                   msHeader :: MuxSDUHeader
msHeader = MuxSDUHeader
h
                 , msBlob :: ByteString
msBlob   = ByteString
BL.empty
                 }
  where
    dec :: Get MuxSDUHeader
dec = do
        RemoteClockModel
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
        Word16
a <- Get Word16
Bin.getWord16be
        Word16
mhLength <- Get Word16
Bin.getWord16be
        let mhDir :: MiniProtocolDir
mhDir  = Word16 -> MiniProtocolDir
forall a. (Bits a, Num a) => a -> MiniProtocolDir
getDir Word16
a
            mhNum :: MiniProtocolNum
mhNum  = Word16 -> MiniProtocolNum
MiniProtocolNum (Word16
a Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x7fff)
        MuxSDUHeader -> Get MuxSDUHeader
forall (m :: * -> *) a. Monad m => a -> m a
return (MuxSDUHeader -> Get MuxSDUHeader)
-> MuxSDUHeader -> Get MuxSDUHeader
forall a b. (a -> b) -> a -> b
$ MuxSDUHeader :: RemoteClockModel
-> MiniProtocolNum -> MiniProtocolDir -> Word16 -> MuxSDUHeader
MuxSDUHeader {
            RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp,
            MiniProtocolNum
mhNum :: MiniProtocolNum
mhNum :: MiniProtocolNum
mhNum,
            MiniProtocolDir
mhDir :: MiniProtocolDir
mhDir :: MiniProtocolDir
mhDir,
            Word16
mhLength :: Word16
mhLength :: Word16
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