cql 3.1.1 → 4.0.0

raw patch · 14 files changed

+592/−336 lines, 14 filesdep +containersnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• AUTHORS +5/−1
• CHANGELOG +9/−0
• README.md +2/−2
• cql.cabal +6/−4
• src/Database/CQL/Protocol.hs +2/−0
• src/Database/CQL/Protocol/Class.hs +23/−0
• src/Database/CQL/Protocol/Codec.hs +87/−116
• src/Database/CQL/Protocol/Header.hs +12/−4
• src/Database/CQL/Protocol/Request.hs +28/−9
• src/Database/CQL/Protocol/Response.hs +126/−33
• src/Database/CQL/Protocol/Tuple.hs +99/−8
• src/Database/CQL/Protocol/Tuple/TH.hs +77/−112
• src/Database/CQL/Protocol/Types.hs +38/−12
• test/Tests.hs +78/−35

@@ -2,12 +2,16 @@ -----------  - Toralf Wittner <tw@dtex.org>+- Roman S. Borschel <roman@pkaboo.org>  Original Authors ----------------  - Toralf Wittner <tw@dtex.org>-- Roman S. Borschel <roman.borschel@googlemail.com>+- Roman S. Borschel <roman@pkaboo.org>  Contributors ------------++- Ewout Van Troostenberghe <e@ewout.name>+- Steve Severance <sseverance@alphaheavy.com>

@@ -1,3 +1,12 @@+4.0.0+-----+- Add support for CQL V4 binary protocol.+- Remove support for CQL V2 binary protocol.+- Documentation updates.+- Bugfix: The generic 'Row' type did not account for null values+  upon decoding.+- Add a minimal stack.yaml for stack builds.+ 3.1.1 ----- - Fix compatibility with template-haskell 2.11.0.0

@@ -2,7 +2,7 @@ ==================================  This Haskell library implements Cassandra's CQL Binary Protocol versions-[2] and [3]. It provides encoding and decoding functionality as well+[3] and [4]. It provides encoding and decoding functionality as well as representations of the various protocol related types.  Contributing@@ -11,5 +11,5 @@ If you want to contribute to this project please read the file CONTRIBUTING first. -[2]: https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v2.spec [3]: https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v3.spec+[4]: https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v4.spec

@@ -1,11 +1,12 @@ name:                 cql-version:              3.1.1+version:              4.0.0 synopsis:             Cassandra CQL binary protocol. stability:            experimental license:              OtherLicense license-file:         LICENSE author:               Toralf Wittner, Roman S. Borschel-maintainer:           Toralf Wittner <tw@dtex.org>+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@@ -19,9 +20,9 @@  description:     Implementation of Cassandra's CQL Binary Protocol-    <https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v2.spec Version 2>+    <https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v3.spec Version 3>     and-    <https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v3.spec Version 3>.+    <https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v4.spec Version 4>.     .     It provides encoding and decoding functionality as well as representations     of the various protocol related types.@@ -64,6 +65,7 @@           base             >= 4.5    && < 5.0         , bytestring       >= 0.10         , cereal           >= 0.3+        , containers       >= 0.5         , Decimal          >= 0.3         , iproute          >= 1.3         , network          >= 2.4

@@ -105,6 +105,8 @@        -- * Response     , Response (..)+    , warnings+    , traceId     , unpack        -- ** Ready

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}  module Database.CQL.Protocol.Class (Cql (..)) where @@ -15,6 +16,8 @@ import Database.CQL.Protocol.Types import Prelude +import qualified Database.CQL.Protocol.Tuple.TH as Tuples+ -- | A type that can be converted from and to some CQL 'Value'. -- -- This type-class is used to map custom types to Cassandra data-types.@@ -47,6 +50,24 @@     fromCql _              = Left "Expected CqlBoolean."  ------------------------------------------------------------------------------+-- Int8++instance Cql Int8 where+    ctype = Tagged TinyIntColumn+    toCql = CqlTinyInt+    fromCql (CqlTinyInt i) = Right i+    fromCql _              = Left "Expected CqlTinyInt."++------------------------------------------------------------------------------+-- Int16++instance Cql Int16 where+    ctype = Tagged SmallIntColumn+    toCql = CqlSmallInt+    fromCql (CqlSmallInt i) = Right i+    fromCql _               = Left "Expected CqlSmallInt."++------------------------------------------------------------------------------ -- Int32  instance Cql Int32 where@@ -222,3 +243,5 @@     toCql (Set a) = CqlSet $ map toCql a     fromCql (CqlSet a) = Set <$> mapM fromCql a     fromCql _          = Left "Expected CqlSet."++Tuples.genCqlInstances 16

