cql (empty) → 3.0.1

raw patch · 17 files changed

+3153/−0 lines, 17 filesdep +Decimaldep +QuickCheckdep +basesetup-changed

Dependencies added: Decimal, QuickCheck, base, bytestring, cereal, cql, iproute, network, tasty, tasty-quickcheck, template-haskell, text, time, transformers, uuid

Files

• LICENSE +409/−0
• README.md +9/−0
• Setup.hs +2/−0
• cql.cabal +89/−0
• src/Database/CQL/Protocol.hs +152/−0
• src/Database/CQL/Protocol/Class.hs +227/−0
• src/Database/CQL/Protocol/Codec.hs +625/−0
• src/Database/CQL/Protocol/Header.hs +162/−0
• src/Database/CQL/Protocol/Internal.hs +38/−0
• src/Database/CQL/Protocol/Record.hs +117/−0
• src/Database/CQL/Protocol/Request.hs +334/−0
• src/Database/CQL/Protocol/Response.hs +431/−0
• src/Database/CQL/Protocol/Tuple.hs +27/−0
• src/Database/CQL/Protocol/Tuple/TH.hs +153/−0
• src/Database/CQL/Protocol/Types.hs +215/−0
• test/Main.hs +11/−0
• test/Tests.hs +152/−0

@@ -0,0 +1,409 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+    means each individual or legal entity that creates, contributes to+    the creation of, or owns Covered Software.++1.2. "Contributor Version"+    means the combination of the Contributions of others (if any) used+    by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+    means Covered Software of a particular Contributor.++1.4. "Covered Software"+    means Source Code Form to which the initial Contributor has attached+    the notice in Exhibit A, the Executable Form of such Source Code+    Form, and Modifications of such Source Code Form, in each case+    including portions thereof.++1.5. "Incompatible With Secondary Licenses"+    means++    (a) that the initial Contributor has attached the notice described+        in Exhibit B to the Covered Software; or++    (b) that the Covered Software was made available under the terms of+        version 1.1 or earlier of the License, but not also under the+        terms of a Secondary License.++1.6. "Executable Form"+    means any form of the work other than Source Code Form.++1.7. "Larger Work"+    means a work that combines Covered Software with other material, in+    a separate file or files, that is not Covered Software.++1.8. "License"+    means this document.++1.9. "Licensable"+    means having the right to grant, to the maximum extent possible,+    whether at the time of the initial grant or subsequently, any and+    all of the rights conveyed by this License.++1.10. "Modifications"+    means any of the following:++    (a) any file in Source Code Form that results from an addition to,+        deletion from, or modification of the contents of Covered+        Software; or++    (b) any new file in Source Code Form that contains any Covered+        Software.++1.11. "Patent Claims" of a Contributor+    means any patent claim(s), including without limitation, method,+    process, and apparatus claims, in any patent Licensable by such+    Contributor that would be infringed, but for the grant of the+    License, by the making, using, selling, offering for sale, having+    made, import, or transfer of either its Contributions or its+    Contributor Version.++1.12. "Secondary License"+    means either the GNU General Public License, Version 2.0, the GNU+    Lesser General Public License, Version 2.1, the GNU Affero General+    Public License, Version 3.0, or any later versions of those+    licenses.++1.13. "Source Code Form"+    means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+    means an individual or a legal entity exercising rights under this+    License. For legal entities, "You" includes any entity that+    controls, is controlled by, or is under common control with You. For+    purposes of this definition, "control" means (a) the power, direct+    or indirect, to cause the direction or management of such entity,+    whether by contract or otherwise, or (b) ownership of more than+    fifty percent (50%) of the outstanding shares or beneficial+    ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+    Licensable by such Contributor to use, reproduce, make available,+    modify, display, perform, distribute, and otherwise exploit its+    Contributions, either on an unmodified basis, with Modifications, or+    as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+    for sale, have made, import, and otherwise transfer either its+    Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+    or++(b) for infringements caused by: (i) Your and any other third party's+    modifications of Covered Software, or (ii) the combination of its+    Contributions with other software (except as part of its Contributor+    Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+    its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+    Form, as described in Section 3.1, and You must inform recipients of+    the Executable Form how they can obtain a copy of such Source Code+    Form by reasonable means in a timely manner, at a charge no more+    than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+    License, or sublicense it under different terms, provided that the+    license for the Executable Form does not attempt to limit or alter+    the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+*                                                                      *+*  6. Disclaimer of Warranty                                           *+*  -------------------------                                           *+*                                                                      *+*  Covered Software is provided under this License on an "as is"       *+*  basis, without warranty of any kind, either expressed, implied, or  *+*  statutory, including, without limitation, warranties that the       *+*  Covered Software is free of defects, merchantable, fit for a        *+*  particular purpose or non-infringing. The entire risk as to the     *+*  quality and performance of the Covered Software is with You.        *+*  Should any Covered Software prove defective in any respect, You     *+*  (not any Contributor) assume the cost of any necessary servicing,   *+*  repair, or correction. This disclaimer of warranty constitutes an   *+*  essential part of this License. No use of any Covered Software is   *+*  authorized under this License except under this disclaimer.         *+*                                                                      *+************************************************************************++************************************************************************+*                                                                      *+*  7. Limitation of Liability                                          *+*  --------------------------                                          *+*                                                                      *+*  Under no circumstances and under no legal theory, whether tort      *+*  (including negligence), contract, or otherwise, shall any           *+*  Contributor, or anyone who distributes Covered Software as          *+*  permitted above, be liable to You for any direct, indirect,         *+*  special, incidental, or consequential damages of any character      *+*  including, without limitation, damages for lost profits, loss of    *+*  goodwill, work stoppage, computer failure or malfunction, or any    *+*  and all other commercial damages or losses, even if such party      *+*  shall have been informed of the possibility of such damages. This   *+*  limitation of liability shall not apply to liability for death or   *+*  personal injury resulting from such party's negligence to the       *+*  extent applicable law prohibits such limitation. Some               *+*  jurisdictions do not allow the exclusion or limitation of           *+*  incidental or consequential damages, so this exclusion and          *+*  limitation may not apply to You.                                    *+*                                                                      *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++  This Source Code Form is subject to the terms of the Mozilla Public+  License, v. 2.0. If a copy of the MPL was not distributed with this+  file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++  This Source Code Form is "Incompatible With Secondary Licenses", as+  defined by the Mozilla Public License, v. 2.0.++=============================================================================++Cereal License++Copyright (c) Lennart Kolmodin, Galois, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+

@@ -0,0 +1,9 @@+CQL Binary Protocol Implementation+==================================++This Haskell library implements Cassandra's CQL Binary Protocol [Version 2][1]+and [Version 3][2]. It provides encoding and decoding functionality as well as+representations of the various protocol related types.++[1]: https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v2.spec+[2]: https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v3.spec

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,89 @@+name:                 cql+version:              3.0.1+synopsis:             Cassandra CQL binary protocol.+stability:            experimental+license:              OtherLicense+license-file:         LICENSE+author:               Toralf Wittner, Roman S. Borschel+maintainer:           Toralf Wittner <tw@dtex.org>+copyright:            2014 Toralf Wittner, Roman S. Borschel+homepage:             https://github.com/twittner/cql/+bug-reports:          https://github.com/twittner/cql/issues+category:             Database+build-type:           Simple+cabal-version:        >= 1.10+extra-source-files:   README.md++description:+    Implementation of Cassandra's CQL Binary Protocol+    <https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v2.spec Version 2>+    and+    <https://github.com/apache/cassandra/blob/trunk/doc/native_protocol_v3.spec Version 3>.+    .+    It provides encoding and decoding functionality as well as representations+    of the various protocol related types.+    .+    Thus it can serve as a building block for writing Cassandra drivers, such+    as <http://hackage.haskell.org/package/cql-io cql-io>.++source-repository head+    type:             git+    location:         git@github.com:twittner/cql.git++library+    default-language: Haskell2010+    hs-source-dirs:   src+    ghc-options:      -Wall -O2 -fwarn-tabs -funbox-strict-fields+    ghc-prof-options: -prof -auto-all++    exposed-modules:+        Database.CQL.Protocol+        Database.CQL.Protocol.Internal++    other-modules:+        Database.CQL.Protocol.Class+        Database.CQL.Protocol.Codec+        Database.CQL.Protocol.Record+        Database.CQL.Protocol.Tuple+        Database.CQL.Protocol.Tuple.TH+        Database.CQL.Protocol.Types+        Database.CQL.Protocol.Header+        Database.CQL.Protocol.Request+        Database.CQL.Protocol.Response++    build-depends:+          base             >= 4.5    && < 5.0+        , bytestring       >= 0.10   && < 1.0+        , cereal           >= 0.3    && < 0.5+        , Decimal          >= 0.3    && < 1.0+        , iproute          >= 1.3    && < 1.4+        , network          >= 2.4    && < 3.0+        , text             >= 0.11   && < 2.0+        , template-haskell+        , time             >= 1.4    && < 2.0+        , transformers     >= 0.3    && < 0.5+        , uuid             >= 1.2.6  && < 2.0++test-suite cql-tests+    type:             exitcode-stdio-1.0+    default-language: Haskell2010+    main-is:          Main.hs+    hs-source-dirs:   test+    ghc-options:      -threaded -Wall -O2 -fwarn-tabs+    other-modules:    Tests++    build-depends:+          base+        , bytestring+        , cereal+        , cql+        , Decimal+        , iproute+        , network+        , QuickCheck+        , tasty            >= 0.8+        , tasty-quickcheck >= 0.8+        , text+        , time+        , uuid+

