content: --
  -- Licensed to the Apache Software Foundation (ASF) under one
  -- or more contributor license agreements. See the NOTICE file
  -- distributed with this work for additional information
  -- regarding copyright ownership. The ASF licenses this file
  -- to you under the Apache License, Version 2.0 (the
  -- "License"); you may not use this file except in compliance
  -- with the License. You may obtain a copy of the License at
  --
  --   http://www.apache.org/licenses/LICENSE-2.0
  --
  -- Unless required by applicable law or agreed to in writing,
  -- software distributed under the License is distributed on an
  -- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
  -- KIND, either express or implied. See the License for the
  -- specific language governing permissions and limitations
  -- under the License.
  --
  
  module Thrift.Protocol.Binary
      ( module Thrift.Protocol
      , BinaryProtocol(..)
      ) where
  
  import Control.Exception ( throw )
  
  import Data.Bits
  import Data.Int
  import Data.List ( foldl' )
  
  import GHC.Exts
  import GHC.Word
  
  import Thrift.Protocol
  import Thrift.Transport
  
  
  version_mask = 0xffff0000
  version_1    = 0x80010000
  
  data BinaryProtocol a = Transport a => BinaryProtocol a
  
  
  instance Protocol BinaryProtocol where
      getTransport (BinaryProtocol t) = t
  
      writeMessageBegin p (n, t, s) = do
          writeI32 p (version_1 .|. (fromEnum t))
          writeString p n
          writeI32 p s
      writeMessageEnd _ = return ()
  
      writeStructBegin _ _ = return ()
      writeStructEnd _ = return ()
      writeFieldBegin p (_, t, i) = writeType p t >> writeI16 p i
      writeFieldEnd _ = return ()
      writeFieldStop p = writeType p T_STOP
      writeMapBegin p (k, v, n) = writeType p k >> writeType p v >> writeI32 p n
      writeMapEnd p = return ()
      writeListBegin p (t, n) = writeType p t >> writeI32 p n
      writeListEnd _ = return ()
      writeSetBegin p (t, n) = writeType p t >> writeI32 p n
      writeSetEnd _ = return ()
  
      writeBool p b = tWrite (getTransport p) [toEnum $ if b then 1 else 0]
      writeByte p b = tWrite (getTransport p) (getBytes b 1)
      writeI16 p b = tWrite (getTransport p) (getBytes b 2)
      writeI32 p b = tWrite (getTransport p) (getBytes b 4)
      writeI64 p b = tWrite (getTransport p) (getBytes b 8)
      writeDouble p d = writeI64 p (fromIntegral $ floatBits d)
      writeString p s = writeI32 p (length s) >> tWrite (getTransport p) s
      writeBinary = writeString
  
      readMessageBegin p = do
          ver <- readI32 p
          if (ver .&. version_mask /= version_1)
              then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier"
              else do
                s <- readString p
                sz <- readI32 p
                return (s, toEnum $ ver .&. 0xFF, sz)
      readMessageEnd _ = return ()
      readStructBegin _ = return ""
      readStructEnd _ = return ()
      readFieldBegin p = do
          t <- readType p
          n <- if t /= T_STOP then readI16 p else return 0
          return ("", t, n)
      readFieldEnd _ = return ()
      readMapBegin p = do
          kt <- readType p
          vt <- readType p
          n <- readI32 p
          return (kt, vt, n)
      readMapEnd _ = return ()
      readListBegin p = do
          t <- readType p
          n <- readI32 p
          return (t, n)
      readListEnd _ = return ()
      readSetBegin p = do
          t <- readType p
          n <- readI32 p
          return (t, n)
      readSetEnd _ = return ()
  
      readBool p = (== 1) `fmap` readByte p
      readByte p = do
          bs <- tReadAll (getTransport p) 1
          return $ fromIntegral (composeBytes bs :: Int8)
      readI16 p = do
          bs <- tReadAll (getTransport p) 2
          return $ fromIntegral (composeBytes bs :: Int16)
      readI32 p = composeBytes `fmap` tReadAll (getTransport p) 4
      readI64 p = composeBytes `fmap` tReadAll (getTransport p) 8
      readDouble p = do
          bs <- readI64 p
          return $ floatOfBits $ fromIntegral bs
      readString p = readI32 p >>= tReadAll (getTransport p)
      readBinary = readString
  
  
  -- | Write a type as a byte
  writeType :: (Protocol p, Transport t) => p t -> ThriftType -> IO ()
  writeType p t = writeByte p (fromEnum t)
  
  -- | Read a byte as though it were a ThriftType
  readType :: (Protocol p, Transport t) => p t -> IO ThriftType
  readType p = toEnum `fmap` readByte p
  
  composeBytes :: (Bits b, Enum t) => [t] -> b
  composeBytes = (foldl' fn 0) . (map $ fromIntegral . fromEnum)
      where fn acc b = (acc `shiftL` 8) .|. b
  
  getByte :: Bits a => a -> Int -> a
  getByte i n = 255 .&. (i `shiftR` (8 * n))
  
  getBytes :: (Bits a, Integral a) => a -> Int -> String
  getBytes i 0 = []
  getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)):(getBytes i (n-1))
  
  floatBits :: Double -> Word64
  floatBits (D# d#) = W64# (unsafeCoerce# d#)
  
  floatOfBits :: Word64 -> Double
  floatOfBits (W64# b#) = D# (unsafeCoerce# b#)
  
  