@@ -250,7 +250,7 @@     putWord32host d     putWord32be (fromIntegral p) encodeSockAddr (SockAddrUnix _) = fail "encode-socket: unix address not allowed"-#if MIN_VERSION_network(2,6,1)+#if MIN_VERSION_network(2,6,1) && !MIN_VERSION_network(3,0,0) encodeSockAddr (SockAddrCan _) = fail "encode-socket: can address not allowed" #endif @@ -306,7 +306,7 @@         mapCode 0x07 = return EachQuorum         mapCode 0x08 = return Serial         mapCode 0x09 = return LocalSerial-        mapCode 0x10 = return LocalOne+        mapCode 0x0A = return LocalOne         mapCode code = fail $ "decode-consistency: unknown: " ++ show code  ------------------------------------------------------------------------------@@ -374,6 +374,10 @@     toType 0x000E = return VarIntColumn     toType 0x000F = return TimeUuidColumn     toType 0x0010 = return InetColumn+    toType 0x0011 = return DateColumn+    toType 0x0012 = return TimeColumn+    toType 0x0013 = return SmallIntColumn+    toType 0x0014 = return TinyIntColumn     toType 0x0020 = ListColumn  <$> (decodeShort >>= toType)     toType 0x0021 = MapColumn   <$> (decodeShort >>= toType) <*> (decodeShort >>= toType)     toType 0x0022 = SetColumn   <$> (decodeShort >>= toType)@@ -401,45 +405,20 @@ -- Value  putValue :: Version -> Putter Value-putValue V3 (CqlList x)        = toBytes 4 $ do-    encodeInt (fromIntegral (length x))-    mapM_ (toBytes 4 . putNative V3) x-putValue V2 (CqlList x)        = toBytes 4 $ do-    encodeShort (fromIntegral (length x))-    mapM_ (toBytes 2 . putNative V2) x-putValue V3 (CqlSet x)         = toBytes 4 $ do-    encodeInt (fromIntegral (length x))-    mapM_ (toBytes 4 . putNative V3) x-putValue V2 (CqlSet x)         = toBytes 4 $ do-    encodeShort (fromIntegral (length x))-    mapM_ (toBytes 2 . putNative V2) x-putValue V3 (CqlMap x)         = toBytes 4 $ do-    encodeInt (fromIntegral (length x))-    forM_ x $ \(k, v) -> toBytes 4 (putNative V3 k) >> toBytes 4 (putNative V3 v)-putValue V2 (CqlMap x)         = toBytes 4 $ do-    encodeShort (fromIntegral (length x))-    forM_ x $ \(k, v) -> toBytes 2 (putNative V2 k) >> toBytes 2 (putNative V2 v)-putValue V3 (CqlTuple x)       =-    toBytes 4 $ putByteString $ runPut (mapM_ (putValue V3) x)-putValue _ (CqlMaybe Nothing)  = put (-1 :: Int32)-putValue v (CqlMaybe (Just x)) = putValue v x-putValue v value               = toBytes 4 $ putNative v value--putNative :: Version -> Putter Value-putNative _ (CqlCustom x)    = putLazyByteString x-putNative _ (CqlBoolean x)   = putWord8 $ if x then 1 else 0-putNative _ (CqlInt x)       = put x-putNative _ (CqlBigInt x)    = put x-putNative _ (CqlFloat x)     = putFloat32be x-putNative _ (CqlDouble x)    = putFloat64be x-putNative _ (CqlText x)      = putByteString (T.encodeUtf8 x)-putNative _ (CqlUuid x)      = encodeUUID x-putNative _ (CqlTimeUuid x)  = encodeUUID x-putNative _ (CqlTimestamp x) = put x-putNative _ (CqlAscii x)     = putByteString (T.encodeUtf8 x)-putNative _ (CqlBlob x)      = putLazyByteString x-putNative _ (CqlCounter x)   = put x-putNative _ (CqlInet x)      = case x of+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@@ -447,66 +426,63 @@         putWord32host b         putWord32host c         putWord32host d-putNative _ (CqlVarInt x)   = integer2bytes x-putNative _ (CqlDecimal x)  = do+putValue _ (CqlVarInt x)   = toBytes $ integer2bytes x+putValue _ (CqlDecimal x)  = toBytes $ do     put (fromIntegral (decimalPlaces x) :: Int32)     integer2bytes (decimalMantissa x)-putNative V3   (CqlUdt   x) = putByteString $ runPut (mapM_ (putValue V3 . snd) x)-putNative V2 v@(CqlUdt   _) = fail $ "putNative: udt: " ++ show v-putNative _  v@(CqlList  _) = fail $ "putNative: collection type: " ++ show v-putNative _  v@(CqlSet   _) = fail $ "putNative: collection type: " ++ show v-putNative _  v@(CqlMap   _) = fail $ "putNative: collection type: " ++ show v-putNative _  v@(CqlMaybe _) = fail $ "putNative: collection type: " ++ show v-putNative _  v@(CqlTuple _) = fail $ "putNative: tuple type: " ++ show v+putValue V4   (CqlDate x)     = toBytes $ put x+putValue _  v@(CqlDate _)     = fail $ "putValue: date: " ++ show v+putValue V4   (CqlTime x)     = toBytes $ put x+putValue _  v@(CqlTime _)     = fail $ "putValue: time: " ++ show v+putValue V4   (CqlSmallInt x) = toBytes $ put x+putValue _  v@(CqlSmallInt _) = fail $ "putValue: smallint: " ++ show v+putValue V4   (CqlTinyInt x)  = toBytes $ put x+putValue _  v@(CqlTinyInt _)  = fail $ "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 --- Note: Empty lists, maps and sets are represented as null in cassandra. getValue :: Version -> ColumnType -> Get Value-getValue V3 (ListColumn t)    = CqlList <$> (getList $ do+getValue v (ListColumn t) = CqlList <$> getList (do     len <- decodeInt-    replicateM (fromIntegral len) (withBytes 4 (getNative V3 t)))-getValue V2 (ListColumn t)    = CqlList <$> (getList $ do-    len <- decodeShort-    replicateM (fromIntegral len) (withBytes 2 (getNative V2 t)))-getValue V3 (SetColumn t)     = CqlSet <$> (getList $ do+    replicateM (fromIntegral len) (getValue v t))+getValue v (SetColumn t) = CqlSet <$> getList (do     len <- decodeInt-    replicateM (fromIntegral len) (withBytes 4 (getNative V3 t)))-getValue V2 (SetColumn t)     = CqlSet <$> (getList $ do-    len <- decodeShort-    replicateM (fromIntegral len) (withBytes 2 (getNative V2 t)))-getValue V3 (MapColumn t u)   = CqlMap <$> (getList $ do+    replicateM (fromIntegral len) (getValue v t))+getValue v (MapColumn t u) = CqlMap <$> getList (do     len <- decodeInt-    replicateM (fromIntegral len)-               ((,) <$> withBytes 4 (getNative V3 t) <*> withBytes 4 (getNative V3 u)))-getValue V2 (MapColumn t u)   = CqlMap <$> (getList $ do-    len <- decodeShort-    replicateM (fromIntegral len)-               ((,) <$> withBytes 2 (getNative V2 t) <*> withBytes 2 (getNative V2 u)))-getValue V3 (TupleColumn t)   = do-    b <- withBytes 4 remainingBytes-    either fail return $ flip runGet b $ CqlTuple <$> mapM (getValue V3) t-getValue v (MaybeColumn t)    = do+    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 v colType            = withBytes 4 $ getNative v colType--getNative :: Version -> ColumnType -> Get Value-getNative _ (CustomColumn _) = CqlCustom <$> remainingBytesLazy-getNative _ BooleanColumn    = CqlBoolean . (/= 0) <$> getWord8-getNative _ IntColumn        = CqlInt <$> get-getNative _ BigIntColumn     = CqlBigInt <$> get-getNative _ FloatColumn      = CqlFloat  <$> getFloat32be-getNative _ DoubleColumn     = CqlDouble <$> getFloat64be-getNative _ TextColumn       = CqlText . T.decodeUtf8 <$> remainingBytes-getNative _ VarCharColumn    = CqlText . T.decodeUtf8 <$> remainingBytes-getNative _ AsciiColumn      = CqlAscii . T.decodeUtf8 <$> remainingBytes-getNative _ BlobColumn       = CqlBlob <$> remainingBytesLazy-getNative _ UuidColumn       = CqlUuid <$> decodeUUID-getNative _ TimeUuidColumn   = CqlTimeUuid <$> decodeUUID-getNative _ TimestampColumn  = CqlTimestamp <$> get-getNative _ CounterColumn    = CqlCounter <$> get-getNative _ InetColumn       = CqlInet <$> do+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@@ -514,37 +490,34 @@             a <- (,,,) <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host             return $ IPv6 (fromHostAddress6 a)         n  -> fail $ "getNative: invalid Inet length: " ++ show n-getNative _ VarIntColumn  = CqlVarInt <$> bytes2integer-getNative _ DecimalColumn = do+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))-getNative V3 (UdtColumn _ x) = do-    b <- remainingBytes-    either fail return $ flip runGet b $ CqlUdt <$> do-        let (n, t) = unzip x-        zip n <$> mapM (getValue V3) t-getNative V2 c@(UdtColumn _ _) = fail $ "getNative: udt: " ++ show c-getNative _  c@(ListColumn  _) = fail $ "getNative: collection type: " ++ show c-getNative _  c@(SetColumn   _) = fail $ "getNative: collection type: " ++ show c-getNative _  c@(MapColumn _ _) = fail $ "getNative: collection type: " ++ show c-getNative _  c@(MaybeColumn _) = fail $ "getNative: collection type: " ++ show c-getNative _  c@(TupleColumn _) = fail $ "getNative: tuple type: " ++ show c+getValue v (UdtColumn _ x) = withBytes $ CqlUdt <$> do+    let (n, t) = unzip x+    zip n <$> mapM (getValue v) t  getList :: Get [a] -> Get [a] getList m = do     n <- lookAhead (get :: Get Int32)     if n < 0 then uncheckedSkip 4 >> return []-             else withBytes 4 m+             else withBytes m -withBytes :: Int -> Get a -> Get a-withBytes s p = do-    n <- case s of-        2 -> fromIntegral <$> (get :: Get Word16)-        4 -> fromIntegral <$> (get :: Get Int32)-        _ -> fail $ "withBytes: invalid size: " ++ show s+withBytes :: Get a -> Get a+withBytes p = do+    n <- fromIntegral <$> (get :: Get Int32)     when (n < 0) $-        fail "withBytes: null"+        fail $ "withBytes: null (length = " ++ show n ++ ")"     b <- getBytes n     case runGet p b of         Left  e -> fail $ "withBytes: " ++ e@@ -556,12 +529,10 @@ remainingBytesLazy :: Get LB.ByteString remainingBytesLazy = remaining >>= getLazyByteString . fromIntegral -toBytes :: Int -> Put -> Put-toBytes s p = do+toBytes :: Put -> Put+toBytes p = do     let bytes = runPut p-    case s of-        2 -> put (fromIntegral (B.length bytes) :: Word16)-        _ -> put (fromIntegral (B.length bytes) :: Int32)+    put (fromIntegral (B.length bytes) :: Int32)     putByteString bytes  #ifdef INCOMPATIBLE_VARINT

