thrift 0.9.3 → 0.10.0
raw patch · 9 files changed
+214/−53 lines, 9 filesdep +base64-bytestringdep +hspecdep +thriftdep ~QuickCheckdep ~basedep ~unordered-containers
Dependencies added: base64-bytestring, hspec, thrift
Dependency ranges changed: QuickCheck, base, unordered-containers, vector
Files
- src/Thrift/Arbitraries.hs +0/−6
- src/Thrift/Protocol.hs +15/−10
- src/Thrift/Protocol/Binary.hs +13/−7
- src/Thrift/Protocol/Compact.hs +20/−12
- src/Thrift/Protocol/JSON.hs +37/−10
- src/Thrift/Transport/Memory.hs +77/−0
- src/Thrift/Types.hs +4/−6
- test/Spec.hs +38/−0
- thrift.cabal +10/−2
src/Thrift/Arbitraries.hs view
@@ -26,12 +26,6 @@ instance Arbitrary ByteString where arbitrary = BS.pack . filter (/= 0) <$> arbitrary -instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where- arbitrary = Map.fromList <$> arbitrary--instance (Ord k, Arbitrary k) => Arbitrary (Set.Set k) where- arbitrary = Set.fromList <$> arbitrary- instance (Arbitrary k) => Arbitrary (Vector.Vector k) where arbitrary = Vector.fromList <$> arbitrary
src/Thrift/Protocol.hs view
@@ -29,6 +29,7 @@ , versionMask , version1 , bsToDouble+ , bsToDoubleLE ) where import Control.Exception@@ -101,12 +102,13 @@ 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 <$> tRead (getTransport prot) 1+ 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)@@ -119,18 +121,22 @@ -- therefore the behavior of this function varies based on whether the local -- machine is big endian or little endian. bsToDouble :: BS.ByteString -> Double-bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs- where+bsToDoubleLE :: BS.ByteString -> Double #if __BYTE_ORDER == __LITTLE_ENDIAN- castBs chrPtr = do- w <- peek (castPtr chrPtr)- poke (castPtr chrPtr) (byteSwap w)- peek (castPtr chrPtr)+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped+bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs #else- castBs = peek . castPtr+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs+bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped #endif -#if __BYTE_ORDER == __LITTLE_ENDIAN++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) .|.@@ -141,4 +147,3 @@ (w `shiftR` 24 .&. 0x0000000000FF0000) .|. (w `shiftR` 40 .&. 0x000000000000FF00) .|. (w `shiftR` 56 .&. 0x00000000000000FF)-#endif
src/Thrift/Protocol/Binary.hs view
@@ -104,6 +104,7 @@ 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@@ -121,7 +122,7 @@ -- | Reading Functions parseBinaryValue :: ThriftType -> P.Parser ThriftVal-parseBinaryValue (T_STRUCT _) = TStruct <$> parseBinaryStruct+parseBinaryValue (T_STRUCT tmap) = TStruct <$> parseBinaryStruct tmap parseBinaryValue (T_MAP _ _) = do kt <- parseType vt <- parseType@@ -141,18 +142,23 @@ 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 = do- i :: Int32 <- Binary.decode . LBS.fromStrict <$> P.take 4- TString . LBS.fromStrict <$> P.take (fromIntegral i)+parseBinaryValue T_STRING = parseBinaryString TString+parseBinaryValue T_BINARY = parseBinaryString TBinary parseBinaryValue ty = error $ "Cannot read value of type " ++ show ty -parseBinaryStruct :: P.Parser (Map.HashMap Int16 (LT.Text, ThriftVal))-parseBinaryStruct = Map.fromList <$> P.manyTill parseField (matchType T_STOP)+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 <- parseBinaryValue t+ 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)]
src/Thrift/Protocol/Compact.hs view
@@ -55,7 +55,7 @@ data CompactProtocol a = CompactProtocol a -- ^ Constuct a 'CompactProtocol' with a 'Transport' -protocolID, version, typeMask :: Int8+protocolID, version, versionMask, typeMask, typeBits :: Word8 protocolID = 0x82 -- 1000 0010 version = 0x01 versionMask = 0x1f -- 0001 1111@@ -69,8 +69,8 @@ getTransport (CompactProtocol t) = t writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $- B.int8 protocolID <>- B.int8 ((version .&. versionMask) .|.+ B.word8 protocolID <>+ B.word8 ((version .&. versionMask) .|. (((fromIntegral $ fromEnum t) `shiftL` typeShiftAmount) .&. typeMask)) <> buildVarint (i32ToZigZag s) <>@@ -120,10 +120,11 @@ buildCompactValue (TI16 i) = buildVarint $ i16ToZigZag i buildCompactValue (TI32 i) = buildVarint $ i32ToZigZag i buildCompactValue (TI64 i) = buildVarint $ i64ToZigZag i-buildCompactValue (TDouble d) = doubleBE d+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@@ -146,7 +147,7 @@ -- | Reading Functions parseCompactValue :: ThriftType -> Parser ThriftVal-parseCompactValue (T_STRUCT _) = TStruct <$> parseCompactStruct+parseCompactValue (T_STRUCT tmap) = TStruct <$> parseCompactStruct tmap parseCompactValue (T_MAP kt' vt') = do n <- parseVarint id if n == 0@@ -163,14 +164,17 @@ parseCompactValue T_I16 = TI16 <$> parseVarint zigZagToI16 parseCompactValue T_I32 = TI32 <$> parseVarint zigZagToI32 parseCompactValue T_I64 = TI64 <$> parseVarint zigZagToI64-parseCompactValue T_DOUBLE = TDouble . bsToDouble <$> P.take 8-parseCompactValue T_STRING = do- len :: Word32 <- parseVarint id- TString . LBS.fromStrict <$> P.take (fromIntegral len)+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 -parseCompactStruct :: Parser (Map.HashMap Int16 (LT.Text, ThriftVal))-parseCompactStruct = Map.fromList <$> parseFields 0+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@@ -185,7 +189,9 @@ else parseVarint zigZagToI16 val <- if ty == T_BOOL then return (TBool $ (w .&. 0x0F) == 0x01)- else parseCompactValue ty+ 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 ->@@ -255,6 +261,7 @@ T_I64 -> 0x06 T_DOUBLE -> 0x07 T_STRING -> 0x08+ T_BINARY -> 0x08 T_LIST{} -> 0x09 T_SET{} -> 0x0A T_MAP{} -> 0x0B@@ -271,6 +278,7 @@ TI64 _ -> 0x06 TDouble _ -> 0x07 TString _ -> 0x08+ TBinary _ -> 0x08 TList{} -> 0x09 TSet{} -> 0x0A TMap{} -> 0x0B
src/Thrift/Protocol/JSON.hs view
@@ -33,6 +33,8 @@ 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@@ -49,9 +51,10 @@ 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 'TSimpleJSONProtocol'. Data is+-- | 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'@@ -105,13 +108,14 @@ else mempty) <> B.char8 ']' buildJSONValue (TSet ty entries) = buildJSONValue (TList ty entries)-buildJSONValue (TBool b) = if b then B.string8 "true" else B.string8 "false"+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 []@@ -149,22 +153,25 @@ between '{' '}' (parseJSONMap kt vt) parseJSONValue (T_LIST ty) = fmap (TList ty) $ between '[' ']' $ do- len <- lexeme escapedString *> lexeme (PC.char8 ',') *>- lexeme decimal <* lexeme (PC.char8 ',')- if len > 0 then parseJSONList ty else return []+ 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 <* lexeme (PC.char8 ',')- if len > 0 then parseJSONList ty else return []+ len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal+ if len > 0+ then lexeme (PC.char8 ',') *> parseJSONList ty+ else return [] parseJSONValue T_BOOL =- (TBool True <$ string "true") <|> (TBool False <$ string "false")+ (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" @@ -179,6 +186,7 @@ , T_I64 , T_DOUBLE , T_STRING+ , T_BINARY ] where skipBetween :: Char -> Char -> Parser ()@@ -200,9 +208,13 @@ parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)] parseJSONMap kt vt =- ((,) <$> lexeme (PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"') <*>+ ((,) <$> 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 ',')@@ -212,6 +224,20 @@ (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"@@ -321,5 +347,6 @@ T_I64 -> "i64" T_DOUBLE -> "dbl" T_STRING -> "str"+ T_BINARY -> "str" _ -> error "Unrecognized Type"
+ src/Thrift/Transport/Memory.hs view
@@ -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)
src/Thrift/Types.hs view
@@ -31,12 +31,6 @@ import qualified Data.HashSet as Set import qualified Data.Vector as Vector -instance (Hashable k, Hashable v) => Hashable (Map.HashMap k v) where- hashWithSalt salt = foldl' hashWithSalt salt . Map.toList--instance (Hashable a) => Hashable (Set.HashSet a) where- hashWithSalt = foldl' hashWithSalt- instance (Hashable a) => Hashable (Vector.Vector a) where hashWithSalt = Vector.foldl' hashWithSalt @@ -53,6 +47,7 @@ | TI32 Int32 | TI64 Int64 | TString LBS.ByteString+ | TBinary LBS.ByteString | TDouble Double deriving (Eq, Show) @@ -70,6 +65,7 @@ | T_I32 | T_I64 | T_STRING+ | T_BINARY | T_STRUCT TypeMap | T_MAP ThriftType ThriftType | T_SET ThriftType@@ -89,6 +85,7 @@ 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@@ -103,6 +100,7 @@ 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
+ test/Spec.hs view
@@ -0,0 +1,38 @@+--+-- 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.+--++-- Our CI does not work well with auto discover.+-- Need to add build-time PATH variable to hspec-discover dir from CMake+-- or install hspec system-wide for the following to work.+-- {-# OPTIONS_GHC -F -pgmF hspec-discover #-}++import Test.Hspec++import qualified BinarySpec+import qualified CompactSpec+import qualified JSONSpec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Binary" BinarySpec.spec+ describe "Compact" CompactSpec.spec+ describe "JSON" JSONSpec.spec
thrift.cabal view
@@ -18,7 +18,7 @@ -- Name: thrift-Version: 0.9.3+Version: 0.10.0 Cabal-Version: >= 1.8 License: OtherLicense Category: Foreign@@ -40,7 +40,7 @@ Hs-Source-Dirs: src Build-Depends:- base >= 4, base < 5, containers, ghc-prim, attoparsec, binary, bytestring >= 0.10, hashable, HTTP, text, unordered-containers, vector, QuickCheck, split+ base >= 4, base < 5, containers, ghc-prim, attoparsec, binary, bytestring >= 0.10, base64-bytestring, hashable, HTTP, text, unordered-containers >= 0.2.6, vector == 0.10.12.2, QuickCheck >= 2.8.2, split if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else@@ -59,6 +59,7 @@ Thrift.Transport.Handle, Thrift.Transport.HttpClient, Thrift.Transport.IOBuffer,+ Thrift.Transport.Memory, Thrift.Types Extensions: DeriveDataTypeable,@@ -70,3 +71,10 @@ RecordWildCards, ScopedTypeVariables, TypeSynonymInstances++Test-Suite spec+ Type: exitcode-stdio-1.0+ Hs-Source-Dirs: test+ Ghc-Options: -Wall+ main-is: Spec.hs+ Build-Depends: base, thrift, hspec, QuickCheck >= 2.8.2, bytestring >= 0.10, unordered-containers >= 0.2.6