@@ -0,0 +1,152 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++-- | The CQL native protocol is a binary frame-based protocol where+-- each frame has a 'Header', a 'Length' and a body. The protocol+-- distinguishes 'Request's and 'Response's.+--+-- Some usage examples:+--+-- __Constructing and Serialising a Request__+--+-- @+-- let q = QueryString "select peer from system.peers where data_center = ? and rack = ?"+--     p = QueryParams One False ("uk-1", "r-0") Nothing Nothing Nothing+--     r = RqQuery (Query q p :: Query R (Text, Text) (Identity IP))+--     i = mkStreamId 0+-- in pack V3 noCompression False i r+-- @+--+-- __Deserialising a Response__+--+-- @+-- -- assuming 'bh' contains the raw header byte string and 'bb' the raw+-- -- body byte string.+-- case header V3 bh of+--     Left  e -> ...+--     Right h -> unpack noCompression h bb+-- @+--+-- __A generic query processing function__+--+-- @+-- query :: (Tuple a, Tuple b) => Version -> Socket -> QueryString k a b -> QueryParams a -> IO (Response k a b)+-- query v s q p = do+--     let i = mkStreamId 0+--     sendToServer s (pack v noCompression False i (RqQuery (Query q p)))+--     b <- recv (if v == V3 then 9 else 8) s+--     h <- either (throwIO . MyException) return (header v b)+--     when (headerType h == RqHeader) $+--         throwIO UnexpectedRequestHeader+--     let len = lengthRepr (bodyLength h)+--     x <- recv (fromIntegral len) s+--     case unpack noCompression h x of+--         Left e              -> throwIO $ AnotherException e+--         Right (RsError _ e) -> throwIO e+--         Right response      -> return response+-- @+--+module Database.CQL.Protocol+    ( -- * Cql type-class+      Cql (..)++      -- * Basic type definitions+    , module Database.CQL.Protocol.Types++      -- * Header+    , Header     (..)+    , HeaderType (..)+    , header++      -- ** Length+    , Length (..)++      -- ** StreamId+    , StreamId+    , mkStreamId+    , fromStreamId++      -- ** Flags+    , Flags+    , compress+    , tracing+    , isSet++      -- * Request+    , Request (..)+    , getOpCode+    , pack++      -- ** Options+    , Options (..)++      -- ** Startup+    , Startup (..)++      -- ** Auth Response+    , AuthResponse (..)++      -- ** Register+    , Register  (..)+    , EventType (..)++      -- ** Query+    , Query             (..)+    , QueryParams       (..)+    , SerialConsistency (..)++      -- ** Batch+    , Batch      (..)+    , BatchQuery (..)+    , BatchType  (..)++      -- ** Prepare+    , Prepare (..)++      -- ** Execute+    , Execute (..)++      -- * Response+    , Response (..)+    , unpack++      -- ** Ready+    , Ready (..)++      -- ** Authenticate+    , Authenticate  (..)+    , AuthChallenge (..)+    , AuthSuccess   (..)++      -- ** Result+    , Result     (..)+    , MetaData   (..)+    , ColumnSpec (..)++      -- ** Supported+    , Supported  (..)++      -- ** Event+    , Event          (..)+    , TopologyChange (..)+    , SchemaChange   (..)+    , StatusChange   (..)+    , Change         (..)++      -- ** Error+    , Error     (..)+    , WriteType (..)++      -- * Tuple and Record+    , module Database.CQL.Protocol.Tuple+    , module Database.CQL.Protocol.Record+    ) where++import Database.CQL.Protocol.Class+import Database.CQL.Protocol.Header+import Database.CQL.Protocol.Record+import Database.CQL.Protocol.Request+import Database.CQL.Protocol.Response+import Database.CQL.Protocol.Tuple+import Database.CQL.Protocol.Types

@@ -0,0 +1,227 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Database.CQL.Protocol.Class (Cql (..)) where++import Control.Applicative+import Control.Arrow+import Data.Decimal+import Data.Int+import Data.IP+import Data.Text (Text)+import Data.Time+import Data.Time.Clock.POSIX+import Data.UUID (UUID)+import Database.CQL.Protocol.Types++-- | 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.+-- For example:+--+-- @+-- newtype MyType = MyType Int32+--+-- instance Cql MyType where+--     ctype              = Tagged IntColumn+--     toCql (MyType i)   = CqlInt i+--     fromCql (CqlInt i) = Right (MyType i)+--     fromCql _          = Left "Expected CqlInt"+-- @+class Cql a where+    -- | the column-type of @a@+    ctype :: Tagged a ColumnType+    -- | map @a@ to some CQL data-type+    toCql :: a -> Value+    -- | map a CQL value back to @a@+    fromCql :: Value -> Either String a++------------------------------------------------------------------------------+-- Bool++instance Cql Bool where+    ctype = Tagged BooleanColumn+    toCql = CqlBoolean+    fromCql (CqlBoolean b) = Right b+    fromCql _              = Left "Expected CqlBoolean."++------------------------------------------------------------------------------+-- Int32++instance Cql Int32 where+    ctype = Tagged IntColumn+    toCql = CqlInt+    fromCql (CqlInt i) = Right i+    fromCql _          = Left "Expected CqlInt."++------------------------------------------------------------------------------+-- Int64++instance Cql Int64 where+    ctype = Tagged BigIntColumn+    toCql = CqlBigInt+    fromCql (CqlBigInt i) = Right i+    fromCql _             = Left "Expected CqlBigInt."++------------------------------------------------------------------------------+-- Integer++instance Cql Integer where+    ctype = Tagged VarIntColumn+    toCql = CqlVarInt+    fromCql (CqlVarInt i) = Right i+    fromCql _             = Left "Expected CqlVarInt."++------------------------------------------------------------------------------+-- Float++instance Cql Float where+    ctype = Tagged FloatColumn+    toCql = CqlFloat+    fromCql (CqlFloat f) = Right f+    fromCql _            = Left "Expected CqlFloat."++------------------------------------------------------------------------------+-- Double++instance Cql Double where+    ctype = Tagged DoubleColumn+    toCql = CqlDouble+    fromCql (CqlDouble d) = Right d+    fromCql _             = Left "Expected CqlDouble."++------------------------------------------------------------------------------+-- Decimal++instance Cql Decimal where+    ctype = Tagged DecimalColumn+    toCql = CqlDecimal+    fromCql (CqlDecimal d) = Right d+    fromCql _              = Left "Expected CqlDecimal."++------------------------------------------------------------------------------+-- Text++instance Cql Text where+    ctype = Tagged TextColumn+    toCql = CqlText+    fromCql (CqlText s) = Right s+    fromCql _           = Left "Expected CqlText."++------------------------------------------------------------------------------+-- Ascii++instance Cql Ascii where+    ctype = Tagged AsciiColumn+    toCql (Ascii a) = CqlAscii a+    fromCql (CqlAscii a) = Right $ Ascii a+    fromCql _            = Left "Expected CqlAscii."++------------------------------------------------------------------------------+-- IP Address++instance Cql IP where+    ctype = Tagged InetColumn+    toCql = CqlInet+    fromCql (CqlInet i) = Right i+    fromCql _           = Left "Expected CqlInet."++------------------------------------------------------------------------------+-- UUID++instance Cql UUID where+    ctype = Tagged UuidColumn+    toCql = CqlUuid+    fromCql (CqlUuid u) = Right u+    fromCql _           = Left "Expected CqlUuid."++------------------------------------------------------------------------------+-- UTCTime++instance Cql UTCTime where+    ctype = Tagged TimestampColumn++    toCql = CqlTimestamp+          . truncate+          . (* 1000)+          . utcTimeToPOSIXSeconds++    fromCql (CqlTimestamp t) =+        let (s, ms)     = t `divMod` 1000+            UTCTime a b = posixSecondsToUTCTime (fromIntegral s)+            ps          = fromIntegral ms * 1000000000+        in Right $ UTCTime a (b + picosecondsToDiffTime ps)+    fromCql _                = Left "Expected CqlTimestamp."++------------------------------------------------------------------------------+-- Blob++instance Cql Blob where+    ctype = Tagged BlobColumn+    toCql (Blob b) = CqlBlob b+    fromCql (CqlBlob b) = Right $ Blob b+    fromCql _           = Left "Expected CqlBlob."++------------------------------------------------------------------------------+-- Counter++instance Cql Counter where+    ctype = Tagged CounterColumn+    toCql (Counter c) = CqlCounter c+    fromCql (CqlCounter c) = Right $ Counter c+    fromCql _              = Left "Expected CqlCounter."++------------------------------------------------------------------------------+-- TimeUuid++instance Cql TimeUuid where+    ctype = Tagged TimeUuidColumn+    toCql (TimeUuid u) = CqlTimeUuid u+    fromCql (CqlTimeUuid t) = Right $ TimeUuid t+    fromCql _               = Left "Expected TimeUuid."++------------------------------------------------------------------------------+-- [a]++instance Cql a => Cql [a] where+    ctype = Tagged (ListColumn (untag (ctype :: Tagged a ColumnType)))+    toCql = CqlList . map toCql+    fromCql (CqlList l) = mapM fromCql l+    fromCql _           = Left "Expected CqlList."++------------------------------------------------------------------------------+-- Maybe a++-- | Please note that due to the fact that Cassandra internally represents+-- empty collection type values (i.e. lists, maps and sets) as @null@, we+-- can not distinguish @Just []@ from @Nothing@ on response decoding.+instance Cql a => Cql (Maybe a) where+    ctype = Tagged (MaybeColumn (untag (ctype :: Tagged a ColumnType)))+    toCql = CqlMaybe . fmap toCql+    fromCql (CqlMaybe (Just m)) = Just <$> fromCql m+    fromCql (CqlMaybe Nothing)  = Right Nothing+    fromCql _                   = Left "Expected CqlMaybe."++------------------------------------------------------------------------------+-- Map a b++instance (Cql a, Cql b) => Cql (Map a b) where+    ctype = Tagged $ MapColumn+        (untag (ctype :: Tagged a ColumnType))+        (untag (ctype :: Tagged b ColumnType))+    toCql (Map m)      = CqlMap $ map (toCql *** toCql) m+    fromCql (CqlMap m) = Map <$> mapM (\(k, v) -> (,) <$> fromCql k <*> fromCql v) m+    fromCql _          = Left "Expected CqlMap."++------------------------------------------------------------------------------+-- Set a++instance Cql a => Cql (Set a) where+    ctype = Tagged (SetColumn (untag (ctype :: Tagged a ColumnType)))+    toCql (Set a) = CqlSet $ map toCql a+    fromCql (CqlSet a) = Set <$> mapM fromCql a+    fromCql _          = Left "Expected CqlSet."