@@ -20,7 +20,9 @@       -- ** Flags     , Flags     , compress+    , customPayload     , tracing+    , warning     , isSet     , encodeFlags     , decodeFlags@@ -83,12 +85,12 @@ -- Version  mapVersion :: Version -> Word8+mapVersion V4 = 4 mapVersion V3 = 3-mapVersion V2 = 2  toVersion :: Word8 -> Get Version-toVersion 2 = return V2 toVersion 3 = return V3+toVersion 4 = return V4 toVersion w = fail $ "decode-version: unknown: " ++ show w  ------------------------------------------------------------------------------@@ -120,12 +122,12 @@ fromStreamId (StreamId i) = fromIntegral i  encodeStreamId :: Version -> Putter StreamId+encodeStreamId V4 (StreamId x) = encodeSignedShort (fromIntegral x) encodeStreamId V3 (StreamId x) = encodeSignedShort (fromIntegral x)-encodeStreamId V2 (StreamId x) = encodeSignedByte (fromIntegral x)  decodeStreamId :: Version -> Get StreamId+decodeStreamId V4 = StreamId <$> decodeSignedShort decodeStreamId V3 = StreamId <$> decodeSignedShort-decodeStreamId V2 = StreamId . fromIntegral <$> decodeSignedByte  ------------------------------------------------------------------------------ -- Flags@@ -153,6 +155,12 @@ -- tracing information. tracing :: Flags tracing = Flags 2++customPayload :: Flags+customPayload = Flags 4++warning :: Flags+warning = Flags 8  -- | Check if a particular flag is present. isSet :: Flags -> Flags -> Bool

