Moving from govendor to dep, updated dependencies (#48)

* Moving from govendor to dep.

* Making the pull request template more friendly.

* Fixing akward space in PR template.

* goimports run on whole project using ` goimports -w $(find . -type f -name '*.go' -not -path "./vendor/*" -not -path "./gen-go/*")`

source of command: https://gist.github.com/bgentry/fd1ffef7dbde01857f66

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+--
+-- 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
+    ( module Thrift.Transport
+    , module Thrift.Protocol
+    , AppExnType(..)
+    , AppExn(..)
+    , readAppExn
+    , writeAppExn
+    , ThriftException(..)
+    ) where
+
+import Control.Exception
+
+import Data.Int
+import Data.Text.Lazy ( Text, pack, unpack )
+import Data.Text.Lazy.Encoding
+import Data.Typeable ( Typeable )
+import qualified Data.HashMap.Strict as Map
+
+import Thrift.Protocol
+import Thrift.Transport
+import Thrift.Types
+
+data ThriftException = ThriftException
+  deriving ( Show, Typeable )
+instance Exception ThriftException
+
+data AppExnType
+    = AE_UNKNOWN
+    | AE_UNKNOWN_METHOD
+    | AE_INVALID_MESSAGE_TYPE
+    | AE_WRONG_METHOD_NAME
+    | AE_BAD_SEQUENCE_ID
+    | AE_MISSING_RESULT
+    | AE_INTERNAL_ERROR
+    | AE_PROTOCOL_ERROR
+    | AE_INVALID_TRANSFORM
+    | AE_INVALID_PROTOCOL
+    | AE_UNSUPPORTED_CLIENT_TYPE
+      deriving ( Eq, Show, Typeable )
+
+instance Enum AppExnType where
+    toEnum 0 = AE_UNKNOWN
+    toEnum 1 = AE_UNKNOWN_METHOD
+    toEnum 2 = AE_INVALID_MESSAGE_TYPE
+    toEnum 3 = AE_WRONG_METHOD_NAME
+    toEnum 4 = AE_BAD_SEQUENCE_ID
+    toEnum 5 = AE_MISSING_RESULT
+    toEnum 6 = AE_INTERNAL_ERROR
+    toEnum 7 = AE_PROTOCOL_ERROR
+    toEnum 8 = AE_INVALID_TRANSFORM
+    toEnum 9 = AE_INVALID_PROTOCOL
+    toEnum 10 = AE_UNSUPPORTED_CLIENT_TYPE
+    toEnum t = error $ "Invalid AppExnType " ++ show t
+
+    fromEnum AE_UNKNOWN = 0
+    fromEnum AE_UNKNOWN_METHOD = 1
+    fromEnum AE_INVALID_MESSAGE_TYPE = 2
+    fromEnum AE_WRONG_METHOD_NAME = 3
+    fromEnum AE_BAD_SEQUENCE_ID = 4
+    fromEnum AE_MISSING_RESULT = 5
+    fromEnum AE_INTERNAL_ERROR = 6
+    fromEnum AE_PROTOCOL_ERROR = 7
+    fromEnum AE_INVALID_TRANSFORM = 8
+    fromEnum AE_INVALID_PROTOCOL = 9
+    fromEnum AE_UNSUPPORTED_CLIENT_TYPE = 10
+
+data AppExn = AppExn { ae_type :: AppExnType, ae_message :: String }
+  deriving ( Show, Typeable )
+instance Exception AppExn
+
+writeAppExn :: (Protocol p, Transport t) => p t -> AppExn -> IO ()
+writeAppExn pt ae = writeVal pt $ TStruct $ Map.fromList
+                    [ (1, ("message", TString $ encodeUtf8 $ pack $ ae_message ae))
+                    , (2, ("type", TI32 $ fromIntegral $ fromEnum (ae_type ae)))
+                    ]
+
+readAppExn :: (Protocol p, Transport t) => p t -> IO AppExn
+readAppExn pt = do
+    let typemap = Map.fromList [(1,("message",T_STRING)),(2,("type",T_I32))]
+    TStruct fields <- readVal pt $ T_STRUCT typemap
+    return $ readAppExnFields fields
+
+readAppExnFields :: Map.HashMap Int16 (Text, ThriftVal) -> AppExn
+readAppExnFields fields = AppExn{
+  ae_message = maybe undefined unwrapMessage $ Map.lookup 1 fields,
+  ae_type    = maybe undefined unwrapType $ Map.lookup 2 fields
+  }
+  where
+    unwrapMessage (_, TString s) = unpack $ decodeUtf8 s
+    unwrapMessage _ = undefined
+    unwrapType (_, TI32 i) = toEnum $ fromIntegral i
+    unwrapType _ = undefined

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Arbitraries.hs

@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Thrift.Arbitraries where
+
+import Data.Bits()
+
+import Test.QuickCheck.Arbitrary
+
+import Control.Applicative ((<$>))
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Vector as Vector
+import qualified Data.Text.Lazy as Text
+import qualified Data.HashSet as HSet
+import qualified Data.HashMap.Strict as HMap
+import Data.Hashable (Hashable)
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BS
+
+-- String has an Arbitrary instance already
+-- Bool has an Arbitrary instance already
+-- A Thrift 'list' is a Vector.
+
+instance Arbitrary ByteString where
+  arbitrary = BS.pack . filter (/= 0) <$> arbitrary
+
+instance (Arbitrary k) => Arbitrary (Vector.Vector k) where
+  arbitrary = Vector.fromList <$> arbitrary
+
+instance Arbitrary Text.Text where
+  arbitrary = Text.pack . filter (/= '\0') <$> arbitrary
+
+instance (Eq k, Hashable k, Arbitrary k) => Arbitrary (HSet.HashSet k) where
+  arbitrary = HSet.fromList <$> arbitrary
+
+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) =>
+    Arbitrary (HMap.HashMap k v) where
+  arbitrary = HMap.fromList <$> arbitrary
+
+{-
+   To handle Thrift 'enum' we would ideally use something like:
+
+instance (Enum a, Bounded a) => Arbitrary a
+    where arbitrary = elements (enumFromTo minBound maxBound)
+
+Unfortunately this doesn't play nicely with the type system.
+Instead we'll generate an arbitrary instance along with the code.
+-}
+
+{-
+    There might be some way to introspect on the Haskell structure of a
+    Thrift 'struct' or 'exception' but generating the code directly is simpler.
+-}

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Protocol.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+--
+-- 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
+    ( Protocol(..)
+    , ProtocolExn(..)
+    , ProtocolExnType(..)
+    , getTypeOf
+    , runParser
+    , versionMask
+    , version1
+    , bsToDouble
+    , bsToDoubleLE
+    ) where
+
+import Control.Exception
+import Data.Attoparsec.ByteString
+import Data.Bits
+import Data.ByteString.Lazy (ByteString, toStrict)
+import Data.ByteString.Unsafe
+import Data.Functor ((<$>))
+import Data.Int
+import Data.Monoid (mempty)
+import Data.Text.Lazy (Text)
+import Data.Typeable (Typeable)
+import Data.Word
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (Storable, peek, poke)
+import System.IO.Unsafe
+import qualified Data.ByteString as BS
+import qualified Data.HashMap.Strict as Map
+
+import Thrift.Types
+import Thrift.Transport
+
+versionMask :: Int32
+versionMask = fromIntegral (0xffff0000 :: Word32)
+
+version1 :: Int32
+version1 = fromIntegral (0x80010000 :: Word32)
+
+class Protocol a where
+  getTransport :: Transport t => a t -> t
+
+  writeMessageBegin :: Transport t => a t -> (Text, MessageType, Int32) -> IO ()
+  writeMessageEnd :: Transport t => a t -> IO ()
+  writeMessageEnd _ = return ()
+  
+  readMessageBegin :: Transport t => a t -> IO (Text, MessageType, Int32)
+  readMessageEnd :: Transport t => a t -> IO ()
+  readMessageEnd _ = return ()
+
+  serializeVal :: Transport t => a t -> ThriftVal -> ByteString
+  deserializeVal :: Transport t => a t -> ThriftType -> ByteString -> ThriftVal
+
+  writeVal :: Transport t => a t -> ThriftVal -> IO ()
+  writeVal p = tWrite (getTransport p) . serializeVal p
+  readVal :: Transport t => a t -> ThriftType -> IO ThriftVal
+
+data ProtocolExnType
+    = PE_UNKNOWN
+    | PE_INVALID_DATA
+    | PE_NEGATIVE_SIZE
+    | PE_SIZE_LIMIT
+    | PE_BAD_VERSION
+    | PE_NOT_IMPLEMENTED
+    | PE_MISSING_REQUIRED_FIELD
+      deriving ( Eq, Show, Typeable )
+
+data ProtocolExn = ProtocolExn ProtocolExnType String
+  deriving ( Show, Typeable )
+instance Exception ProtocolExn
+
+getTypeOf :: ThriftVal -> ThriftType
+getTypeOf v =  case v of
+  TStruct{} -> T_STRUCT Map.empty
+  TMap{} -> T_MAP T_VOID T_VOID
+  TList{} -> T_LIST T_VOID
+  TSet{} -> T_SET T_VOID
+  TBool{} -> T_BOOL
+  TByte{} -> T_BYTE
+  TI16{} -> T_I16
+  TI32{} -> T_I32
+  TI64{} -> T_I64
+  TString{} -> T_STRING
+  TBinary{} -> T_BINARY
+  TDouble{} -> T_DOUBLE
+
+runParser :: (Protocol p, Transport t, Show a) => p t -> Parser a -> IO a
+runParser prot p = refill >>= getResult . parse p
+  where
+    refill = handle handleEOF $ toStrict <$> tReadAll (getTransport prot) 1
+    getResult (Done _ a) = return a
+    getResult (Partial k) = refill >>= getResult . k
+    getResult f = throw $ ProtocolExn PE_INVALID_DATA (show f)
+
+handleEOF :: SomeException -> IO BS.ByteString
+handleEOF = const $ return mempty
+
+-- | Converts a ByteString to a Floating point number
+-- The ByteString is assumed to be encoded in network order (Big Endian)
+-- therefore the behavior of this function varies based on whether the local
+-- machine is big endian or little endian.
+bsToDouble :: BS.ByteString -> Double
+bsToDoubleLE :: BS.ByteString -> Double
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped
+bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs
+#else
+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs
+bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped
+#endif
+
+
+castBsSwapped chrPtr = do
+  w <- peek (castPtr chrPtr)
+  poke (castPtr chrPtr) (byteSwap w)
+  peek (castPtr chrPtr)
+castBs = peek . castPtr
+
+-- | Swap endianness of a 64-bit word
+byteSwap :: Word64 -> Word64
+byteSwap w = (w `shiftL` 56 .&. 0xFF00000000000000) .|.
+             (w `shiftL` 40 .&. 0x00FF000000000000) .|.
+             (w `shiftL` 24 .&. 0x0000FF0000000000) .|.
+             (w `shiftL` 8  .&. 0x000000FF00000000) .|.
+             (w `shiftR` 8  .&. 0x00000000FF000000) .|.
+             (w `shiftR` 24 .&. 0x0000000000FF0000) .|.
+             (w `shiftR` 40 .&. 0x000000000000FF00) .|.
+             (w `shiftR` 56 .&. 0x00000000000000FF)

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Protocol/Binary.hs