@@ -0,0 +1,625 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++module Database.CQL.Protocol.Codec+    ( encodeByte+    , decodeByte++    , encodeSignedByte+    , decodeSignedByte++    , encodeShort+    , decodeShort++    , encodeSignedShort+    , decodeSignedShort++    , encodeInt+    , decodeInt++    , encodeString+    , decodeString++    , encodeLongString+    , decodeLongString++    , encodeBytes+    , decodeBytes++    , encodeShortBytes+    , decodeShortBytes++    , encodeUUID+    , decodeUUID++    , encodeList+    , decodeList++    , encodeMap+    , decodeMap++    , encodeMultiMap+    , decodeMultiMap++    , encodeSockAddr+    , decodeSockAddr++    , encodeConsistency+    , decodeConsistency++    , encodeOpCode+    , decodeOpCode++    , encodeColumnType+    , decodeColumnType++    , encodePagingState+    , decodePagingState++    , decodeKeyspace+    , decodeTable+    , decodeQueryId++    , putValue+    , getValue+    ) where++import Control.Applicative+import Control.Monad+import Data.Bits+import Data.ByteString (ByteString)+import Data.Decimal+import Data.Int+import Data.IP+import Data.List (unfoldr)+import Data.Text (Text)+import Data.UUID (UUID)+import Data.Word+import Data.Serialize hiding (decode, encode)+import Database.CQL.Protocol.Types+import Network.Socket (SockAddr (..), PortNumber (..))++import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as LB+import qualified Data.Text.Encoding      as T+import qualified Data.Text.Lazy          as LT+import qualified Data.Text.Lazy.Encoding as LT+import qualified Data.UUID               as UUID++------------------------------------------------------------------------------+-- Byte++encodeByte :: Putter Word8+encodeByte = put++decodeByte :: Get Word8+decodeByte = get++------------------------------------------------------------------------------+-- Signed Byte++encodeSignedByte :: Putter Int8+encodeSignedByte = put++decodeSignedByte :: Get Int8+decodeSignedByte = get++------------------------------------------------------------------------------+-- Short++encodeShort :: Putter Word16+encodeShort = put++decodeShort :: Get Word16+decodeShort = get++------------------------------------------------------------------------------+-- Signed Short++encodeSignedShort :: Putter Int16+encodeSignedShort = put++decodeSignedShort :: Get Int16+decodeSignedShort = get++------------------------------------------------------------------------------+-- Int++encodeInt :: Putter Int32+encodeInt = put++decodeInt :: Get Int32+decodeInt = get++------------------------------------------------------------------------------+-- String++encodeString :: Putter Text+encodeString = encodeShortBytes . T.encodeUtf8++decodeString :: Get Text+decodeString = T.decodeUtf8 <$> decodeShortBytes++------------------------------------------------------------------------------+-- Long String++encodeLongString :: Putter LT.Text+encodeLongString = encodeBytes . LT.encodeUtf8++decodeLongString :: Get LT.Text+decodeLongString = do+    n <- get :: Get Int32+    LT.decodeUtf8 <$> getLazyByteString (fromIntegral n)++------------------------------------------------------------------------------+-- Bytes++encodeBytes :: Putter LB.ByteString+encodeBytes bs = do+    put (fromIntegral (LB.length bs) :: Int32)+    putLazyByteString bs++decodeBytes :: Get (Maybe LB.ByteString)+decodeBytes = do+    n <- get :: Get Int32+    if n < 0+        then return Nothing+        else Just <$> getLazyByteString (fromIntegral n)++------------------------------------------------------------------------------+-- Short Bytes++encodeShortBytes :: Putter ByteString+encodeShortBytes bs = do+    put (fromIntegral (B.length bs) :: Word16)+    putByteString bs++decodeShortBytes :: Get ByteString+decodeShortBytes = do+    n <- get :: Get Word16+    getByteString (fromIntegral n)++------------------------------------------------------------------------------+-- UUID++encodeUUID :: Putter UUID+encodeUUID = putLazyByteString . UUID.toByteString++decodeUUID :: Get UUID+decodeUUID = do+    uuid <- UUID.fromByteString <$> getLazyByteString 16+    maybe (fail "decode-uuid: invalid") return uuid++------------------------------------------------------------------------------+-- String List++encodeList :: Putter [Text]+encodeList sl = do+    put (fromIntegral (length sl) :: Word16)+    mapM_ encodeString sl++decodeList :: Get [Text]+decodeList = do+    n <- get :: Get Word16+    replicateM (fromIntegral n) decodeString++------------------------------------------------------------------------------+-- String Map++encodeMap :: Putter [(Text, Text)]+encodeMap m = do+    put (fromIntegral (length m) :: Word16)+    forM_ m $ \(k, v) -> encodeString k >> encodeString v++decodeMap :: Get [(Text, Text)]+decodeMap = do+    n <- get :: Get Word16+    replicateM (fromIntegral n) ((,) <$> decodeString <*> decodeString)++------------------------------------------------------------------------------+-- String Multi-Map++encodeMultiMap :: Putter [(Text, [Text])]+encodeMultiMap mm = do+    put (fromIntegral (length mm) :: Word16)+    forM_ mm $ \(k, v) -> encodeString k >> encodeList v++decodeMultiMap :: Get [(Text, [Text])]+decodeMultiMap = do+    n <- get :: Get Word16+    replicateM (fromIntegral n) ((,) <$> decodeString <*> decodeList)++------------------------------------------------------------------------------+-- Inet Address++encodeSockAddr :: Putter SockAddr+encodeSockAddr (SockAddrInet p a) = do+    putWord8 4+    putWord32le a+    putWord32be (fromIntegral p)+encodeSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do+    putWord8 16+    putWord32host a+    putWord32host b+    putWord32host c+    putWord32host d+    putWord32be (fromIntegral p)+encodeSockAddr (SockAddrUnix _) = fail "encode-socket: unix address not allowed"++decodeSockAddr :: Get SockAddr+decodeSockAddr = do+    n <- getWord8+    case n of+        4  -> do+            i <- getIPv4+            p <- getPort+            return $ SockAddrInet p i+        16 -> do+            i <- getIPv6+            p <- getPort+            return $ SockAddrInet6 p 0 i 0+        _  -> fail $ "decode-socket: unknown: " ++ show n+  where+    getPort :: Get PortNumber+    getPort = fromIntegral <$> getWord32be++    getIPv4 :: Get Word32+    getIPv4 = getWord32le++    getIPv6 :: Get (Word32, Word32, Word32, Word32)+    getIPv6 = (,,,) <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host++------------------------------------------------------------------------------+-- Consistency++encodeConsistency :: Putter Consistency+encodeConsistency Any         = encodeShort 0x00+encodeConsistency One         = encodeShort 0x01+encodeConsistency Two         = encodeShort 0x02+encodeConsistency Three       = encodeShort 0x03+encodeConsistency Quorum      = encodeShort 0x04+encodeConsistency All         = encodeShort 0x05+encodeConsistency LocalQuorum = encodeShort 0x06+encodeConsistency EachQuorum  = encodeShort 0x07+encodeConsistency Serial      = encodeShort 0x08+encodeConsistency LocalSerial = encodeShort 0x09+encodeConsistency LocalOne    = encodeShort 0x0A++decodeConsistency :: Get Consistency+decodeConsistency = decodeShort >>= mapCode+      where+        mapCode 0x00 = return Any+        mapCode 0x01 = return One+        mapCode 0x02 = return Two+        mapCode 0x03 = return Three+        mapCode 0x04 = return Quorum+        mapCode 0x05 = return All+        mapCode 0x06 = return LocalQuorum+        mapCode 0x07 = return EachQuorum+        mapCode 0x08 = return Serial+        mapCode 0x09 = return LocalSerial+        mapCode 0x10 = return LocalOne+        mapCode code = fail $ "decode-consistency: unknown: " ++ show code++------------------------------------------------------------------------------+-- OpCode++encodeOpCode :: Putter OpCode+encodeOpCode OcError         = encodeByte 0x00+encodeOpCode OcStartup       = encodeByte 0x01+encodeOpCode OcReady         = encodeByte 0x02+encodeOpCode OcAuthenticate  = encodeByte 0x03+encodeOpCode OcOptions       = encodeByte 0x05+encodeOpCode OcSupported     = encodeByte 0x06+encodeOpCode OcQuery         = encodeByte 0x07+encodeOpCode OcResult        = encodeByte 0x08+encodeOpCode OcPrepare       = encodeByte 0x09+encodeOpCode OcExecute       = encodeByte 0x0A+encodeOpCode OcRegister      = encodeByte 0x0B+encodeOpCode OcEvent         = encodeByte 0x0C+encodeOpCode OcBatch         = encodeByte 0x0D+encodeOpCode OcAuthChallenge = encodeByte 0x0E+encodeOpCode OcAuthResponse  = encodeByte 0x0F+encodeOpCode OcAuthSuccess   = encodeByte 0x10++decodeOpCode :: Get OpCode+decodeOpCode = decodeByte >>= mapCode+  where+    mapCode 0x00 = return OcError+    mapCode 0x01 = return OcStartup+    mapCode 0x02 = return OcReady+    mapCode 0x03 = return OcAuthenticate+    mapCode 0x05 = return OcOptions+    mapCode 0x06 = return OcSupported+    mapCode 0x07 = return OcQuery+    mapCode 0x08 = return OcResult+    mapCode 0x09 = return OcPrepare+    mapCode 0x0A = return OcExecute+    mapCode 0x0B = return OcRegister+    mapCode 0x0C = return OcEvent+    mapCode 0x0D = return OcBatch+    mapCode 0x0E = return OcAuthChallenge+    mapCode 0x0F = return OcAuthResponse+    mapCode 0x10 = return OcAuthSuccess+    mapCode word = fail $ "decode-opcode: unknown: " ++ show word++------------------------------------------------------------------------------+-- ColumnType++encodeColumnType :: Putter ColumnType+encodeColumnType (CustomColumn x)   = encodeShort 0x0000 >> encodeString x+encodeColumnType AsciiColumn        = encodeShort 0x0001+encodeColumnType BigIntColumn       = encodeShort 0x0002+encodeColumnType BlobColumn         = encodeShort 0x0003+encodeColumnType BooleanColumn      = encodeShort 0x0004+encodeColumnType CounterColumn      = encodeShort 0x0005+encodeColumnType DecimalColumn      = encodeShort 0x0006+encodeColumnType DoubleColumn       = encodeShort 0x0007+encodeColumnType FloatColumn        = encodeShort 0x0008+encodeColumnType IntColumn          = encodeShort 0x0009+encodeColumnType TextColumn         = encodeShort 0x000A+encodeColumnType TimestampColumn    = encodeShort 0x000B+encodeColumnType UuidColumn         = encodeShort 0x000C+encodeColumnType VarCharColumn      = encodeShort 0x000D+encodeColumnType VarIntColumn       = encodeShort 0x000E+encodeColumnType TimeUuidColumn     = encodeShort 0x000F+encodeColumnType InetColumn         = encodeShort 0x0010+encodeColumnType (MaybeColumn x)    = encodeColumnType x+encodeColumnType (ListColumn x)     = encodeShort 0x0020 >> encodeColumnType x+encodeColumnType (MapColumn  x y)   = encodeShort 0x0021 >> encodeColumnType x >> encodeColumnType y+encodeColumnType (SetColumn  x)     = encodeShort 0x0022 >> encodeColumnType x+encodeColumnType (TupleColumn xs)   = encodeShort 0x0031 >> mapM_ encodeColumnType xs+encodeColumnType (UdtColumn k n xs) = do+    encodeShort 0x0030+    encodeString (unKeyspace k)+    encodeString n+    encodeShort (fromIntegral (length xs))+    forM_ xs $ \(x, t) -> encodeString x >> encodeColumnType t++decodeColumnType :: Get ColumnType+decodeColumnType = decodeShort >>= toType+  where+    toType 0x0000 = CustomColumn <$> decodeString+    toType 0x0001 = return AsciiColumn+    toType 0x0002 = return BigIntColumn+    toType 0x0003 = return BlobColumn+    toType 0x0004 = return BooleanColumn+    toType 0x0005 = return CounterColumn+    toType 0x0006 = return DecimalColumn+    toType 0x0007 = return DoubleColumn+    toType 0x0008 = return FloatColumn+    toType 0x0009 = return IntColumn+    toType 0x000A = return TextColumn+    toType 0x000B = return TimestampColumn+    toType 0x000C = return UuidColumn+    toType 0x000D = return VarCharColumn+    toType 0x000E = return VarIntColumn+    toType 0x000F = return TimeUuidColumn+    toType 0x0010 = return InetColumn+    toType 0x0020 = ListColumn  <$> (decodeShort >>= toType)+    toType 0x0021 = MapColumn   <$> (decodeShort >>= toType) <*> (decodeShort >>= toType)+    toType 0x0022 = SetColumn   <$> (decodeShort >>= toType)+    toType 0x0030 = UdtColumn   <$> (Keyspace <$> decodeString) <*> decodeString <*> do+        n <- fromIntegral <$> decodeShort+        replicateM n ((,) <$> decodeString <*> (decodeShort >>= toType))+    toType 0x0031 = TupleColumn <$> do+        n <- fromIntegral <$> decodeShort+        replicateM n (decodeShort >>= toType)+    toType other  = fail $ "decode-type: unknown: " ++ show other++------------------------------------------------------------------------------+-- Paging State++encodePagingState :: Putter PagingState+encodePagingState (PagingState s) = encodeBytes s++decodePagingState :: Get (Maybe PagingState)+decodePagingState = liftM PagingState <$> decodeBytes++------------------------------------------------------------------------------+-- Value++putValue :: Version -> Putter Value+putValue V3 (CqlList x)        = toBytes 4 $ do+    encodeInt (fromIntegral (length x))+    mapM_ (toBytes 4 . putNative) x+putValue V2 (CqlList x)        = toBytes 4 $ do+    encodeShort (fromIntegral (length x))+    mapM_ (toBytes 2 . putNative) x+putValue V3 (CqlSet x)         = toBytes 4 $ do+    encodeInt (fromIntegral (length x))+    mapM_ (toBytes 4 . putNative) x+putValue V2 (CqlSet x)         = toBytes 4 $ do+    encodeShort (fromIntegral (length x))+    mapM_ (toBytes 2 . putNative) x+putValue V3 (CqlMap x)         = toBytes 4 $ do+    encodeInt (fromIntegral (length x))+    forM_ x $ \(k, v) -> toBytes 4 (putNative k) >> toBytes 4 (putNative v)+putValue V2 (CqlMap x)         = toBytes 4 $ do+    encodeShort (fromIntegral (length x))+    forM_ x $ \(k, v) -> toBytes 2 (putNative k) >> toBytes 2 (putNative v)+putValue V3 (CqlTuple x)       = mapM_ (toBytes 4 . putValue V3) x+putValue V3 (CqlUdt x)         = mapM_ (toBytes 4 . putValue V3 . snd) x+putValue _ (CqlMaybe Nothing)  = put (-1 :: Int32)+putValue v (CqlMaybe (Just x)) = putValue v x+putValue _ value               = toBytes 4 $ putNative value++putNative :: 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+    IPv4 i -> putWord32le (toHostAddress i)+    IPv6 i -> do+        let (a, b, c, d) = toHostAddress6 i+        putWord32host a+        putWord32host b+        putWord32host c+        putWord32host d+putNative (CqlVarInt x)    = integer2bytes x+putNative (CqlDecimal x)   = do+    put (fromIntegral (decimalPlaces x) :: Int32)+    integer2bytes (decimalMantissa x)+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+putNative v@(CqlUdt   _)   = fail $ "putNative: UDT: " ++ show v++-- Note: Empty lists, maps and sets are represented as null in cassandra.+getValue :: Version -> ColumnType -> Get Value+getValue V3 (ListColumn t)    = CqlList <$> (getList $ do+    len <- decodeInt+    replicateM (fromIntegral len) (withBytes 4 (getNative t)))+getValue V2 (ListColumn t)    = CqlList <$> (getList $ do+    len <- decodeShort+    replicateM (fromIntegral len) (withBytes 2 (getNative t)))+getValue V3 (SetColumn t)     = CqlSet <$> (getList $ do+    len <- decodeInt+    replicateM (fromIntegral len) (withBytes 4 (getNative t)))+getValue V2 (SetColumn t)     = CqlSet <$> (getList $ do+    len <- decodeShort+    replicateM (fromIntegral len) (withBytes 2 (getNative t)))+getValue V3 (MapColumn t u)   = CqlMap <$> (getList $ do+    len <- decodeInt+    replicateM (fromIntegral len)+               ((,) <$> withBytes 4 (getNative t) <*> withBytes 4 (getNative u)))+getValue V2 (MapColumn t u)   = CqlMap <$> (getList $ do+    len <- decodeShort+    replicateM (fromIntegral len)+               ((,) <$> withBytes 2 (getNative t) <*> withBytes 2 (getNative u)))+getValue V3 (TupleColumn t)   = CqlTuple <$> mapM (getValue V3) t+getValue V3 (UdtColumn _ _ x) = CqlUdt <$> do+    let (n, t) = unzip x+    zip n <$> mapM (getValue V3) 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 _ colType            = withBytes 4 $ getNative colType++getNative :: 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+    len <- remaining+    case len of+        4  -> IPv4 . fromHostAddress <$> getWord32le+        16 -> do+            a <- (,,,) <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+            return $ IPv6 (fromHostAddress6 a)+        n  -> fail $ "getNative: invalid Inet length: " ++ show n+getNative VarIntColumn     = CqlVarInt <$> bytes2integer+getNative DecimalColumn    = do+    x <- get :: Get Int32+    y <- bytes2integer+    return (CqlDecimal (Decimal (fromIntegral x) y))+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+getNative c@(UdtColumn _ _ _) = fail $ "getNative: udt: " ++ show c++getList :: Get [a] -> Get [a]+getList m = do+    n <- lookAhead (get :: Get Int32)+    if n < 0 then uncheckedSkip 4 >> return []+             else withBytes 4 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+    when (n < 0) $+        fail "withBytes: null"+    b <- getBytes n+    case runGet p b of+        Left  e -> fail $ "withBytes: " ++ e+        Right x -> return x++remainingBytes :: Get ByteString+remainingBytes = remaining >>= getByteString . fromIntegral++remainingBytesLazy :: Get LB.ByteString+remainingBytesLazy = remaining >>= getLazyByteString . fromIntegral++toBytes :: Int -> Put -> Put+toBytes s p = do+    let bytes = runPut p+    case s of+        2 -> put (fromIntegral (B.length bytes) :: Word16)+        _ -> put (fromIntegral (B.length bytes) :: Int32)+    putByteString bytes++-- 'integer2bytes' and 'bytes2integer' implementations are taken+-- from cereal's instance declaration of 'Serialize' for 'Integer'+-- except that no distinction between small and large integers is made.+-- Cf. to LICENSE for copyright details.+integer2bytes :: Putter Integer+integer2bytes n = do+    put sign+    put (unroll (abs n))+  where+    sign = fromIntegral (signum n) :: Word8++    unroll :: Integer -> [Word8]+    unroll = unfoldr step+      where+        step 0 = Nothing+        step i = Just (fromIntegral i, i `shiftR` 8)++bytes2integer :: Get Integer+bytes2integer = do+    sign  <- get+    bytes <- get+    let v = roll bytes+    return $! if sign == (1 :: Word8) then v else - v+  where+    roll :: [Word8] -> Integer+    roll = foldr unstep 0+      where+        unstep b a = a `shiftL` 8 .|. fromIntegral b++------------------------------------------------------------------------------+-- Various++decodeKeyspace :: Get Keyspace+decodeKeyspace = Keyspace <$> decodeString++decodeTable :: Get Table+decodeTable = Table <$> decodeString++decodeQueryId :: Get (QueryId k a b)+decodeQueryId = QueryId <$> decodeShortBytes

