diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,6 +1,11 @@ Maintainers ----------- +- Kyle Butt + +Prior Maintainers +----------------- + - Toralf Wittner - Roman S. Borschel diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,24 @@ +4.1.0.0 +------- +- Drop incompatible varint +- Use persist instead of cereal to avoid reserialization. The new release of + persist allows for length backpatching, which is exactly what the CQL native + encoding needs. +- Add a utility function for the Cassandra Murmur3 hash +- Add rowKey function to Tuple/PrivateTuple typeclass +- Add Ord instances for newtype wrapper types +- Add Cql instance for Keyspace newtype +- Add Cql instances for Data.Word types +- Supports GHC 9.2-9.12 + +Breaking changes: +- persist library instead of cereal. Interface of `persist` library is very + similar to `cereal`, so this should be easy to port. +- `putValue` has been split into `putValue` and `putValueLength`. + `putValueLength` has the behavior that was previously handled by `putValue`. + This separation is necessary to support token aware routing. Token aware + routing doesn't use the length prefix on the outermost value. + 4.0.4 ----- - Compatibility with template-haskell-2.17 and 2.18. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,3 @@ -Free Public License 1.0.0 - Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted. @@ -10,38 +8,3 @@ DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - -============================================================================= - -Cereal License - -Copyright (c) Lennart Kolmodin, Galois, Inc. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS -OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. diff --git a/cql.cabal b/cql.cabal --- a/cql.cabal +++ b/cql.cabal @@ -1,19 +1,18 @@ +cabal-version: 3.6 name: cql -version: 4.0.4 +version: 4.1.0.0 synopsis: Cassandra CQL binary protocol. stability: experimental -license: OtherLicense +license: 0BSD license-file: LICENSE -author: Toralf Wittner, Roman S. Borschel -maintainer: Toralf Wittner , - Roman S. Borschel -copyright: (C) 2014-2015 Toralf Wittner, Roman S. Borschel -homepage: https://gitlab.com/twittner/cql/ -bug-reports: https://gitlab.com/twittner/cql/issues +author: Kyle Butt, Toralf Wittner, Roman S. Borschel +maintainer: Kyle Butt +copyright: (C) 2014-2015 Toralf Wittner, Roman S. Borschel (C) 2024-2025 Kyle Butt +homepage: https://github.com/iteratee/cql/ +bug-reports: https://github.com/iteratee/cql/issues category: Database build-type: Simple -cabal-version: >= 1.10 -extra-source-files: README.md +extra-doc-files: README.md CHANGELOG CONTRIBUTING AUTHORS @@ -30,18 +29,14 @@ Thus it can serve as a building block for writing Cassandra drivers, such as . -flag incompatible-varint - description: Use incompatible legacy encoding for varint and decimal. - default: False - source-repository head type: git - location: https://gitlab.com/twittner/cql + location: https://github.com/iteratee/cql library default-language: Haskell2010 hs-source-dirs: src - ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields exposed-modules: Database.CQL.Protocol @@ -50,52 +45,58 @@ other-modules: Database.CQL.Protocol.Class Database.CQL.Protocol.Codec + Database.CQL.Protocol.Header + Database.CQL.Protocol.Murmur3 Database.CQL.Protocol.Record + Database.CQL.Protocol.Request + Database.CQL.Protocol.Response Database.CQL.Protocol.Tuple Database.CQL.Protocol.Tuple.TH Database.CQL.Protocol.Types - Database.CQL.Protocol.Header - Database.CQL.Protocol.Request - Database.CQL.Protocol.Response - - if flag(incompatible-varint) - cpp-options: -DINCOMPATIBLE_VARINT + include-dirs: + murmur-src/ + includes: + murmur-src/murmur_hash_3_cassandra.h + install-includes: + murmur-src/murmur_hash_3_cassandra.h + c-sources: + murmur-src/murmur_hash_3_cassandra.c build-depends: - base >= 4.9 && < 5.0 - , bytestring >= 0.10 - , cereal >= 0.3 - , containers >= 0.5 - , Decimal >= 0.3 - , iproute >= 1.3 - , network >= 2.4 - , text >= 0.11 - , template-haskell - , time >= 1.4 - , transformers >= 0.3 - , uuid >= 1.2.6 - , vector >= 0.10 + base >= 4.9 && < 5 + , bytestring >= 0.10 && < 0.13 + , persist >= 1.0 && < 1.1 + , containers >= 0.5 && < 0.9 + , Decimal >= 0.3 && < 0.6 + , iproute >= 1.3 && < 1.8 + , network >= 2.4 && < 3.3 + , text >= 0.11 && < 2.2 + , template-haskell >= 2.18 && < 2.24 + , time >= 1.4 && < 1.16 + , transformers >= 0.3 && < 0.7 + , uuid >= 1.2.6 && < 1.4 + , vector >= 0.10 && < 0.14 test-suite cql-tests type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: Main.hs hs-source-dirs: test - ghc-options: -threaded -Wall -O2 -fwarn-tabs + ghc-options: -threaded -Wall -fwarn-tabs other-modules: Tests build-depends: base , bytestring - , cereal , cql , Decimal , iproute , network + , persist , QuickCheck , tasty >= 0.8 , tasty-quickcheck >= 0.8 + , tasty-hunit >= 0.10 && < 0.11 , text , time , uuid - diff --git a/murmur-src/murmur_hash_3_cassandra.c b/murmur-src/murmur_hash_3_cassandra.c new file mode 100644 --- /dev/null +++ b/murmur-src/murmur_hash_3_cassandra.c @@ -0,0 +1,126 @@ +#include +#include + +inline int64_t rotsl64(int64_t x, int8_t r) { + return (x << r) | ((uint64_t)x >> (64 - r)); +} + +#define ROTSL64(x,y) rotsl64(x,y) +#define BIG_SIGNED_CONSTANT(x) (x##LL) + +inline int64_t sfmix(int64_t k) { + k ^= (uint64_t)k >> 33; + k *= BIG_SIGNED_CONSTANT(0xff51afd7ed558ccd); + k ^= (uint64_t)k >> 33; + k *= BIG_SIGNED_CONSTANT(0xc4ceb9fe1a85ec53); + k ^= (uint64_t)k >> 33; + + return k; +} + +void MurmurHash3_x64_128_cassandra( + const void *key, const size_t len, const int64_t seed, void *out) { + const uint8_t *data = (const uint8_t *)key; + const size_t nblocks = len / 16; + + int64_t h1 = seed; + int64_t h2 = seed; + + const int64_t c1 = BIG_SIGNED_CONSTANT(0x87c37b91114253d5); + const int64_t c2 = BIG_SIGNED_CONSTANT(0x4cf5ad432745937f); + + //---------- + // body + + const int64_t *blocks = (const int64_t *)(data); + + for (size_t i = 0; i < nblocks; i++) { + int64_t k1 = blocks[i * 2 + 0]; + int64_t k2 = blocks[i * 2 + 1]; + + k1 *= c1; + k1 = ROTSL64(k1, 31); + k1 *= c2; + h1 ^= k1; + + h1 = ROTSL64(h1, 27); + h1 += h2; + h1 = h1 * 5 + 0x52dce729; + + k2 *= c2; + k2 = ROTSL64(k2, 33); + k2 *= c1; + h2 ^= k2; + + h2 = ROTSL64(h2, 31); + h2 += h1; + h2 = h2 * 5 + 0x38495ab5; + } + + //---------- + // tail + + const int8_t *tail = (const int8_t *)(data + nblocks * 16); + + int64_t k1 = 0; + int64_t k2 = 0; + + switch (len & 15) { + case 15: + k2 ^= ((int64_t)tail[14]) << 48; + case 14: + k2 ^= ((int64_t)tail[13]) << 40; + case 13: + k2 ^= ((int64_t)tail[12]) << 32; + case 12: + k2 ^= ((int64_t)tail[11]) << 24; + case 11: + k2 ^= ((int64_t)tail[10]) << 16; + case 10: + k2 ^= ((int64_t)tail[9]) << 8; + case 9: + k2 ^= ((int64_t)tail[ 8]) << 0; + k2 *= c2; + k2 = ROTSL64(k2, 33); + k2 *= c1; + h2 ^= k2; + case 8: + k1 ^= ((int64_t)tail[7]) << 56; + case 7: + k1 ^= ((int64_t)tail[6]) << 48; + case 6: + k1 ^= ((int64_t)tail[5]) << 40; + case 5: + k1 ^= ((int64_t)tail[4]) << 32; + case 4: + k1 ^= ((int64_t)tail[3]) << 24; + case 3: + k1 ^= ((int64_t)tail[2]) << 16; + case 2: + k1 ^= ((int64_t)tail[1]) << 8; + case 1: + k1 ^= ((int64_t)tail[0]) << 0; + k1 *= c1; + k1 = ROTSL64(k1, 31); + k1 *= c2; + h1 ^= k1; + }; + + //---------- + // finalization + + h1 ^= len; + h2 ^= len; + + h1 += h2; + h2 += h1; + + h1 = sfmix(h1); + h2 = sfmix(h2); + + h1 += h2; + h2 += h1; + + ((int64_t *)out)[0] = h1; + ((int64_t *)out)[1] = h2; +} diff --git a/murmur-src/murmur_hash_3_cassandra.h b/murmur-src/murmur_hash_3_cassandra.h new file mode 100644 --- /dev/null +++ b/murmur-src/murmur_hash_3_cassandra.h @@ -0,0 +1,5 @@ +#include +#include + +void MurmurHash3_x64_128_cassandra( + const void *key, const size_t len, const int64_t seed, void *out); diff --git a/src/Database/CQL/Protocol.hs b/src/Database/CQL/Protocol.hs --- a/src/Database/CQL/Protocol.hs +++ b/src/Database/CQL/Protocol.hs @@ -139,9 +139,12 @@ -- * Row, Tuple and Record , module Database.CQL.Protocol.Tuple , module Database.CQL.Protocol.Record + -- * Cassandra Specific Murmur3 Hash + , module Database.CQL.Protocol.Murmur3 ) where import Database.CQL.Protocol.Class +import Database.CQL.Protocol.Murmur3 import Database.CQL.Protocol.Header import Database.CQL.Protocol.Record import Database.CQL.Protocol.Request diff --git a/src/Database/CQL/Protocol/Class.hs b/src/Database/CQL/Protocol/Class.hs --- a/src/Database/CQL/Protocol/Class.hs +++ b/src/Database/CQL/Protocol/Class.hs @@ -8,6 +8,7 @@ import Control.Arrow import Data.Decimal import Data.Int +import Data.Word import Data.IP import Data.Text (Text) import Data.Time @@ -59,6 +60,15 @@ fromCql _ = Left "Expected CqlTinyInt." ------------------------------------------------------------------------------ +-- Word8 + +instance Cql Word8 where + ctype = Tagged TinyIntColumn + toCql = CqlTinyInt . fromIntegral + fromCql (CqlTinyInt i) = Right (fromIntegral i) + fromCql _ = Left "Expected CqlTinyWord." + +------------------------------------------------------------------------------ -- Int16 instance Cql Int16 where @@ -68,6 +78,15 @@ fromCql _ = Left "Expected CqlSmallInt." ------------------------------------------------------------------------------ +-- Word16 + +instance Cql Word16 where + ctype = Tagged SmallIntColumn + toCql = CqlSmallInt . fromIntegral + fromCql (CqlSmallInt i) = Right (fromIntegral i) + fromCql _ = Left "Expected CqlSmallInt." + +------------------------------------------------------------------------------ -- Int32 instance Cql Int32 where @@ -77,6 +96,15 @@ fromCql _ = Left "Expected CqlInt." ------------------------------------------------------------------------------ +-- Word32 + +instance Cql Word32 where + ctype = Tagged IntColumn + toCql = CqlInt . fromIntegral + fromCql (CqlInt i) = Right (fromIntegral i) + fromCql _ = Left "Expected CqlInt." + +------------------------------------------------------------------------------ -- Int64 instance Cql Int64 where @@ -86,6 +114,15 @@ fromCql _ = Left "Expected CqlBigInt." ------------------------------------------------------------------------------ +-- Word64 + +instance Cql Word64 where + ctype = Tagged BigIntColumn + toCql = CqlBigInt . fromIntegral + fromCql (CqlBigInt i) = Right (fromIntegral i) + fromCql _ = Left "Expected CqlBigInt." + +------------------------------------------------------------------------------ -- Integer instance Cql Integer where @@ -128,6 +165,15 @@ ctype = Tagged TextColumn toCql = CqlText fromCql (CqlText s) = Right s + fromCql _ = Left "Expected CqlText." + +------------------------------------------------------------------------------ +-- Keyspace + +instance Cql Keyspace where + ctype = Tagged TextColumn + toCql = CqlText . unKeyspace + fromCql (CqlText s) = Right (Keyspace s) fromCql _ = Left "Expected CqlText." ------------------------------------------------------------------------------ diff --git a/src/Database/CQL/Protocol/Codec.hs b/src/Database/CQL/Protocol/Codec.hs --- a/src/Database/CQL/Protocol/Codec.hs +++ b/src/Database/CQL/Protocol/Codec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Database.CQL.Protocol.Codec ( encodeByte @@ -60,7 +61,10 @@ , decodeQueryId , putValue - , getValue + , getValuePrefix + , getValueLength + , putValueLength + , putLazyByteString ) where import Control.Applicative @@ -70,15 +74,11 @@ import Data.Decimal import Data.Int import Data.IP -#ifdef INCOMPATIBLE_VARINT -import Data.List (unfoldr) -#else import Data.List (foldl') -#endif import Data.Text (Text) import Data.UUID (UUID) import Data.Word -import Data.Serialize hiding (decode, encode) +import Data.Persist hiding (decode, encode) import Database.CQL.Protocol.Types import Network.Socket (SockAddr (..), PortNumber) import Prelude @@ -90,6 +90,19 @@ import qualified Data.Text.Lazy.Encoding as LT import qualified Data.UUID as UUID +type Putter a = a -> Put () + +getLazyByteString :: Int -> Get LB.ByteString +getLazyByteString n = LB.fromStrict <$!> getByteString n + +getText :: Int -> Get Text +getText n = T.decodeUtf8 <$!> getByteString n + +putLazyByteString :: LB.ByteString -> Put () +putLazyByteString lbs = do + forM_ (LB.toChunks lbs) $ \c -> + putByteString c + ------------------------------------------------------------------------------ -- Byte @@ -112,28 +125,28 @@ -- Short encodeShort :: Putter Word16 -encodeShort = put +encodeShort = putBE decodeShort :: Get Word16 -decodeShort = get +decodeShort = getBE ------------------------------------------------------------------------------ -- Signed Short encodeSignedShort :: Putter Int16 -encodeSignedShort = put +encodeSignedShort = putBE decodeSignedShort :: Get Int16 -decodeSignedShort = get +decodeSignedShort = getBE ------------------------------------------------------------------------------ -- Int encodeInt :: Putter Int32 -encodeInt = put +encodeInt = putBE decodeInt :: Get Int32 -decodeInt = get +decodeInt = getBE ------------------------------------------------------------------------------ -- String @@ -152,7 +165,7 @@ decodeLongString :: Get LT.Text decodeLongString = do - n <- get :: Get Int32 + n <- getBE :: Get Int32 LT.decodeUtf8 <$> getLazyByteString (fromIntegral n) ------------------------------------------------------------------------------ @@ -160,12 +173,12 @@ encodeBytes :: Putter LB.ByteString encodeBytes bs = do - put (fromIntegral (LB.length bs) :: Int32) + putBE (fromIntegral (LB.length bs) :: Int32) putLazyByteString bs decodeBytes :: Get (Maybe LB.ByteString) decodeBytes = do - n <- get :: Get Int32 + n <- getBE :: Get Int32 if n < 0 then return Nothing else Just <$> getLazyByteString (fromIntegral n) @@ -175,12 +188,12 @@ encodeShortBytes :: Putter ByteString encodeShortBytes bs = do - put (fromIntegral (B.length bs) :: Word16) + putBE (fromIntegral (B.length bs) :: Word16) putByteString bs decodeShortBytes :: Get ByteString decodeShortBytes = do - n <- get :: Get Word16 + n <- getBE :: Get Word16 getByteString (fromIntegral n) ------------------------------------------------------------------------------ @@ -199,12 +212,12 @@ encodeList :: Putter [Text] encodeList sl = do - put (fromIntegral (length sl) :: Word16) + putBE (fromIntegral (length sl) :: Word16) mapM_ encodeString sl decodeList :: Get [Text] decodeList = do - n <- get :: Get Word16 + n <- getBE :: Get Word16 replicateM (fromIntegral n) decodeString ------------------------------------------------------------------------------ @@ -212,12 +225,12 @@ encodeMap :: Putter [(Text, Text)] encodeMap m = do - put (fromIntegral (length m) :: Word16) + putBE (fromIntegral (length m) :: Word16) forM_ m $ \(k, v) -> encodeString k >> encodeString v decodeMap :: Get [(Text, Text)] decodeMap = do - n <- get :: Get Word16 + n <- getBE :: Get Word16 replicateM (fromIntegral n) ((,) <$> decodeString <*> decodeString) ------------------------------------------------------------------------------ @@ -225,12 +238,12 @@ encodeMultiMap :: Putter [(Text, [Text])] encodeMultiMap mm = do - put (fromIntegral (length mm) :: Word16) + putBE (fromIntegral (length mm) :: Word16) forM_ mm $ \(k, v) -> encodeString k >> encodeList v decodeMultiMap :: Get [(Text, [Text])] decodeMultiMap = do - n <- get :: Get Word16 + n <- getBE :: Get Word16 replicateM (fromIntegral n) ((,) <$> decodeString <*> decodeList) ------------------------------------------------------------------------------ @@ -238,16 +251,16 @@ encodeSockAddr :: Putter SockAddr encodeSockAddr (SockAddrInet p a) = do - putWord8 4 - putWord32le a - putWord32be (fromIntegral p) + put @Word8 4 + putHE a + putBE @Word32 (fromIntegral p) encodeSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do - putWord8 16 - putWord32host a - putWord32host b - putWord32host c - putWord32host d - putWord32be (fromIntegral p) + put @Word8 16 + putBE a + putBE b + putBE c + putBE d + putBE @Word32 (fromIntegral p) encodeSockAddr (SockAddrUnix _) = error "encode-socket: unix address not supported" #if MIN_VERSION_network(2,6,1) && !MIN_VERSION_network(3,0,0) encodeSockAddr (SockAddrCan _) = error "encode-socket: can address not supported" @@ -255,7 +268,7 @@ decodeSockAddr :: Get SockAddr decodeSockAddr = do - n <- getWord8 + n <- get @Word8 case n of 4 -> do i <- getIPv4 @@ -268,13 +281,13 @@ _ -> fail $ "decode-socket: unknown: " ++ show n where getPort :: Get PortNumber - getPort = fromIntegral <$> getWord32be + getPort = fromIntegral <$!> getBE @Word32 getIPv4 :: Get Word32 - getIPv4 = getWord32le + getIPv4 = getHE getIPv6 :: Get (Word32, Word32, Word32, Word32) - getIPv6 = (,,,) <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + getIPv6 = (,,,) <$> getBE <*> getBE <*> getBE <*> getBE ------------------------------------------------------------------------------ -- Consistency @@ -404,183 +417,195 @@ -- Value putValue :: Version -> Putter Value -putValue _ (CqlCustom x) = toBytes $ putLazyByteString x -putValue _ (CqlBoolean x) = toBytes $ putWord8 $ if x then 1 else 0 -putValue _ (CqlInt x) = toBytes $ put x -putValue _ (CqlBigInt x) = toBytes $ put x -putValue _ (CqlFloat x) = toBytes $ putFloat32be x -putValue _ (CqlDouble x) = toBytes $ putFloat64be x -putValue _ (CqlText x) = toBytes $ putByteString (T.encodeUtf8 x) -putValue _ (CqlUuid x) = toBytes $ encodeUUID x -putValue _ (CqlTimeUuid x) = toBytes $ encodeUUID x -putValue _ (CqlTimestamp x) = toBytes $ put x -putValue _ (CqlAscii x) = toBytes $ putByteString (T.encodeUtf8 x) -putValue _ (CqlBlob x) = toBytes $ putLazyByteString x -putValue _ (CqlCounter x) = toBytes $ put x -putValue _ (CqlInet x) = toBytes $ case x of - IPv4 i -> putWord32le (toHostAddress i) - IPv6 i -> do - let (a, b, c, d) = toHostAddress6 i - putWord32host a - putWord32host b - putWord32host c - putWord32host d -putValue _ (CqlVarInt x) = toBytes $ integer2bytes x -putValue _ (CqlDecimal x) = toBytes $ do - put (fromIntegral (decimalPlaces x) :: Int32) +putValue _ (CqlBoolean False) = put @Word8 0 +putValue _ (CqlBoolean True) = put @Word8 1 +putValue _ (CqlCustom x) = putLazyByteString x +putValue _ (CqlInt x) = putBE x +putValue _ (CqlBigInt x) = putBE x +putValue _ (CqlFloat x) = putBE x +putValue _ (CqlDouble x) = putBE x +putValue V4 (CqlSmallInt x) = putBE x +putValue _ v@(CqlSmallInt _) = error $ "putValue: smallint: " ++ show v +putValue V4 (CqlTinyInt x) = put @Int8 x +putValue _ v@(CqlTinyInt _) = error $ "putValue: tinyint: " ++ show v +putValue _ (CqlVarInt x) = integer2bytes x +putValue _ (CqlDecimal x) = do + putBE @Int32 (fromIntegral $ decimalPlaces x) integer2bytes (decimalMantissa x) -putValue V4 (CqlDate x) = toBytes $ put x -putValue _ v@(CqlDate _) = error $ "putValue: date: " ++ show v -putValue V4 (CqlTime x) = toBytes $ put x -putValue _ v@(CqlTime _) = error $ "putValue: time: " ++ show v -putValue V4 (CqlSmallInt x) = toBytes $ put x -putValue _ v@(CqlSmallInt _) = error $ "putValue: smallint: " ++ show v -putValue V4 (CqlTinyInt x) = toBytes $ put x -putValue _ v@(CqlTinyInt _) = error $ "putValue: tinyint: " ++ show v -putValue v (CqlUdt x) = toBytes $ mapM_ (putValue v . snd) x -putValue v (CqlList x) = toBytes $ do - encodeInt (fromIntegral (length x)) - mapM_ (putValue v) x -putValue v (CqlSet x) = toBytes $ do - encodeInt (fromIntegral (length x)) - mapM_ (putValue v) x -putValue v (CqlMap x) = toBytes $ do - encodeInt (fromIntegral (length x)) - forM_ x $ \(k, w) -> putValue v k >> putValue v w -putValue v (CqlTuple x) = toBytes $ mapM_ (putValue v) x -putValue _ (CqlMaybe Nothing) = put (-1 :: Int32) -putValue v (CqlMaybe (Just x)) = putValue v x +putValue _ (CqlText x) = putByteString $ T.encodeUtf8 x +putValue _ (CqlAscii x) = putByteString $ T.encodeUtf8 x +putValue _ (CqlInet x) = case x of + IPv4 i -> putBE $ fromIPv4w i + IPv6 i -> do + let (a, b, c, d) = fromIPv6w i + putBE a >> putBE b >> putBE c >> putBE d +putValue _ (CqlUuid x) = encodeUUID x +putValue _ (CqlTimeUuid x) = encodeUUID x +putValue _ (CqlTimestamp x) = putBE x +putValue _ (CqlBlob x) = putLazyByteString x +putValue _ (CqlCounter x) = putBE x +putValue _ (CqlMaybe Nothing) = error "putValue: Nothing" +putValue ver (CqlMaybe (Just x)) = putValue ver x +putValue ver (CqlUdt x) = mapM_ (putValueLength ver . snd) x +putValue ver (CqlList x) = do + putBE @Int32 (fromIntegral (length x)) + mapM_ (putValueLength ver) x +putValue ver (CqlSet x) = do + putBE @Int32 (fromIntegral (length x)) + mapM_ (putValueLength ver) x +putValue ver (CqlMap x) = do + putBE @Int32 (fromIntegral (length x)) + forM_ x $ \(k, val) -> putValueLength ver k >> putValueLength ver val +putValue ver (CqlTuple x) = mapM_ (putValueLength ver) x +putValue V4 (CqlDate x) = putBE x +putValue _ v@(CqlDate _) = error $ "putValueLength: date: " ++ show v +putValue V4 (CqlTime x) = putBE x +putValue _ v@(CqlTime _) = error $ "putValueLength: time: " ++ show v -getValue :: Version -> ColumnType -> Get Value -getValue v (ListColumn t) = CqlList <$> getList (do +putValueLength :: Version -> Putter Value +putValueLength _ (CqlCustom x) = do + putBE @Int32 (fromIntegral $ LB.length x) + putLazyByteString x +putValueLength ver val@(CqlBoolean _) = putBE @Int32 1 >> putValue ver val +putValueLength _ (CqlInt x) = putBE @Int32 4 >> putBE x +putValueLength _ (CqlBigInt x) = putBE @Int32 8 >> putBE x +putValueLength _ (CqlFloat x) = putBE @Int32 4 >> putBE x +putValueLength _ (CqlDouble x) = putBE @Int32 8 >> putBE x +putValueLength _ (CqlText x) = do + let xBS = T.encodeUtf8 x + putBE @Int32 (fromIntegral $ B.length xBS) + putByteString xBS +putValueLength _ (CqlUuid x) = putBE @Int32 16 >> encodeUUID x +putValueLength _ (CqlTimeUuid x) = putBE @Int32 16 >> encodeUUID x +putValueLength _ (CqlTimestamp x) = putBE @Int32 8 >> putBE x +putValueLength ver (CqlAscii x) = putValueLength ver (CqlText x) +putValueLength _ (CqlBlob x) = do + putBE @Int32 (fromIntegral $ LB.length x) + putLazyByteString x +putValueLength _ (CqlCounter x) = putBE @Int32 8 >> putBE x +putValueLength ver val@(CqlInet x) = case x of + IPv4 _ -> putBE @Int32 4 >> putValue ver val + IPv6 _ -> putBE @Int32 16 >> putValue ver val +putValueLength V4 (CqlDate x) = putBE @Int32 4 >> putBE x +putValueLength _ v@(CqlDate _) = error $ "putValueLength: date: " ++ show v +putValueLength V4 (CqlTime x) = putBE @Int32 8 >> putBE x +putValueLength _ v@(CqlTime _) = error $ "putValueLength: time: " ++ show v +putValueLength V4 (CqlSmallInt x) = putBE @Int32 2 >> putBE x +putValueLength _ v@(CqlSmallInt _) = error $ "putValueLength: smallint: " ++ show v +putValueLength V4 (CqlTinyInt x) = putBE @Int32 1 >> putBE x +putValueLength _ v@(CqlTinyInt _) = error $ "putValueLength: tinyint: " ++ show v +putValueLength _ (CqlMaybe Nothing) = putBE @Int32 (-1) +putValueLength v (CqlMaybe (Just x)) = putValueLength v x +putValueLength ver val = withLength32 $ putValue ver val + +getValueLength :: Version -> ColumnType -> Get Value +getValueLength ver colType@(MaybeColumn _) = do + mLen <- getBE @Int32 + if mLen < -1 + then fail $ "getNative: MaybeColumn too small: " ++ show mLen + else getValuePrefix ver colType mLen +getValueLength v t = withReadPrefix (getValuePrefix v t) + +getValuePrefix :: Version -> ColumnType -> Int32 -> Get Value +getValuePrefix v (ListColumn t) listLength = CqlList <$!> getList listLength (do len <- decodeInt - replicateM (fromIntegral len) (getValue v t)) -getValue v (SetColumn t) = CqlSet <$> getList (do + replicateM (fromIntegral len) (getValueLength v t)) +getValuePrefix v (SetColumn t) setLength = CqlSet <$!> getList setLength (do len <- decodeInt - replicateM (fromIntegral len) (getValue v t)) -getValue v (MapColumn t u) = CqlMap <$> getList (do + replicateM (fromIntegral len) (getValueLength v t)) +getValuePrefix v (MapColumn t u) mapLength = CqlMap <$!> getList mapLength (do len <- decodeInt - replicateM (fromIntegral len) ((,) <$> getValue v t <*> getValue v u)) -getValue v (TupleColumn t) = withBytes $ CqlTuple <$> mapM (getValue v) t -getValue v (MaybeColumn t) = do - n <- lookAhead (get :: Get Int32) - if n < 0 - then uncheckedSkip 4 >> return (CqlMaybe Nothing) - else CqlMaybe . Just <$> getValue v t -getValue _ (CustomColumn _) = withBytes $ CqlCustom <$> remainingBytesLazy -getValue _ BooleanColumn = withBytes $ CqlBoolean . (/= 0) <$> getWord8 -getValue _ IntColumn = withBytes $ CqlInt <$> get -getValue _ BigIntColumn = withBytes $ CqlBigInt <$> get -getValue _ FloatColumn = withBytes $ CqlFloat <$> getFloat32be -getValue _ DoubleColumn = withBytes $ CqlDouble <$> getFloat64be -getValue _ TextColumn = withBytes $ CqlText . T.decodeUtf8 <$> remainingBytes -getValue _ VarCharColumn = withBytes $ CqlText . T.decodeUtf8 <$> remainingBytes -getValue _ AsciiColumn = withBytes $ CqlAscii . T.decodeUtf8 <$> remainingBytes -getValue _ BlobColumn = withBytes $ CqlBlob <$> remainingBytesLazy -getValue _ UuidColumn = withBytes $ CqlUuid <$> decodeUUID -getValue _ TimeUuidColumn = withBytes $ CqlTimeUuid <$> decodeUUID -getValue _ TimestampColumn = withBytes $ CqlTimestamp <$> get -getValue _ CounterColumn = withBytes $ CqlCounter <$> get -getValue _ InetColumn = withBytes $ CqlInet <$> do - len <- remaining - case len of - 4 -> IPv4 . fromHostAddress <$> getWord32le + replicateM (fromIntegral len) ((,) <$!> getValueLength v t <*> getValueLength v u)) +getValuePrefix v (TupleColumn t) tLength = withPrefix tLength $ CqlTuple <$!> mapM (getValueLength v) t +getValuePrefix v (MaybeColumn t) mLength = do + if mLength < 0 + then return (CqlMaybe Nothing) + else CqlMaybe . Just <$!> getValuePrefix v t mLength +getValuePrefix _ (CustomColumn _) l = CqlCustom <$!> getLazyByteString (fromIntegral l) +getValuePrefix _ BooleanColumn l = assertLength 1 l >> CqlBoolean . (/= 0) <$!> get @Word8 +getValuePrefix _ IntColumn l = assertLength 4 l >> CqlInt <$!> getBE +getValuePrefix _ BigIntColumn l = assertLength 8 l >> CqlBigInt <$!> getBE +getValuePrefix _ FloatColumn l = assertLength 4 l >> CqlFloat <$!> getBE +getValuePrefix _ DoubleColumn l = assertLength 8 l >> CqlDouble <$!> getBE +getValuePrefix _ TextColumn l = CqlText <$!> getText (fromIntegral l) +getValuePrefix _ VarCharColumn l = CqlText <$!> getText (fromIntegral l) +getValuePrefix _ AsciiColumn l = CqlAscii <$!> getText (fromIntegral l) +getValuePrefix _ BlobColumn l = CqlBlob <$!> getLazyByteString (fromIntegral l) +getValuePrefix _ UuidColumn l = assertLength 16 l >> CqlUuid <$!> decodeUUID +getValuePrefix _ TimeUuidColumn l = assertLength 16 l >> CqlTimeUuid <$!> decodeUUID +getValuePrefix _ TimestampColumn l = assertLength 8 l >> CqlTimestamp <$!> getBE +getValuePrefix _ CounterColumn l = assertLength 8 l >> CqlCounter <$!> getBE +getValuePrefix _ InetColumn l = CqlInet <$!> do + case l of + 4 -> IPv4 . toIPv4w <$!> getBE 16 -> do - a <- (,,,) <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host - return $ IPv6 (fromHostAddress6 a) + a <- getBE + b <- getBE + c <- getBE + d <- getBE + pure . IPv6 $! toIPv6w (a, b, c, d) n -> fail $ "getNative: invalid Inet length: " ++ show n -getValue V4 DateColumn = withBytes $ CqlDate <$> get -getValue _ DateColumn = fail "getNative: date type" -getValue V4 TimeColumn = withBytes $ CqlTime <$> get -getValue _ TimeColumn = fail "getNative: time type" -getValue V4 SmallIntColumn = withBytes $ CqlSmallInt <$> get -getValue _ SmallIntColumn = fail "getNative: smallint type" -getValue V4 TinyIntColumn = withBytes $ CqlTinyInt <$> get -getValue _ TinyIntColumn = fail "getNative: tinyint type" -getValue _ VarIntColumn = withBytes $ CqlVarInt <$> bytes2integer -getValue _ DecimalColumn = withBytes $ do - x <- get :: Get Int32 - y <- bytes2integer - return (CqlDecimal (Decimal (fromIntegral x) y)) -getValue v (UdtColumn _ x) = withBytes $ CqlUdt <$> do +getValuePrefix V4 DateColumn l = assertLength 4 l >> CqlDate <$!> getBE +getValuePrefix _ DateColumn _ = fail "getNative: date type" +getValuePrefix V4 TimeColumn l = assertLength 8 l >> CqlTime <$!> getBE +getValuePrefix _ TimeColumn _ = fail "getNative: time type" +getValuePrefix V4 SmallIntColumn l = assertLength 2 l >> CqlSmallInt <$!> getBE +getValuePrefix _ SmallIntColumn _ = fail "getNative: smallint type" +getValuePrefix V4 TinyIntColumn l = assertLength 1 l >> CqlTinyInt <$!> get +getValuePrefix _ TinyIntColumn _ = fail "getNative: tinyint type" +getValuePrefix _ VarIntColumn l = withPrefix l $ CqlVarInt <$!> bytes2integer +getValuePrefix _ DecimalColumn l = withPrefix l $ do + x <- getBE @Int32 + CqlDecimal . Decimal (fromIntegral x) <$> bytes2integer +getValuePrefix v (UdtColumn _ x) l = withPrefix l $ CqlUdt <$!> do let (n, t) = unzip x - zip n <$> mapM (getValue v) t + zip n <$> mapM (getValueLength v) t -getList :: Get [a] -> Get [a] -getList m = do - n <- lookAhead (get :: Get Int32) - if n < 0 then uncheckedSkip 4 >> return [] - else withBytes m +assertLength :: Int32 -> Int32 -> Get () +assertLength expected provided | expected == provided = pure () + | otherwise = + fail $ "getNative: Expecting length: " ++ show expected ++ ", but got: " ++ show provided -withBytes :: Get a -> Get a -withBytes p = do - n <- fromIntegral <$> (get :: Get Int32) +getList :: Int32 -> Get [a] -> Get [a] +getList n m = do + if n < 0 then return [] + else withPrefix n m + +withPrefix :: Int32 -> Get a -> Get a +withPrefix prefixLength = getPrefix (fromIntegral prefixLength) + +withReadPrefix :: (Int32 -> Get a) -> Get a +withReadPrefix p = do + n <- fromIntegral <$!> getBE @Int32 when (n < 0) $ - fail $ "withBytes: null (length = " ++ show n ++ ")" - b <- getBytes n - case runGet p b of - Left e -> fail $ "withBytes: " ++ e - Right x -> return x + fail $ "withReadPrefix: null (length = " ++ show n ++ ")" + p n remainingBytes :: Get ByteString remainingBytes = remaining >>= getByteString . fromIntegral -remainingBytesLazy :: Get LB.ByteString -remainingBytesLazy = remaining >>= getLazyByteString . fromIntegral - -toBytes :: Put -> Put -toBytes p = do - let bytes = runPut p - put (fromIntegral (B.length bytes) :: Int32) - putByteString bytes - -#ifdef INCOMPATIBLE_VARINT - --- 'integer2bytes' and 'bytes2integer' implementations are taken --- from cereal's instance declaration of 'Serialize' for 'Integer' --- except that no distinction between small and large integers is made. --- Cf. to LICENSE for copyright details. -integer2bytes :: Putter Integer -integer2bytes n = do - put sign - put (unroll (abs n)) - where - sign = fromIntegral (signum n) :: Word8 - - unroll :: Integer -> [Word8] - unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -bytes2integer :: Get Integer -bytes2integer = do - sign <- get - bytes <- get - let v = roll bytes - return $! if sign == (1 :: Word8) then v else - v - where - roll :: [Word8] -> Integer - roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b - -#else +withLength32 :: Put () -> Put () +withLength32 basePut = do + lengthSlot <- reserveSize @Int32 + basePut + resolveSizeExclusiveBE lengthSlot integer2bytes :: Putter Integer integer2bytes n - | n == 0 = putWord8 0x00 - | n == -1 = putWord8 0xFF + | n == 0 = put @Word8 0x00 + | n == -1 = put @Word8 0xFF | n < 0 = do let bytes = explode (-1) n - unless (head bytes >= 0x80) $ - putWord8 0xFF - mapM_ putWord8 bytes + case bytes of + byte : _ -> unless (byte >= 0x80) $ put @Word8 0xFF + [] -> pure () + mapM_ (put @Word8) bytes | otherwise = do let bytes = explode 0 n - unless (head bytes < 0x80) $ - putWord8 0x00 - mapM_ putWord8 bytes + case bytes of + byte : _ -> unless (byte < 0x80) $ put @Word8 0x00 + [] -> pure () + mapM_ (put @Word8) bytes explode :: Integer -> Integer -> [Word8] explode x n = loop n [] @@ -591,7 +616,7 @@ bytes2integer :: Get Integer bytes2integer = do - msb <- getWord8 + msb <- get @Word8 bytes <- B.unpack <$> remainingBytes if msb < 0x80 then return (implode (msb:bytes)) @@ -602,7 +627,6 @@ where fun i b = i `shiftL` 8 .|. fromIntegral b -#endif ------------------------------------------------------------------------------ -- Various diff --git a/src/Database/CQL/Protocol/Header.hs b/src/Database/CQL/Protocol/Header.hs --- a/src/Database/CQL/Protocol/Header.hs +++ b/src/Database/CQL/Protocol/Header.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} module Database.CQL.Protocol.Header ( Header (..) , HeaderType (..) @@ -30,11 +31,11 @@ import Control.Applicative import Data.Bits -import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy (ByteString, toStrict) import Data.Int import Data.Monoid hiding ((<>)) import Data.Semigroup -import Data.Serialize +import Data.Persist import Data.Word import Database.CQL.Protocol.Codec import Database.CQL.Protocol.Types @@ -55,7 +56,7 @@ | RsHeader -- ^ A response frame header. deriving Show -encodeHeader :: Version -> HeaderType -> Flags -> StreamId -> OpCode -> Length -> PutM () +encodeHeader :: Version -> HeaderType -> Flags -> StreamId -> OpCode -> Length -> Put () encodeHeader v t f i o l = do encodeByte $ case t of RqHeader -> mapVersion v @@ -67,7 +68,7 @@ decodeHeader :: Version -> Get Header decodeHeader v = do - b <- getWord8 + b <- get @Word8 Header (mapHeaderType b) <$> toVersion (b .&. 0x7F) <*> decodeFlags @@ -80,7 +81,7 @@ -- | Deserialise a frame header using the version specific decoding format. header :: Version -> ByteString -> Either String Header -header v = runGetLazy (decodeHeader v) +header v = runGet (decodeHeader v) . toStrict ------------------------------------------------------------------------------ -- Version @@ -100,7 +101,7 @@ -- | The type denoting a protocol frame length. newtype Length = Length { lengthRepr :: Int32 } deriving (Eq, Show) -encodeLength :: Putter Length +encodeLength :: Length -> Put () encodeLength (Length x) = encodeInt x decodeLength :: Get Length @@ -122,7 +123,7 @@ fromStreamId :: StreamId -> Int fromStreamId (StreamId i) = fromIntegral i -encodeStreamId :: Version -> Putter StreamId +encodeStreamId :: Version -> StreamId -> Put () encodeStreamId V4 (StreamId x) = encodeSignedShort (fromIntegral x) encodeStreamId V3 (StreamId x) = encodeSignedShort (fromIntegral x) @@ -144,7 +145,7 @@ mempty = Flags 0 mappend = (<>) -encodeFlags :: Putter Flags +encodeFlags :: Flags -> Put () encodeFlags (Flags x) = encodeByte x decodeFlags :: Get Flags diff --git a/src/Database/CQL/Protocol/Murmur3.hsc b/src/Database/CQL/Protocol/Murmur3.hsc new file mode 100644 --- /dev/null +++ b/src/Database/CQL/Protocol/Murmur3.hsc @@ -0,0 +1,28 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TypeApplications #-} + +module Database.CQL.Protocol.Murmur3 + ( murmur3HashKey + ) where + +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Int (Int64) +import Data.Word (Word8) +import Foreign.C.Types (CSize (..)) +import Foreign.Marshal.Alloc (allocaBytesAligned) +import Foreign.Storable (Storable (..)) +import Foreign.Ptr (Ptr, castPtr) +import System.IO.Unsafe (unsafePerformIO) + +foreign import capi unsafe "murmur_hash_3_cassandra.h MurmurHash3_x64_128_cassandra" + c_Murmur3HashCassandra :: Ptr Word8 -> CSize -> Int64 -> Ptr Int64 -> IO () + +murmur3HashKey :: ByteString -> Int64 +murmur3HashKey key = unsafePerformIO $ + unsafeUseAsCStringLen key $ \(p, l) -> + allocaBytesAligned (sizeOf @Int64 0 * 2) (alignment @Int64 0) $ \hPtr -> do + c_Murmur3HashCassandra (castPtr p) (fromIntegral l) 0 hPtr + peek hPtr + diff --git a/src/Database/CQL/Protocol/Record.hs b/src/Database/CQL/Protocol/Record.hs --- a/src/Database/CQL/Protocol/Record.hs +++ b/src/Database/CQL/Protocol/Record.hs @@ -58,19 +58,21 @@ _ -> fail "expecting record type" start :: Dec -> Q [Dec] -start (DataD _ tname _ _ cons _) = do - unless (length cons == 1) $ - fail "expecting single data constructor" - tt <- tupleType (head cons) - at <- asTupleDecl (head cons) - ar <- asRecrdDecl (head cons) - return - [ typeSynDecl (mkName "TupleType") (ConT tname) tt - , InstanceD Nothing [] (ConT (mkName "Record") $: ConT tname) - [ FunD (mkName "asTuple") [at] - , FunD (mkName "asRecord") [ar] - ] - ] +start (DataD _ tname _ _ cons _) = + case cons of + [] -> fail "expecting single data constructor" + (_:_:_) -> fail "expecting single data constructor" + [singleCon] -> do + tt <- tupleType singleCon + at <- asTupleDecl singleCon + ar <- asRecrdDecl singleCon + return + [ typeSynDecl (mkName "TupleType") (ConT tname) tt + , InstanceD Nothing [] (ConT (mkName "Record") $: ConT tname) + [ FunD (mkName "asTuple") [at] + , FunD (mkName "asRecord") [ar] + ] + ] start _ = fail "unsupported data type" tupleType :: Con -> Q Type diff --git a/src/Database/CQL/Protocol/Request.hs b/src/Database/CQL/Protocol/Request.hs --- a/src/Database/CQL/Protocol/Request.hs +++ b/src/Database/CQL/Protocol/Request.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} module Database.CQL.Protocol.Request ( Request (..) @@ -51,7 +52,6 @@ , encodeExecute ) where -import Control.Applicative import Data.Bits import Data.ByteString.Lazy (ByteString) import Data.Foldable (traverse_) @@ -59,7 +59,7 @@ import Data.Text (Text) import Data.Maybe (isJust) import Data.Monoid -import Data.Serialize hiding (decode, encode) +import Data.Persist hiding (decode, encode) import Data.Word import Database.CQL.Protocol.Tuple import Database.CQL.Protocol.Codec @@ -90,7 +90,7 @@ | RqExecute !(Execute k a b) deriving Show -encodeRequest :: Tuple a => Version -> Putter (Request k a b) +encodeRequest :: Tuple a => Version -> Request k a b -> Put () encodeRequest _ (RqStartup r) = encodeStartup r encodeRequest _ (RqOptions r) = encodeOptions r encodeRequest _ (RqRegister r) = encodeRegister r @@ -117,7 +117,7 @@ encodeHeader v RqHeader mkFlags i (getOpCode r) len putLazyByteString body where - runCompression f x = maybe compressError return (shrink f $ x) + runCompression f x = maybe compressError return (shrink f x) compressError = Left "pack: compression failure" mkFlags = (if t then tracing else mempty) @@ -142,7 +142,7 @@ -- compression algorithm. data Startup = Startup !CqlVersion !CompressionAlgorithm deriving Show -encodeStartup :: Putter Startup +encodeStartup :: Startup -> Put () encodeStartup (Startup v c) = encodeMap $ ("CQL_VERSION", mapVersion v) : mapCompression c where @@ -161,7 +161,7 @@ -- | A request send in response to a previous authentication challenge. newtype AuthResponse = AuthResponse LB.ByteString deriving Show -encodeAuthResponse :: Putter AuthResponse +encodeAuthResponse :: AuthResponse -> Put () encodeAuthResponse (AuthResponse b) = encodeBytes b ------------------------------------------------------------------------------ @@ -171,7 +171,7 @@ -- startup options. data Options = Options deriving Show -encodeOptions :: Putter Options +encodeOptions :: Options -> Put () encodeOptions _ = return () ------------------------------------------------------------------------------ @@ -180,7 +180,7 @@ -- | A CQL query (select, insert, etc.). data Query k a b = Query !(QueryString k a b) !(QueryParams a) deriving Show -encodeQuery :: Tuple a => Version -> Putter (Query k a b) +encodeQuery :: Tuple a => Version -> Query k a b -> Put () encodeQuery v (Query (QueryString s) p) = encodeLongString s >> encodeQueryParams v p @@ -190,7 +190,7 @@ -- | Executes a prepared query. data Execute k a b = Execute !(QueryId k a b) !(QueryParams a) deriving Show -encodeExecute :: Tuple a => Version -> Putter (Execute k a b) +encodeExecute :: Tuple a => Version -> Execute k a b -> Put () encodeExecute v (Execute (QueryId q) p) = encodeShortBytes q >> encodeQueryParams v p @@ -200,7 +200,7 @@ -- | Prepare a query for later execution (cf. 'Execute'). newtype Prepare k a b = Prepare (QueryString k a b) deriving Show -encodePrepare :: Putter (Prepare k a b) +encodePrepare :: Prepare k a b -> Put () encodePrepare (Prepare (QueryString p)) = encodeLongString p ------------------------------------------------------------------------------ @@ -210,7 +210,7 @@ -- server events. newtype Register = Register [EventType] deriving Show -encodeRegister :: Putter Register +encodeRegister :: Register -> Put () encodeRegister (Register t) = do encodeShort (fromIntegral (length t)) mapM_ encodeEventType t @@ -222,7 +222,7 @@ | SchemaChangeEvent -- ^ events related to schema change deriving Show -encodeEventType :: Putter EventType +encodeEventType :: EventType -> Put () encodeEventType TopologyChangeEvent = encodeString "TOPOLOGY_CHANGE" encodeEventType StatusChangeEvent = encodeString "STATUS_CHANGE" encodeEventType SchemaChangeEvent = encodeString "SCHEMA_CHANGE" @@ -244,22 +244,22 @@ | BatchCounter -- ^ used for batched counter updates deriving (Show) -encodeBatch :: Version -> Putter Batch +encodeBatch :: Version -> Batch -> Put () encodeBatch v (Batch t q c s) = do encodeBatchType t encodeShort (fromIntegral (length q)) mapM_ (encodeBatchQuery v) q encodeConsistency c put batchFlags - traverse_ encodeConsistency (mapCons <$> s) + traverse_ (encodeConsistency . mapCons) s where batchFlags :: Word8 batchFlags = if isJust s then 0x10 else 0x0 -encodeBatchType :: Putter BatchType -encodeBatchType BatchLogged = putWord8 0 -encodeBatchType BatchUnLogged = putWord8 1 -encodeBatchType BatchCounter = putWord8 2 +encodeBatchType :: BatchType -> Put () +encodeBatchType BatchLogged = put @Word8 0 +encodeBatchType BatchUnLogged = put @Word8 1 +encodeBatchType BatchCounter = put @Word8 2 -- | A GADT to unify queries and prepared queries both of which can be used -- in batch requests. @@ -276,13 +276,13 @@ deriving instance Show BatchQuery -encodeBatchQuery :: Version -> Putter BatchQuery +encodeBatchQuery :: Version -> BatchQuery -> Put () encodeBatchQuery n (BatchQuery (QueryString q) v) = do - putWord8 0 + put @Word8 0 encodeLongString q store n v encodeBatchQuery n (BatchPrepared (QueryId i) v) = do - putWord8 1 + put @Word8 1 encodeShortBytes i store n v @@ -325,14 +325,14 @@ -- data center. deriving Show -encodeQueryParams :: forall a. Tuple a => Version -> Putter (QueryParams a) +encodeQueryParams :: forall a. Tuple a => Version -> QueryParams a -> Put () encodeQueryParams v p = do encodeConsistency (consistency p) put queryFlags store v (values p) traverse_ encodeInt (pageSize p) traverse_ encodePagingState (queryPagingState p) - traverse_ encodeConsistency (mapCons <$> serialConsistency p) + traverse_ (encodeConsistency . mapCons) (serialConsistency p) where queryFlags :: Word8 queryFlags = diff --git a/src/Database/CQL/Protocol/Response.hs b/src/Database/CQL/Protocol/Response.hs --- a/src/Database/CQL/Protocol/Response.hs +++ b/src/Database/CQL/Protocol/Response.hs @@ -58,7 +58,7 @@ import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text) -import Data.Serialize hiding (Result) +import Data.Persist import Data.Typeable import Data.UUID (UUID) import Data.Word @@ -125,7 +125,7 @@ let f = flags h let v = version h x <- if compress `isSet` f then deflate c b else return b - flip runGetLazy x $ do + flip runGet (LB.toStrict x) $ do t <- if tracing `isSet` f then Just <$> decodeUUID else return Nothing w <- if warning `isSet` f then decodeList else return [] message v t w (opCode h) @@ -191,7 +191,7 @@ decodeSupported = do opt <- decodeMultiMap cmp <- mapM toCompression . fromMaybe [] $ lookup "COMPRESSION" opt - let v = map toVersion . fromMaybe [] $ lookup "CQL_VERSION" opt + let v = maybe [] (map toVersion) $ lookup "CQL_VERSION" opt return $ Supported cmp v where toCompression "snappy" = return Snappy diff --git a/src/Database/CQL/Protocol/Tuple.hs b/src/Database/CQL/Protocol/Tuple.hs --- a/src/Database/CQL/Protocol/Tuple.hs +++ b/src/Database/CQL/Protocol/Tuple.hs @@ -1,15 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -- | A tuple represents the types of multiple cassandra columns. It is used -- to check that column-types match. module Database.CQL.Protocol.Tuple ( Tuple - , count , check - , tuple + , count + , rowKey , store + , tuple , Row , mkRow , fromRow @@ -20,11 +22,12 @@ import Control.Applicative import Control.Monad import Data.Functor.Identity -import Data.Serialize +import Data.Int (Int32) +import Data.Persist import Data.Vector (Vector, (!?)) import Data.Word import Database.CQL.Protocol.Class -import Database.CQL.Protocol.Codec (putValue, getValue) +import Database.CQL.Protocol.Codec (getValueLength, putValue, putValueLength) import Database.CQL.Protocol.Tuple.TH import Database.CQL.Protocol.Types import Prelude @@ -63,7 +66,8 @@ count :: Tagged a Int check :: Tagged a ([ColumnType] -> [ColumnType]) tuple :: Version -> [ColumnType] -> Get a - store :: Version -> Putter a + store :: Version -> a -> Put () + rowKey :: Version -> [Int32] -> a -> Put () class PrivateTuple a => Tuple a @@ -74,6 +78,7 @@ check = Tagged $ const [] tuple _ _ = return () store _ = const $ return () + rowKey _ _ _ = pure () instance Tuple () @@ -82,25 +87,37 @@ check = Tagged $ typecheck [untag (ctype :: Tagged a ColumnType)] tuple v _ = Identity <$> element v ctype store v (Identity a) = do - put (1 :: Word16) - putValue v (toCql a) + putBE (1 :: Word16) + putValueLength v (toCql a) + rowKey _ [] _ = pure () + rowKey v [0] (Identity x) = putValue v (toCql x) + rowKey _ ks _ = error $ "unexpected rowKey indices: " ++ show ks instance Cql a => Tuple (Identity a) instance PrivateTuple Row where count = Tagged (-1) check = Tagged $ const [] - tuple v t = Row t . Vec.fromList <$> mapM (getValue v . MaybeColumn) t + tuple v t = Row t . Vec.fromList <$> mapM (getValueLength v . MaybeColumn) t store v r = do - put (fromIntegral (rowLength r) :: Word16) - Vec.mapM_ (putValue v) (values r) + putBE (fromIntegral (rowLength r) :: Word16) + Vec.mapM_ (putValueLength v) (values r) + rowKey _ [] _ = pure () + rowKey v [i] r = putValue v $ values r Vec.! fromIntegral i + rowKey v is r = + forM_ is $ \i -> do + let putComponent = putValue v $ values r Vec.! fromIntegral i + sizeRef <- reserveSize @Word16 + putComponent + resolveSizeExclusiveBE sizeRef + put (0 :: Word8) instance Tuple Row -- Implementation helpers --------------------------------------------------- element :: Cql a => Version -> Tagged a ColumnType -> Get a -element v t = getValue v (untag t) >>= either fail return . fromCql +element v t = getValueLength v (untag t) >>= either fail return . fromCql typecheck :: [ColumnType] -> [ColumnType] -> [ColumnType] typecheck rr cc = if checkAll (===) rr cc then [] else rr diff --git a/src/Database/CQL/Protocol/Tuple/TH.hs b/src/Database/CQL/Protocol/Tuple/TH.hs --- a/src/Database/CQL/Protocol/Tuple/TH.hs +++ b/src/Database/CQL/Protocol/Tuple/TH.hs @@ -1,10 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Database.CQL.Protocol.Tuple.TH where import Control.Applicative import Control.Monad +import qualified Data.Vector as Vec ((!), fromList) +import Data.Word (Word16, Word8) import Language.Haskell.TH import Prelude @@ -22,12 +26,14 @@ let ctx = map (AppT (ConT cql)) vtypes td <- tupleDecl n sd <- storeDecl n + rks <- rowKeyDecl n return [ InstanceD Nothing ctx (tcon "PrivateTuple" $: tupleType) [ FunD (mkName "count") [countDecl n] , FunD (mkName "check") [taggedDecl (var "typecheck") vnames] , FunD (mkName "tuple") [td] , FunD (mkName "store") [sd] + , FunD (mkName "rowKey") rks ] , InstanceD Nothing ctx (tcon "Tuple" $: tupleType) [] ] @@ -65,7 +71,7 @@ let f = NormalB $ mkTup (map VarE names) return [ FunD (mkName "combine") [Clause (map VarP names) f []] ] --- store v (a, b) = put (2 :: Word16) >> putValue v (toCql a) >> putValue v (toCql b) +-- store v (a, b) = putBE (2 :: Word16) >> putValueLength v (toCql a) >> putValueLength v (toCql b) storeDecl :: Int -> Q Clause storeDecl n = do let v = mkName "v" @@ -77,9 +83,55 @@ #else body x names = DoE (NoBindS size : map (NoBindS . value x) names) #endif - size = var "put" $$ SigE (litInt n) (tcon "Word16") - value x v = var "putValue" $$ VarE x $$ (var "toCql" $$ VarE v) + size = var "putBE" $$ SigE (litInt n) (tcon "Word16") + value x v = var "putValueLength" $$ VarE x $$ (var "toCql" $$ VarE v) +-- rowKey v [] (a, b) = pure () +-- rowKey v [i] (ks) = putValue v $ toVec ks Vec.! fromIntegral i +-- rowKey v is ks = +-- let vecKs = toVec ks +-- in forM_ is $ \i -> do +-- let putComponent = putValue $ vecKs Vec.! fromIntegral i +-- sizeRef <- reserveSize @Word16 +-- putComponent +-- resolveSizeExclusiveBE sizeRef +-- put (0 :: Word8) +rowKeyDecl :: Int -> Q [Clause] +rowKeyDecl n = do + names <- replicateM n (newName "k") + eb <- emptyBody + sb <- singleBody names + mb <- multiBody names + return $ emptyClause eb : zipWith (makeClause names) [singleP, multiP] [sb, mb] + where + unused x = mkName ("_" ++ x) + unusedP x = VarP (unused x) + v = mkName "v" + i = mkName "i" + is = mkName "is" + iE = pure $ VarE i + isE = pure $ VarE is + vE = pure $ VarE v + emptyP = ListP [] + singleP = ListP [VarP i] + multiP = VarP is + emptyClause eb = Clause [unusedP "v", emptyP, unusedP "ks"] (NormalB eb) [] + makeClause names pat body = + Clause [VarP v, pat, TupP (map VarP names)] (NormalB body) [] + tupList names = pure $ ListE $ map (AppE (var "toCql") . VarE) names + tupVector names = [| Vec.fromList $(tupList names) |] + emptyBody = [| pure () |] + singleBody names = [| putValue $vE $ $(tupVector names) Vec.! fromIntegral $iE |] + multiBody names = [| + let ks = $(tupVector names) + in forM_ $isE $ \j -> do + let putComponent = putValue $vE $ ks Vec.! fromIntegral j + sizeRef <- reserveSize @Word16 + putComponent + resolveSizeExclusiveBE sizeRef + put @Word8 0 |] + + genCqlInstances :: Int -> Q [Dec] genCqlInstances n = join <$> mapM cqlInstances [2 .. n] @@ -135,8 +187,8 @@ <$> combine where body names = UInfixE (var "combine") (var "<$>") (foldl1 star (fn names)) - star a b = UInfixE a (var "<*>") b - fn names = map (AppE (var "fromCql") . VarE) names + star a = UInfixE a (var "<*>") + fn = map (AppE (var "fromCql") . VarE) combine = do names <- replicateM n (newName "x") let f = NormalB $ mkTup (map VarE names) diff --git a/src/Database/CQL/Protocol/Types.hs b/src/Database/CQL/Protocol/Types.hs --- a/src/Database/CQL/Protocol/Types.hs +++ b/src/Database/CQL/Protocol/Types.hs @@ -15,21 +15,21 @@ import qualified Data.Text.Lazy as LT newtype Keyspace = Keyspace - { unKeyspace :: Text } deriving (Eq, Show) + { unKeyspace :: Text } deriving (Eq, Ord, Show) newtype Table = Table - { unTable :: Text } deriving (Eq, Show) + { unTable :: Text } deriving (Eq, Ord, Show) -- | Opaque token passed to the server to continue result paging. newtype PagingState = PagingState - { unPagingState :: LB.ByteString } deriving (Eq, Show) + { unPagingState :: LB.ByteString } deriving (Eq, Ord, Show) -- | ID representing a prepared query. newtype QueryId k a b = QueryId - { unQueryId :: ByteString } deriving (Eq, Show) + { unQueryId :: ByteString } deriving (Eq, Ord, Show) newtype QueryString k a b = QueryString - { unQueryString :: LT.Text } deriving (Eq, Show) + { unQueryString :: LT.Text } deriving (Eq, Ord, Show) instance IsString (QueryString k a b) where fromString = QueryString . LT.pack diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -16,7 +16,7 @@ import Data.Int import Data.IP import Data.Maybe -import Data.Serialize +import Data.Persist (runGet, runPut) import Data.Text (Text) import Data.Time import Data.Time.Clock.POSIX @@ -28,28 +28,20 @@ import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T +import Test.Tasty.HUnit (testCase, Assertion, assertEqual) +import Data.Functor.Identity (Identity(..)) +import Data.Function ((&)) -tests :: TestTree -tests = testGroup "Codec" - [ testProperty "V3: getValue . putValue = id" (getPutIdentity :: Val V3 -> Property) - , testProperty "V4: getValue . putValue = id" (getPutIdentity :: Val V4 -> Property) - , testProperty "toCql . fromCql = id" toCqlFromCqlIdentity - , testGroup "Integrals" - [ testProperty "Int Codec" $ integralCodec (elements [-512..512]) IntColumn CqlInt - , testProperty "BigInt Codec" $ integralCodec (elements [-512..512]) BigIntColumn CqlBigInt - , testProperty "Integer Codec" $ integralCodec (elements [-512..512]) VarIntColumn CqlVarInt - ] - ] getPutIdentity :: Val v -> Property getPutIdentity Val{..} = let t = typeof value - x = runGet (getValue version t) (runPut (putValue version value)) + x = runGet (getValueLength version t) (runPut (putValueLength version value)) in Right value === x integralCodec :: Show a => Gen a -> ColumnType -> (a -> Value) -> Property integralCodec g t f = forAll g $ \i -> - let x = f i in Right x === runGet (getValue V3 t) (runPut (putValue V3 x)) + let x = f i in Right x === runGet (getValueLength V3 t) (runPut (putValueLength V3 x)) toCqlFromCqlIdentity :: Value -> Property toCqlFromCqlIdentity x@(CqlBoolean _) = (toCql <$> (fromCql x :: Either String Bool)) === Right x @@ -205,3 +197,103 @@ recordInstance ''TestRecord +----------------------------------------------------------------------------- +-- Test cases for Murmur3 partition keys + +testMurmur3Vectors :: Assertion +testMurmur3Vectors = do + assertEqual + "Text key from murmur3 test vectors: WRfl" + 422668743870662549 + (rowKey V4 [0] (Identity ("WRfl" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: mrG7A06RDb04APyqtJDcSQ" + (-6351911484294487542) + (rowKey V4 [0] (Identity ("mrG7A06RDb04APyqtJDcSQ" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: P3/cwhnIkfwYgfg" + (-794555513299321809) + (rowKey V4 [0] (Identity ("P3/cwhnIkfwYgfg" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: 9mjOeUyuFA" + 8688054346336436262 + (rowKey V4 [0] (Identity ("9mjOeUyuFA" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: U/a/7qtkKQx7rzjVjDKscxbb" + 5768307025851008073 + (rowKey V4 [0] (Identity ("U/a/7qtkKQx7rzjVjDKscxbb" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: RfZfkoP0UPPez+6jQbvtTA1BwWiLVLLP" + 2204601279383471284 + (rowKey V4 [0] (Identity ("RfZfkoP0UPPez+6jQbvtTA1BwWiLVLLP" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: CzOkHw5RLoUvA3YyXlw4Lq8e4j8" + (-3675581488006656363) + (rowKey V4 [0] (Identity ("CzOkHw5RLoUvA3YyXlw4Lq8e4j8" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: wI6jMf/mmg" + (-1509962630060265403) + (rowKey V4 [0] (Identity ("wI6jMf/mmg" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: JI8cbVgTif6cB6+nSGaORSMHcr8bZw" + (-6681131792718328292) + (rowKey V4 [0] (Identity ("JI8cbVgTif6cB6+nSGaORSMHcr8bZw" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: mIycuRm3Z3LARmzEkDO4zoH1705rLD8" + 2637968942887083513 + (rowKey V4 [0] (Identity ("mIycuRm3Z3LARmzEkDO4zoH1705rLD8" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: Ctt0a606J7cSNA" + 7401972305268388745 + (rowKey V4 [0] (Identity ("Ctt0a606J7cSNA" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: 60rZ+HacaYtqujAXU4xOzZCVlFjOkjC9SlS4" + (-1780712415847777487) + (rowKey V4 [0] (Identity ("60rZ+HacaYtqujAXU4xOzZCVlFjOkjC9SlS4" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: jqMk6mIIn8NUxaKr4rQO3CyU" + (-7948171348135874697) + (rowKey V4 [0] (Identity ("jqMk6mIIn8NUxaKr4rQO3CyU" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: jRci7TcmwIARMXB3KsQdHS8Y1qj6izB4Pmksfh0" + (-355136189899934876) + (rowKey V4 [0] (Identity ("jRci7TcmwIARMXB3KsQdHS8Y1qj6izB4Pmksfh0" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: 9V9Olj0H" + (-7800684702521659878) + (rowKey V4 [0] (Identity ("9V9Olj0H" :: Text)) & runPut & murmur3HashKey) + assertEqual + "Text key from murmur3 test vectors: WLu4UWFyx0WaFlNPeCn4O1EFWzzzdM6akqyOdA" + 5257543896247840857 + (rowKey V4 [0] (Identity ("WLu4UWFyx0WaFlNPeCn4O1EFWzzzdM6akqyOdA" :: Text)) & runPut & murmur3HashKey) + +testCompoundKeys :: Assertion +testCompoundKeys = do + assertEqual + "Known compound key for: []" + (-3485513579396041028) + (rowKey V4 [0] (Identity ([] :: [Text])) & runPut & murmur3HashKey) + assertEqual + "Known compound key for: [\"rules\"]" + 5696842773425782423 + (rowKey V4 [0] (Identity (["rules"] :: [Text])) & runPut & murmur3HashKey) + assertEqual + "Known compound key for: [\"rules\", \"scoring\", \"basic\"]" + 1132589589130033412 + (rowKey V4 [0] (Identity (["rules", "scoring", "basic"] :: [Text])) & runPut & murmur3HashKey) + +tests :: TestTree +tests = testGroup "Codec" + [ testProperty "V3: getValue . putValueLength = id" (getPutIdentity :: Val V3 -> Property) + , testProperty "V4: getValue . putValueLength = id" (getPutIdentity :: Val V4 -> Property) + , testProperty "toCql . fromCql = id" toCqlFromCqlIdentity + , testGroup "Integrals" + [ testProperty "Int Codec" $ integralCodec (elements [-512..512]) IntColumn CqlInt + , testProperty "BigInt Codec" $ integralCodec (elements [-512..512]) BigIntColumn CqlBigInt + , testProperty "Integer Codec" $ integralCodec (elements [-512..512]) VarIntColumn CqlVarInt + ] + , testGroup "Tokens" + [ testCase "Murmur3 C Test Vectors" testMurmur3Vectors + , testCase "Known Compound Keys" testCompoundKeys + ] + ]