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
hasContent :: FramePayload -> Bool
hasContent (MethodPayload (Basic_get_ok _ _ _ _ _)) = True
hasContent (MethodPayload (Basic_deliver _ _ _ _ _)) = True
hasContent (MethodPayload (Basic_return _ _ _ _)) = True
hasContent _ = False
data Frame = Frame ChannelID FramePayload
deriving Show
instance Binary Frame where
get = do
fType <- getWord8
channel <- get :: Get ChannelID
payloadSize <- get :: Get PayloadSize
payload <- getPayload fType payloadSize :: Get FramePayload
0xCE <- getWord8
return $ Frame channel payload
put (Frame chan payload) = do
putWord8 $ frameType payload
put chan
let buf = runPut $ putPayload payload
put ((fromIntegral $ BL.length buf)::PayloadSize)
putLazyByteString buf
putWord8 0xCE
peekFrameSize :: BL.ByteString -> PayloadSize
peekFrameSize = runGet f
where
f = do
void $ getWord8
void $ (get :: Get ChannelID)
get :: Get PayloadSize
data FramePayload =
MethodPayload MethodPayload
| ContentHeaderPayload ShortInt ShortInt LongLongInt ContentHeaderProperties
| ContentBodyPayload BL.ByteString
| HeartbeatPayload
deriving Show
frameType :: FramePayload -> Word8
frameType (MethodPayload _) = 1
frameType (ContentHeaderPayload _ _ _ _) = 2
frameType (ContentBodyPayload _) = 3
frameType HeartbeatPayload = 8
getPayload :: Word8 -> PayloadSize -> Get FramePayload
getPayload 1 _ = do
payLoad <- get :: Get MethodPayload
return (MethodPayload payLoad)
getPayload 2 _ = do
classID <- get :: Get ShortInt
weight <- get :: Get ShortInt
bodySize <- get :: Get LongLongInt
props <- getContentHeaderProperties classID
return (ContentHeaderPayload classID weight bodySize props)
getPayload 3 payloadSize = do
payload <- getLazyByteString $ fromIntegral payloadSize
return (ContentBodyPayload payload)
getPayload 8 payloadSize = do
_ <- getLazyByteString $ fromIntegral payloadSize
return HeartbeatPayload
getPayload n _ = error ("Unknown frame payload: " ++ show n)
putPayload :: FramePayload -> Put
putPayload (MethodPayload payload) = put payload
putPayload (ContentHeaderPayload classID weight bodySize p) = do
put classID
put weight
put bodySize
putContentHeaderProperties p
putPayload (ContentBodyPayload payload) = putLazyByteString payload
putPayload HeartbeatPayload = putLazyByteString BL.empty