@@ -0,0 +1,162 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++module Database.CQL.Protocol.Header+    ( Header     (..)+    , HeaderType (..)+    , header+    , encodeHeader+    , decodeHeader++      -- ** Length+    , Length     (..)+    , encodeLength+    , decodeLength++      -- ** StreamId+    , StreamId+    , mkStreamId+    , fromStreamId+    , encodeStreamId+    , decodeStreamId++      -- ** Flags+    , Flags+    , compress+    , tracing+    , isSet+    , encodeFlags+    , decodeFlags+    ) where++import Control.Applicative+import Data.Bits+import Data.ByteString.Lazy (ByteString)+import Data.Int+import Data.Monoid+import Data.Serialize+import Data.Word+import Database.CQL.Protocol.Codec+import Database.CQL.Protocol.Types++-- | Protocol frame header.+data Header = Header+    { headerType :: !HeaderType+    , version    :: !Version+    , flags      :: !Flags+    , streamId   :: !StreamId+    , opCode     :: !OpCode+    , bodyLength :: !Length+    } deriving Show++data HeaderType+    = RqHeader -- ^ A request frame header.+    | RsHeader -- ^ A response frame header.+    deriving Show++encodeHeader :: Version -> HeaderType -> Flags -> StreamId -> OpCode -> Length -> PutM ()+encodeHeader v t f i o l = do+    encodeByte $ case t of+        RqHeader -> mapVersion v+        RsHeader -> mapVersion v `setBit` 7+    encodeFlags f+    encodeStreamId v i+    encodeOpCode o+    encodeLength l++decodeHeader :: Version -> Get Header+decodeHeader v = do+    b <- getWord8+    Header (mapHeaderType b)+        <$> toVersion (b .&. 0x7F)+        <*> decodeFlags+        <*> decodeStreamId v+        <*> decodeOpCode+        <*> decodeLength++mapHeaderType :: Word8 -> HeaderType+mapHeaderType b = if b `testBit` 7 then RsHeader else RqHeader++-- | Deserialise a frame header using the version specific decoding format.+header :: Version -> ByteString -> Either String Header+header v = runGetLazy (decodeHeader v)++------------------------------------------------------------------------------+-- Version++mapVersion :: Version -> Word8+mapVersion V3 = 3+mapVersion V2 = 2++toVersion :: Word8 -> Get Version+toVersion 2 = return V2+toVersion 3 = return V3+toVersion w = fail $ "decode-version: unknown: " ++ show w++------------------------------------------------------------------------------+-- Length++-- | The type denoting a protocol frame length.+newtype Length = Length { lengthRepr :: Int32 } deriving (Eq, Show)++encodeLength :: Putter Length+encodeLength (Length x) = encodeInt x++decodeLength :: Get Length+decodeLength = Length <$> decodeInt++------------------------------------------------------------------------------+-- StreamId++-- | Streams allow multiplexing of requests over a single communication+-- channel. The 'StreamId' correlates 'Request's with 'Response's.+newtype StreamId = StreamId Int16 deriving (Eq, Show)++-- | Create a StreamId from the given integral value. In version 2,+-- a StreamId is an 'Int8' and in version 3 an 'Int16'.+mkStreamId :: Integral i => i -> StreamId+mkStreamId = StreamId . fromIntegral++-- | Convert the stream ID to an integer.+fromStreamId :: StreamId -> Int+fromStreamId (StreamId i) = fromIntegral i++encodeStreamId :: Version -> Putter StreamId+encodeStreamId V3 (StreamId x) = encodeSignedShort (fromIntegral x)+encodeStreamId V2 (StreamId x) = encodeSignedByte (fromIntegral x)++decodeStreamId :: Version -> Get StreamId+decodeStreamId V3 = StreamId <$> decodeSignedShort+decodeStreamId V2 = StreamId . fromIntegral <$> decodeSignedByte++------------------------------------------------------------------------------+-- Flags++-- | Type representing header flags. Flags form a monoid and can be used+-- as in @compress <> tracing <> mempty@.+newtype Flags = Flags Word8 deriving (Eq, Show)++instance Monoid Flags where+    mempty = Flags 0+    mappend (Flags a) (Flags b) = Flags (a .|. b)++encodeFlags :: Putter Flags+encodeFlags (Flags x) = encodeByte x++decodeFlags :: Get Flags+decodeFlags = Flags <$> decodeByte++-- | Compression flag. If set, the frame body is compressed.+compress :: Flags+compress = Flags 1++-- | Tracing flag. If a request support tracing and the tracing flag was set,+-- the response to this request will have the tracing flag set and contain+-- tracing information.+tracing :: Flags+tracing = Flags 2++-- | Check if a particular flag is present.+isSet :: Flags -> Flags -> Bool+isSet (Flags a) (Flags b) = a .&. b == a

