module Network.AMQP.Protocol where

import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put

import qualified Data.ByteString.Lazy.Char8 as BL

import Network.AMQP.Types
import Network.AMQP.Generated

--True if a content (contentheader and possibly contentbody) will follow the method

hasContent :: FramePayload -> Bool
hasContent :: FramePayload -> Bool
hasContent (MethodPayload Basic_get_ok{}) = Bool
True
hasContent (MethodPayload Basic_deliver{}) = Bool
True
hasContent (MethodPayload Basic_return{}) = Bool
True
hasContent FramePayload
_ = Bool
False

data Frame = Frame ChannelID FramePayload --channel, payload

    deriving Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Frame] -> ShowS
$cshowList :: [Frame] -> ShowS
show :: Frame -> String
$cshow :: Frame -> String
showsPrec :: Int -> Frame -> ShowS
$cshowsPrec :: Int -> Frame -> ShowS
Show
instance Binary Frame where
    get :: Get Frame
get = do
        Word8
fType <- Get Word8
getWord8
        ShortInt
channel <- forall t. Binary t => Get t
get :: Get ChannelID
        PayloadSize
payloadSize <- forall t. Binary t => Get t
get :: Get PayloadSize
        FramePayload
payload <- Word8 -> PayloadSize -> Get FramePayload
getPayload Word8
fType PayloadSize
payloadSize :: Get FramePayload
        Word8
0xCE <- Get Word8
getWord8 --frame end

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ShortInt -> FramePayload -> Frame
Frame ShortInt
channel FramePayload
payload

    put :: Frame -> Put
put (Frame ShortInt
chan FramePayload
payload) = do
        Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ FramePayload -> Word8
frameType FramePayload
payload
        forall t. Binary t => t -> Put
put ShortInt
chan
        let buf :: ByteString
buf = Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ FramePayload -> Put
putPayload FramePayload
payload
        forall t. Binary t => t -> Put
put ((forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
buf)::PayloadSize)
        ByteString -> Put
putLazyByteString ByteString
buf
        Word8 -> Put
putWord8 Word8
0xCE

-- gets the size of the frame

-- the bytestring should be at least 7 bytes long, otherwise this method will fail

peekFrameSize :: BL.ByteString -> PayloadSize
peekFrameSize :: ByteString -> PayloadSize
peekFrameSize = forall a. Get a -> ByteString -> a
runGet Get PayloadSize
f
  where
    f :: Get PayloadSize
f = do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void Get Word8
getWord8 -- 1 byte

        forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall t. Binary t => Get t
get :: Get ChannelID) -- 2 bytes

        forall t. Binary t => Get t
get :: Get PayloadSize -- 4 bytes


data FramePayload =
      MethodPayload MethodPayload
    | ContentHeaderPayload ShortInt ShortInt LongLongInt ContentHeaderProperties --classID, weight, bodySize, propertyFields

    | ContentBodyPayload BL.ByteString
    | HeartbeatPayload
    deriving Int -> FramePayload -> ShowS
[FramePayload] -> ShowS
FramePayload -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FramePayload] -> ShowS
$cshowList :: [FramePayload] -> ShowS
show :: FramePayload -> String
$cshow :: FramePayload -> String
showsPrec :: Int -> FramePayload -> ShowS
$cshowsPrec :: Int -> FramePayload -> ShowS
Show

frameType :: FramePayload -> Word8
frameType :: FramePayload -> Word8
frameType (MethodPayload MethodPayload
_) = Word8
1
frameType ContentHeaderPayload{} = Word8
2
frameType (ContentBodyPayload ByteString
_) = Word8
3
frameType FramePayload
HeartbeatPayload = Word8
8

getPayload :: Word8 -> PayloadSize -> Get FramePayload
getPayload :: Word8 -> PayloadSize -> Get FramePayload
getPayload Word8
1 PayloadSize
_ = do --METHOD FRAME

    MethodPayload
payLoad <- forall t. Binary t => Get t
get :: Get MethodPayload
    forall (m :: * -> *) a. Monad m => a -> m a
return (MethodPayload -> FramePayload
MethodPayload MethodPayload
payLoad)
getPayload Word8
2 PayloadSize
_ = do --content header frame

    ShortInt
classID <- forall t. Binary t => Get t
get :: Get ShortInt
    ShortInt
weight <- forall t. Binary t => Get t
get :: Get ShortInt
    LongLongInt
bodySize <- forall t. Binary t => Get t
get :: Get LongLongInt
    ContentHeaderProperties
props <- ShortInt -> Get ContentHeaderProperties
getContentHeaderProperties ShortInt
classID
    forall (m :: * -> *) a. Monad m => a -> m a
return (ShortInt
-> ShortInt
-> LongLongInt
-> ContentHeaderProperties
-> FramePayload
ContentHeaderPayload ShortInt
classID ShortInt
weight LongLongInt
bodySize ContentHeaderProperties
props)
getPayload Word8
3 PayloadSize
payloadSize = do --content body frame

    ByteString
payload <- Int64 -> Get ByteString
getLazyByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral PayloadSize
payloadSize
    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> FramePayload
ContentBodyPayload ByteString
payload)
getPayload Word8
8 PayloadSize
payloadSize = do
    -- ignoring the actual payload, but still need to read the bytes from the network buffer

    ByteString
_ <- Int64 -> Get ByteString
getLazyByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral PayloadSize
payloadSize
    forall (m :: * -> *) a. Monad m => a -> m a
return FramePayload
HeartbeatPayload
-- this should never happen:

getPayload Word8
n PayloadSize
_ = forall a. HasCallStack => String -> a
error (String
"Unknown frame payload: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
n)

putPayload :: FramePayload -> Put
putPayload :: FramePayload -> Put
putPayload (MethodPayload MethodPayload
payload) = forall t. Binary t => t -> Put
put MethodPayload
payload
putPayload (ContentHeaderPayload ShortInt
classID ShortInt
weight LongLongInt
bodySize ContentHeaderProperties
p) = do
    forall t. Binary t => t -> Put
put ShortInt
classID
    forall t. Binary t => t -> Put
put ShortInt
weight
    forall t. Binary t => t -> Put
put LongLongInt
bodySize
    ContentHeaderProperties -> Put
putContentHeaderProperties ContentHeaderProperties
p
putPayload (ContentBodyPayload ByteString
payload) = ByteString -> Put
putLazyByteString ByteString
payload
putPayload FramePayload
HeartbeatPayload = ByteString -> Put
putLazyByteString ByteString
BL.empty