THRIFT-3482 Haskell JSON protocol does not encode binary field as Base64

compiler/cpp/src/generate/t_hs_generator.cc

@@ -1367,6 +1367,11 @@ void t_hs_generator::generate_deserialize_type(ofstream& out, t_type* type, stri
       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 @@ string t_hs_generator::type_to_enum(t_type* type) {
     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 @@ string t_hs_generator::type_to_constructor(t_type* type) {
     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:

lib/hs/Thrift.cabal

@@ -40,7 +40,7 @@ Library
   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

lib/hs/src/Thrift/Protocol.hs

@@ -102,6 +102,7 @@ getTypeOf v =  case v of
   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

lib/hs/src/Thrift/Protocol/Binary.hs

@@ -104,6 +104,7 @@ 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
@@ -121,7 +122,7 @@ buildBinaryList = foldr (mappend . buildBinaryValue) mempty
 
 -- | 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_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 = 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)]

lib/hs/src/Thrift/Protocol/Compact.hs

@@ -124,6 +124,7 @@ 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 @@ buildCompactList = foldr (mappend . buildCompactValue) mempty
 
 -- | 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_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 = 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 @@ parseCompactStruct = Map.fromList <$> parseFields 0
                  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 @@ fromTType ty = case ty of
   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 @@ typeOf v = case v of
   TI64 _ -> 0x06
   TDouble _ -> 0x07
   TString _ -> 0x08
+  TBinary _ -> 0x08
   TList{} -> 0x09
   TSet{} -> 0x0A
   TMap{} -> 0x0B

lib/hs/src/Thrift/Protocol/JSON.hs

@@ -33,6 +33,8 @@ 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
@@ -113,6 +115,7 @@ 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 []
@@ -168,6 +171,7 @@ 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"
 
@@ -182,6 +186,7 @@ parseAnyValue = choice $
                   , T_I64
                   , T_DOUBLE
                   , T_STRING
+                  , T_BINARY
                   ]
   where
     skipBetween :: Char -> Char -> Parser ()
@@ -208,6 +213,7 @@ parseJSONMap kt vt =
   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 @@ 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"
@@ -327,5 +347,6 @@ getTypeName ty = B.string8 $ case ty of
   T_I64      -> "i64"
   T_DOUBLE   -> "dbl"
   T_STRING   -> "str"
+  T_BINARY   -> "str"
   _ -> error "Unrecognized Type"
 

lib/hs/src/Thrift/Types.hs

@@ -53,6 +53,7 @@ data ThriftVal = TStruct (Map.HashMap Int16 (Text, ThriftVal))
                | TI32 Int32
                | TI64 Int64
                | TString LBS.ByteString
+               | TBinary LBS.ByteString
                | TDouble Double
                  deriving (Eq, Show)
 
@@ -70,6 +71,7 @@ data ThriftType
     | T_I32
     | T_I64
     | T_STRING
+    | T_BINARY
     | T_STRUCT TypeMap
     | T_MAP ThriftType ThriftType
     | T_SET ThriftType
@@ -89,6 +91,7 @@ instance Enum ThriftType where
     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 @@ instance Enum ThriftType where
     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

lib/hs/test/BinarySpec.hs

@@ -66,3 +66,26 @@ spec = do
         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)
+

lib/hs/test/CompactSpec.hs

@@ -56,3 +56,26 @@ spec = do
         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)
+

lib/hs/test/JSONSpec.hs

@@ -22,6 +22,7 @@ module JSONSpec where
 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 @@ spec = do
         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

test/crossrunner/report.py

@@ -57,7 +57,7 @@ def collect_failures(results):
     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 @@ def match(line):
     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 _render_result(self, test):
   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 @@ def add_prog_log(fp, test, prog_kind):
           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)