THRIFT-3433 Doubles aren't interpreted correctly
Client: Haskell
Patch: Nobuaki Sukegawa
This closes #736
diff --git a/lib/hs/CMakeLists.txt b/lib/hs/CMakeLists.txt
index 37ea288..b5d1d20 100644
--- a/lib/hs/CMakeLists.txt
+++ b/lib/hs/CMakeLists.txt
@@ -36,6 +36,15 @@
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 @@
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 @@
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()
diff --git a/lib/hs/LICENSE b/lib/hs/LICENSE
old mode 100755
new mode 100644
diff --git a/lib/hs/Makefile.am b/lib/hs/Makefile.am
old mode 100755
new mode 100644
index 45529c7..543381f
--- a/lib/hs/Makefile.am
+++ b/lib/hs/Makefile.am
@@ -42,3 +42,7 @@
check-local:
$(CABAL) check
+ $(CABAL) install --only-dependencies --enable-tests
+ $(CABAL) configure --enable-tests
+ $(CABAL) build
+ $(CABAL) test
diff --git a/lib/hs/README.md b/lib/hs/README.md
old mode 100755
new mode 100644
diff --git a/lib/hs/TODO b/lib/hs/TODO
old mode 100755
new mode 100644
diff --git a/lib/hs/Thrift.cabal b/lib/hs/Thrift.cabal
old mode 100755
new mode 100644
index 5610a5c..f0a09aa
--- a/lib/hs/Thrift.cabal
+++ b/lib/hs/Thrift.cabal
@@ -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, bytestring >= 0.10, unordered-containers
diff --git a/lib/hs/src/Thrift/Protocol.hs b/lib/hs/src/Thrift/Protocol.hs
index ea58642..31e48b5 100644
--- a/lib/hs/src/Thrift/Protocol.hs
+++ b/lib/hs/src/Thrift/Protocol.hs
@@ -29,6 +29,7 @@
, versionMask
, version1
, bsToDouble
+ , bsToDoubleLE
) where
import Control.Exception
@@ -119,18 +120,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 +146,3 @@
(w `shiftR` 24 .&. 0x0000000000FF0000) .|.
(w `shiftR` 40 .&. 0x000000000000FF00) .|.
(w `shiftR` 56 .&. 0x00000000000000FF)
-#endif
diff --git a/lib/hs/src/Thrift/Protocol/Compact.hs b/lib/hs/src/Thrift/Protocol/Compact.hs
index a329f4e..759466b 100644
--- a/lib/hs/src/Thrift/Protocol/Compact.hs
+++ b/lib/hs/src/Thrift/Protocol/Compact.hs
@@ -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,7 +120,7 @@
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_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)
diff --git a/lib/hs/src/Thrift/Transport/Memory.hs b/lib/hs/src/Thrift/Transport/Memory.hs
new file mode 100644
index 0000000..1c93af6
--- /dev/null
+++ b/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)
diff --git a/lib/hs/test/BinarySpec.hs b/lib/hs/test/BinarySpec.hs
new file mode 100644
index 0000000..5039610
--- /dev/null
+++ b/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]
diff --git a/lib/hs/test/CompactSpec.hs b/lib/hs/test/CompactSpec.hs
new file mode 100644
index 0000000..22708b4
--- /dev/null
+++ b/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)
diff --git a/lib/hs/test/Spec.hs b/lib/hs/test/Spec.hs
new file mode 100644
index 0000000..0f5a816
--- /dev/null
+++ b/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