@@ -0,0 +1,191 @@
+--
+-- 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(..)
+    ) 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 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
+
+data BinaryProtocol a = BinaryProtocol a
+
+-- 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 Protocol BinaryProtocol where
+    getTransport (BinaryProtocol t) = t
+
+    writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $
+        buildBinaryValue (TI32 (version1 .|. fromIntegral (fromEnum t))) <>
+        buildBinaryValue (TString $ encodeUtf8 n) <>
+        buildBinaryValue (TI32 s)
+
+    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)
+
+    serializeVal _ = toLazyByteString . buildBinaryValue
+    deserializeVal _ ty bs =
+      case LP.eitherResult $ LP.parse (parseBinaryValue ty) bs of
+        Left s -> error s
+        Right val -> val
+
+    readVal p = runParser p . parseBinaryValue
+
+-- | 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)

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Protocol/Compact.hs

@@ -0,0 +1,301 @@
+--
+-- 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.Compact
+    ( module Thrift.Protocol
+    , CompactProtocol(..)
+    ) where
+
+import Control.Applicative
+import Control.Exception ( throw )
+import Control.Monad
+import Data.Attoparsec.ByteString as P
+import Data.Attoparsec.ByteString.Lazy as LP
+import Data.Bits
+import Data.ByteString.Lazy.Builder as B
+import Data.Int
+import Data.List as List
+import Data.Monoid
+import Data.Word
+import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 )
+
+import Thrift.Protocol hiding (versionMask)
+import Thrift.Transport
+import Thrift.Types
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict as Map
+import qualified Data.Text.Lazy as LT
+
+-- | the Compact Protocol implements the standard Thrift 'TCompactProcotol'
+-- which is similar to the 'TBinaryProtocol', but takes less space on the wire.
+-- Integral types are encoded using as varints.
+data CompactProtocol a = CompactProtocol a
+                         -- ^ Constuct a 'CompactProtocol' with a 'Transport'
+
+protocolID, version, versionMask, typeMask, typeBits :: Word8
+protocolID  = 0x82 -- 1000 0010
+version     = 0x01
+versionMask = 0x1f -- 0001 1111
+typeMask    = 0xe0 -- 1110 0000
+typeBits    = 0x07 -- 0000 0111
+typeShiftAmount :: Int
+typeShiftAmount = 5
+
+
+instance Protocol CompactProtocol where
+    getTransport (CompactProtocol t) = t
+
+    writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $
+      B.word8 protocolID <>
+      B.word8 ((version .&. versionMask) .|.
+              (((fromIntegral $ fromEnum t) `shiftL`
+                typeShiftAmount) .&. typeMask)) <>
+      buildVarint (i32ToZigZag s) <>
+      buildCompactValue (TString $ encodeUtf8 n)
+    
+    readMessageBegin p = runParser p $ do
+      pid <- fromIntegral <$> P.anyWord8
+      when (pid /= protocolID) $ error "Bad Protocol ID"
+      w <- fromIntegral <$> P.anyWord8
+      let ver = w .&. versionMask 
+      when (ver /= version) $ error "Bad Protocol version"
+      let typ = (w `shiftR` typeShiftAmount) .&. typeBits
+      seqId <- parseVarint zigZagToI32
+      TString name <- parseCompactValue T_STRING
+      return (decodeUtf8 name, toEnum $ fromIntegral $ typ, seqId)
+
+    serializeVal _ = toLazyByteString . buildCompactValue
+    deserializeVal _ ty bs =
+      case LP.eitherResult $ LP.parse (parseCompactValue ty) bs of
+        Left s -> error s
+        Right val -> val
+
+    readVal p ty = runParser p $ parseCompactValue ty
+
+
+-- | Writing Functions
+buildCompactValue :: ThriftVal -> Builder
+buildCompactValue (TStruct fields) = buildCompactStruct fields
+buildCompactValue (TMap kt vt entries) =
+  let len = fromIntegral $ length entries :: Word32 in
+  if len == 0
+  then B.word8 0x00
+  else buildVarint len <>
+       B.word8 (fromTType kt `shiftL` 4 .|. fromTType vt) <>
+       buildCompactMap entries
+buildCompactValue (TList ty entries) =
+  let len = length entries in
+  (if len < 15
+   then B.word8 $ (fromIntegral len `shiftL` 4) .|. fromTType ty
+   else B.word8 (0xF0 .|. fromTType ty) <>
+        buildVarint (fromIntegral len :: Word32)) <>
+  buildCompactList entries
+buildCompactValue (TSet ty entries) = buildCompactValue (TList ty entries)
+buildCompactValue (TBool b) =
+  B.word8 $ toEnum $ if b then 1 else 0
+buildCompactValue (TByte b) = int8 b
+buildCompactValue (TI16 i) = buildVarint $ i16ToZigZag i
+buildCompactValue (TI32 i) = buildVarint $ i32ToZigZag i
+buildCompactValue (TI64 i) = buildVarint $ i64ToZigZag i
+buildCompactValue (TDouble d) = doubleLE d
+buildCompactValue (TString s) = buildVarint len <> lazyByteString s
+  where
+    len = fromIntegral (LBS.length s) :: Word32
+buildCompactValue (TBinary s) = buildCompactValue (TString s)
+
+buildCompactStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
+buildCompactStruct = flip (loop 0) mempty . Map.toList
+  where
+    loop _ [] acc = acc <> B.word8 (fromTType T_STOP)
+    loop lastId ((fid, (_,val)) : fields) acc = loop fid fields $ acc <>
+      (if fid > lastId && fid - lastId <= 15
+       then B.word8 $ fromIntegral ((fid - lastId) `shiftL` 4) .|. typeOf val
+       else B.word8 (typeOf val) <> buildVarint (i16ToZigZag fid)) <>
+      (if typeOf val > 0x02 -- Not a T_BOOL
+       then buildCompactValue val
+       else mempty) -- T_BOOLs are encoded in the type
+buildCompactMap :: [(ThriftVal, ThriftVal)] -> Builder
+buildCompactMap = foldl combine mempty
+  where
+    combine s (key, val) = buildCompactValue key <> buildCompactValue val <> s
+
+buildCompactList :: [ThriftVal] -> Builder
+buildCompactList = foldr (mappend . buildCompactValue) mempty
+
+-- | Reading Functions
+parseCompactValue :: ThriftType -> Parser ThriftVal
+parseCompactValue (T_STRUCT tmap) = TStruct <$> parseCompactStruct tmap
+parseCompactValue (T_MAP kt' vt') = do
+  n <- parseVarint id
+  if n == 0
+    then return $ TMap kt' vt' []
+    else do
+    w <- P.anyWord8
+    let kt = typeFrom $ w `shiftR` 4
+        vt = typeFrom $ w .&. 0x0F
+    TMap kt vt <$> parseCompactMap kt vt n
+parseCompactValue (T_LIST ty) = TList ty <$> parseCompactList
+parseCompactValue (T_SET ty) = TSet ty <$> parseCompactList
+parseCompactValue T_BOOL = TBool . (/=0) <$> P.anyWord8
+parseCompactValue T_BYTE = TByte . fromIntegral <$> P.anyWord8
+parseCompactValue T_I16 = TI16 <$> parseVarint zigZagToI16
+parseCompactValue T_I32 = TI32 <$> parseVarint zigZagToI32
+parseCompactValue T_I64 = TI64 <$> parseVarint zigZagToI64
+parseCompactValue T_DOUBLE = TDouble . bsToDoubleLE <$> P.take 8
+parseCompactValue T_STRING = parseCompactString TString
+parseCompactValue T_BINARY = parseCompactString TBinary
+parseCompactValue ty = error $ "Cannot read value of type " ++ show ty
+
+parseCompactString ty = do
+  len :: Word32 <- parseVarint id
+  ty . LBS.fromStrict <$> P.take (fromIntegral len)
+
+parseCompactStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
+parseCompactStruct tmap = Map.fromList <$> parseFields 0
+  where
+    parseFields :: Int16 -> Parser [(Int16, (LT.Text, ThriftVal))]
+    parseFields lastId = do
+      w <- P.anyWord8
+      if w == 0x00
+        then return []
+        else do
+          let ty = typeFrom (w .&. 0x0F)
+              modifier = (w .&. 0xF0) `shiftR` 4
+          fid <- if modifier /= 0
+                 then return (lastId + fromIntegral modifier)
+                 else parseVarint zigZagToI16
+          val <- if ty == T_BOOL
+                 then return (TBool $ (w .&. 0x0F) == 0x01)
+                 else case (ty, Map.lookup fid tmap) of
+                        (T_STRING, Just (_, T_BINARY)) -> parseCompactValue T_BINARY
+                        _ -> parseCompactValue ty
+          ((fid, (LT.empty, val)) : ) <$> parseFields fid
+
+parseCompactMap :: ThriftType -> ThriftType -> Int32 ->
+                   Parser [(ThriftVal, ThriftVal)]
+parseCompactMap kt vt n | n <= 0 = return []
+                        | otherwise = do
+  k <- parseCompactValue kt
+  v <- parseCompactValue vt
+  ((k,v) :) <$> parseCompactMap kt vt (n-1)
+
+parseCompactList :: Parser [ThriftVal]
+parseCompactList = do
+  w <- P.anyWord8
+  let ty = typeFrom $ w .&. 0x0F
+      lsize = w `shiftR` 4
+  size <- if lsize == 0xF
+          then parseVarint id
+          else return $ fromIntegral lsize
+  loop ty size
+  where
+    loop :: ThriftType -> Int32 -> Parser [ThriftVal]
+    loop ty n | n <= 0 = return []
+              | otherwise = liftM2 (:) (parseCompactValue ty)
+                            (loop ty (n-1))
+
+-- Signed numbers must be converted to "Zig Zag" format before they can be
+-- serialized in the Varint format
+i16ToZigZag :: Int16 -> Word16
+i16ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 15)
+
+zigZagToI16 :: Word16 -> Int16
+zigZagToI16 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)
+
+i32ToZigZag :: Int32 -> Word32
+i32ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 31)
+
+zigZagToI32 :: Word32 -> Int32
+zigZagToI32 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)
+
+i64ToZigZag :: Int64 -> Word64
+i64ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 63)
+
+zigZagToI64 :: Word64 -> Int64
+zigZagToI64 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)
+
+buildVarint :: (Bits a, Integral a)  => a -> Builder
+buildVarint n | n .&. complement 0x7F == 0 = B.word8 $ fromIntegral n
+              | otherwise = B.word8 (0x80 .|. (fromIntegral n .&. 0x7F)) <>
+                            buildVarint (n `shiftR` 7)
+
+parseVarint :: (Bits a, Integral a, Ord a) => (a -> b) -> Parser b
+parseVarint fromZigZag = do
+  bytestemp <- BS.unpack <$> P.takeTill (not . flip testBit 7)
+  lsb <- P.anyWord8
+  let bytes = lsb : List.reverse bytestemp
+  return $ fromZigZag $ List.foldl' combine 0x00 bytes
+  where combine a b = (a `shiftL` 7) .|. (fromIntegral b .&. 0x7f)
+
+-- | Compute the Compact Type
+fromTType :: ThriftType -> Word8
+fromTType ty = case ty of
+  T_STOP -> 0x00
+  T_BOOL -> 0x01
+  T_BYTE -> 0x03
+  T_I16 -> 0x04
+  T_I32 -> 0x05
+  T_I64 -> 0x06
+  T_DOUBLE -> 0x07
+  T_STRING -> 0x08
+  T_BINARY -> 0x08
+  T_LIST{} -> 0x09
+  T_SET{} -> 0x0A
+  T_MAP{} -> 0x0B
+  T_STRUCT{} -> 0x0C
+  T_VOID -> error "No Compact type for T_VOID"
+
+typeOf :: ThriftVal -> Word8
+typeOf v = case v of
+  TBool True -> 0x01
+  TBool False -> 0x02
+  TByte _ -> 0x03
+  TI16 _ -> 0x04
+  TI32 _ -> 0x05
+  TI64 _ -> 0x06
+  TDouble _ -> 0x07
+  TString _ -> 0x08
+  TBinary _ -> 0x08
+  TList{} -> 0x09
+  TSet{} -> 0x0A
+  TMap{} -> 0x0B
+  TStruct{} -> 0x0C
+  
+typeFrom :: Word8 -> ThriftType
+typeFrom w = case w of
+  0x01 -> T_BOOL
+  0x02 -> T_BOOL
+  0x03 -> T_BYTE
+  0x04 -> T_I16
+  0x05 -> T_I32
+  0x06 -> T_I64
+  0x07 -> T_DOUBLE
+  0x08 -> T_STRING
+  0x09 -> T_LIST T_VOID
+  0x0A -> T_SET T_VOID
+  0x0B -> T_MAP T_VOID T_VOID
+  0x0C -> T_STRUCT Map.empty
+  n -> error $ "typeFrom: " ++ show n ++ " is not a compact type"

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Protocol/JSON.hs