@@ -0,0 +1,38 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++-- | Like "Database.CQL.Protocol" but exports the whole+-- encode/decode machinery for all types.+module Database.CQL.Protocol.Internal+    ( -- * Cql type-class+      module Database.CQL.Protocol.Class++      -- * Basic type definitions+    , module Database.CQL.Protocol.Types++      -- * Header+    , module Database.CQL.Protocol.Header++      -- * Request+    , module Database.CQL.Protocol.Request++      -- * Response+    , module Database.CQL.Protocol.Response++      -- * Tuple and Record+    , module Database.CQL.Protocol.Tuple+    , module Database.CQL.Protocol.Record++      -- * Codec+    , module Database.CQL.Protocol.Codec+    ) where++import Database.CQL.Protocol.Class+import Database.CQL.Protocol.Codec+import Database.CQL.Protocol.Header+import Database.CQL.Protocol.Record+import Database.CQL.Protocol.Request+import Database.CQL.Protocol.Response+import Database.CQL.Protocol.Tuple+import Database.CQL.Protocol.Types

@@ -0,0 +1,117 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE CPP          #-}+{-# LANGUAGE TypeFamilies #-}++module Database.CQL.Protocol.Record+    ( Record    (..)+    , TupleType+    , recordInstance+    ) where++import Control.Monad+import Language.Haskell.TH++typeSynDecl :: Name -> [Type] -> Type -> Dec+#if __GLASGOW_HASKELL__ < 708+typeSynDecl = TySynInstD+#else+typeSynDecl x y z = TySynInstD x (TySynEqn y z)+#endif++type family TupleType a++-- | Record/Tuple conversion.+-- For example:+--+-- @+-- data Peer = Peer+--     { peerAddr :: IP+--     , peerRPC  :: IP+--     , peerDC   :: Text+--     , peerRack :: Text+--     } deriving Show+--+-- recordInstance ''Peer+--+-- map asRecord \<$\> performQuery "SELECT peer, rpc_address, data_center, rack FROM system.peers"+-- @+--+-- The generated type-class instance maps between record and tuple constructors:+--+-- @+-- type instance TupleType Peer = (IP, IP, Text, Text)+--+-- instance Record Peer where+--     asTuple (Peer a b c d) = (a, b, c, d)+--     asRecord (a, b, c, d)  = Peer a b c d+-- @+--+class Record a where+    asTuple  :: a -> TupleType a+    asRecord :: TupleType a -> a++recordInstance :: Name -> Q [Dec]+recordInstance n = do+    i <- reify n+    case i of+        TyConI d -> start d+        _        -> fail "expecting record type"++start :: Dec -> Q [Dec]+start (DataD _ tname _ cons _) = do+    unless (length cons == 1) $+        fail "expecting single data constructor"+    tt <- tupleType (head cons)+    at <- asTupleDecl (head cons)+    ar <- asRecrdDecl (head cons)+    return+        [ typeSynDecl (mkName "TupleType") [ConT tname] tt+        , InstanceD [] (ConT (mkName "Record") $: ConT tname)+            [ FunD (mkName "asTuple")  [at]+            , FunD (mkName "asRecord") [ar]+            ]+        ]+start _ = fail "unsupported data type"++tupleType :: Con -> Q Type+tupleType c = do+    let tt = types c+    return $ foldl1 ($:) (TupleT (length tt) : types c)+  where+    types (NormalC _ tt) = map snd tt+    types (RecC _ tt)    = map (\(_, _, t) -> t) tt+    types _              = fail "record and normal constructors only"++asTupleDecl ::Con -> Q Clause+asTupleDecl c =+    case c of+        (NormalC n t) -> go n t+        (RecC    n t) -> go n t+        _             -> fail "record and normal constructors only"+  where+    go n t = do+        vars <- replicateM (length t) (newName "a")+        return $ Clause [ConP n (map VarP vars)] (body vars) []+    body = NormalB . TupE . map VarE++asRecrdDecl ::Con -> Q Clause+asRecrdDecl c =+    case c of+        (NormalC n t) -> go n t+        (RecC    n t) -> go n t+        _             -> fail "record and normal constructors only"+  where+    go n t = do+        vars <- replicateM (length t) (newName "a")+        return $ Clause [TupP (map VarP vars)] (body n vars) []+    body n v = NormalB $ foldl1 ($$) (ConE n : map VarE v)++($$) :: Exp -> Exp -> Exp+($$) = AppE++($:) :: Type -> Type -> Type+($:) = AppT+

@@ -0,0 +1,334 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}++module Database.CQL.Protocol.Request+    ( Request           (..)+    , pack+    , encodeRequest+    , getOpCode++      -- ** Options+    , Options           (..)+    , encodeOptions++      -- ** Startup+    , Startup           (..)+    , encodeStartup++      -- ** Auth Response+    , AuthResponse      (..)+    , encodeAuthResponse++      -- ** Register+    , Register          (..)+    , EventType         (..)+    , encodeRegister+    , encodeEventType++      -- ** Query+    , Query             (..)+    , QueryParams       (..)+    , SerialConsistency (..)+    , encodeQuery+    , encodeQueryParams++      -- ** Batch+    , Batch             (..)+    , BatchQuery        (..)+    , BatchType         (..)+    , encodeBatch+    , encodeBatchType+    , encodeBatchQuery++      -- ** Prepare+    , Prepare           (..)+    , encodePrepare++      -- ** Execute+    , Execute           (..)+    , encodeExecute+    ) where++import Control.Applicative+import Control.Monad (when)+import Data.Bits+import Data.ByteString.Lazy (ByteString)+import Data.Foldable (traverse_)+import Data.Int+import Data.Text (Text)+import Data.Maybe (isJust)+import Data.Monoid+import Data.Serialize hiding (decode, encode)+import Data.Word+import Database.CQL.Protocol.Tuple+import Database.CQL.Protocol.Codec+import Database.CQL.Protocol.Types+import Database.CQL.Protocol.Header++import qualified Data.ByteString.Lazy as LB++------------------------------------------------------------------------------+-- Request++-- | The type corresponding to the protocol request frame.+--+-- The type parameter 'k' denotes the kind of request. It is present to allow+-- distinguishing read operations from write operations. Use 'R' for read,+-- 'W' for write and 'S' for schema related operations.+--+-- 'a' represents the argument type and 'b' the return type of this request.+data Request k a b+    = RqStartup  !Startup+    | RqOptions  !Options+    | RqRegister !Register+    | RqBatch    !Batch+    | RqAuthResp !AuthResponse+    | RqPrepare  !(Prepare k a b)+    | RqQuery    !(Query k a b)+    | RqExecute  !(Execute k a b)+    deriving Show++encodeRequest :: Tuple a => Version -> Putter (Request k a b)+encodeRequest _ (RqStartup  r) = encodeStartup r+encodeRequest _ (RqOptions  r) = encodeOptions r+encodeRequest _ (RqRegister r) = encodeRegister r+encodeRequest v (RqBatch    r) = encodeBatch v r+encodeRequest _ (RqAuthResp r) = encodeAuthResponse r+encodeRequest _ (RqPrepare  r) = encodePrepare r+encodeRequest v (RqQuery    r) = encodeQuery v r+encodeRequest v (RqExecute  r) = encodeExecute v r++-- | Serialise the given request, optionally using compression.+-- The result is either an error description in case of failure or a binary+-- protocol frame, including 'Header', 'Length' and body.+pack :: Tuple a+     => Version       -- ^ protocol version, which determines the encoding+     -> Compression   -- ^ compression to use+     -> Bool          -- ^ enable/disable tracing+     -> StreamId      -- ^ the stream Id to use+     -> Request k a b -- ^ the actual request to serialise+     -> Either String ByteString+pack v c t i r = do+    body <- runCompression c (runPutLazy $ encodeRequest v r)+    let len = Length . fromIntegral $ LB.length body+    return . runPutLazy $ do+        encodeHeader v RqHeader mkFlags i (getOpCode r) len+        putLazyByteString body+  where+    runCompression f x = maybe compressError return (shrink f $ x)+    compressError      = Left "pack: compression failure"++    mkFlags = (if t then tracing else mempty)+        <> (if algorithm c /= None then compress else mempty)++-- | Get the protocol 'OpCode' corresponding to the given 'Request'.+getOpCode :: Request k a b -> OpCode+getOpCode (RqQuery _)    = OcQuery+getOpCode (RqExecute _)  = OcExecute+getOpCode (RqPrepare _)  = OcPrepare+getOpCode (RqBatch _)    = OcBatch+getOpCode (RqRegister _) = OcRegister+getOpCode (RqOptions _)  = OcOptions+getOpCode (RqStartup _)  = OcStartup+getOpCode (RqAuthResp _) = OcAuthResponse++------------------------------------------------------------------------------+-- STARTUP++-- | A startup request which is used when initialising a connection to the+-- server. It specifies the CQL version to use and optionally the+-- compression algorithm.+data Startup = Startup !CqlVersion !CompressionAlgorithm deriving Show++encodeStartup :: Putter Startup+encodeStartup (Startup v c) =+    encodeMap $ ("CQL_VERSION", mapVersion v) : mapCompression c+  where+    mapVersion :: CqlVersion -> Text+    mapVersion Cqlv300        = "3.0.0"+    mapVersion (CqlVersion s) = s++    mapCompression :: CompressionAlgorithm -> [(Text, Text)]+    mapCompression Snappy = [("COMPRESSION", "snappy")]+    mapCompression LZ4    = [("COMPRESSION", "lz4")]+    mapCompression None   = []++------------------------------------------------------------------------------+-- AUTH_RESPONSE++-- | A request send in response to a previous authentication challenge.+newtype AuthResponse = AuthResponse LB.ByteString deriving Show++encodeAuthResponse :: Putter AuthResponse+encodeAuthResponse (AuthResponse b) = encodeBytes b++------------------------------------------------------------------------------+-- OPTIONS++-- | An options request, send prior to 'Startup' to request the server's+-- startup options.+data Options = Options deriving Show++encodeOptions :: Putter Options+encodeOptions _ = return ()++------------------------------------------------------------------------------+-- QUERY++-- | A CQL query (select, insert, etc.).+data Query k a b = Query !(QueryString k a b) !(QueryParams a) deriving Show++encodeQuery :: Tuple a => Version -> Putter (Query k a b)+encodeQuery v (Query (QueryString s) p) =+    encodeLongString s >> encodeQueryParams v p++------------------------------------------------------------------------------+-- EXECUTE++-- | Executes a prepared query.+data Execute k a b = Execute !(QueryId k a b) !(QueryParams a) deriving Show++encodeExecute :: Tuple a => Version -> Putter (Execute k a b)+encodeExecute v (Execute (QueryId q) p) =+    encodeShortBytes q >> encodeQueryParams v p++------------------------------------------------------------------------------+-- PREPARE++-- | Prepare a query for later execution (cf. 'Execute').+newtype Prepare k a b = Prepare (QueryString k a b) deriving Show++encodePrepare :: Putter (Prepare k a b)+encodePrepare (Prepare (QueryString p)) = encodeLongString p++------------------------------------------------------------------------------+-- REGISTER++-- | Register's the connection this request is made through, to receive+-- server events.+newtype Register = Register [EventType] deriving Show++encodeRegister :: Putter Register+encodeRegister (Register t) = do+    encodeShort (fromIntegral (length t))+    mapM_ encodeEventType t++-- | Event types to register.+data EventType+    = TopologyChangeEvent -- ^ events related to change in the cluster topology+    | StatusChangeEvent   -- ^ events related to change of node status+    | SchemaChangeEvent   -- ^ events related to schema change+    deriving Show++encodeEventType :: Putter EventType+encodeEventType TopologyChangeEvent = encodeString "TOPOLOGY_CHANGE"+encodeEventType StatusChangeEvent   = encodeString "STATUS_CHANGE"+encodeEventType SchemaChangeEvent   = encodeString "SCHEMA_CHANGE"++------------------------------------------------------------------------------+-- BATCH++-- | Allows executing a list of queries (prepared or not) as a batch.+data Batch = Batch+    { batchType              :: !BatchType+    , batchQuery             :: [BatchQuery]+    , batchConsistency       :: !Consistency+    , batchSerialConsistency :: Maybe SerialConsistency+    } deriving Show++data BatchType+    = BatchLogged   -- ^ default, uses a batch log for atomic application+    | BatchUnLogged -- ^ skip the batch log+    | BatchCounter  -- ^ used for batched counter updates+    deriving (Show)++encodeBatch :: Version -> Putter Batch+encodeBatch v (Batch t q c s) = do+    encodeBatchType t+    encodeShort (fromIntegral (length q))+    mapM_ (encodeBatchQuery v) q+    encodeConsistency c+    when (v == V3) $ do+        put batchFlags+        traverse_ encodeConsistency (mapCons <$> s)+  where+    batchFlags :: Word8+    batchFlags = if isJust s then 0x10 else 0x0++encodeBatchType :: Putter BatchType+encodeBatchType BatchLogged   = putWord8 0+encodeBatchType BatchUnLogged = putWord8 1+encodeBatchType BatchCounter  = putWord8 2++-- | A GADT to unify queries and prepared queries both of which can be used+-- in batch requests.+data BatchQuery where+    BatchQuery :: (Show a, Tuple a, Tuple b)+               => !(QueryString W a b)+               -> !a+               -> BatchQuery++    BatchPrepared :: (Show a, Tuple a, Tuple b)+                  => !(QueryId W a b)+                  -> !a+                  -> BatchQuery++deriving instance Show BatchQuery++encodeBatchQuery :: Version -> Putter BatchQuery+encodeBatchQuery n (BatchQuery (QueryString q) v) = do+    putWord8 0+    encodeLongString q+    store n v+encodeBatchQuery n (BatchPrepared (QueryId i) v)  = do+    putWord8 1+    encodeShortBytes i+    store n v++------------------------------------------------------------------------------+-- Query Parameters++-- | 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+    , serialConsistency :: Maybe SerialConsistency+    } deriving Show++-- | Consistency level for the serial phase of conditional updates.+data SerialConsistency+    = SerialConsistency+    | LocalSerialConsistency+    deriving Show++encodeQueryParams :: forall a. Tuple a => Version -> Putter (QueryParams a)+encodeQueryParams v p = do+    encodeConsistency (consistency p)+    put queryFlags+    store v (values p)+    traverse_ encodeInt         (pageSize p)+    traverse_ encodePagingState (queryPagingState p)+    traverse_ encodeConsistency (mapCons <$> serialConsistency p)+  where+    queryFlags :: Word8+    queryFlags =+            (if hasValues                    then 0x01 else 0x0)+        .|. (if skipMetaData p               then 0x02 else 0x0)+        .|. (if isJust (pageSize p)          then 0x04 else 0x0)+        .|. (if isJust (queryPagingState p)  then 0x08 else 0x0)+        .|. (if isJust (serialConsistency p) then 0x10 else 0x0)++    hasValues = untag (count :: Tagged a Int) /= 0++mapCons :: SerialConsistency -> Consistency+mapCons SerialConsistency      = Serial+mapCons LocalSerialConsistency = LocalSerial

