+++ /dev/null
---
--- 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.
---
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Thrift.Protocol.Binary
- ( module Thrift.Protocol
- , BinaryProtocol(..)
- , versionMask
- , version1
- ) where
-
-import Control.Exception ( throw )
-import Control.Monad
-import Data.Bits
-import Data.ByteString.Lazy.Builder
-import Data.Functor
-import Data.Int
-import Data.Monoid
-import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 )
-import Data.Word
-
-import Thrift.Protocol
-import Thrift.Transport
-import Thrift.Types
-
-import qualified Data.Attoparsec.ByteString as P
-import qualified Data.Attoparsec.ByteString.Lazy as LP
-import qualified Data.Binary as Binary
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.HashMap.Strict as Map
-import qualified Data.Text.Lazy as LT
-
-versionMask :: Int32
-versionMask = fromIntegral (0xffff0000 :: Word32)
-
-version1 :: Int32
-version1 = fromIntegral (0x80010000 :: Word32)
-
-data BinaryProtocol a = Transport a => BinaryProtocol a
-
-getTransport :: Transport t => BinaryProtocol t -> t
-getTransport (BinaryProtocol t) = t
-
--- NOTE: Reading and Writing functions rely on Builders and Data.Binary to
--- encode and decode data. Data.Binary assumes that the binary values it is
--- encoding to and decoding from are in BIG ENDIAN format, and converts the
--- endianness as necessary to match the local machine.
-instance Transport t => Protocol (BinaryProtocol t) where
- readByte p = tReadAll (getTransport p) 1
- -- flushTransport p = tFlush (getTransport p)
- writeMessage p (n, t, s) f = do
- tWrite (getTransport p) messageBegin
- f
- tFlush $ getTransport p
- where
- messageBegin = toLazyByteString $
- buildBinaryValue (TI32 (version1 .|. fromIntegral (fromEnum t))) <>
- buildBinaryValue (TString $ encodeUtf8 n) <>
- buildBinaryValue (TI32 s)
-
- readMessage p = (readMessageBegin p >>=)
- where
- readMessageBegin p = runParser p $ do
- TI32 ver <- parseBinaryValue T_I32
- if ver .&. versionMask /= version1
- then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier"
- else do
- TString s <- parseBinaryValue T_STRING
- TI32 sz <- parseBinaryValue T_I32
- return (decodeUtf8 s, toEnum $ fromIntegral $ ver .&. 0xFF, sz)
-
- writeVal p = tWrite (getTransport p) . toLazyByteString . buildBinaryValue
- readVal p = runParser p . parseBinaryValue
-
-instance Transport t => StatelessProtocol (BinaryProtocol t) where
- serializeVal _ = toLazyByteString . buildBinaryValue
- deserializeVal _ ty bs =
- case LP.eitherResult $ LP.parse (parseBinaryValue ty) bs of
- Left s -> error s
- Right val -> val
-
--- | Writing Functions
-buildBinaryValue :: ThriftVal -> Builder
-buildBinaryValue (TStruct fields) = buildBinaryStruct fields <> buildType T_STOP
-buildBinaryValue (TMap ky vt entries) =
- buildType ky <>
- buildType vt <>
- int32BE (fromIntegral (length entries)) <>
- buildBinaryMap entries
-buildBinaryValue (TList ty entries) =
- buildType ty <>
- int32BE (fromIntegral (length entries)) <>
- buildBinaryList entries
-buildBinaryValue (TSet ty entries) =
- buildType ty <>
- int32BE (fromIntegral (length entries)) <>
- buildBinaryList entries
-buildBinaryValue (TBool b) =
- word8 $ toEnum $ if b then 1 else 0
-buildBinaryValue (TByte b) = int8 b
-buildBinaryValue (TI16 i) = int16BE i
-buildBinaryValue (TI32 i) = int32BE i
-buildBinaryValue (TI64 i) = int64BE i
-buildBinaryValue (TDouble d) = doubleBE d
-buildBinaryValue (TString s) = int32BE len <> lazyByteString s
- where
- len :: Int32 = fromIntegral (LBS.length s)
-buildBinaryValue (TBinary s) = buildBinaryValue (TString s)
-
-buildBinaryStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
-buildBinaryStruct = Map.foldrWithKey combine mempty
- where
- combine fid (_,val) s =
- buildTypeOf val <> int16BE fid <> buildBinaryValue val <> s
-
-buildBinaryMap :: [(ThriftVal, ThriftVal)] -> Builder
-buildBinaryMap = foldl combine mempty
- where
- combine s (key, val) = s <> buildBinaryValue key <> buildBinaryValue val
-
-buildBinaryList :: [ThriftVal] -> Builder
-buildBinaryList = foldr (mappend . buildBinaryValue) mempty
-
--- | Reading Functions
-parseBinaryValue :: ThriftType -> P.Parser ThriftVal
-parseBinaryValue (T_STRUCT tmap) = TStruct <$> parseBinaryStruct tmap
-parseBinaryValue (T_MAP _ _) = do
- kt <- parseType
- vt <- parseType
- n <- Binary.decode . LBS.fromStrict <$> P.take 4
- TMap kt vt <$> parseBinaryMap kt vt n
-parseBinaryValue (T_LIST _) = do
- t <- parseType
- n <- Binary.decode . LBS.fromStrict <$> P.take 4
- TList t <$> parseBinaryList t n
-parseBinaryValue (T_SET _) = do
- t <- parseType
- n <- Binary.decode . LBS.fromStrict <$> P.take 4
- TSet t <$> parseBinaryList t n
-parseBinaryValue T_BOOL = TBool . (/=0) <$> P.anyWord8
-parseBinaryValue T_BYTE = TByte . Binary.decode . LBS.fromStrict <$> P.take 1
-parseBinaryValue T_I16 = TI16 . Binary.decode . LBS.fromStrict <$> P.take 2
-parseBinaryValue T_I32 = TI32 . Binary.decode . LBS.fromStrict <$> P.take 4
-parseBinaryValue T_I64 = TI64 . Binary.decode . LBS.fromStrict <$> P.take 8
-parseBinaryValue T_DOUBLE = TDouble . bsToDouble <$> P.take 8
-parseBinaryValue T_STRING = parseBinaryString TString
-parseBinaryValue T_BINARY = parseBinaryString TBinary
-parseBinaryValue ty = error $ "Cannot read value of type " ++ show ty
-
-parseBinaryString ty = do
- i :: Int32 <- Binary.decode . LBS.fromStrict <$> P.take 4
- ty . LBS.fromStrict <$> P.take (fromIntegral i)
-
-parseBinaryStruct :: TypeMap -> P.Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
-parseBinaryStruct tmap = Map.fromList <$> P.manyTill parseField (matchType T_STOP)
- where
- parseField = do
- t <- parseType
- n <- Binary.decode . LBS.fromStrict <$> P.take 2
- v <- case (t, Map.lookup n tmap) of
- (T_STRING, Just (_, T_BINARY)) -> parseBinaryValue T_BINARY
- _ -> parseBinaryValue t
- return (n, ("", v))
-
-parseBinaryMap :: ThriftType -> ThriftType -> Int32 -> P.Parser [(ThriftVal, ThriftVal)]
-parseBinaryMap kt vt n | n <= 0 = return []
- | otherwise = do
- k <- parseBinaryValue kt
- v <- parseBinaryValue vt
- ((k,v) :) <$> parseBinaryMap kt vt (n-1)
-
-parseBinaryList :: ThriftType -> Int32 -> P.Parser [ThriftVal]
-parseBinaryList ty n | n <= 0 = return []
- | otherwise = liftM2 (:) (parseBinaryValue ty)
- (parseBinaryList ty (n-1))
-
-
-
--- | Write a type as a byte
-buildType :: ThriftType -> Builder
-buildType t = word8 $ fromIntegral $ fromEnum t
-
--- | Write type of a ThriftVal as a byte
-buildTypeOf :: ThriftVal -> Builder
-buildTypeOf = buildType . getTypeOf
-
--- | Read a byte as though it were a ThriftType
-parseType :: P.Parser ThriftType
-parseType = toEnum . fromIntegral <$> P.anyWord8
-
-matchType :: ThriftType -> P.Parser ThriftType
-matchType t = t <$ P.word8 (fromIntegral $ fromEnum t)
projects / ceph.git / blobdiff