Types.hs

{-# OPTIONS -XBangPatterns #-}
module Network.AMQP.Types
    (Octet,
     Bit,
     ChannelID,
     PayloadSize,
     ShortInt,
     LongInt,
     LongLongInt,
     ShortString(..),
     LongString(..),
     Timestamp,
     FieldTable(..),
     FieldValue(..),
     Decimals,
     DecimalValue(..)
     )
     where


import Data.Int
import Data.Char
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Lazy.Internal as BL
import qualified Data.Binary.Put as BPut
import Control.Monad
import qualified Data.Map as M



-- performs runGet on a bytestring until the string is empty
readMany :: (Show t, Binary t) => BL.ByteString -> [t]
readMany str = runGet (readMany' [] 0) str
readMany' _ 1000 = error "readMany overflow"
readMany' acc overflow = do
    x <- get
    rem <- remaining
    if rem > 0 
        then readMany' (x:acc) (overflow+1)
        else return (x:acc)
        
putMany x = mapM_ put x

-- Lowlevel Types
type Octet = Word8
type Bit = Bool

type ChannelID = ShortInt
type PayloadSize = LongInt

type ShortInt = Word16
type LongInt = Word32
type LongLongInt = Word64



newtype ShortString = ShortString String
    deriving (Show, Ord, Eq)
instance Binary ShortString where
    get = do
      len <- getWord8
      dat <- getByteString (fromIntegral len)
      return $ ShortString $ BS.unpack dat
    put (ShortString x) = do
        let s = BS.pack $ take 255 x --ensure string isn't longer than 255 bytes
        putWord8 $ fromIntegral (BS.length s)
        putByteString s
    
newtype LongString = LongString String
    deriving Show
instance Binary LongString where
    get = do
      len <- getWord32be
      dat <- getByteString (fromIntegral len)
      return $ LongString $ BS.unpack dat
    put (LongString x) = do
        putWord32be $ fromIntegral (length x)
        putByteString (BS.pack x) 

type Timestamp = LongLongInt



--- field-table ---
data FieldTable = FieldTable (M.Map ShortString FieldValue)
    deriving Show
instance Binary FieldTable where
    get = do
        len <- get :: Get LongInt --length of fieldValuePairs in bytes
        
        if len > 0 
            then do
                fvp <- getLazyByteString (fromIntegral len)
                let !fields = readMany fvp
                
                return $ FieldTable $ M.fromList fields
            else return $ FieldTable $ M.empty
                
    put (FieldTable fvp) = do
        let bytes = runPut (putMany $ M.toList fvp) :: BL.ByteString
        put ((fromIntegral $ BL.length bytes):: LongInt)
        putLazyByteString bytes
    

    
--- field-value ---  

data FieldValue = FVLongString LongString
                | FVSignedInt Int32
                | FVDecimalValue DecimalValue
                | FVTimestamp Timestamp
                | FVFieldTable FieldTable
    deriving Show
                
instance Binary FieldValue where
    get = do
        fieldType <- getWord8
        case chr $ fromIntegral fieldType of
            'S' -> do 
                x <- get :: Get LongString
                return $ FVLongString x
            'I' -> do
                x <- get :: Get Int32
                return $ FVSignedInt x
            'D' -> do
                x <- get :: Get DecimalValue
                return $ FVDecimalValue $ x
            'T' -> do
                x <- get :: Get Timestamp
                return $ FVTimestamp x
            'F' -> do
                ft <- get :: Get FieldTable
                return $ FVFieldTable ft
    put (FVLongString s)   = put 'S' >> put s
    put (FVSignedInt s)    = put 'I' >> put s
    put (FVDecimalValue s) = put 'D' >> put s
    put (FVTimestamp s)    = put 'T' >> put s
    put (FVFieldTable s)   = put 'F' >> put s
    
    
    
data DecimalValue = DecimalValue Decimals LongInt    
    deriving Show
instance Binary DecimalValue where   
    get = do
      a <- getWord8
      b <- get :: Get LongInt
      return $ DecimalValue a b
    put (DecimalValue a b) = put a >> put b
    
type Decimals = Octet