@@ -0,0 +1,431 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Database.CQL.Protocol.Response+    ( Response            (..)+    , unpack++      -- ** Ready+    , Ready               (..)+    , decodeReady++      -- ** Authenticate+    , Authenticate        (..)+    , AuthChallenge       (..)+    , AuthSuccess         (..)+    , decodeAuthenticate+    , decodeAuthChallenge+    , decodeAuthSuccess++      -- ** Result+    , Result              (..)+    , MetaData            (..)+    , ColumnSpec          (..)+    , decodeResult+    , decodeMetaData++      -- ** Supported+    , Supported           (..)+    , decodeSupported++      -- ** Event+    , Event               (..)+    , TopologyChange      (..)+    , SchemaChange        (..)+    , StatusChange        (..)+    , Change              (..)+    , decodeSchemaChange+    , decodeChange+    , decodeEvent+    , decodeTopologyChange+    , decodeStatusChange++      -- ** Error+    , Error               (..)+    , WriteType           (..)+    , decodeError+    , decodeWriteType+    ) where++import Control.Applicative+import Control.Exception (Exception)+import Control.Monad+import Data.Bits+import Data.ByteString (ByteString)+import Data.Int+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Serialize hiding (Result)+import Data.Typeable+import Data.UUID (UUID)+import Data.Word+import Database.CQL.Protocol.Tuple+import Database.CQL.Protocol.Codec+import Database.CQL.Protocol.Types+import Database.CQL.Protocol.Header+import Network.Socket (SockAddr)++import qualified Data.ByteString.Lazy as LB+import qualified Data.Text            as T++------------------------------------------------------------------------------+-- Response++-- | The type corresponding to the protocol response frame.+--+-- The type parameter 'k' denotes the kind of response. It is present to allow+-- distinguishing read operations from write operations. Use 'R' for read,+-- 'W' for write and 'S' for schema related operations.+--+-- '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+    deriving Show++-- | Deserialise a 'Response' from the given 'ByteString'.+unpack :: (Tuple a, Tuple b)+       => Compression+       -> Header+       -> LB.ByteString+       -> Either String (Response k a b)+unpack c h b = do+    let f = flags h+    let v = version h+    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)+  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++    deflate f x  = maybe deflateError return (expand f x)+    deflateError = Left "unpack: decompression failure"++------------------------------------------------------------------------------+-- AUTHENTICATE++-- | The server requires authentication.+newtype Authenticate = Authenticate Text deriving Show++decodeAuthenticate :: Get Authenticate+decodeAuthenticate = Authenticate <$> decodeString++------------------------------------------------------------------------------+-- AUTH_CHALLENGE++-- | A server-send authentication challenge.+newtype AuthChallenge = AuthChallenge (Maybe LB.ByteString) deriving Show++decodeAuthChallenge :: Get AuthChallenge+decodeAuthChallenge = AuthChallenge <$> decodeBytes++------------------------------------------------------------------------------+-- AUTH_SUCCESS++-- | Indicates the success of an authentication phase.+newtype AuthSuccess = AuthSuccess (Maybe LB.ByteString) deriving Show++decodeAuthSuccess :: Get AuthSuccess+decodeAuthSuccess = AuthSuccess <$> decodeBytes++------------------------------------------------------------------------------+-- READY++-- | The server is ready to process queries. Response of a 'Startup'+-- request.+data Ready = Ready deriving Show++decodeReady :: Get Ready+decodeReady = return Ready++------------------------------------------------------------------------------+-- SUPPORTED++-- | The startup options supported by the server. Response of an 'Options'+-- request.+data Supported = Supported [CompressionAlgorithm] [CqlVersion] deriving Show++decodeSupported :: Get Supported+decodeSupported = do+    opt <- decodeMultiMap+    cmp <- mapM toCompression . fromMaybe [] $ lookup "COMPRESSION" opt+    let v = map toVersion . fromMaybe [] $ lookup "CQL_VERSION" opt+    return $ Supported cmp v+  where+    toCompression "snappy" = return Snappy+    toCompression "lz4"    = return LZ4+    toCompression other    = fail $+        "decode-supported: unknown compression: " ++ show other++    toVersion "3.0.0" = Cqlv300+    toVersion other   = CqlVersion other++------------------------------------------------------------------------------+-- RESULT++-- | Query response.+data Result k a b+    = VoidResult+    | RowsResult         !MetaData [b]+    | SetKeyspaceResult  !Keyspace+    | PreparedResult     !(QueryId k a b) !MetaData !MetaData+    | SchemaChangeResult !SchemaChange+    deriving (Show)++-- | Part of a @RowsResult@. Describes the result set.+data MetaData = MetaData+    { columnCount :: !Int32+    , pagingState :: Maybe PagingState+    , columnSpecs :: [ColumnSpec]+    } deriving (Show)++-- | The column specification. Part of 'MetaData' unless 'skipMetaData' in+-- 'QueryParams' was True.+data ColumnSpec = ColumnSpec+    { keyspace   :: !Keyspace+    , table      :: !Table+    , columnName :: !Text+    , columnType :: !ColumnType+    } deriving (Show)++decodeResult :: forall k a b. (Tuple a, Tuple b) => Version -> Get (Result k a b)+decodeResult v = decodeInt >>= go+  where+    go 0x1 = return VoidResult+    go 0x2 = do+        m <- decodeMetaData+        n <- decodeInt+        let c = untag (count :: Tagged b Int)+        unless (columnCount m == fromIntegral c) $+            fail $ "column count: "+                ++ show (columnCount m)+                ++ " =/= "+                ++ show c+        let typecheck = untag (check :: Tagged b ([ColumnType] -> [ColumnType]))+        let ctypes    = map columnType (columnSpecs m)+        let expected  = typecheck ctypes+        let message   = "expected: " ++ show expected ++ ", but got " ++ show ctypes+        unless (null expected) $+            fail $ "column-type error: " ++ message+        RowsResult m <$> replicateM (fromIntegral n) (tuple v)+    go 0x3 = SetKeyspaceResult <$> decodeKeyspace+    go 0x4 = PreparedResult <$> decodeQueryId <*> decodeMetaData <*> decodeMetaData+    go 0x5 = SchemaChangeResult <$> decodeSchemaChange v+    go int = fail $ "decode-result: unknown: " ++ show int++decodeMetaData :: Get MetaData+decodeMetaData = do+    f <- decodeInt+    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)+  where+    hasGlobalSpec f = f `testBit` 0+    hasMorePages  f = f `testBit` 1+    hasNoMetaData f = f `testBit` 2++    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++data SchemaChange+    = SchemaCreated !Change+    | SchemaUpdated !Change+    | SchemaDropped !Change+    deriving Show++data Change+    = KeyspaceChange !Keyspace+    | TableChange    !Keyspace !Table+    | TypeChange     !Keyspace !Text+    deriving Show++decodeSchemaChange :: Version -> Get SchemaChange+decodeSchemaChange v = decodeString >>= fromString+  where+    fromString "CREATED" = SchemaCreated <$> decodeChange v+    fromString "UPDATED" = SchemaUpdated <$> decodeChange v+    fromString "DROPPED" = SchemaDropped <$> decodeChange v+    fromString other     = fail $ "decode-schema-change: unknown: " ++ show other++decodeChange :: Version -> Get Change+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++------------------------------------------------------------------------------+-- EVENT++-- | Messages send by the server without request, if the connection has+-- been 'Register'ed to receive such events.+data Event+    = TopologyEvent !TopologyChange !SockAddr+    | StatusEvent   !StatusChange   !SockAddr+    | SchemaEvent   !SchemaChange+    deriving Show++data TopologyChange = NewNode | RemovedNode deriving (Eq, Ord, Show)+data StatusChange   = Up | Down deriving (Eq, Ord, Show)++decodeEvent :: Version -> Get Event+decodeEvent v = decodeString >>= decodeByType+  where+    decodeByType "TOPOLOGY_CHANGE" = TopologyEvent <$> decodeTopologyChange <*> decodeSockAddr+    decodeByType "STATUS_CHANGE"   = StatusEvent   <$> decodeStatusChange <*> decodeSockAddr+    decodeByType "SCHEMA_CHANGE"   = SchemaEvent   <$> decodeSchemaChange v+    decodeByType other             = fail $ "decode-event: unknown: " ++ show other++decodeTopologyChange :: Get TopologyChange+decodeTopologyChange = decodeString >>= fromString+  where+    fromString "NEW_NODE"     = return NewNode+    fromString "REMOVED_NODE" = return RemovedNode+    fromString other          = fail $+        "decode-topology: unknown: "  ++ show other++decodeStatusChange :: Get StatusChange+decodeStatusChange = decodeString >>= fromString+  where+    fromString "UP"   = return Up+    fromString "DOWN" = return Down+    fromString other  = fail $+        "decode-status-change: unknown: " ++ show other++-----------------------------------------------------------------------------+-- ERROR++-- | Error response.+data Error+    = AlreadyExists   !Text !Keyspace !Table+    | BadCredentials  !Text+    | ConfigError     !Text+    | Invalid         !Text+    | IsBootstrapping !Text+    | Overloaded      !Text+    | ProtocolError   !Text+    | ServerError     !Text+    | SyntaxError     !Text+    | TruncateError   !Text+    | Unauthorized    !Text+    | Unprepared      !Text !ByteString+    | Unavailable+        { unavailMessage     :: !Text+        , unavailConsistency :: !Consistency+        , unavailNumRequired :: !Int32+        , unavailNumAlive    :: !Int32+        }+    | ReadTimeout+        { rTimeoutMessage     :: !Text+        , rTimeoutConsistency :: !Consistency+        , rTimeoutNumAck      :: !Int32+        , rTimeoutNumRequired :: !Int32+        , rTimeoutDataPresent :: !Bool+        }+    | WriteTimeout+        { wTimeoutMessage     :: !Text+        , wTimeoutConsistency :: !Consistency+        , wTimeoutNumAck      :: !Int32+        , wTimeoutNumRequired :: !Int32+        , wTimeoutWriteType   :: !WriteType+        }+    deriving (Eq, Show, Typeable)++instance Exception Error++data WriteType+    = WriteSimple+    | WriteBatch+    | WriteBatchLog+    | WriteUnloggedBatch+    | WriteCounter+    deriving (Eq, Show)++decodeError :: Get Error+decodeError = do+    code <- decodeInt+    msg  <- decodeString+    toError code msg+  where+    toError :: Int32 -> Text -> Get Error+    toError 0x0000 m = return $ ServerError m+    toError 0x000A m = return $ ProtocolError m+    toError 0x0100 m = return $ BadCredentials m+    toError 0x1000 m = Unavailable m <$> decodeConsistency <*> decodeInt <*> decodeInt+    toError 0x1001 m = return $ Overloaded m+    toError 0x1002 m = return $ IsBootstrapping m+    toError 0x1003 m = return $ TruncateError m+    toError 0x1100 m = WriteTimeout m+        <$> decodeConsistency+        <*> decodeInt+        <*> decodeInt+        <*> decodeWriteType+    toError 0x1200 m = ReadTimeout m+        <$> decodeConsistency+        <*> decodeInt+        <*> decodeInt+        <*> (bool <$> decodeByte)+    toError 0x2000 m = return $ SyntaxError m+    toError 0x2100 m = return $ Unauthorized m+    toError 0x2200 m = return $ Invalid m+    toError 0x2300 m = return $ ConfigError m+    toError 0x2400 m = AlreadyExists m <$> decodeKeyspace <*> decodeTable+    toError 0x2500 m = Unprepared m <$> decodeShortBytes+    toError code _   = fail $ "decode-error: unknown: " ++ show code++    bool :: Word8 -> Bool+    bool 0 = False+    bool _ = True++decodeWriteType :: Get WriteType+decodeWriteType = decodeString >>= fromString+  where+    fromString "SIMPLE"          = return WriteSimple+    fromString "BATCH"           = return WriteBatch+    fromString "BATCH_LOG"       = return WriteBatchLog+    fromString "UNLOGGED_BATCH"  = return WriteUnloggedBatch+    fromString "COUNTER"         = return WriteCounter+    fromString unknown           = fail $+        "decode: unknown write-type: " ++ show unknown