@@ -0,0 +1,352 @@
+--
+-- 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 #-}
+{-# LANGUAGE TupleSections #-}
+
+module Thrift.Protocol.JSON
+    ( module Thrift.Protocol
+    , JSONProtocol(..)
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Attoparsec.ByteString as P
+import Data.Attoparsec.ByteString.Char8 as PC
+import Data.Attoparsec.ByteString.Lazy as LP
+import Data.ByteString.Base64.Lazy as B64C
+import Data.ByteString.Base64 as B64
+import Data.ByteString.Lazy.Builder as B
+import Data.ByteString.Internal (c2w, w2c)
+import Data.Functor
+import Data.Int
+import Data.List
+import Data.Maybe (catMaybes)
+import Data.Monoid
+import Data.Text.Lazy.Encoding
+import Data.Word
+import qualified Data.HashMap.Strict as Map
+
+import Thrift.Protocol
+import Thrift.Transport
+import Thrift.Types
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Data.Text.Lazy as LT
+
+-- | The JSON Protocol data uses the standard 'TJSONProtocol'.  Data is
+-- encoded as a JSON 'ByteString'
+data JSONProtocol t = JSONProtocol t
+                      -- ^ Construct a 'JSONProtocol' with a 'Transport'
+
+instance Protocol JSONProtocol where
+    getTransport (JSONProtocol t) = t
+
+    writeMessageBegin (JSONProtocol t) (s, ty, sq) = tWrite t $ toLazyByteString $
+      B.char8 '[' <> buildShowable (1 :: Int32) <>
+      B.string8 ",\"" <> escape (encodeUtf8 s) <> B.char8 '\"' <>
+      B.char8 ',' <> buildShowable (fromEnum ty) <>
+      B.char8 ',' <> buildShowable sq <>
+      B.char8 ','
+    writeMessageEnd (JSONProtocol t) = tWrite t "]"
+    readMessageBegin p = runParser p $ skipSpace *> do
+      _ver :: Int32 <- lexeme (PC.char8 '[') *> lexeme (signed decimal)
+      bs <- lexeme (PC.char8 ',') *> lexeme escapedString
+      case decodeUtf8' bs of
+        Left _ -> fail "readMessage: invalid text encoding"
+        Right str -> do
+          ty <- toEnum <$> (lexeme (PC.char8 ',') *> lexeme (signed decimal))
+          seqNum <- lexeme (PC.char8 ',') *> lexeme (signed decimal)
+          _ <- PC.char8 ','
+          return (str, ty, seqNum)
+    readMessageEnd p = void $ runParser p (PC.char8 ']')
+
+    serializeVal _ = toLazyByteString . buildJSONValue
+    deserializeVal _ ty bs =
+      case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of
+        Left s -> error s
+        Right val -> val
+
+    readVal p ty = runParser p $ skipSpace *> parseJSONValue ty
+
+
+-- Writing Functions
+
+buildJSONValue :: ThriftVal -> Builder
+buildJSONValue (TStruct fields) = B.char8 '{' <> buildJSONStruct fields <> B.char8 '}'
+buildJSONValue (TMap kt vt entries) =
+  B.char8 '[' <> B.char8 '"' <> getTypeName kt <> B.char8 '"' <>
+  B.char8 ',' <> B.char8 '"' <> getTypeName vt <> B.char8 '"' <>
+  B.char8 ',' <> buildShowable (length entries) <>
+  B.char8 ',' <> B.char8 '{' <> buildJSONMap entries <> B.char8 '}' <>
+  B.char8 ']'
+buildJSONValue (TList ty entries) =
+  B.char8 '[' <> B.char8 '"' <> getTypeName ty <> B.char8 '"' <>
+  B.char8 ',' <> buildShowable (length entries) <>
+  (if length entries > 0
+   then B.char8 ',' <> buildJSONList entries
+   else mempty) <>
+  B.char8 ']'
+buildJSONValue (TSet ty entries) = buildJSONValue (TList ty entries)
+buildJSONValue (TBool b) = if b then B.char8 '1' else B.char8 '0'
+buildJSONValue (TByte b) = buildShowable b
+buildJSONValue (TI16 i) = buildShowable i
+buildJSONValue (TI32 i) = buildShowable i
+buildJSONValue (TI64 i) = buildShowable i
+buildJSONValue (TDouble d) = buildShowable d
+buildJSONValue (TString s) = B.char8 '\"' <> escape s <> B.char8 '\"'
+buildJSONValue (TBinary s) = B.char8 '\"' <> (B.lazyByteString . B64C.encode $ s) <> B.char8 '\"'
+
+buildJSONStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
+buildJSONStruct = mconcat . intersperse (B.char8 ',') . Map.foldrWithKey buildField []
+  where 
+    buildField fid (_,val) = (:) $
+      B.char8 '"' <> buildShowable fid <> B.string8 "\":" <> 
+      B.char8 '{' <>
+      B.char8 '"' <> getTypeName (getTypeOf val) <> B.string8 "\":" <>
+      buildJSONValue val <>
+      B.char8 '}'
+
+buildJSONMap :: [(ThriftVal, ThriftVal)] -> Builder
+buildJSONMap = mconcat . intersperse (B.char8 ',') . map buildKV
+  where
+    buildKV (key@(TString _), val) =
+      buildJSONValue key <> B.char8 ':' <> buildJSONValue val
+    buildKV (key, val) =
+      B.char8 '\"' <> buildJSONValue key <> B.string8 "\":" <> buildJSONValue val
+buildJSONList :: [ThriftVal] -> Builder
+buildJSONList = mconcat . intersperse (B.char8 ',') . map buildJSONValue
+
+buildShowable :: Show a => a ->  Builder
+buildShowable = B.string8 . show
+
+-- Reading Functions
+
+parseJSONValue :: ThriftType -> Parser ThriftVal
+parseJSONValue (T_STRUCT tmap) =
+  TStruct <$> (lexeme (PC.char8 '{') *> parseJSONStruct tmap <* PC.char8 '}')
+parseJSONValue (T_MAP kt vt) = fmap (TMap kt vt) $
+  between '[' ']' $
+    lexeme escapedString *> lexeme (PC.char8 ',') *>
+    lexeme escapedString *> lexeme (PC.char8 ',') *>
+    lexeme decimal *> lexeme (PC.char8 ',') *>
+    between '{' '}' (parseJSONMap kt vt)
+parseJSONValue (T_LIST ty) = fmap (TList ty) $
+  between '[' ']' $ do
+    len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal
+    if len > 0
+      then lexeme (PC.char8 ',') *> parseJSONList ty
+      else return []
+parseJSONValue (T_SET ty) = fmap (TSet ty) $
+  between '[' ']' $ do
+    len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal
+    if len > 0
+      then  lexeme (PC.char8 ',') *> parseJSONList ty
+      else return []
+parseJSONValue T_BOOL =
+  (TBool True <$ PC.char8 '1') <|> (TBool False <$ PC.char8 '0')
+parseJSONValue T_BYTE = TByte <$> signed decimal
+parseJSONValue T_I16 = TI16 <$> signed decimal
+parseJSONValue T_I32 = TI32 <$> signed decimal
+parseJSONValue T_I64 = TI64 <$> signed decimal
+parseJSONValue T_DOUBLE = TDouble <$> double
+parseJSONValue T_STRING = TString <$> escapedString
+parseJSONValue T_BINARY = TBinary <$> base64String
+parseJSONValue T_STOP = fail "parseJSONValue: cannot parse type T_STOP"
+parseJSONValue T_VOID = fail "parseJSONValue: cannot parse type T_VOID"
+
+parseAnyValue :: Parser ()
+parseAnyValue = choice $
+                skipBetween '{' '}' :
+                skipBetween '[' ']' :
+                map (void . parseJSONValue)
+                  [ T_BOOL
+                  , T_I16
+                  , T_I32
+                  , T_I64
+                  , T_DOUBLE
+                  , T_STRING
+                  , T_BINARY
+                  ]
+  where
+    skipBetween :: Char -> Char -> Parser ()
+    skipBetween a b = between a b $ void (PC.satisfy (\c -> c /= a && c /= b))
+                                          <|> skipBetween a b
+
+parseJSONStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
+parseJSONStruct tmap = Map.fromList . catMaybes <$> parseField
+                       `sepBy` lexeme (PC.char8 ',')
+  where
+    parseField = do
+      fid <- lexeme (between '"' '"' decimal) <* lexeme (PC.char8 ':')
+      case Map.lookup fid tmap of
+        Just (str, ftype) -> between '{' '}' $ do
+          _ <- lexeme (escapedString) *> lexeme (PC.char8 ':')
+          val <- lexeme (parseJSONValue ftype)
+          return $ Just (fid, (str, val))
+        Nothing -> lexeme parseAnyValue *> return Nothing
+
+parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)]
+parseJSONMap kt vt =
+  ((,) <$> lexeme (parseJSONKey kt) <*>
+   (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy`
+  lexeme (PC.char8 ',')
+  where
+    parseJSONKey T_STRING = parseJSONValue T_STRING
+    parseJSONKey T_BINARY = parseJSONValue T_BINARY
+    parseJSONKey kt = PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"'
+
+parseJSONList :: ThriftType -> Parser [ThriftVal]
+parseJSONList ty = lexeme (parseJSONValue ty) `sepBy` lexeme (PC.char8 ',')
+
+escapedString :: Parser LBS.ByteString
+escapedString = PC.char8 '"' *>
+                (LBS.pack <$> P.many' (escapedChar <|> notChar8 '"')) <*
+                PC.char8 '"'
+
+base64String :: Parser LBS.ByteString
+base64String = PC.char8 '"' *>
+               (decodeBase64 . LBSC.pack <$> P.many' (PC.notChar '"')) <*
+               PC.char8 '"'
+               where
+                 decodeBase64 b =
+                   let padded = case (LBS.length b) `mod` 4 of
+                                  2 -> LBS.append b "=="
+                                  3 -> LBS.append b "="
+                                  _ -> b in
+                   case B64C.decode padded of
+                     Right s -> s
+                     Left x -> error x
+
+escapedChar :: Parser Word8
+escapedChar = PC.char8 '\\' *> (c2w <$> choice
+                                [ '\SOH' <$ P.string "u0001"
+                                , '\STX' <$ P.string "u0002"
+                                , '\ETX' <$ P.string "u0003"
+                                , '\EOT' <$ P.string "u0004"
+                                , '\ENQ' <$ P.string "u0005"
+                                , '\ACK' <$ P.string "u0006"
+                                , '\BEL' <$ P.string "u0007"
+                                , '\BS'  <$ P.string "u0008"
+                                , '\VT'  <$ P.string "u000b"
+                                , '\FF'  <$ P.string "u000c"
+                                , '\CR'  <$ P.string "u000d"
+                                , '\SO'  <$ P.string "u000e"
+                                , '\SI'  <$ P.string "u000f"
+                                , '\DLE' <$ P.string "u0010"
+                                , '\DC1' <$ P.string "u0011"
+                                , '\DC2' <$ P.string "u0012"
+                                , '\DC3' <$ P.string "u0013"
+                                , '\DC4' <$ P.string "u0014"
+                                , '\NAK' <$ P.string "u0015"
+                                , '\SYN' <$ P.string "u0016"
+                                , '\ETB' <$ P.string "u0017"
+                                , '\CAN' <$ P.string "u0018"
+                                , '\EM'  <$ P.string "u0019"
+                                , '\SUB' <$ P.string "u001a"
+                                , '\ESC' <$ P.string "u001b"
+                                , '\FS'  <$ P.string "u001c"
+                                , '\GS'  <$ P.string "u001d"
+                                , '\RS'  <$ P.string "u001e"
+                                , '\US'  <$ P.string "u001f"
+                                , '\DEL' <$ P.string "u007f"
+                                , '\0' <$ PC.char '0'
+                                , '\a' <$ PC.char 'a'
+                                , '\b' <$ PC.char 'b'
+                                , '\f' <$ PC.char 'f'
+                                , '\n' <$ PC.char 'n'
+                                , '\r' <$ PC.char 'r'
+                                , '\t' <$ PC.char 't'
+                                , '\v' <$ PC.char 'v'
+                                , '\"' <$ PC.char '"'
+                                , '\'' <$ PC.char '\''
+                                , '\\' <$ PC.char '\\'
+                                , '/'  <$ PC.char '/'
+                                ])
+
+escape :: LBS.ByteString -> Builder
+escape = LBS.foldl' escapeChar mempty
+  where
+    escapeChar b w = b <> (B.lazyByteString $ case w2c w of
+      '\0' -> "\\0"
+      '\b' -> "\\b"
+      '\f' -> "\\f"
+      '\n' -> "\\n"
+      '\r' -> "\\r"
+      '\t' -> "\\t"
+      '\"' -> "\\\""
+      '\\' -> "\\\\"
+      '\SOH' -> "\\u0001"
+      '\STX' -> "\\u0002"
+      '\ETX' -> "\\u0003"
+      '\EOT' -> "\\u0004"
+      '\ENQ' -> "\\u0005"
+      '\ACK' -> "\\u0006"
+      '\BEL' -> "\\u0007"
+      '\VT'  -> "\\u000b"
+      '\SO'  -> "\\u000e"
+      '\SI'  -> "\\u000f"
+      '\DLE' -> "\\u0010"
+      '\DC1' -> "\\u0011"
+      '\DC2' -> "\\u0012"
+      '\DC3' -> "\\u0013"
+      '\DC4' -> "\\u0014"
+      '\NAK' -> "\\u0015"
+      '\SYN' -> "\\u0016"
+      '\ETB' -> "\\u0017"
+      '\CAN' -> "\\u0018"
+      '\EM'  -> "\\u0019"
+      '\SUB' -> "\\u001a"
+      '\ESC' -> "\\u001b"
+      '\FS'  -> "\\u001c"
+      '\GS'  -> "\\u001d"
+      '\RS'  -> "\\u001e"
+      '\US'  -> "\\u001f"
+      '\DEL' -> "\\u007f"
+      _ -> LBS.singleton w)
+
+lexeme :: Parser a -> Parser a
+lexeme = (<* skipSpace)
+
+notChar8 :: Char -> Parser Word8
+notChar8 c = P.satisfy (/= c2w c)
+
+between :: Char -> Char -> Parser a -> Parser a
+between a b p = lexeme (PC.char8 a) *> lexeme p <* lexeme (PC.char8 b)
+
+getTypeName :: ThriftType -> Builder
+getTypeName ty = B.string8 $ case ty of
+  T_STRUCT _ -> "rec"
+  T_MAP _ _  -> "map"
+  T_LIST _   -> "lst"
+  T_SET _    -> "set"
+  T_BOOL     -> "tf"
+  T_BYTE     -> "i8"
+  T_I16      -> "i16"
+  T_I32      -> "i32"
+  T_I64      -> "i64"
+  T_DOUBLE   -> "dbl"
+  T_STRING   -> "str"
+  T_BINARY   -> "str"
+  _ -> error "Unrecognized Type"
+

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Server.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+--
+-- 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.Server
+    ( runBasicServer
+    , runThreadedServer
+    ) where
+
+import Control.Concurrent ( forkIO )
+import Control.Exception
+import Control.Monad ( forever, when )
+
+import Network
+
+import System.IO
+
+import Thrift
+import Thrift.Transport.Handle()
+import Thrift.Protocol.Binary
+
+
+-- | A threaded sever that is capable of using any Transport or Protocol
+-- instances.
+runThreadedServer :: (Transport t, Protocol i, Protocol o)
+                  => (Socket -> IO (i t, o t))
+                  -> h
+                  -> (h -> (i t, o t) -> IO Bool)
+                  -> PortID
+                  -> IO a
+runThreadedServer accepter hand proc_ port = do
+    socket <- listenOn port
+    acceptLoop (accepter socket) (proc_ hand)
+
+-- | A basic threaded binary protocol socket server.
+runBasicServer :: h
+               -> (h -> (BinaryProtocol Handle, BinaryProtocol Handle) -> IO Bool)
+               -> PortNumber
+               -> IO a
+runBasicServer hand proc_ port = runThreadedServer binaryAccept hand proc_ (PortNumber port)
+  where binaryAccept s = do
+            (h, _, _) <- accept s
+            return (BinaryProtocol h, BinaryProtocol h)
+
+acceptLoop :: IO t -> (t -> IO Bool) -> IO a
+acceptLoop accepter proc_ = forever $
+    do ps <- accepter
+       forkIO $ handle (\(_ :: SomeException) -> return ())
+                  (loop $ proc_ ps)
+  where loop m = do { continue <- m; when continue (loop m) }

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+--
+-- 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.Transport
+  ( Transport(..)
+  , TransportExn(..)
+  , TransportExnType(..)
+  ) where
+
+import Control.Monad ( when )
+import Control.Exception ( Exception, throw )
+import Data.Functor ( (<$>) )
+import Data.Typeable ( Typeable )
+import Data.Word
+
+import qualified Data.ByteString.Lazy as LBS
+import Data.Monoid
+
+class Transport a where
+    tIsOpen :: a -> IO Bool
+    tClose  :: a -> IO ()
+    tRead   :: a -> Int -> IO LBS.ByteString
+    tPeek   :: a -> IO (Maybe Word8)
+    tWrite  :: a -> LBS.ByteString -> IO ()
+    tFlush  :: a -> IO ()
+    tReadAll :: a -> Int -> IO LBS.ByteString
+
+    tReadAll _ 0 = return mempty
+    tReadAll a len = do
+        result <- tRead a len
+        let rlen = fromIntegral $ LBS.length result
+        when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN)
+        if len <= rlen
+          then return result
+          else (result `mappend`) <$> tReadAll a (len - rlen)
+
+data TransportExn = TransportExn String TransportExnType
+  deriving ( Show, Typeable )
+instance Exception TransportExn
+
+data TransportExnType
+    = TE_UNKNOWN
+    | TE_NOT_OPEN
+    | TE_ALREADY_OPEN
+    | TE_TIMED_OUT
+    | TE_END_OF_FILE
+      deriving ( Eq, Show, Typeable )

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport/Empty.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+--
+-- 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.Transport.Empty
+       ( EmptyTransport(..)
+       ) where
+
+import Thrift.Transport
+
+data EmptyTransport = EmptyTransport
+
+instance Transport EmptyTransport where
+    tIsOpen = const $ return False
+    tClose  = const $ return ()
+    tRead _ _ = return ""
+    tPeek = const $ return Nothing
+    tWrite _ _ = return ()
+    tFlush = const$ return ()

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport/Framed.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+--
+-- 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.Transport.Framed
+    ( module Thrift.Transport
+    , FramedTransport
+    , openFramedTransport
+    ) where
+
+import Thrift.Transport
+import Thrift.Transport.IOBuffer
+
+import Data.Int (Int32)
+import qualified Data.Binary as B
+import qualified Data.ByteString.Lazy as LBS
+
+
+-- | FramedTransport wraps a given transport in framed mode.
+data FramedTransport t = FramedTransport {
+      wrappedTrans :: t,           -- ^ Underlying transport.
+      writeBuffer  :: WriteBuffer, -- ^ Write buffer.
+      readBuffer   :: ReadBuffer   -- ^ Read buffer.
+    }
+
+-- | Create a new framed transport which wraps the given transport.
+openFramedTransport :: Transport t => t -> IO (FramedTransport t)
+openFramedTransport trans = do
+  wbuf <- newWriteBuffer
+  rbuf <- newReadBuffer
+  return FramedTransport{ wrappedTrans = trans, writeBuffer = wbuf, readBuffer = rbuf }
+
+instance Transport t => Transport (FramedTransport t) where
+
+    tClose = tClose . wrappedTrans
+
+    tRead trans n = do
+      -- First, check the read buffer for any data.
+      bs <- readBuf (readBuffer trans) n
+      if LBS.null bs
+         then
+         -- When the buffer is empty, read another frame from the
+         -- underlying transport.
+           do len <- readFrame trans
+              if len > 0
+                 then tRead trans n
+                 else return bs
+         else return bs
+    tPeek trans = do
+      mw <- peekBuf (readBuffer trans)
+      case mw of
+        Just _ -> return mw
+        Nothing -> do
+          len <- readFrame trans
+          if len > 0
+             then tPeek trans
+             else return Nothing
+
+    tWrite = writeBuf . writeBuffer
+
+    tFlush trans = do
+      bs <- flushBuf (writeBuffer trans)
+      let szBs = B.encode $ (fromIntegral $ LBS.length bs :: Int32)
+      tWrite (wrappedTrans trans) szBs
+      tWrite (wrappedTrans trans) bs
+      tFlush (wrappedTrans trans)
+
+    tIsOpen = tIsOpen . wrappedTrans
+
+readFrame :: Transport t => FramedTransport t -> IO Int
+readFrame trans = do
+  -- Read and decode the frame size.
+  szBs <- tRead (wrappedTrans trans) 4
+  let sz = fromIntegral (B.decode szBs :: Int32)
+
+  -- Read the frame and stuff it into the read buffer.
+  bs <- tRead (wrappedTrans trans) sz
+  fillBuf (readBuffer trans) bs
+
+  -- Return the frame size so that the caller knows whether to expect
+  -- something in the read buffer or not.
+  return sz

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport/Handle.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--
+-- 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.Transport.Handle
+    ( module Thrift.Transport
+    , HandleSource(..)
+    ) where
+
+import Control.Exception ( catch, throw )
+import Data.ByteString.Internal (c2w)
+import Data.Functor
+
+import Network
+
+import System.IO
+import System.IO.Error ( isEOFError )
+
+import Thrift.Transport
+
+import qualified Data.ByteString.Lazy as LBS
+import Data.Monoid
+
+instance Transport Handle where
+    tIsOpen = hIsOpen
+    tClose = hClose
+    tRead h n = LBS.hGet h n `Control.Exception.catch` handleEOF mempty
+    tPeek h = (Just . c2w <$> hLookAhead h) `Control.Exception.catch` handleEOF Nothing
+    tWrite = LBS.hPut
+    tFlush = hFlush
+
+
+-- | Type class for all types that can open a Handle. This class is used to
+-- replace tOpen in the Transport type class.
+class HandleSource s where
+    hOpen :: s -> IO Handle
+
+instance HandleSource FilePath where
+    hOpen s = openFile s ReadWriteMode
+
+instance HandleSource (HostName, PortID) where
+    hOpen = uncurry connectTo
+
+
+handleEOF :: a -> IOError -> IO a
+handleEOF a e = if isEOFError e
+    then return a
+    else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport/HttpClient.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE FlexibleInstances #-}
+--
+-- 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.Transport.HttpClient
+    ( module Thrift.Transport
+    , HttpClient (..)
+    , openHttpClient
+) where
+
+import Thrift.Transport
+import Thrift.Transport.IOBuffer
+import Network.URI
+import Network.HTTP hiding (port, host)
+
+import Data.Maybe (fromJust)
+import Data.Monoid (mempty)
+import Control.Exception (throw)
+import qualified Data.ByteString.Lazy as LBS
+
+
+-- | 'HttpClient', or THttpClient implements the Thrift Transport
+-- | Layer over http or https.
+data HttpClient =
+    HttpClient {
+      hstream :: HandleStream LBS.ByteString,
+      uri :: URI,
+      writeBuffer :: WriteBuffer,
+      readBuffer :: ReadBuffer
+    }
+
+uriAuth :: URI -> URIAuth
+uriAuth = fromJust . uriAuthority
+
+host :: URI -> String
+host = uriRegName . uriAuth
+
+port :: URI -> Int
+port uri_ =
+    if portStr == mempty then
+        httpPort
+    else
+        read portStr
+    where
+      portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_
+      httpPort = 80
+
+-- | Use 'openHttpClient' to create an HttpClient connected to @uri@
+openHttpClient :: URI -> IO HttpClient
+openHttpClient uri_ = do
+  stream <- openTCPConnection (host uri_) (port uri_)
+  wbuf <- newWriteBuffer
+  rbuf <- newReadBuffer
+  return $ HttpClient stream uri_ wbuf rbuf
+
+instance Transport HttpClient where
+
+    tClose = close . hstream
+
+    tPeek = peekBuf . readBuffer
+
+    tRead = readBuf . readBuffer
+
+    tWrite = writeBuf . writeBuffer
+
+    tFlush hclient = do
+      body <- flushBuf $ writeBuffer hclient
+      let request = Request {
+                      rqURI = uri hclient,
+                      rqHeaders = [
+                       mkHeader HdrContentType "application/x-thrift",
+                       mkHeader HdrContentLength $  show $ LBS.length body],
+                      rqMethod = POST,
+                      rqBody = body
+                    }
+
+      res <- sendHTTP (hstream hclient) request
+      case res of
+        Right response ->
+          fillBuf (readBuffer hclient) (rspBody response)
+        Left _ ->
+            throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN
+      return ()
+
+    tIsOpen _ = return True

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport/IOBuffer.hs

@@ -0,0 +1,69 @@
+--
+-- 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.Transport.IOBuffer
+       ( WriteBuffer
+       , newWriteBuffer
+       , writeBuf
+       , flushBuf
+       , ReadBuffer
+       , newReadBuffer
+       , fillBuf
+       , readBuf
+       , peekBuf
+       ) where
+
+import Data.ByteString.Lazy.Builder
+import Data.Functor
+import Data.IORef
+import Data.Monoid
+import Data.Word
+
+import qualified Data.ByteString.Lazy as LBS
+
+type WriteBuffer = IORef Builder
+type ReadBuffer = IORef LBS.ByteString
+
+newWriteBuffer :: IO WriteBuffer
+newWriteBuffer = newIORef mempty
+
+writeBuf :: WriteBuffer -> LBS.ByteString -> IO ()
+writeBuf w s = modifyIORef w ( <> lazyByteString s)
+
+flushBuf :: WriteBuffer -> IO LBS.ByteString
+flushBuf w = do
+  buf <- readIORef w
+  writeIORef w mempty
+  return $ toLazyByteString buf
+
+newReadBuffer :: IO ReadBuffer
+newReadBuffer = newIORef mempty
+
+fillBuf :: ReadBuffer -> LBS.ByteString -> IO ()
+fillBuf = writeIORef
+
+readBuf :: ReadBuffer -> Int -> IO LBS.ByteString
+readBuf r n = do
+  bs <- readIORef r
+  let (hd, tl) = LBS.splitAt (fromIntegral n) bs
+  writeIORef r tl
+  return hd
+
+peekBuf :: ReadBuffer -> IO (Maybe Word8)
+peekBuf r = (fmap fst . LBS.uncons) <$> readIORef r

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Transport/Memory.hs

@@ -0,0 +1,77 @@
+--
+-- 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.Transport.Memory
+       ( openMemoryBuffer
+       , MemoryBuffer(..)
+       ) where
+
+import Data.ByteString.Lazy.Builder
+import Data.Functor
+import Data.IORef
+import Data.Monoid
+import qualified Data.ByteString.Lazy as LBS
+
+import Thrift.Transport
+
+
+data MemoryBuffer = MemoryBuffer {
+  writeBuffer :: IORef Builder,
+  readBuffer :: IORef LBS.ByteString
+}
+
+openMemoryBuffer :: IO MemoryBuffer
+openMemoryBuffer = do
+  wbuf <- newIORef mempty
+  rbuf <- newIORef mempty
+  return MemoryBuffer {
+    writeBuffer = wbuf,
+    readBuffer = rbuf
+  }
+
+instance Transport MemoryBuffer where
+  tIsOpen = const $ return False
+  tClose  = const $ return ()
+  tFlush trans = do
+    let wBuf = writeBuffer trans
+    wb <- readIORef wBuf
+    modifyIORef (readBuffer trans) $ \rb -> mappend rb $ toLazyByteString wb
+    writeIORef wBuf mempty
+
+  tRead _ 0 = return mempty
+  tRead trans n = do
+    let rbuf = readBuffer trans
+    rb <- readIORef rbuf
+    let len = fromIntegral $ LBS.length rb
+    if len == 0
+      then do
+        tFlush trans
+        rb2 <- readIORef (readBuffer trans)
+        if (fromIntegral $ LBS.length rb2) == 0
+          then return mempty
+          else tRead trans n
+      else do
+        let (ret, remain) = LBS.splitAt (fromIntegral n) rb
+        writeIORef rbuf remain
+        return ret
+
+  tPeek trans = (fmap fst . LBS.uncons) <$> readIORef (readBuffer trans)
+
+  tWrite trans v = do
+    modifyIORef (writeBuffer trans) (<> lazyByteString v)

vendor/git.apache.org/thrift.git/lib/hs/src/Thrift/Types.hs

@@ -0,0 +1,130 @@
+-- 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.
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Thrift.Types where
+
+import Data.Foldable (foldl')
+import Data.Hashable ( Hashable, hashWithSalt )
+import Data.Int
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen (elements)
+import Data.Text.Lazy (Text)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict as Map
+import qualified Data.HashSet as Set
+import qualified Data.Vector as Vector
+
+instance (Hashable a) => Hashable (Vector.Vector a) where
+  hashWithSalt = Vector.foldl' hashWithSalt
+
+
+type TypeMap = Map.HashMap Int16 (Text, ThriftType)
+
+data ThriftVal = TStruct (Map.HashMap Int16 (Text, ThriftVal))
+               | TMap ThriftType ThriftType [(ThriftVal, ThriftVal)]
+               | TList ThriftType [ThriftVal]
+               | TSet ThriftType [ThriftVal]
+               | TBool Bool
+               | TByte Int8
+               | TI16 Int16
+               | TI32 Int32
+               | TI64 Int64
+               | TString LBS.ByteString
+               | TBinary LBS.ByteString
+               | TDouble Double
+                 deriving (Eq, Show)
+
+-- Information is needed here for collection types (ie T_STRUCT, T_MAP,
+-- T_LIST, and T_SET) so that we know what types those collections are
+-- parameterized by.  In most protocols, this cannot be discerned directly
+-- from the data being read.
+data ThriftType
+    = T_STOP
+    | T_VOID
+    | T_BOOL
+    | T_BYTE
+    | T_DOUBLE
+    | T_I16
+    | T_I32
+    | T_I64
+    | T_STRING
+    | T_BINARY
+    | T_STRUCT TypeMap
+    | T_MAP ThriftType ThriftType
+    | T_SET ThriftType
+    | T_LIST ThriftType
+      deriving ( Eq, Show )
+
+-- NOTE: when using toEnum information about parametized types is NOT preserved.
+-- This design choice is consistent woth the Thrift implementation in other
+-- languages
+instance Enum ThriftType where
+    fromEnum T_STOP       = 0
+    fromEnum T_VOID       = 1
+    fromEnum T_BOOL       = 2
+    fromEnum T_BYTE       = 3
+    fromEnum T_DOUBLE     = 4
+    fromEnum T_I16        = 6
+    fromEnum T_I32        = 8
+    fromEnum T_I64        = 10
+    fromEnum T_STRING     = 11
+    fromEnum T_BINARY     = 11
+    fromEnum (T_STRUCT _) = 12
+    fromEnum (T_MAP _ _)  = 13
+    fromEnum (T_SET _)    = 14
+    fromEnum (T_LIST _)   = 15
+
+    toEnum 0  = T_STOP
+    toEnum 1  = T_VOID
+    toEnum 2  = T_BOOL
+    toEnum 3  = T_BYTE
+    toEnum 4  = T_DOUBLE
+    toEnum 6  = T_I16
+    toEnum 8  = T_I32
+    toEnum 10 = T_I64
+    toEnum 11 = T_STRING
+    -- toEnum 11 = T_BINARY
+    toEnum 12 = T_STRUCT Map.empty
+    toEnum 13 = T_MAP T_VOID T_VOID
+    toEnum 14 = T_SET T_VOID
+    toEnum 15 = T_LIST T_VOID
+    toEnum t = error $ "Invalid ThriftType " ++ show t
+
+data MessageType
+    = M_CALL
+    | M_REPLY
+    | M_EXCEPTION
+    | M_ONEWAY
+      deriving ( Eq, Show )
+
+instance Enum MessageType where
+    fromEnum M_CALL      =  1
+    fromEnum M_REPLY     =  2
+    fromEnum M_EXCEPTION =  3
+    fromEnum M_ONEWAY    =  4
+
+    toEnum 1 = M_CALL
+    toEnum 2 = M_REPLY
+    toEnum 3 = M_EXCEPTION
+    toEnum 4 = M_ONEWAY
+    toEnum t = error $ "Invalid MessageType " ++ show t
+
+instance Arbitrary MessageType where
+  arbitrary = elements [M_CALL, M_REPLY, M_EXCEPTION, M_ONEWAY]