@@ -251,9 +251,8 @@     encodeShort (fromIntegral (length q))     mapM_ (encodeBatchQuery v) q     encodeConsistency c-    when (v == V3) $ do-        put batchFlags-        traverse_ encodeConsistency (mapCons <$> s)+    put batchFlags+    traverse_ encodeConsistency (mapCons <$> s)   where     batchFlags :: Word8     batchFlags = if isJust s then 0x10 else 0x0@@ -293,18 +292,38 @@  -- | Query parameters. data QueryParams a = QueryParams-    { consistency       :: !Consistency -- ^ consistency leven to use-    , skipMetaData      :: !Bool        -- ^ skip metadata in response-    , values            :: a            -- ^ query arguments-    , pageSize          :: Maybe Int32  -- ^ desired result set size-    , queryPagingState  :: Maybe PagingState+    { consistency :: !Consistency+        -- ^ (Regular) consistency level to use.+    , skipMetaData :: !Bool+        -- ^ Whether to omit the metadata in the 'Response'+        -- of the query. This is an optimisation only relevant for+        -- use with prepared queries, for which the metadata obtained+        -- from the 'PreparedResult' may be reused.+    , values :: a+        -- ^ The bound parameters of the query.+    , pageSize :: Maybe Int32+        -- ^ The desired maximum result set size.+    , queryPagingState :: Maybe PagingState+        -- ^ The current paging state that determines the "offset"+        -- of the results to return for a read query.     , serialConsistency :: Maybe SerialConsistency+        -- ^ Serial consistency level to use for conditional updates+        -- (aka "lightweight transactions"). Irrelevant for any other queries.+    , enableTracing :: Maybe Bool+        -- ^ Whether tracing should be enabled for the query, in which case the+        -- 'Response' will carry a 'traceId'.     } deriving Show --- | Consistency level for the serial phase of conditional updates.+-- | Consistency level for the serial phase of conditional updates+-- (aka "lightweight transactions").+--+-- See: <https://docs.datastax.com/en/cassandra/latest/cassandra/dml/dmlConfigSerialConsistency.html SerialConsistency> data SerialConsistency     = SerialConsistency+        -- ^ Default. Quorum-based linearizable consistency.     | LocalSerialConsistency+        -- ^ Like 'SerialConsistency' except confined to a single (logical)+        -- data center.     deriving Show  encodeQueryParams :: forall a. Tuple a => Version -> Putter (QueryParams a)

@@ -4,6 +4,8 @@  module Database.CQL.Protocol.Response     ( Response            (..)+    , warnings+    , traceId     , unpack        -- ** Ready@@ -68,7 +70,6 @@ import Prelude  import qualified Data.ByteString.Lazy as LB-import qualified Data.Text            as T  ------------------------------------------------------------------------------ -- Response@@ -82,16 +83,38 @@ -- 'a' represents the argument type and 'b' the return type of this -- response. data Response k a b-    = RsError         (Maybe UUID) !Error-    | RsReady         (Maybe UUID) !Ready-    | RsAuthenticate  (Maybe UUID) !Authenticate-    | RsAuthChallenge (Maybe UUID) !AuthChallenge-    | RsAuthSuccess   (Maybe UUID) !AuthSuccess-    | RsSupported     (Maybe UUID) !Supported-    | RsResult        (Maybe UUID) !(Result k a b)-    | RsEvent         (Maybe UUID) !Event+    = RsError         (Maybe UUID) [Text] !Error+    | RsReady         (Maybe UUID) [Text] !Ready+    | RsAuthenticate  (Maybe UUID) [Text] !Authenticate+    | RsAuthChallenge (Maybe UUID) [Text] !AuthChallenge+    | RsAuthSuccess   (Maybe UUID) [Text] !AuthSuccess+    | RsSupported     (Maybe UUID) [Text] !Supported+    | RsResult        (Maybe UUID) [Text] !(Result k a b)+    | RsEvent         (Maybe UUID) [Text] !Event     deriving Show +-- | Get server warnings from response if any.+warnings :: Response k a b -> [Text]+warnings (RsError         _ w _) = w+warnings (RsReady         _ w _) = w+warnings (RsAuthenticate  _ w _) = w+warnings (RsAuthChallenge _ w _) = w+warnings (RsAuthSuccess   _ w _) = w+warnings (RsSupported     _ w _) = w+warnings (RsResult        _ w _) = w+warnings (RsEvent         _ w _) = w++-- | Get server trace ID from response if any.+traceId :: Response k a b -> Maybe UUID+traceId (RsError         x _ _) = x+traceId (RsReady         x _ _) = x+traceId (RsAuthenticate  x _ _) = x+traceId (RsAuthChallenge x _ _) = x+traceId (RsAuthSuccess   x _ _) = x+traceId (RsSupported     x _ _) = x+traceId (RsResult        x _ _) = x+traceId (RsEvent         x _ _) = x+ -- | Deserialise a 'Response' from the given 'ByteString'. unpack :: (Tuple a, Tuple b)        => Compression@@ -104,17 +127,18 @@     x <- if compress `isSet` f then deflate c b else return b     flip runGetLazy x $ do         t <- if tracing `isSet` f then Just <$> decodeUUID else return Nothing-        message v t (opCode h)+        w <- if warning `isSet` f then decodeList else return []+        message v t w (opCode h)   where-    message _ t OcError         = RsError         t <$> decodeError-    message _ t OcReady         = RsReady         t <$> decodeReady-    message _ t OcAuthenticate  = RsAuthenticate  t <$> decodeAuthenticate-    message _ t OcSupported     = RsSupported     t <$> decodeSupported-    message v t OcResult        = RsResult        t <$> decodeResult v-    message v t OcEvent         = RsEvent         t <$> decodeEvent v-    message _ t OcAuthChallenge = RsAuthChallenge t <$> decodeAuthChallenge-    message _ t OcAuthSuccess   = RsAuthSuccess   t <$> decodeAuthSuccess-    message _ _ other           = fail $ "decode-response: unknown: " ++ show other+    message _ t w OcError         = RsError         t w <$> decodeError+    message _ t w OcReady         = RsReady         t w <$> decodeReady+    message _ t w OcAuthenticate  = RsAuthenticate  t w <$> decodeAuthenticate+    message _ t w OcSupported     = RsSupported     t w <$> decodeSupported+    message v t w OcResult        = RsResult        t w <$> decodeResult v+    message v t w OcEvent         = RsEvent         t w <$> decodeEvent v+    message _ t w OcAuthChallenge = RsAuthChallenge t w <$> decodeAuthChallenge+    message _ t w OcAuthSuccess   = RsAuthSuccess   t w <$> decodeAuthSuccess+    message _ _ _ other           = fail $ "decode-response: unknown: " ++ show other      deflate f x  = maybe deflateError return (expand f x)     deflateError = Left "unpack: decompression failure"@@ -192,9 +216,10 @@  -- | Part of a @RowsResult@. Describes the result set. data MetaData = MetaData-    { columnCount :: !Int32-    , pagingState :: Maybe PagingState-    , columnSpecs :: [ColumnSpec]+    { columnCount        :: !Int32+    , pagingState        :: Maybe PagingState+    , columnSpecs        :: [ColumnSpec]+    , primaryKeyIndicies :: [Int32]     } deriving (Show)  -- | The column specification. Part of 'MetaData' unless 'skipMetaData' in@@ -227,7 +252,9 @@             fail $ "column-type error: " ++ message         RowsResult m <$> replicateM (fromIntegral n) (tuple v ctypes)     go 0x3 = SetKeyspaceResult <$> decodeKeyspace-    go 0x4 = PreparedResult <$> decodeQueryId <*> decodeMetaData <*> decodeMetaData+    go 0x4 = if v == V4+                then PreparedResult <$> decodeQueryId <*> decodePreparedV4 <*> decodeMetaData+                else PreparedResult <$> decodeQueryId <*> decodeMetaData <*> decodeMetaData     go 0x5 = SchemaChangeResult <$> decodeSchemaChange v     go int = fail $ "decode-result: unknown: " ++ show int @@ -237,8 +264,8 @@     n <- decodeInt     p <- if hasMorePages f then decodePagingState else return Nothing     if hasNoMetaData f-        then return $ MetaData n p []-        else MetaData n p <$> decodeSpecs n (hasGlobalSpec f)+        then return $ MetaData n p [] []+        else MetaData n p <$> decodeSpecs n (hasGlobalSpec f) <*> pure []   where     hasGlobalSpec f = f `testBit` 0     hasMorePages  f = f `testBit` 1@@ -258,6 +285,31 @@             <*> decodeString             <*> decodeColumnType +decodePreparedV4 :: Get MetaData+decodePreparedV4 = do+    f <- decodeInt+    n <- decodeInt+    pkCount <- decodeInt+    pkis <- replicateM (fromIntegral pkCount) decodeShort+    specs <- decodeSpecs n (hasGlobalSpec f)+    return $ MetaData n Nothing specs (fromIntegral <$> pkis)+  where+    hasGlobalSpec f = f `testBit` 0++    decodeSpecs n True = do+        k <- decodeKeyspace+        t <- decodeTable+        replicateM (fromIntegral n) $ ColumnSpec k t+            <$> decodeString+            <*> decodeColumnType++    decodeSpecs n False =+        replicateM (fromIntegral n) $ ColumnSpec+            <$> decodeKeyspace+            <*> decodeTable+            <*> decodeString+            <*> decodeColumnType+ ------------------------------------------------------------------------------ -- SCHEMA_CHANGE @@ -268,9 +320,11 @@     deriving Show  data Change-    = KeyspaceChange !Keyspace-    | TableChange    !Keyspace !Table-    | TypeChange     !Keyspace !Text+    = KeyspaceChange  !Keyspace+    | TableChange     !Keyspace !Table+    | TypeChange      !Keyspace !Text+    | FunctionChange  !Keyspace !Text ![Text]+    | AggregateChange !Keyspace !Text ![Text]     deriving Show  decodeSchemaChange :: Version -> Get SchemaChange@@ -282,16 +336,20 @@     fromString other     = fail $ "decode-schema-change: unknown: " ++ show other  decodeChange :: Version -> Get Change+decodeChange V4 = decodeString >>= fromString+  where+    fromString "KEYSPACE"  = KeyspaceChange  <$> decodeKeyspace+    fromString "TABLE"     = TableChange     <$> decodeKeyspace <*> decodeTable+    fromString "TYPE"      = TypeChange      <$> decodeKeyspace <*> decodeString+    fromString "FUNCTION"  = FunctionChange  <$> decodeKeyspace <*> decodeString <*> decodeList+    fromString "AGGREGATE" = AggregateChange <$> decodeKeyspace <*> decodeString <*> decodeList+    fromString other      = fail $ "decode-change V4: unknown: " ++ show other decodeChange V3 = decodeString >>= fromString   where     fromString "KEYSPACE" = KeyspaceChange <$> decodeKeyspace     fromString "TABLE"    = TableChange    <$> decodeKeyspace <*> decodeTable     fromString "TYPE"     = TypeChange     <$> decodeKeyspace <*> decodeString-    fromString other      = fail $ "decode-change: unknown: " ++ show other-decodeChange V2 = do-    k <- decodeKeyspace-    t <- decodeTable-    return $ if T.null (unTable t) then KeyspaceChange k else TableChange k t+    fromString other      = fail $ "decode-change V3: unknown: " ++ show other  ------------------------------------------------------------------------------ -- EVENT@@ -339,6 +397,7 @@     = AlreadyExists   !Text !Keyspace !Table     | BadCredentials  !Text     | ConfigError     !Text+    | FunctionFailure !Text !Keyspace !Text ![Text]     | Invalid         !Text     | IsBootstrapping !Text     | Overloaded      !Text@@ -354,6 +413,15 @@         , unavailNumRequired :: !Int32         , unavailNumAlive    :: !Int32         }+    | ReadFailure+        { rFailureMessage     :: !Text+        , rFailureConsistency :: !Consistency+        , rFailureNumAck      :: !Int32+        , rFailureNumRequired :: !Int32+        , rFailureNumFailures :: !Int32+        , rFailureDataPresent :: !Bool+        }+     | ReadTimeout         { rTimeoutMessage     :: !Text         , rTimeoutConsistency :: !Consistency@@ -361,6 +429,14 @@         , rTimeoutNumRequired :: !Int32         , rTimeoutDataPresent :: !Bool         }+    | WriteFailure+        { wFailureMessage     :: !Text+        , wFailureConsistency :: !Consistency+        , wFailureNumAck      :: !Int32+        , wFailureNumRequired :: !Int32+        , wFailureNumFailures :: !Int32+        , wFailureWriteType   :: !WriteType+        }     | WriteTimeout         { wTimeoutMessage     :: !Text         , wTimeoutConsistency :: !Consistency@@ -368,6 +444,7 @@         , wTimeoutNumRequired :: !Int32         , wTimeoutWriteType   :: !WriteType         }+     deriving (Eq, Show, Typeable)  instance Exception Error@@ -404,6 +481,22 @@         <*> decodeInt         <*> decodeInt         <*> (bool <$> decodeByte)+    toError 0x1300 m = ReadFailure m+        <$> decodeConsistency+        <*> decodeInt+        <*> decodeInt+        <*> decodeInt+        <*> (bool <$> decodeByte)+    toError 0x1400 m = FunctionFailure m+        <$> decodeKeyspace+        <*> decodeString+        <*> decodeList+    toError 0x1500 m = WriteFailure m+        <$> decodeConsistency+        <*> decodeInt+        <*> decodeInt+        <*> decodeInt+        <*> decodeWriteType     toError 0x2000 m = return $ SyntaxError m     toError 0x2100 m = return $ Unauthorized m     toError 0x2200 m = return $ Invalid m

@@ -1,7 +1,6 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}  -- | A tuple represents the types of multiple cassandra columns. It is used -- to check that column-types match.@@ -18,14 +17,106 @@     , rowLength     ) where -#if __GLASGOW_HASKELL__ < 710 import Control.Applicative-#endif+import Control.Monad+import Data.Functor.Identity import Data.Serialize+import Data.Vector (Vector, (!?)) import Data.Word import Database.CQL.Protocol.Class-import Database.CQL.Protocol.Codec (putValue)-import Database.CQL.Protocol.Types+import Database.CQL.Protocol.Codec (putValue, getValue) import Database.CQL.Protocol.Tuple.TH+import Database.CQL.Protocol.Types+import Prelude++import qualified Data.Vector as Vec++-- Row ----------------------------------------------------------------------++-- | A row is a vector of 'Value's.+data Row = Row+    { types  :: ![ColumnType]+    , values :: !(Vector Value)+    } deriving (Eq, Show)++-- | Convert a row element.+fromRow :: Cql a => Int -> Row -> Either String a+fromRow i r =+    case values r !? i of+        Nothing -> Left "out of bounds access"+        Just  v -> fromCql v++mkRow :: [(Value, ColumnType)] -> Row+mkRow xs = let (v, t) = unzip xs in Row t (Vec.fromList v)++rowLength :: Row -> Int+rowLength r = Vec.length (values r)++columnTypes :: Row -> [ColumnType]+columnTypes = types++-- Tuples -------------------------------------------------------------------++-- Database.CQL.Protocol.Tuple does not export 'PrivateTuple' but only+-- 'Tuple' effectively turning 'Tuple' into a closed type-class.+class PrivateTuple a where+    count :: Tagged a Int+    check :: Tagged a ([ColumnType] -> [ColumnType])+    tuple :: Version -> [ColumnType] -> Get a+    store :: Version -> Putter a++class PrivateTuple a => Tuple a++-- Manual instances ---------------------------------------------------------++instance PrivateTuple () where+    count     = Tagged 0+    check     = Tagged $ const []+    tuple _ _ = return ()+    store _   = const $ return ()++instance Tuple ()++instance Cql a => PrivateTuple (Identity a) where+    count     = Tagged 1+    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)++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+    store v r = do+        put (fromIntegral (rowLength r) :: Word16)+        Vec.mapM_ (putValue v) (values r)++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++typecheck :: [ColumnType] -> [ColumnType] -> [ColumnType]+typecheck rr cc = if checkAll (===) rr cc then [] else rr+  where+    checkAll f as bs = and (zipWith f as bs)++    checkField (a, b) (c, d) = a == c && b === d++    TextColumn       === VarCharColumn    = True+    VarCharColumn    === TextColumn       = True+    (MaybeColumn  a) === b                = a === b+    (ListColumn   a) === (ListColumn   b) = a === b+    (SetColumn    a) === (SetColumn    b) = a === b+    (MapColumn  a b) === (MapColumn  c d) = a === c && b === d+    (UdtColumn a as) === (UdtColumn b bs) = a == b && checkAll checkField as bs+    (TupleColumn as) === (TupleColumn bs) = checkAll (===) as bs+    a                === b                = a == b  genInstances 48

