THRIFT-3482 Haskell JSON protocol does not encode binary field as Base64
diff --git a/compiler/cpp/src/generate/t_hs_generator.cc b/compiler/cpp/src/generate/t_hs_generator.cc
index d2867ea..247c9a8 100644
--- a/compiler/cpp/src/generate/t_hs_generator.cc
+++ b/compiler/cpp/src/generate/t_hs_generator.cc
@@ -1367,6 +1367,11 @@
out << "E.decodeUtf8 ";
}
out << val;
+ if (((t_base_type*)type)->is_binary()) {
+ // Since wire type of binary is the same as string, we actually receive T.TString not
+ // T.TBinary
+ out << "; T.TString " << val << " -> " << val;
+ }
} else if (type->is_enum()) {
out << "P.toEnum $ P.fromIntegral " << val;
@@ -1539,7 +1544,7 @@
case t_base_type::TYPE_VOID:
return "T.T_VOID";
case t_base_type::TYPE_STRING:
- return "T.T_STRING";
+ return ((t_base_type*)type)->is_binary() ? "T.T_BINARY" : "T.T_STRING";
case t_base_type::TYPE_BOOL:
return "T.T_BOOL";
case t_base_type::TYPE_I8:
@@ -1687,7 +1692,7 @@
case t_base_type::TYPE_VOID:
throw "invalid type: T_VOID";
case t_base_type::TYPE_STRING:
- return "T.TString";
+ return ((t_base_type*)type)->is_binary() ? "T.TBinary" : "T.TString";
case t_base_type::TYPE_BOOL:
return "T.TBool";
case t_base_type::TYPE_I8:
diff --git a/lib/hs/Thrift.cabal b/lib/hs/Thrift.cabal
index f0a09aa..6f6a150 100644
--- a/lib/hs/Thrift.cabal
+++ b/lib/hs/Thrift.cabal
@@ -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, vector, QuickCheck, split
if flag(network-uri)
build-depends: network-uri >= 2.6, network >= 2.6
else
diff --git a/lib/hs/src/Thrift/Protocol.hs b/lib/hs/src/Thrift/Protocol.hs
index 8467f40..ed779a2 100644
--- a/lib/hs/src/Thrift/Protocol.hs
+++ b/lib/hs/src/Thrift/Protocol.hs
@@ -102,6 +102,7 @@
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
diff --git a/lib/hs/src/Thrift/Protocol/Binary.hs b/lib/hs/src/Thrift/Protocol/Binary.hs
index ac78483..2d35305 100644
--- a/lib/hs/src/Thrift/Protocol/Binary.hs
+++ b/lib/hs/src/Thrift/Protocol/Binary.hs
@@ -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)]
diff --git a/lib/hs/src/Thrift/Protocol/Compact.hs b/lib/hs/src/Thrift/Protocol/Compact.hs
index 759466b..07113df 100644
--- a/lib/hs/src/Thrift/Protocol/Compact.hs
+++ b/lib/hs/src/Thrift/Protocol/Compact.hs
@@ -124,6 +124,7 @@
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
@@ -164,13 +165,16 @@
parseCompactValue T_I32 = TI32 <$> parseVarint zigZagToI32
parseCompactValue T_I64 = TI64 <$> parseVarint zigZagToI64
parseCompactValue T_DOUBLE = TDouble . bsToDoubleLE <$> P.take 8
-parseCompactValue T_STRING = do
- len :: Word32 <- parseVarint id
- TString . LBS.fromStrict <$> P.take (fromIntegral len)
+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
diff --git a/lib/hs/src/Thrift/Protocol/JSON.hs b/lib/hs/src/Thrift/Protocol/JSON.hs
index ea6bcf3..7f619e8 100644
--- a/lib/hs/src/Thrift/Protocol/JSON.hs
+++ b/lib/hs/src/Thrift/Protocol/JSON.hs
@@ -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
@@ -113,6 +115,7 @@
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 []
@@ -168,6 +171,7 @@
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"
@@ -182,6 +186,7 @@
, T_I64
, T_DOUBLE
, T_STRING
+ , T_BINARY
]
where
skipBetween :: Char -> Char -> Parser ()
@@ -208,6 +213,7 @@
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]
@@ -218,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"
@@ -327,5 +347,6 @@
T_I64 -> "i64"
T_DOUBLE -> "dbl"
T_STRING -> "str"
+ T_BINARY -> "str"
_ -> error "Unrecognized Type"
diff --git a/lib/hs/src/Thrift/Types.hs b/lib/hs/src/Thrift/Types.hs
index b90c42c..8719e72 100644
--- a/lib/hs/src/Thrift/Types.hs
+++ b/lib/hs/src/Thrift/Types.hs
@@ -53,6 +53,7 @@
| TI32 Int32
| TI64 Int64
| TString LBS.ByteString
+ | TBinary LBS.ByteString
| TDouble Double
deriving (Eq, Show)
@@ -70,6 +71,7 @@
| T_I32
| T_I64
| T_STRING
+ | T_BINARY
| T_STRUCT TypeMap
| T_MAP ThriftType ThriftType
| T_SET ThriftType
@@ -89,6 +91,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 +106,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
diff --git a/lib/hs/test/BinarySpec.hs b/lib/hs/test/BinarySpec.hs
index 5039610..d692fab 100644
--- a/lib/hs/test/BinarySpec.hs
+++ b/lib/hs/test/BinarySpec.hs
@@ -66,3 +66,26 @@
writeVal proto (TString val)
bin <- tRead trans 7
(LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 97, 97, 97]
+
+ describe "binary" $ do
+ it "writes" $ do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto (TBinary $ LBS.pack [42, 43, 44])
+ bin <- tRead trans 100
+ (LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 42, 43, 44]
+
+ it "reads" $ do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ tWrite trans $ LBS.pack [0, 0, 0, 3, 42, 43, 44]
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [42, 43, 44])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = BinaryProtocol trans
+ writeVal proto (TBinary $ LBS.pack val)
+ val2 <- readVal proto (T_BINARY)
+ val2 `shouldBe` (TBinary $ LBS.pack val)
+
diff --git a/lib/hs/test/CompactSpec.hs b/lib/hs/test/CompactSpec.hs
index 22708b4..5540e7b 100644
--- a/lib/hs/test/CompactSpec.hs
+++ b/lib/hs/test/CompactSpec.hs
@@ -56,3 +56,26 @@
writeVal proto $ TDouble val
val2 <- readVal proto T_DOUBLE
val2 `shouldBe` (TDouble val)
+
+ describe "binary" $ do
+ it "writes" $ do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ writeVal proto (TBinary $ LBS.pack [42, 43, 44])
+ bin <- tRead trans 100
+ (LBS.unpack bin) `shouldBe` [3, 42, 43, 44]
+
+ it "reads" $ do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ tWrite trans $ LBS.pack [3, 42, 43, 44]
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [42, 43, 44])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = CompactProtocol trans
+ writeVal proto (TBinary $ LBS.pack val)
+ val2 <- readVal proto (T_BINARY)
+ val2 `shouldBe` (TBinary $ LBS.pack val)
+
diff --git a/lib/hs/test/JSONSpec.hs b/lib/hs/test/JSONSpec.hs
index 079be02..022c826 100644
--- a/lib/hs/test/JSONSpec.hs
+++ b/lib/hs/test/JSONSpec.hs
@@ -22,6 +22,7 @@
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
+import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as C
import Thrift.Types
@@ -82,6 +83,35 @@
val2 <- readVal proto (T_STRING)
val2 `shouldBe` (TString $ C.pack val)
+ describe "binary" $ do
+ it "writes with padding" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TBinary $ LBS.pack [1])
+ bin <- tRead trans 100
+ (C.unpack bin) `shouldBe` "\"AQ==\""
+
+ it "reads with padding" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans $ C.pack "\"AQ==\""
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [1])
+
+ it "reads without padding" $ do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ tWrite trans $ C.pack "\"AQ\""
+ val <- readVal proto (T_BINARY)
+ val `shouldBe` (TBinary $ LBS.pack [1])
+
+ prop "round trip" $ \val -> do
+ trans <- openMemoryBuffer
+ let proto = JSONProtocol trans
+ writeVal proto (TBinary $ LBS.pack val)
+ val2 <- readVal proto (T_BINARY)
+ val2 `shouldBe` (TBinary $ LBS.pack val)
+
describe "list" $ do
it "writes empty list" $ do
trans <- openMemoryBuffer
diff --git a/test/crossrunner/report.py b/test/crossrunner/report.py
index defc486..3f91002 100644
--- a/test/crossrunner/report.py
+++ b/test/crossrunner/report.py
@@ -57,7 +57,7 @@
fails = known
fails_json = json.dumps(sorted(set(fails)), indent=2, separators=(',', ': '))
if save:
- with open(os.path.join(testdir, FAIL_JSON % platform.system()), 'w+') as fp:
+ with logfile_open(os.path.join(testdir, FAIL_JSON % platform.system()), 'w+') as fp:
fp.write(fails_json)
sys.stdout.write('Successfully updated known failures.\n')
if out:
@@ -180,7 +180,7 @@
return False
def _open(self):
- self.out = open(self.logpath, 'w+')
+ self.out = logfile_open(self.logpath, 'w+')
def _close(self):
self.out.close()
@@ -324,7 +324,7 @@
def _write_html_data(self):
"""Writes JSON data to be read by result html"""
results = [self._render_result(r) for r in self._tests]
- with open(self.out_path, 'w+') as fp:
+ with logfile_open(self.out_path, 'w+') as fp:
fp.write(json.dumps({
'date': self._format_date(),
'revision': str(self._revision),
@@ -343,7 +343,7 @@
with logfile_open(path, 'r') as prog_fp:
print(prog_fp.read(), file=fp)
filename = title.replace(' ', '_') + '.log'
- with open(os.path.join(self.logdir, filename), 'w+') as fp:
+ with logfile_open(os.path.join(self.logdir, filename), 'w+') as fp:
for test in map(self._tests.__getitem__, indexes):
fp.write('TEST: [%s]\n' % test.name)
add_prog_log(fp, test, test.server.kind)
diff --git a/test/hs/DebugProtoTest_Main.hs b/test/hs/DebugProtoTest_Main.hs
old mode 100755
new mode 100644
diff --git a/test/hs/TestClient.hs b/test/hs/TestClient.hs
index 0ebc0fd..d1ebb3c 100644
--- a/test/hs/TestClient.hs
+++ b/test/hs/TestClient.hs
@@ -168,13 +168,13 @@
}
putStrLn "testNest"
nestOut <- Client.testNest prot nestIn
- when (nestIn /= nestOut) exitSuccess
+ when (nestIn /= nestOut) exitFailure
-- Map Test
let mapIn = Map.fromList $ map (\i -> (i, i-10)) [1..5]
putStrLn "testMap"
mapOut <- Client.testMap prot mapIn
- when (mapIn /= mapOut) exitSuccess
+ when (mapIn /= mapOut) exitFailure
-- Set Test
let setIn = Set.fromList [-2..3]
diff --git a/test/hs/TestServer.hs b/test/hs/TestServer.hs
old mode 100755
new mode 100644
diff --git a/test/hs/ThriftTest_Main.hs b/test/hs/ThriftTest_Main.hs
old mode 100755
new mode 100644
diff --git a/test/known_failures_Linux.json b/test/known_failures_Linux.json
index 3e9240f..be51ecc 100644
--- a/test/known_failures_Linux.json
+++ b/test/known_failures_Linux.json
@@ -7,9 +7,6 @@
"cpp-cpp_json_http-ip",
"cpp-dart_binary_http-ip",
"cpp-dart_json_http-ip",
- "cpp-hs_json_buffered-ip",
- "cpp-hs_json_framed-ip",
- "cpp-hs_json_http-ip",
"cpp-java_binary_http-ip",
"cpp-java_binary_http-ip-ssl",
"cpp-java_compact_http-ip",
@@ -65,8 +62,6 @@
"hs-csharp_json_framed-ip",
"hs-dart_binary_framed-ip",
"hs-dart_json_framed-ip",
- "hs-nodejs_json_buffered-ip",
- "hs-nodejs_json_framed-ip",
"hs-py3_json_buffered-ip",
"hs-py3_json_framed-ip",
"hs-py_json_buffered-ip",
@@ -74,12 +69,6 @@
"java-perl_binary_buffered-ip-ssl",
"java-perl_binary_fastframed-framed-ip-ssl",
"java-perl_binary_framed-ip-ssl",
- "nodejs-hs_binary_buffered-ip",
- "nodejs-hs_binary_framed-ip",
- "nodejs-hs_compact_buffered-ip",
- "nodejs-hs_compact_framed-ip",
- "nodejs-hs_json_buffered-ip",
- "nodejs-hs_json_framed-ip",
"nodejs-perl_binary_buffered-ip-ssl",
"nodejs-perl_binary_framed-ip-ssl",
"perl-perl_binary_buffered-ip-ssl",
diff --git a/test/tests.json b/test/tests.json
index be7d52b..c816d6e 100644
--- a/test/tests.json
+++ b/test/tests.json
@@ -181,6 +181,7 @@
"timeout": 10,
"command": [
"TestClient.py",
+ "--verbose",
"--host=localhost",
"--genpydir=gen-py"
]