cql 4.0.4 → 4.1.0.0

raw patch · 18 files changed

+736/−350 lines, 18 filesdep +persistdep +tasty-hunitdep −cerealdep ~Decimaldep ~basedep ~bytestringnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: persist, tasty-hunit

Dependencies removed: cereal

Dependency ranges changed: Decimal, base, bytestring, containers, iproute, network, template-haskell, text, time, transformers, uuid, vector

API changes (from Hackage documentation)

Files

• AUTHORS +5/−0
• CHANGELOG +21/−0
• LICENSE +0/−37
• cql.cabal +39/−38
• murmur-src/murmur_hash_3_cassandra.c +126/−0
• murmur-src/murmur_hash_3_cassandra.h +5/−0
• src/Database/CQL/Protocol.hs +3/−0
• src/Database/CQL/Protocol/Class.hs +46/−0
• src/Database/CQL/Protocol/Codec.hs +217/−193
• src/Database/CQL/Protocol/Header.hs +9/−8
• src/Database/CQL/Protocol/Murmur3.hsc +28/−0
• src/Database/CQL/Protocol/Record.hs +15/−13
• src/Database/CQL/Protocol/Request.hs +23/−23
• src/Database/CQL/Protocol/Response.hs +3/−3
• src/Database/CQL/Protocol/Tuple.hs +28/−11
• src/Database/CQL/Protocol/Tuple/TH.hs +57/−5
• src/Database/CQL/Protocol/Types.hs +5/−5
• test/Tests.hs +106/−14

@@ -1,6 +1,11 @@ Maintainers ----------- +- Kyle Butt <kyle@iteratee.net>++Prior Maintainers+-----------------+ - Toralf Wittner <tw@dtex.org> - Roman S. Borschel <roman@pkaboo.org> 

@@ -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.

@@ -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.

@@ -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 <tw@dtex.org>,-                      Roman S. Borschel <roman@pkaboo.org>-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 <kyle@iteratee.net>+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 <http://hackage.haskell.org/package/cql-io cql-io>. -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-

@@ -0,0 +1,126 @@+#include <stdint.h>+#include <stddef.h>++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;+}

@@ -0,0 +1,5 @@+#include <stdint.h>+#include <stddef.h>++void MurmurHash3_x64_128_cassandra(+        const void *key, const size_t len, const int64_t seed, void *out);

@@ -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

@@ -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."  ------------------------------------------------------------------------------

@@ -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 

@@ -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

@@ -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+    

@@ -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

@@ -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 =

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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+        ]+    ]