diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -2,12 +2,16 @@ ----------- - Toralf Wittner +- Roman S. Borschel Original Authors ---------------- - Toralf Wittner -- Roman S. Borschel +- Roman S. Borschel Contributors ------------ + +- Ewout Van Troostenberghe +- Steve Severance diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/cql.cabal b/cql.cabal --- a/cql.cabal +++ b/cql.cabal @@ -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 +maintainer: Toralf Wittner , + Roman S. Borschel copyright: (C) 2014-2015 Toralf Wittner, Roman S. Borschel homepage: https://gitlab.com/twittner/cql/ bug-reports: https://gitlab.com/twittner/cql/issues @@ -19,9 +20,9 @@ description: Implementation of Cassandra's CQL Binary Protocol - + and - . + . . 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 diff --git a/src/Database/CQL/Protocol.hs b/src/Database/CQL/Protocol.hs --- a/src/Database/CQL/Protocol.hs +++ b/src/Database/CQL/Protocol.hs @@ -105,6 +105,8 @@ -- * Response , Response (..) + , warnings + , traceId , unpack -- ** Ready diff --git a/src/Database/CQL/Protocol/Class.hs b/src/Database/CQL/Protocol/Class.hs --- a/src/Database/CQL/Protocol/Class.hs +++ b/src/Database/CQL/Protocol/Class.hs @@ -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 diff --git a/src/Database/CQL/Protocol/Codec.hs b/src/Database/CQL/Protocol/Codec.hs --- a/src/Database/CQL/Protocol/Codec.hs +++ b/src/Database/CQL/Protocol/Codec.hs @@ -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 diff --git a/src/Database/CQL/Protocol/Header.hs b/src/Database/CQL/Protocol/Header.hs --- a/src/Database/CQL/Protocol/Header.hs +++ b/src/Database/CQL/Protocol/Header.hs @@ -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 diff --git a/src/Database/CQL/Protocol/Request.hs b/src/Database/CQL/Protocol/Request.hs --- a/src/Database/CQL/Protocol/Request.hs +++ b/src/Database/CQL/Protocol/Request.hs @@ -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: 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) diff --git a/src/Database/CQL/Protocol/Response.hs b/src/Database/CQL/Protocol/Response.hs --- a/src/Database/CQL/Protocol/Response.hs +++ b/src/Database/CQL/Protocol/Response.hs @@ -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 diff --git a/src/Database/CQL/Protocol/Tuple.hs b/src/Database/CQL/Protocol/Tuple.hs --- a/src/Database/CQL/Protocol/Tuple.hs +++ b/src/Database/CQL/Protocol/Tuple.hs @@ -1,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 diff --git a/src/Database/CQL/Protocol/Tuple/TH.hs b/src/Database/CQL/Protocol/Tuple/TH.hs --- a/src/Database/CQL/Protocol/Tuple/TH.hs +++ b/src/Database/CQL/Protocol/Tuple/TH.hs @@ -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 diff --git a/src/Database/CQL/Protocol/Types.hs b/src/Database/CQL/Protocol/Types.hs --- a/src/Database/CQL/Protocol/Types.hs +++ b/src/Database/CQL/Protocol/Types.hs @@ -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: 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 + diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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