@@ -5,89 +5,10 @@  import Control.Applicative import Control.Monad-import Data.Functor.Identity-import Data.Serialize-import Data.Vector (Vector, (!?))-import Data.Word-import Database.CQL.Protocol.Class-import Database.CQL.Protocol.Codec (putValue, getValue)-import Database.CQL.Protocol.Types import Language.Haskell.TH import Prelude -import qualified Data.Vector as Vec----------------------------------------------------------------------------------- Row---- | A row is a vector of 'Value's.-data Row = Row-    { types  :: !([ColumnType])-    , values :: !(Vector Value)-    } deriving (Eq, Show)---- | Convert a row element.-fromRow :: Cql a => Int -> Row -> Either String a-fromRow i r =-    case values r !? i of-        Nothing -> Left "out of bounds access"-        Just  v -> fromCql v--mkRow :: [(Value, ColumnType)] -> Row-mkRow xs = let (v, t) = unzip xs in Row t (Vec.fromList v)--rowLength :: Row -> Int-rowLength r = Vec.length (values r)--columnTypes :: Row -> [ColumnType]-columnTypes = types----------------------------------------------------------------------------------- Tuples---- Database.CQL.Protocol.Tuple does not export 'PrivateTuple' but only--- 'Tuple' effectively turning 'Tuple' into a closed type-class.-class PrivateTuple a where-    count :: Tagged a Int-    check :: Tagged a ([ColumnType] -> [ColumnType])-    tuple :: Version -> [ColumnType] -> Get a-    store :: Version -> Putter a--class PrivateTuple a => Tuple a----------------------------------------------------------------------------------- Manual instances--instance PrivateTuple () where-    count     = Tagged 0-    check     = Tagged $ const []-    tuple _ _ = return ()-    store _   = const $ return ()--instance Tuple ()--instance Cql a => PrivateTuple (Identity a) where-    count     = Tagged 1-    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)--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) t-    store v r = do-        put (fromIntegral (rowLength r) :: Word16)-        Vec.mapM_ (putValue v) (values r)--instance Tuple Row----------------------------------------------------------------------------------- Templated instances+-- Templated instances ------------------------------------------------------  genInstances :: Int -> Q [Dec] genInstances n = join <$> mapM tupleInstance [2 .. n]@@ -112,7 +33,7 @@         [ InstanceD ctx (tcon "PrivateTuple" $: tupleType) #endif             [ FunD (mkName "count") [countDecl n]-            , FunD (mkName "check") [checkDecl vnames]+            , FunD (mkName "check") [taggedDecl (var "typecheck") vnames]             , FunD (mkName "tuple") [td]             , FunD (mkName "store") [sd]             ]@@ -128,15 +49,15 @@   where     body = con "Tagged" $$ litInt n --- check = Tagged $---     typecheck [ untag (ctype :: Tagged x ColumnType)---               , untag (ctype :: Tagged y ColumnType)---               , ...---               ])-checkDecl :: [Name] -> Clause-checkDecl names = Clause [] (NormalB body) []+-- Tagged $ ident+--    [ untag (ctype :: Tagged x ColumnType)+--    , untag (ctype :: Tagged y ColumnType)+--    , ...+--    ])+taggedDecl :: Exp -> [Name] -> Clause+taggedDecl ident names = Clause [] (NormalB body) []   where-    body  = con "Tagged" $$ (var "typecheck" $$ ListE (map fn names))+    body  = con "Tagged" $$ (ident $$ ListE (map fn names))     fn n  = var "untag" $$ SigE (var "ctype") (tty n)     tty n = tcon "Tagged" $: VarT n $: tcon "ColumnType" @@ -167,6 +88,73 @@     size         = var "put" $$ SigE (litInt n) (tcon "Word16")     value x v    = var "putValue" $$ VarE x $$ (var "toCql" $$ VarE v) +genCqlInstances :: Int -> Q [Dec]+genCqlInstances n = join <$> mapM cqlInstances [2 .. n]++-- instance (Cql a, Cql b) => Cql (a, b) where+--     ctype = Tagged $ TupleColumn+--         [ untag (ctype :: Tagged a ColumnType)+--         , untag (ctype :: Tagged b ColumnType)+--         ]+--     toCql (a, b) = CqlTuple [toCql a, toCql b]+--     fromCql (CqlTuple [a, b]) = (,) <$> fromCql a <*> fromCql b+--     fromCql _                 = Left "Expected CqlTuple with 2 elements."+cqlInstances :: Int -> Q [Dec]+cqlInstances n = do+    let cql = mkName "Cql"+    vnames <- replicateM n (newName "a")+    let vtypes    = map VarT vnames+    let tupleType = foldl1 ($:) (TupleT n : vtypes)+#if MIN_VERSION_template_haskell(2,10,0)+    let ctx = map (AppT (ConT cql)) vtypes+#else+    let ctx = map (\t -> ClassP cql [t]) vtypes+#endif+    tocql   <- toCqlDecl+    fromcql <- fromCqlDecl+    return+#if MIN_VERSION_template_haskell(2,11,0)+        [ InstanceD Nothing ctx (tcon "Cql" $: tupleType)+#else+        [ InstanceD ctx (tcon "Cql" $: tupleType)+#endif+            [ FunD (mkName "ctype")   [taggedDecl (con "TupleColumn") vnames]+            , FunD (mkName "toCql")   [tocql]+            , FunD (mkName "fromCql") [fromcql]+            ]+        ]+  where+    toCqlDecl = do+        names <- replicateM n (newName "x")+        let tocql nme = var "toCql" $$ VarE nme+        return $ Clause+            [TupP (map VarP names)]+            (NormalB . AppE (con "CqlTuple") $ ListE $ map tocql names)+            []++    fromCqlDecl = do+        names <- replicateM n (newName "x")+        Clause+            [VarP (mkName "t")]+            (NormalB $ CaseE (var "t")+                [ Match (ParensP (ConP (mkName "CqlTuple") [ListP (map VarP names)]))+                        (NormalB $ body names)+                        []+                , Match WildP+                        (NormalB (con "Left" $$ failure))+                        []+                ])+            <$> 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+        combine    = do+            names <- replicateM n (newName "x")+            let f = NormalB $ TupE (map VarE names)+            return [ FunD (mkName "combine") [Clause (map VarP names) f []] ]+        failure = LitE (StringL $ "Expected CqlTuple with " ++ show n ++ " elements")+ ------------------------------------------------------------------------------ -- Helpers @@ -185,27 +173,4 @@  ($:) :: Type -> Type -> Type ($:) = AppT----------------------------------------------------------------------------------- Implementation helpers--element :: Cql a => Version -> Tagged a ColumnType -> Get a-element v t = getValue v (untag t) >>= either fail return . fromCql--typecheck :: [ColumnType] -> [ColumnType] -> [ColumnType]-typecheck rr cc = if checkAll (===) rr cc then [] else rr-  where-    checkAll f as bs = and (zipWith f as bs)--    checkField (a, b) (c, d) = a == c && b === d--    TextColumn       === VarCharColumn    = True-    VarCharColumn    === TextColumn       = True-    (MaybeColumn  a) === b                = a === b-    (ListColumn   a) === (ListColumn   b) = a === b-    (SetColumn    a) === (SetColumn    b) = a === b-    (MapColumn  a b) === (MapColumn  c d) = a === c && b === d-    (UdtColumn a as) === (UdtColumn b bs) = a == b && checkAll checkField as bs-    (TupleColumn as) === (TupleColumn bs) = checkAll (===) as bs-    a                === b                = a == b 

@@ -10,6 +10,8 @@  import qualified Data.ByteString.Lazy as LB import qualified Data.List            as List+import qualified Data.Set             as Set+import qualified Data.Map.Strict      as Map import qualified Data.Text.Lazy       as LT  newtype Keyspace = Keyspace@@ -34,9 +36,9 @@  -- | CQL binary protocol version. data Version-    = V2 -- ^ version 2-    | V3 -- ^ version 3-    deriving (Eq, Show)+    = V3 -- ^ version 3+    | V4 -- ^ version 4+    deriving (Eq, Ord, Show)  -- | The CQL version (not the binary protocol version). data CqlVersion@@ -63,18 +65,20 @@ noCompression = Compression None Just Just  -- | Consistency level.+--+-- See: <https://docs.datastax.com/en/cassandra/latest/cassandra/dml/dmlConfigConsistency.html Consistency> data Consistency     = Any     | One+    | LocalOne     | Two     | Three     | Quorum-    | All     | LocalQuorum-    | EachQuorum-    | Serial-    | LocalOne-    | LocalSerial+    | All+    | EachQuorum  -- ^ Only for write queries.+    | Serial      -- ^ Only for read queries.+    | LocalSerial -- ^ Only for read queries.     deriving (Eq, Show)  -- | An opcode is a tag to distinguish protocol frame bodies.@@ -122,6 +126,10 @@     | MapColumn   !ColumnType !ColumnType     | TupleColumn [ColumnType]     | UdtColumn   !Text [(Text, ColumnType)]+    | DateColumn+    | TimeColumn+    | SmallIntColumn+    | TinyIntColumn     deriving (Eq)  instance Show ColumnType where@@ -142,6 +150,10 @@     show VarIntColumn      = "varint"     show TimeUuidColumn    = "timeuuid"     show InetColumn        = "inet"+    show DateColumn        = "date"+    show TimeColumn        = "time"+    show SmallIntColumn    = "smallint"+    show TinyIntColumn     = "tinyint"     show (MaybeColumn a)   = show a ++ "?"     show (ListColumn a)    = showString "list<" . shows a . showString ">" $ ""     show (SetColumn a)     = showString "set<" . shows a . showString ">" $ ""@@ -165,12 +177,18 @@ newtype Blob     = Blob     { fromBlob     :: LB.ByteString } deriving (Eq, Ord, Show) newtype Counter  = Counter  { fromCounter  :: Int64         } deriving (Eq, Ord, Show) newtype TimeUuid = TimeUuid { fromTimeUuid :: UUID          } deriving (Eq, Ord, Show)-newtype Set a    = Set      { fromSet      :: [a]           } deriving (Show)-newtype Map a b  = Map      { fromMap      :: [(a, b)]      } deriving (Show)+newtype Set a    = Set      { fromSet      :: [a]           } deriving Show+newtype Map a b  = Map      { fromMap      :: [(a, b)]      } deriving Show  instance IsString Ascii where     fromString = Ascii . pack +instance (Eq a, Ord a) => Eq (Set a) where+    a == b = Set.fromList (fromSet a) == Set.fromList (fromSet b)++instance (Eq k, Eq v, Ord k) => Eq (Map k v) where+    a == b = Map.fromList (fromMap a) == Map.fromList (fromMap b)+ -- | A CQL value. The various constructors correspond to CQL data-types for -- individual columns in Cassandra. data Value@@ -194,8 +212,12 @@     | CqlList      [Value]     | CqlSet       [Value]     | CqlMap       [(Value, Value)]-    | CqlTuple     [Value]             -- ^ binary protocol version >= 3-    | CqlUdt       [(Text, Value)]     -- ^ binary protocol version >= 3+    | CqlTuple     [Value]+    | CqlUdt       [(Text, Value)]+    | CqlDate      !Int32+    | CqlTime      !Int64+    | CqlSmallInt  !Int16+    | CqlTinyInt   !Int8     deriving (Eq, Show)  -- | Tag some value with a phantom type.@@ -204,6 +226,10 @@ retag :: Tagged a c -> Tagged b c retag = Tagged . untag +-- | Type tag for read queries, i.e. 'QueryString R a b'. data R+-- | Type tag for write queries, i.e. 'QueryString W a b'. data W+-- | Type tag for schema queries, i.e. 'QueryString S a b'. data S+

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE OverloadedStrings #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -27,9 +28,9 @@  tests :: TestTree tests = testGroup "Codec"-    [ testProperty "V2: getValue . putValue = id" (getPutIdentity V2)-    , testProperty "V3: getValue . putValue = id" (getPutIdentity V3)-    , testProperty "toCql . fromCql = id"     toCqlFromCqlIdentity+    [ 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@@ -37,11 +38,11 @@         ]     ] -getPutIdentity :: Version -> Value -> Property-getPutIdentity v x =-    let t = typeof x-        y = runGet (getValue v t) (runPut (putValue v x))-    in Right x === y+getPutIdentity :: Val v -> Property+getPutIdentity Val{..} =+    let t = typeof value+        x = runGet (getValue version t) (runPut (putValue version value))+    in Right value === x  integralCodec :: Show a => Gen a -> ColumnType -> (a -> Value) -> Property integralCodec g t f = forAll g $ \i ->@@ -51,6 +52,8 @@ toCqlFromCqlIdentity x@(CqlBoolean _)   = (toCql <$> (fromCql x :: Either String Bool))     === Right x toCqlFromCqlIdentity x@(CqlInt _)       = (toCql <$> (fromCql x :: Either String Int32))    === Right x toCqlFromCqlIdentity x@(CqlBigInt _)    = (toCql <$> (fromCql x :: Either String Int64))    === Right x+toCqlFromCqlIdentity x@(CqlSmallInt _)  = (toCql <$> (fromCql x :: Either String Int16))    === Right x+toCqlFromCqlIdentity x@(CqlTinyInt _)   = (toCql <$> (fromCql x :: Either String Int8))     === Right x toCqlFromCqlIdentity x@(CqlFloat _)     = (toCql <$> (fromCql x :: Either String Float))    === Right x toCqlFromCqlIdentity x@(CqlDouble _)    = (toCql <$> (fromCql x :: Either String Double))   === Right x toCqlFromCqlIdentity x@(CqlText _)      = (toCql <$> (fromCql x :: Either String T.Text))   === Right x@@ -69,6 +72,8 @@ typeof (CqlBoolean _)      = BooleanColumn typeof (CqlInt _)          = IntColumn typeof (CqlBigInt _)       = BigIntColumn+typeof (CqlSmallInt _)     = SmallIntColumn+typeof (CqlTinyInt _)      = TinyIntColumn typeof (CqlVarInt _)       = VarIntColumn typeof (CqlFloat _)        = FloatColumn typeof (CqlDecimal _)      = DecimalColumn@@ -81,6 +86,8 @@ typeof (CqlBlob _)         = BlobColumn typeof (CqlCounter _)      = CounterColumn typeof (CqlTimeUuid _)     = TimeUuidColumn+typeof (CqlDate _)         = DateColumn+typeof (CqlTime _)         = TimeColumn typeof (CqlMaybe Nothing)  = MaybeColumn (CustomColumn "a") typeof (CqlMaybe (Just a)) = MaybeColumn (typeof a) typeof (CqlList [])        = ListColumn  (CustomColumn "a")@@ -93,34 +100,70 @@ typeof (CqlTuple x)        = TupleColumn (map typeof x) typeof (CqlUdt   x)        = UdtColumn "" (map (second typeof) x) -instance Arbitrary Value where-    arbitrary = oneof-        [ simple-        , CqlMaybe <$> oneof [Just <$> simple, return Nothing]-        , CqlList  <$> many-        , CqlSet   <$> many-        , CqlMap   <$> (zip <$> many <*> many)+genValue :: Version -> Gen Value+genValue v = sized $ \n ->+    oneof [ gen v n+          , CqlMaybe <$> oneof [Just <$> gen v n, pure Nothing]+          ]+  where+    many   n = gen v (n `div` 2) >>= resize n . listOf  . return+    many1  n = gen v (n `div` 2) >>= resize n . listOf1 . return+    gen V3 n = oneof (v3 n)+    gen V4 n = oneof (v4 n)++    v3 0 = v3Leaf+    v3 n = v3Leaf +++        [ CqlList      <$> many n+        , CqlSet       <$> many n+        , CqlMap       <$> (zip <$> many n <*> many n)+        , CqlTuple     <$> many1 n         ]-      where-        many   = simple >>= listOf . return-        simple = oneof-            [ CqlAscii     <$> arbitrary-            , CqlBigInt    <$> arbitrary-            , CqlBlob      <$> arbitrary-            , CqlBoolean   <$> arbitrary-            , CqlCounter   <$> arbitrary-            , CqlCustom    <$> arbitrary-            , CqlDouble    <$> arbitrary-            , CqlFloat     <$> arbitrary-            , CqlInet      <$> arbitrary-            , CqlInt       <$> arbitrary-            , CqlTimeUuid  <$> arbitrary-            , CqlTimestamp <$> arbitrary-            , CqlUuid      <$> arbitrary-            , CqlText      <$> arbitrary-            , CqlDecimal   <$> arbitrary-            , CqlVarInt    <$> arbitrary-            ]++    v4 0 = v4Leaf ++ v3Leaf+    v4 n = v4Leaf ++ v3 n++    v3Leaf =+        [ CqlAscii     <$> arbitrary+        , CqlBigInt    <$> arbitrary+        , CqlBlob      <$> arbitrary+        , CqlBoolean   <$> arbitrary+        , CqlCounter   <$> arbitrary+        , CqlCustom    <$> arbitrary+        , CqlDouble    <$> arbitrary+        , CqlFloat     <$> arbitrary+        , CqlInet      <$> arbitrary+        , CqlInt       <$> arbitrary+        , CqlTimeUuid  <$> arbitrary+        , CqlTimestamp <$> arbitrary+        , CqlUuid      <$> arbitrary+        , CqlText      <$> arbitrary+        , CqlDecimal   <$> arbitrary+        , CqlVarInt    <$> arbitrary+        ]++    v4Leaf =+        [ CqlTime      <$> arbitrary+        , CqlDate      <$> arbitrary+        , CqlSmallInt  <$> arbitrary+        , CqlTinyInt   <$> arbitrary+        ]++data Val v = Val+    { version :: !Version+    , value   :: !Value+    } deriving Show++data V3+data V4++instance Arbitrary (Val V3) where+    arbitrary = Val V3 <$> genValue V3++instance Arbitrary (Val V4) where+    arbitrary = Val V4 <$> genValue V4++instance Arbitrary Value where+    arbitrary = genValue V4  instance Arbitrary LB.ByteString where     arbitrary = LB.pack <$> arbitrary