@@ -0,0 +1,27 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | A tuple represents the types of multiple cassandra columns. It is used+-- to check that column-types match.+module Database.CQL.Protocol.Tuple+    ( Tuple+    , count+    , check+    , tuple+    , store+    ) where++import Control.Applicative+import Data.Serialize+import Data.Word+import Database.CQL.Protocol.Class+import Database.CQL.Protocol.Codec (putValue)+import Database.CQL.Protocol.Types+import Database.CQL.Protocol.Tuple.TH++genInstances 48

@@ -0,0 +1,153 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE ScopedTypeVariables #-}++module Database.CQL.Protocol.Tuple.TH where++import Control.Applicative+import Control.Monad+import Data.Functor.Identity+import Data.Serialize+import Data.Word+import Database.CQL.Protocol.Class+import Database.CQL.Protocol.Codec (putValue, getValue)+import Database.CQL.Protocol.Types+import Language.Haskell.TH++-- 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 -> 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)++------------------------------------------------------------------------------+-- Templated instances++genInstances :: Int -> Q [Dec]+genInstances n = join <$> mapM tupleInstance [2 .. n]++tupleInstance :: Int -> Q [Dec]+tupleInstance n = do+    let cql = mkName "Cql"+    vnames <- replicateM n (newName "a")+    let vtypes    = map VarT vnames+    let tupleType = foldl1 ($:) (TupleT n : vtypes)+    let ctx       = map (\t -> ClassP cql [t]) vtypes+    td <- tupleDecl n+    sd <- storeDecl n+    return+        [ InstanceD ctx (tcon "PrivateTuple" $: tupleType)+            [ FunD (mkName "count") [countDecl n]+            , FunD (mkName "check") [checkDecl vnames]+            , FunD (mkName "tuple") [td]+            , FunD (mkName "store") [sd]+            ]+        , InstanceD ctx (tcon "Tuple" $: tupleType) []+        ]++countDecl :: Int -> Clause+countDecl n = Clause [] (NormalB body) []+  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) []+  where+    body  = con "Tagged" $$ (var "typecheck" $$ ListE (map fn names))+    fn n  = var "untag" $$ SigE (var "ctype") (tty n)+    tty n = tcon "Tagged" $: VarT n $: tcon "ColumnType"++-- tuple v = (,)  <$> element v ctype <*> element v ctype+-- tuple v = (,,) <$> element v ctype <*> element v ctype <*> element v ctype+-- ...+tupleDecl :: Int -> Q Clause+tupleDecl n = do+    let v = mkName "v"+    Clause [VarP v] (NormalB $ body v) <$> comb+  where+    body v = UInfixE (var "combine") (var "<$>") (foldl1 star (elts v))+    elts v = replicate n (var "element" $$ VarE v $$ var "ctype")+    star   = flip UInfixE (var "<*>")+    comb   = do+        names <- replicateM n (newName "x")+        let f = NormalB $ TupE (map VarE names)+        return [ FunD (mkName "combine") [Clause (map VarP names) f []] ]++-- store v (a, b) = put (2 :: Word16) >> putValue v (toCql a) >> putValue v (toCql b)+storeDecl :: Int -> Q Clause+storeDecl n = do+    let v = mkName "v"+    names <- replicateM n (newName "k")+    return $ Clause [VarP v, TupP (map VarP names)] (NormalB $ body v names) []+  where+    body x names = DoE (NoBindS size : map (NoBindS . value x) names)+    size         = var "put" $$ SigE (litInt n) (tcon "Word16")+    value x v    = var "putValue" $$ VarE x $$ (var "toCql" $$ VarE v)++------------------------------------------------------------------------------+-- Helpers++litInt :: Integral i => i -> Exp+litInt = LitE . IntegerL . fromIntegral++var, con :: String -> Exp+var = VarE . mkName+con = ConE . mkName++tcon :: String -> Type+tcon = ConT . mkName++($$) :: Exp -> Exp -> Exp+($$) = AppE++($:) :: 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 and (zipWith (===) rr cc) then [] else rr+  where+    (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+    TextColumn      === VarCharColumn   = True+    VarCharColumn   === TextColumn      = True+    a               === b               = a == b

