THRIFT-3433 Doubles aren't interpreted correctly

Client: Haskell
Patch: Nobuaki Sukegawa

This closes #736

lib/hs/CMakeLists.txt

@@ -36,6 +36,15 @@ set(haskell_sources
     Thrift.cabal
 )
 
+if(BUILD_TESTING)
+    list(APPEND haskell_soruces
+        test/Spec.hs
+        test/BinarySpec.hs
+        test/CompactSpec.hs
+    )
+    set(hs_enable_test "--enable-tests")
+endif()
+
 set(haskell_artifacts thrift_cabal.stamp)
 # Adding *.hi files so that any missing file triggers the build
 foreach(SRC ${haskell_sources})
@@ -48,18 +57,19 @@ foreach(SRC ${haskell_sources})
     endif()
 endforeach()
 
-if (CMAKE_BUILD_TYPE STREQUAL "Debug")
-  set(hs_optimize -O0)
+if(CMAKE_BUILD_TYPE STREQUAL "Debug")
+    set(hs_optimize -O0)
 elseif(CMAKE_BUILD_TYPE STREQUAL "Release")
-  set(hs_optimize -O1)
+    set(hs_optimize -O1)
 endif()
 
 add_custom_command(
     OUTPUT ${haskell_artifacts}
     COMMAND ${CABAL} update
     # Build dependencies first without --builddir, otherwise it fails.
-    COMMAND ${CABAL} install --only-dependencies
-    COMMAND ${CABAL} configure ${hs_optimize}
+    COMMAND ${CABAL} install --only-dependencies ${hs_enable_test}
+    COMMAND ${CABAL} configure ${hs_optimize} ${hs_enable_test} --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
+    COMMAND ${CABAL} build --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
     COMMAND ${CABAL} install --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
     COMMAND ${CMAKE_COMMAND} -E touch ${CMAKE_CURRENT_BINARY_DIR}/thrift_cabal.stamp
     WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
@@ -70,7 +80,13 @@ add_custom_target(haskell_library ALL
     DEPENDS ${haskell_artifacts})
 
 if(BUILD_TESTING)
-    add_test(NAME CabalCheck
+    add_test(NAME HaskellCabalCheck
             COMMAND ${CABAL} check
             WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+    add_test(NAME HaskellCabalTest
+            # Cabal fails to find built executable when --builddir is specified.
+            # So we invoke the executable directly.
+            # COMMAND ${CABAL} test --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist
+            # WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+            COMMAND dist/build/spec/spec)
 endif()

lib/hs/Makefile.am

@@ -42,3 +42,7 @@ maintainer-clean-local:
 
 check-local:
 	$(CABAL) check
+	$(CABAL) install --only-dependencies --enable-tests
+	$(CABAL) configure --enable-tests
+	$(CABAL) build
+	$(CABAL) test

lib/hs/Thrift.cabal

@@ -59,6 +59,7 @@ Library
     Thrift.Transport.Handle,
     Thrift.Transport.HttpClient,
     Thrift.Transport.IOBuffer,
+    Thrift.Transport.Memory,
     Thrift.Types
   Extensions:
     DeriveDataTypeable,
@@ -70,3 +71,10 @@ Library
     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, bytestring >= 0.10, unordered-containers

lib/hs/src/Thrift/Protocol.hs

@@ -29,6 +29,7 @@ module Thrift.Protocol
     , versionMask
     , version1
     , bsToDouble
+    , bsToDoubleLE
     ) where
 
 import Control.Exception
@@ -119,18 +120,22 @@ handleEOF = const $ return mempty
 -- 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 +146,3 @@ byteSwap w = (w `shiftL` 56 .&. 0xFF00000000000000) .|.
              (w `shiftR` 24 .&. 0x0000000000FF0000) .|.
              (w `shiftR` 40 .&. 0x000000000000FF00) .|.
              (w `shiftR` 56 .&. 0x00000000000000FF)
-#endif

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

@@ -55,7 +55,7 @@ import qualified Data.Text.Lazy as LT
 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 @@ instance Protocol CompactProtocol where
     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,7 +120,7 @@ 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) = doubleBE d
+buildCompactValue (TDouble d) = doubleLE d
 buildCompactValue (TString s) = buildVarint len <> lazyByteString s
   where
     len = fromIntegral (LBS.length s) :: Word32
@@ -163,7 +163,7 @@ 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 . bsToDouble <$> P.take 8
+parseCompactValue T_DOUBLE = TDouble . bsToDoubleLE <$> P.take 8
 parseCompactValue T_STRING = do
   len :: Word32 <- parseVarint id
   TString . LBS.fromStrict <$> P.take (fromIntegral len)

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)

lib/hs/test/BinarySpec.hs

@@ -0,0 +1,68 @@
+--
+-- 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 BinarySpec 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
+import Thrift.Transport
+import Thrift.Transport.Memory
+import Thrift.Protocol
+import Thrift.Protocol.Binary
+
+spec :: Spec
+spec = do
+  describe "BinaryProtocol" $ do
+    describe "double" $ do
+      it "writes in big endian order" $ do
+        let val = 2 ** 53
+        trans <- openMemoryBuffer
+        let proto = BinaryProtocol trans
+        writeVal proto (TDouble val)
+        bin <- tRead trans 8
+        (LBS.unpack bin) `shouldBe`[67, 64, 0, 0, 0, 0, 0, 0]
+
+      it "reads in big endian order" $ do
+        let bin = LBS.pack [67, 64, 0, 0, 0, 0, 0, 0]
+        trans <- openMemoryBuffer
+        let proto = BinaryProtocol trans
+        tWrite trans bin
+        val <- readVal proto T_DOUBLE
+        val `shouldBe` (TDouble $ 2 ** 53)
+
+      prop "round trip" $ \val -> do
+        trans <- openMemoryBuffer
+        let proto = BinaryProtocol trans
+        writeVal proto $ TDouble val
+        val2 <- readVal proto T_DOUBLE
+        val2 `shouldBe` (TDouble val)
+
+    describe "string" $ do
+      it "writes" $ do
+        let val = C.pack "aaa"
+        trans <- openMemoryBuffer
+        let proto = BinaryProtocol trans
+        writeVal proto (TString val)
+        bin <- tRead trans 7
+        (LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 97, 97, 97]

lib/hs/test/CompactSpec.hs

@@ -0,0 +1,58 @@
+--
+-- 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 CompactSpec where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+
+import qualified Data.ByteString.Lazy as LBS
+
+import Thrift.Types
+import Thrift.Transport
+import Thrift.Transport.Memory
+import Thrift.Protocol
+import Thrift.Protocol.Compact
+
+spec :: Spec
+spec = do
+  describe "CompactProtocol" $ do
+    describe "double" $ do
+      it "writes in little endian order" $ do
+        let val = 2 ** 53
+        trans <- openMemoryBuffer
+        let proto = CompactProtocol trans
+        writeVal proto (TDouble val)
+        bin <- tReadAll trans 8
+        (LBS.unpack bin) `shouldBe`[0, 0, 0, 0, 0, 0, 64, 67]
+
+      it "reads in little endian order" $ do
+        let bin = LBS.pack [0, 0, 0, 0, 0, 0, 64, 67]
+        trans <- openMemoryBuffer
+        let proto = CompactProtocol trans
+        tWrite trans bin
+        val <- readVal proto T_DOUBLE
+        val `shouldBe` (TDouble $ 2 ** 53)
+
+      prop "round trip" $ \val -> do
+        trans <- openMemoryBuffer
+        let proto = CompactProtocol trans
+        writeVal proto $ TDouble val
+        val2 <- readVal proto T_DOUBLE
+        val2 `shouldBe` (TDouble val)

lib/hs/test/Spec.hs

@@ -0,0 +1,36 @@
+--
+-- 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
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "Binary" BinarySpec.spec
+  describe "Compact" CompactSpec.spec