| iproctor | ff8eb92 | 2007-07-25 19:06:13 +0000 | [diff] [blame^] | 1 | module TBinaryProtocol (TBinaryProtocol(..)) where |
| 2 | import Thrift |
| 3 | import Data.Bits |
| 4 | import Data.Int |
| 5 | import GHC.Exts |
| 6 | import GHC.Prim |
| 7 | import GHC.Word |
| 8 | import Control.Exception |
| 9 | |
| 10 | data TBinaryProtocol a = (TTransport a) => TBinaryProtocol a |
| 11 | |
| 12 | version_mask = 0xffff0000 |
| 13 | version_1 = 0x80010000; |
| 14 | |
| 15 | getByte i b= 255 .&. (shiftR i (8*b)) |
| 16 | getBytes i 0 = [] |
| 17 | getBytes i n = (toEnum (getByte i (n-1)) :: Char):(getBytes i (n-1)) |
| 18 | |
| 19 | floatBits :: Double -> Word64 |
| 20 | floatBits (D# d#) = W64# (unsafeCoerce# d#) |
| 21 | |
| 22 | floatOfBits :: Word64 -> Double |
| 23 | floatOfBits (W64# b#) = D# (unsafeCoerce# b#) |
| 24 | |
| 25 | composeBytesH :: [Char] -> Int -> Word32 |
| 26 | composeBytesH [] n = 0 |
| 27 | composeBytesH (h:t) n = (shiftL (fromIntegral (fromEnum h) :: Word32) (8*n)) .|. (composeBytesH t (n-1)) |
| 28 | compBytes :: [Char] -> Word32 |
| 29 | compBytes b = composeBytesH b ((length b)-1) |
| 30 | |
| 31 | composeBytes64H :: [Char] -> Int -> Word64 |
| 32 | composeBytes64H [] n = 0 |
| 33 | composeBytes64H (h:t) n = (shiftL (fromIntegral (fromEnum h) :: Word64) (8*n)) .|. (composeBytes64H t (n-1)) |
| 34 | compBytes64 :: [Char] -> Word64 |
| 35 | compBytes64 b = composeBytes64H b ((length b)-1) |
| 36 | instance TTransport a => Protocol (TBinaryProtocol a) where |
| 37 | writeBool (TBinaryProtocol tr) b = twrite tr (if b then [toEnum 1::Char] else [toEnum 0::Char]) |
| 38 | writeByte (TBinaryProtocol tr) b = twrite tr (getBytes b 1) |
| 39 | writeI16 (TBinaryProtocol tr) b = twrite tr (getBytes b 2) |
| 40 | writeI32 (TBinaryProtocol tr) b = twrite tr (getBytes b 4) |
| 41 | writeI64 (TBinaryProtocol tr) b = twrite tr (getBytes b 8) |
| 42 | writeDouble (TBinaryProtocol tr) b = writeI64 (TBinaryProtocol tr) (fromIntegral (floatBits b) :: Int) |
| 43 | writeString (TBinaryProtocol tr) s = do twrite tr (getBytes (length s) 4) |
| 44 | twrite tr s |
| 45 | writeBinary = writeString |
| 46 | writeMessageBegin (TBinaryProtocol tr) (n,t,s) = do writeI32 (TBinaryProtocol tr) (version_1 .|. (fromEnum t)) |
| 47 | writeString (TBinaryProtocol tr) n |
| 48 | writeI32 (TBinaryProtocol tr) s |
| 49 | writeMessageEnd (TBinaryProtocol tr) = return () |
| 50 | writeStructBegin (TBinaryProtocol tr) s = return () |
| 51 | writeStructEnd (TBinaryProtocol tr) = return () |
| 52 | writeFieldBegin a (n,t,i) = do writeByte a (fromEnum t) |
| 53 | writeI16 a i |
| 54 | writeFieldEnd a = return () |
| 55 | writeFieldStop a = writeByte a (fromEnum T_STOP) |
| 56 | writeMapBegin a (k,v,s) = do writeByte a (fromEnum k) |
| 57 | writeByte a (fromEnum v) |
| 58 | writeI32 a s |
| 59 | writeMapEnd a = return () |
| 60 | writeListBegin a (t,s) = do writeByte a (fromEnum t) |
| 61 | writeI32 a s |
| 62 | writeListEnd a = return () |
| 63 | writeSetBegin = writeListBegin |
| 64 | writeSetEnd a = return () |
| 65 | readByte (TBinaryProtocol tr) = do b <- treadAll tr 1 |
| 66 | return $ (fromIntegral (fromIntegral (compBytes b) :: Int8) :: Int) |
| 67 | readI16 (TBinaryProtocol tr) = do b <- treadAll tr 2 |
| 68 | return $ (fromIntegral (fromIntegral (compBytes b) :: Int16) :: Int) |
| 69 | readI32 (TBinaryProtocol tr) = do b <- treadAll tr 4 |
| 70 | return $ (fromIntegral (fromIntegral (compBytes b) :: Int32) :: Int) |
| 71 | readI64 (TBinaryProtocol tr) = do b <- treadAll tr 8 |
| 72 | return $ (fromIntegral (fromIntegral (compBytes64 b) :: Int64) :: Int) |
| 73 | readDouble (TBinaryProtocol tr) = do b <- readI64 (TBinaryProtocol tr) |
| 74 | return $ floatOfBits (fromIntegral b :: Word64) |
| 75 | readBool (TBinaryProtocol tr) = do b <- readByte (TBinaryProtocol tr) |
| 76 | return $ b == 1 |
| 77 | readString (TBinaryProtocol tr) = do l <- readI32 (TBinaryProtocol tr) |
| 78 | treadAll tr l |
| 79 | readBinary = readString |
| 80 | readMessageBegin (TBinaryProtocol tr) = do ver <- readI32 (TBinaryProtocol tr) |
| 81 | if (ver .&. version_mask /= version_1) then |
| 82 | throwDyn (ProtocolExn PE_BAD_VERSION "Missing version identifier") |
| 83 | else do |
| 84 | s <- readString (TBinaryProtocol tr) |
| 85 | sz <- readI32 (TBinaryProtocol tr) |
| 86 | return (s,toEnum (ver .&. 0xFF) :: Message_type,fromIntegral sz :: Int) |
| 87 | readMessageEnd (TBinaryProtocol tr) = return () |
| 88 | readStructBegin (TBinaryProtocol tr) = return "" |
| 89 | readStructEnd (TBinaryProtocol tr) = return () |
| 90 | readFieldBegin (TBinaryProtocol tr) = do t <- readByte (TBinaryProtocol tr) |
| 91 | if (toEnum t :: T_type) /= T_STOP then |
| 92 | do s <- readI16 (TBinaryProtocol tr) |
| 93 | return ("",toEnum t :: T_type,fromIntegral s :: Int) |
| 94 | else return ("",toEnum t :: T_type,0) |
| 95 | readFieldEnd (TBinaryProtocol tr) = return () |
| 96 | readMapBegin a = do kt <- readByte a |
| 97 | vt <- readByte a |
| 98 | s <- readI32 a |
| 99 | return (toEnum kt :: T_type,toEnum vt :: T_type,fromIntegral s :: Int) |
| 100 | readMapEnd a = return () |
| 101 | readListBegin a = do b <- readByte a |
| 102 | s <- readI32 a |
| 103 | return (toEnum b :: T_type,fromIntegral s :: Int) |
| 104 | readListEnd a = return () |
| 105 | readSetBegin = readListBegin |
| 106 | readSetEnd = readListEnd |
| 107 | pflush (TBinaryProtocol tr) = tflush tr |
| 108 | |
| 109 | |
| 110 | |