@@ -0,0 +1,215 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++module Database.CQL.Protocol.Types where++import Data.ByteString (ByteString)+import Data.Text (Text, pack, unpack)+import Data.Decimal+import Data.Int+import Data.IP+import Data.String+import Data.UUID (UUID)++import qualified Data.ByteString.Lazy as LB+import qualified Data.List            as List+import qualified Data.Text.Lazy       as LT++newtype Keyspace = Keyspace+    { unKeyspace :: Text } deriving (Eq, Show)++newtype Table = Table+    { unTable :: Text } deriving (Eq, Show)++-- | Opaque token passed to the server to continue result paging.+newtype PagingState = PagingState+    { unPagingState :: LB.ByteString } deriving (Eq, Show)++-- | ID representing a prepared query.+newtype QueryId k a b = QueryId+    { unQueryId :: ByteString } deriving (Eq, Show)++newtype QueryString k a b = QueryString+    { unQueryString :: LT.Text } deriving (Eq, Show)++instance IsString (QueryString k a b) where+    fromString = QueryString . LT.pack++-- | CQL binary protocol version.+data Version+    = V2 -- ^ version 2+    | V3 -- ^ version 3+    deriving (Eq, Show)++-- | The CQL version (not the binary protocol version).+data CqlVersion+    = Cqlv300+    | CqlVersion !Text+    deriving (Eq, Show)++data CompressionAlgorithm+    = Snappy+    | LZ4+    | None+    deriving (Eq, Show)++data Compression = Compression+    { algorithm :: !CompressionAlgorithm+    , shrink    :: LB.ByteString -> Maybe LB.ByteString+    , expand    :: LB.ByteString -> Maybe LB.ByteString+    }++instance Show Compression where+    show = show . algorithm++noCompression :: Compression+noCompression = Compression None Just Just++-- | Consistency level.+data Consistency+    = Any+    | One+    | Two+    | Three+    | Quorum+    | All+    | LocalQuorum+    | EachQuorum+    | Serial+    | LocalOne+    | LocalSerial+    deriving (Eq, Show)++-- | An opcode is a tag to distinguish protocol frame bodies.+data OpCode+    = OcError+    | OcStartup+    | OcReady+    | OcAuthenticate+    | OcOptions+    | OcSupported+    | OcQuery+    | OcResult+    | OcPrepare+    | OcExecute+    | OcRegister+    | OcEvent+    | OcBatch+    | OcAuthChallenge+    | OcAuthResponse+    | OcAuthSuccess+    deriving (Eq, Show)++-- | The type of a single CQL column.+data ColumnType+    = CustomColumn !Text+    | AsciiColumn+    | BigIntColumn+    | BlobColumn+    | BooleanColumn+    | CounterColumn+    | DecimalColumn+    | DoubleColumn+    | FloatColumn+    | IntColumn+    | TextColumn+    | TimestampColumn+    | UuidColumn+    | VarCharColumn+    | VarIntColumn+    | TimeUuidColumn+    | InetColumn+    | MaybeColumn !ColumnType+    | ListColumn  !ColumnType+    | SetColumn   !ColumnType+    | MapColumn   !ColumnType !ColumnType+    | TupleColumn [ColumnType]+    | UdtColumn   !Keyspace !Text [(Text, ColumnType)]+    deriving (Eq)++instance Show ColumnType where+    show (CustomColumn a)  = unpack a+    show AsciiColumn       = "ascii"+    show BigIntColumn      = "bigint"+    show BlobColumn        = "blob"+    show BooleanColumn     = "boolean"+    show CounterColumn     = "counter"+    show DecimalColumn     = "decimal"+    show DoubleColumn      = "double"+    show FloatColumn       = "float"+    show IntColumn         = "int"+    show TextColumn        = "text"+    show TimestampColumn   = "timestamp"+    show UuidColumn        = "uuid"+    show VarCharColumn     = "varchar"+    show VarIntColumn      = "varint"+    show TimeUuidColumn    = "timeuuid"+    show InetColumn        = "inet"+    show (MaybeColumn a)   = show a ++ "?"+    show (ListColumn a)    = showString "list<" . shows a . showString ">" $ ""+    show (SetColumn a)     = showString "set<" . shows a . showString ">" $ ""+    show (MapColumn a b)   = showString "map<"+                           . shows a+                           . showString ", "+                           . shows b+                           . showString ">"+                           $ ""+    show (TupleColumn a)   = showString "tuple<"+                           . showString (List.intercalate ", " (map show a))+                           . showString ">"+                           $ ""+    show (UdtColumn k n f) = showString (unpack (unKeyspace k))+                           . showString "."+                           . showString (unpack n)+                           . showString "<"+                           . shows (List.intercalate ", " (map show f))+                           . showString ">"+                           $ ""++newtype Ascii    = Ascii    { fromAscii    :: Text          } deriving (Eq, Ord, Show)+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)++instance IsString Ascii where+    fromString = Ascii . pack++-- | A CQL value. The various constructors correspond to CQL data-types for+-- individual columns in Cassandra.+data Value+    = CqlCustom    !LB.ByteString+    | CqlBoolean   !Bool+    | CqlInt       !Int32+    | CqlBigInt    !Int64+    | CqlVarInt    !Integer+    | CqlFloat     !Float+    | CqlDecimal   !Decimal+    | CqlDouble    !Double+    | CqlText      !Text+    | CqlInet      !IP+    | CqlUuid      !UUID+    | CqlTimestamp !Int64+    | CqlAscii     !Text+    | CqlBlob      !LB.ByteString+    | CqlCounter   !Int64+    | CqlTimeUuid  !UUID+    | CqlMaybe     (Maybe Value)+    | CqlList      [Value]+    | CqlSet       [Value]+    | CqlMap       [(Value, Value)]+    | CqlTuple     [Value]             -- ^ binary protocol version >= 3+    | CqlUdt       [(Text, Value)]     -- ^ binary protocol version >= 3+    deriving (Eq, Show)++-- | Tag some value with a phantom type.+newtype Tagged a b = Tagged { untag :: b }++retag :: Tagged a c -> Tagged b c+retag = Tagged . untag++data R+data W+data S

@@ -0,0 +1,11 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++module Main where++import Test.Tasty+import Tests++main :: IO ()+main = defaultMain tests

@@ -0,0 +1,152 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Tests where++import Control.Applicative hiding (many)+import Control.Arrow+import Database.CQL.Protocol+import Database.CQL.Protocol.Internal+import Data.Decimal+import Data.Int+import Data.IP+import Data.Maybe+import Data.Serialize+import Data.Time+import Data.Time.Clock.POSIX+import Data.UUID+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.ByteString.Lazy as LB+import qualified Data.Text            as T++tests :: TestTree+tests = testGroup "Codec"+    [ testProperty "V2: getValue . putValue = id" (getPutIdentity V2)+    , testProperty "V3: getValue . putValue = id" (getPutIdentity V3)+    , testProperty "toCql . fromCql = id"     toCqlFromCqlIdentity+    , testGroup "Integrals"+        [ testProperty "Int Codec"     $ integralCodec (elements [-512..512]) IntColumn CqlInt+        , testProperty "BigInt Codec"  $ integralCodec (elements [-512..512]) BigIntColumn CqlBigInt+        , testProperty "Integer Codec" $ integralCodec (elements [-512..512]) VarIntColumn CqlVarInt+        ]+    ]++getPutIdentity :: Version -> Value -> Property+getPutIdentity v x =+    let t = typeof x+        y = runGet (getValue v t) (runPut (putValue v x))+    in Right x === y++integralCodec :: Show a => Gen a -> ColumnType -> (a -> Value) -> Property+integralCodec g t f = forAll g $ \i ->+    let x = f i in Right x === runGet (getValue V3 t) (runPut (putValue V3 x))++toCqlFromCqlIdentity :: Value -> Property+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@(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+toCqlFromCqlIdentity x@(CqlInet _)      = (toCql <$> (fromCql x :: Either String IP))       === Right x+toCqlFromCqlIdentity x@(CqlUuid _)      = (toCql <$> (fromCql x :: Either String UUID))     === Right x+toCqlFromCqlIdentity x@(CqlTimestamp _) = (toCql <$> (fromCql x :: Either String UTCTime))  === Right x+toCqlFromCqlIdentity x@(CqlAscii _)     = (toCql <$> (fromCql x :: Either String Ascii))    === Right x+toCqlFromCqlIdentity x@(CqlBlob _)      = (toCql <$> (fromCql x :: Either String Blob))     === Right x+toCqlFromCqlIdentity x@(CqlCounter _)   = (toCql <$> (fromCql x :: Either String Counter))  === Right x+toCqlFromCqlIdentity x@(CqlTimeUuid _)  = (toCql <$> (fromCql x :: Either String TimeUuid)) === Right x+toCqlFromCqlIdentity x@(CqlVarInt _)    = (toCql <$> (fromCql x :: Either String Integer))  === Right x+toCqlFromCqlIdentity x@(CqlDecimal _)   = (toCql <$> (fromCql x :: Either String Decimal))  === Right x+toCqlFromCqlIdentity _                  = True === True++typeof :: Value -> ColumnType+typeof (CqlBoolean _)      = BooleanColumn+typeof (CqlInt _)          = IntColumn+typeof (CqlBigInt _)       = BigIntColumn+typeof (CqlVarInt _)       = VarIntColumn+typeof (CqlFloat _)        = FloatColumn+typeof (CqlDecimal _)      = DecimalColumn+typeof (CqlDouble _)       = DoubleColumn+typeof (CqlText _)         = TextColumn+typeof (CqlInet _)         = InetColumn+typeof (CqlUuid _)         = UuidColumn+typeof (CqlTimestamp _)    = TimestampColumn+typeof (CqlAscii _)        = AsciiColumn+typeof (CqlBlob _)         = BlobColumn+typeof (CqlCounter _)      = CounterColumn+typeof (CqlTimeUuid _)     = TimeUuidColumn+typeof (CqlMaybe Nothing)  = MaybeColumn (CustomColumn "a")+typeof (CqlMaybe (Just a)) = MaybeColumn (typeof a)+typeof (CqlList [])        = ListColumn  (CustomColumn "a")+typeof (CqlList (x:_))     = ListColumn  (typeof x)+typeof (CqlSet  [])        = SetColumn (CustomColumn "a")+typeof (CqlSet  (x:_))     = SetColumn (typeof x)+typeof (CqlMap  [])        = MapColumn (CustomColumn "a") (CustomColumn "b")+typeof (CqlMap  ((x,y):_)) = MapColumn (typeof x) (typeof y)+typeof (CqlCustom _)       = CustomColumn "a"+typeof (CqlTuple x)        = TupleColumn (map typeof x)+typeof (CqlUdt   x)        = UdtColumn (Keyspace "") "" (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)+        ]+      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+            ]++instance Arbitrary LB.ByteString where+    arbitrary = LB.pack <$> arbitrary++instance Arbitrary T.Text where+    arbitrary = T.pack <$> arbitrary++instance Arbitrary IP where+    arbitrary = oneof+        [ IPv4 . fromHostAddress  <$> arbitrary+        , IPv6 . fromHostAddress6 <$> arbitrary+        ]++instance Bounded UUID where+    minBound = nil+    maxBound = fromJust $ fromString "ffffffff-ffff-4fff-bfff-ffffffffffff"++instance Arbitrary UUID where+    arbitrary = arbitraryBoundedRandom++instance Arbitrary UTCTime where+    arbitrary = posixSecondsToUTCTime . fromIntegral+        <$> (arbitrary :: Gen Int64)++instance Arbitrary (DecimalRaw Integer) where+    arbitrary = Decimal <$> arbitrary <*> arbitrary