├── .ghci ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── cassy.cabal ├── runTests.sh ├── src └── Database │ └── Cassandra │ ├── Basic.hs │ ├── JSON.hs │ ├── Marshall.hs │ ├── Pack.hs │ ├── Pool.hs │ └── Types.hs └── test ├── Test.hs └── Test.py /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -itest 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.csv 2 | *.o 3 | *.hi 4 | dist 5 | cabal-dev 6 | *DS* 7 | *.swp 8 | TAGS 9 | .cabal-sandbox 10 | cabal.sandbox.config 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Ozgun Ataman 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ozgun Ataman nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # cassy - Haskell Cassandra Client [![Build Status](https://travis-ci.org/Soostone/cassy.svg?branch=master)](https://travis-ci.org/Soostone/cassy) 3 | 4 | 5 | ## Introduction 6 | 7 | The intent is to develop a high quality, high level driver similar to 8 | pycassa. 9 | 10 | ## API Documentation 11 | 12 | Please see the Haddocks hosted on HackageDB: 13 | 14 | http://hackage.haskell.org/package/cassy 15 | 16 | 17 | ## Examples 18 | 19 | ### Database.Cassandra.Basic Usage 20 | 21 | This module offers low-level functionality that is still much 22 | more pleasant than using Thrift directly. 23 | 24 | import Database.Cassandra.Basic 25 | 26 | test :: IO () 27 | test = do 28 | pool <- createCassandraPool defServers 3 300 "TestKeySpace" 29 | insert pool "testCF" "key1" QUORUM [col "col1" "value1"] 30 | getCol pool "testCF" "key1" "col1" QUORUM 31 | 32 | 33 | ### Database.Cassandra.Marshall Usage 34 | 35 | This is the primary high level functionality module. Its use is 36 | recommended above the other options. 37 | 38 | - Columns can be any Haskell type with a CasType instance. See 39 | `Database.Cassandra.Pack` for what you can use there out of the box. 40 | - You can choose how to encode/decode your column content. Out of the 41 | box, we support Show/Read, ToJSON/FromJSON, Serialize and SafeCopy. 42 | 43 | 44 | Example usage: JSON-encoded columns 45 | 46 | import Database.Cassandra.Marshall 47 | import Data.Aeson 48 | 49 | type Name = String 50 | type Age = Int 51 | data Person = Person Name Age 52 | 53 | -- Define JSON serialization for our data structure 54 | 55 | instance ToJSON Person where 56 | toJSON (Person nm age) = toJSON (nm,age) 57 | 58 | instance FromJSON Person where 59 | parseJSON v = do 60 | (nm, age) <- parseJSON v 61 | return $ Person nm age 62 | 63 | 64 | test :: Person -> IO () 65 | test p@(Person nm age) = do 66 | pool <- createCassandraPool defServers 3 300 "TestKeySpace" 67 | 68 | -- I can use any string-like key and don't have to explicitly 69 | -- convert person to ByteString. 70 | runCas pool $ insertCol casJSON "testCF" "people" nm QUORUM p 71 | 72 | -- Automatically de-serialized back to a datatype 73 | res <- runCas pool $ getCol casJSON "testCF" "people" nm QUORUM 74 | case res of 75 | Just (Person nm age) -> return age 76 | Nothing -> error "Oh NO!!!" 77 | 78 | ## Release Notes 79 | 80 | 81 | ### Version 0.7 82 | 83 | * We now use retry >= 0.4 and hence exceptions machinery instead of 84 | monad-control. 85 | 86 | ### Version 0.6 87 | 88 | * Updated to work with monad-control instead of MonadCatchIO. 89 | * Now using retry >= 0.3 for the same reason. 90 | * More CasType instances in Pack module for completeness. Preference 91 | is shifting to using native Haskell types directly. 92 | * `Database.Cassandra.JSON` module is now formally deprecated and will 93 | be removed in 0.7. Please switch to `Marshall`, which can replace it 94 | in entirety. 95 | 96 | ### Version 0.5 97 | 98 | * Added `Database.Cassandra.Marshall` that is now intended to be the 99 | primary module to be used in all Cassandra operations. This module 100 | supercedes and replaces the `Database.Cassandra.JSON` high level 101 | module. Building on top of the Basic module, Marshall allows user to 102 | pick the serialization methodology for each of the operations. We 103 | provide out of box support for JSON, cereal, safecopy and plain old 104 | show/read. 105 | * A new `TTimeStamp` type makes it easier to have timestamps as 106 | Long-encoded columns. 107 | * There is now simple support for pagination of columns in wide rows, 108 | CPS-style. See the `paginate` function in 109 | `Database.Cassandra.Marshall`. 110 | * Numerous other fixes and tweaks 111 | 112 | ### Version 0.4 113 | 114 | This version packs a fairly large changeset. It will almost definitely 115 | break your code, although the fix/adjustment is likely to be minor. 116 | 117 | * Vastly enhanced the Database.Cassandra.Pack module to represent 118 | types that Cassandra can sort and validate. 119 | * Added CasType typeclass that offers `encodeCas` and `decodeCas` 120 | methods that handle conversions to/from the binary ByteString 121 | representation. 122 | * Composite columns are now supported through tuples. Just pick two or 123 | more CasType instances and put them in a tuple to automatically 124 | trigger composite column conversion. Keep in mind that your 125 | ColumnFamily schema must be configured right or else you'll get 126 | runtime exceptions. 127 | * Added a bunch of newtype wrappers to directly map to types Cassandra 128 | knows. These include `TAscii`, `TBytes`, `TInt`, `TUtf8` and some 129 | others. 130 | * Changed several methods in Basic and JSON modules to expect CasType 131 | column key values instead of concrete ByteString. 132 | * Added the useful `packCol` and `unpackCol` functions to smoothly 133 | handle column key type conversions when working with the Basic 134 | module. 135 | * Made the Cas monad a simple type synonym for ReaderT CPool. 136 | * Added the `get_` metho to `JSON` to make it easier to discard key 137 | names and just get the column contents. 138 | * Numerous fixes and minor tweaks. 139 | 140 | 141 | ### Version 0.3 142 | 143 | * Added MonadCassandra typeclass, which is now used by *all* 144 | operations by default. 145 | * Added a default Cas moand that instantiates MonadCassandra for 146 | convenience. 147 | * All Basic module ops now return results directly instead of an 148 | Either wrapper. Each operation may raise a CassandraException. 149 | * Connection pooling now builds on top of the resource-pool library to 150 | initiate connections to multiple servers in round-robin fashion. 151 | * Basic.insert now knows how to insert a SuperColumn. 152 | 153 | 154 | ## TODOs 155 | 156 | * Add support for counters and batch mutators 157 | * Add support for database/admin operations 158 | 159 | ## Contributions 160 | 161 | Would love to get contributions, bug reports, suggestions, feedback 162 | from the community. 163 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cassy.cabal: -------------------------------------------------------------------------------- 1 | Name: cassy 2 | Version: 0.8 3 | Synopsis: A high level driver for the Cassandra datastore 4 | License: BSD3 5 | License-file: LICENSE 6 | Author: Ozgun Ataman 7 | Maintainer: ozataman@gmail.com 8 | Homepage: http://github.com/ozataman/cassy 9 | Category: Database 10 | Build-type: Simple 11 | description: 12 | The objective is to completely isolate away the thrift layer, providing 13 | a more idiomatic and naruall Haskell experience working with Cassandra. Be sure 14 | to check out the README on Github for some more explanation and 15 | Release Notes, which is helpful in talking about what this library 16 | can do. 17 | . 18 | Certain parts of the API was inspired by pycassa (Python client) and 19 | hscassandra (on Hackage). 20 | . 21 | Please see the Github repository for more detailed documentation, 22 | release notes and examples. 23 | . 24 | A brief explanation of modules: 25 | . 26 | * /Database.Cassandra.Basic/: Contains a low level, simple 27 | implementation of Cassandra interaction using the thrift API 28 | underneath. 29 | . 30 | * /Database.Cassandra.Marshall/: Intended to be the main high level 31 | module that you should use, Marshall allows you to pick the 32 | serialization strategy you would like to use at each function 33 | call. We recommend using 'casSafeCopy' due to its support for 34 | evolving data types, although casJSON maybe another popular 35 | choice. 36 | . 37 | * /Database.Cassandra.JSON/: (Now deprecated; use Marshall instead) 38 | A higher level API that operates on values with ToJSON and 39 | FromJSON isntances from the /aeson/ library. This module has in 40 | part been inspired by Bryan O\'Sullivan\'s /riak/ client for 41 | Haskell. 42 | . 43 | * /Database.Cassandra.Pool/: Handles a /pool/ of connections to 44 | multiple servers in a cluster, splitting the load among them. 45 | . 46 | * /Database.Cassandra.Pack/: Handles column types that Cassandra 47 | recognizes and adds support for Composite Columns. 48 | . 49 | * /Database.Cassandra.Types/: A common set of types used everywhere. 50 | . 51 | Potential TODOs include: 52 | . 53 | * Support for counters and batch mutators 54 | . 55 | * Support for database admin operations 56 | 57 | -- Extra-source-files: 58 | 59 | Cabal-version: >= 1.16 60 | 61 | Library 62 | default-language: Haskell2010 63 | hs-source-dirs: src 64 | Exposed-modules: 65 | Database.Cassandra.Basic 66 | Database.Cassandra.Marshall 67 | Database.Cassandra.JSON 68 | Database.Cassandra.Pool 69 | Database.Cassandra.Types 70 | Database.Cassandra.Pack 71 | 72 | Build-depends: 73 | base >= 4 && < 5 74 | , Thrift >= 0.6 75 | , aeson 76 | , async 77 | , attoparsec >= 0.10 && < 0.14 78 | , binary 79 | , bytestring 80 | , cassandra-thrift >= 0.8 81 | , cereal 82 | , conduit >= 1.1 && < 1.3 83 | , containers 84 | , data-default 85 | , errors 86 | , exceptions 87 | , mtl 88 | , network 89 | , resource-pool 90 | , retry >= 0.7 && < 0.8 91 | , safecopy 92 | , stm 93 | , syb 94 | , text 95 | , time 96 | , transformers-base 97 | 98 | 99 | test-suite test 100 | type: exitcode-stdio-1.0 101 | main-is: Test.hs 102 | ghc-options: -Wall 103 | hs-source-dirs: test 104 | Build-depends: 105 | base >= 4 && < 5 106 | , cassy 107 | , bytestring 108 | , text 109 | , Thrift 110 | , network 111 | , cassandra-thrift 112 | , time 113 | , containers 114 | 115 | , test-framework >= 0.6 116 | , test-framework-quickcheck2 >= 0.2.12.2 117 | , test-framework-hunit >= 0.2.7 118 | , QuickCheck 119 | , HUnit 120 | , derive 121 | -------------------------------------------------------------------------------- /runTests.sh: -------------------------------------------------------------------------------- 1 | cabal configure --enable-tests 2 | cabal build 3 | cabal test 4 | -------------------------------------------------------------------------------- /src/Database/Cassandra/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE PatternGuards #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | 12 | ----------------------------------------------------------------------------- 13 | -- | 14 | -- Module : Database.Cassandra.Basic 15 | -- Copyright : Ozgun Ataman 16 | -- License : BSD3 17 | -- 18 | -- Maintainer : Ozgun Ataman 19 | -- Stability : experimental 20 | -- 21 | -- Low-level functionality for working with Cassandra at the most 22 | -- basic level. 23 | ---------------------------------------------------------------------------- 24 | 25 | module Database.Cassandra.Basic 26 | 27 | ( 28 | 29 | -- * Connection 30 | CPool 31 | , Server 32 | , defServer 33 | , defServers 34 | , KeySpace 35 | , createCassandraPool 36 | 37 | -- * MonadCassandra Typeclass 38 | , MonadCassandra (..) 39 | , Cas (..) 40 | , runCas 41 | , transCas 42 | , mapCassandra 43 | 44 | -- * Cassandra Operations 45 | , getCol 46 | , get 47 | , getMulti 48 | , insert 49 | , delete 50 | 51 | -- * Retrying Queries 52 | , retryCas 53 | , casRetryH 54 | , networkRetryH 55 | 56 | -- * Filtering 57 | , Selector(..) 58 | , range 59 | , boundless 60 | , Order(..) 61 | , reverseOrder 62 | , KeySelector(..) 63 | , KeyRangeType(..) 64 | 65 | -- * Exceptions 66 | , CassandraException(..) 67 | 68 | -- * Utility 69 | , getTime 70 | , throwing 71 | , wrapException 72 | 73 | -- * Basic Types 74 | , ColumnFamily 75 | , Key 76 | , ColumnName 77 | , Value 78 | , Column(..) 79 | , col 80 | , packCol 81 | , unpackCol 82 | , packKey 83 | , Row 84 | , ConsistencyLevel(..) 85 | 86 | -- * Helpers 87 | , CKey (..) 88 | , fromColKey' 89 | 90 | -- * Cassandra Column Key Types 91 | , module Database.Cassandra.Pack 92 | 93 | ) where 94 | 95 | 96 | ------------------------------------------------------------------------------- 97 | import Control.Applicative 98 | import Control.Concurrent.Async 99 | import Control.Monad 100 | import Control.Monad.Catch 101 | import Control.Monad.Reader 102 | import Control.Retry as R 103 | import Data.ByteString.Lazy (ByteString) 104 | import Data.Map (Map) 105 | import qualified Data.Map as M 106 | import Data.Maybe (mapMaybe) 107 | import Data.Traversable (Traversable) 108 | import qualified Database.Cassandra.Thrift.Cassandra_Client as C 109 | import Database.Cassandra.Thrift.Cassandra_Types (ConsistencyLevel (..)) 110 | import qualified Database.Cassandra.Thrift.Cassandra_Types as T 111 | import Prelude hiding (catch) 112 | ------------------------------------------------------------------------------- 113 | import Database.Cassandra.Pack 114 | import Database.Cassandra.Pool 115 | import Database.Cassandra.Types 116 | ------------------------------------------------------------------------------- 117 | 118 | 119 | -- test = do 120 | -- pool <- createCassandraPool [("127.0.0.1", 9160)] 3 300 "Keyspace1" 121 | -- withResource pool $ \ Cassandra{..} -> do 122 | -- let cp = T.ColumnParent (Just "CF1") Nothing 123 | -- let sr = Just $ T.SliceRange (Just "") (Just "") (Just False) (Just 100) 124 | -- let ks = Just ["eben"] 125 | -- let sp = T.SlicePredicate Nothing sr 126 | -- C.get_slice (cProto, cProto) "darak" cp sp ONE 127 | -- flip runCas pool $ do 128 | -- get "CF1" "CF1" All ONE 129 | -- getCol "CF1" "darak" "eben" ONE 130 | -- insert "CF1" "test1" ONE [col "col1" "val1", col "col2" "val2"] 131 | -- get "CF1" "CF1" All ONE >>= liftIO . print 132 | -- get "CF1" "not here" All ONE >>= liftIO . print 133 | -- delete "CF1" "CF1" (ColNames ["col2"]) ONE 134 | -- get "CF1" "CF1" (Range Nothing Nothing Reversed 1) ONE >>= liftIO . putStrLn . show 135 | 136 | 137 | ------------------------------------------------------------------------------- 138 | -- | All Cassy operations are designed to run inside 'MonadCassandra' 139 | -- context. 140 | -- 141 | -- We provide a default concrete 'Cas' datatype, but you can simply 142 | -- make your own application monads an instance of 'MonadCassandra' 143 | -- for conveniently using all operations of this package. 144 | -- 145 | -- Please keep in mind that all Cassandra operations may raise 146 | -- 'CassandraException's at any point in time. 147 | class (MonadIO m) => MonadCassandra m where 148 | getCassandraPool :: m CPool 149 | 150 | 151 | ------------------------------------------------------------------------------- 152 | -- | Run a list of cassandra computations in parallel using the async library 153 | mapCassandra :: (Traversable t, MonadCassandra m) => t (Cas b) -> m (t b) 154 | mapCassandra ms = do 155 | cp <- getCassandraPool 156 | let f m = runCas cp m 157 | liftIO $ mapConcurrently f ms 158 | 159 | 160 | ------------------------------------------------------------------------------- 161 | withCassandraPool :: MonadCassandra m => (Cassandra -> IO b) -> m b 162 | withCassandraPool f = do 163 | p <- getCassandraPool 164 | liftIO $ withResource p f 165 | 166 | 167 | ------------------------------------------------------------------------------- 168 | type Cas a = ReaderT CPool IO a 169 | 170 | 171 | ------------------------------------------------------------------------------- 172 | -- | Main running function when using the ad-hoc Cas monad. Just write 173 | -- your cassandra actions within the 'Cas' monad and supply them with 174 | -- a 'CPool' to execute. 175 | runCas :: CPool -> Cas a -> IO a 176 | runCas = flip runReaderT 177 | 178 | 179 | -- | Unwrap a Cassandra action and return an IO continuation that can 180 | -- then be run in a pure IO context. 181 | -- 182 | -- This is useful when you design all your functions in a generic form 183 | -- with 'MonadCassandra' m constraints and then one day need to feed 184 | -- your function to a utility that can only run in an IO context. This 185 | -- function is then your friendly utility for extracting an IO action. 186 | transCas :: MonadCassandra m => Cas a -> m (IO a) 187 | transCas m = do 188 | cp <- getCassandraPool 189 | return $ runCas cp m 190 | 191 | 192 | ------------------------------------------------------------------------------- 193 | instance (MonadIO m) => MonadCassandra (ReaderT CPool m) where 194 | getCassandraPool = ask 195 | 196 | 197 | ------------------------------------------------------------------------------ 198 | -- | Get a single key-column value. 199 | getCol 200 | :: (MonadCassandra m, CasType k) 201 | => ColumnFamily 202 | -> ByteString 203 | -- ^ Row key 204 | -> k 205 | -- ^ Column/SuperColumn key; see 'CasType' for what it can be. Use 206 | -- ByteString in the simple case. 207 | -> ConsistencyLevel 208 | -- ^ Read quorum 209 | -> m (Maybe Column) 210 | getCol cf k cn cl = do 211 | res <- get cf k (ColNames [encodeCas cn]) cl 212 | case res of 213 | [] -> return Nothing 214 | x:_ -> return $ Just x 215 | 216 | 217 | ------------------------------------------------------------------------------ 218 | -- | An arbitrary get operation - slice with 'Selector' 219 | get 220 | :: (MonadCassandra m) 221 | => ColumnFamily 222 | -- ^ in ColumnFamily 223 | -> ByteString 224 | -- ^ Row key to get 225 | -> Selector 226 | -- ^ Slice columns with selector 227 | -> ConsistencyLevel 228 | -> m [Column] 229 | get cf k s cl = withCassandraPool $ \ Cassandra{..} -> do 230 | res <- wrapException $ C.get_slice (cProto, cProto) k cp (mkPredicate s) cl 231 | throwing . return $ mapM castColumn res 232 | where 233 | cp = T.ColumnParent (Just cf) Nothing 234 | 235 | 236 | ------------------------------------------------------------------------------ 237 | -- | Do multiple 'get's in one DB hit 238 | getMulti 239 | :: (MonadCassandra m) 240 | => ColumnFamily 241 | -> KeySelector 242 | -- ^ A selection of rows to fetch in one hit 243 | -> Selector 244 | -- ^ Subject to column selector conditions 245 | -> ConsistencyLevel 246 | -> m (Map ByteString Row) 247 | -- ^ A Map from Row keys to 'Row's is returned 248 | getMulti cf ks s cl = withCassandraPool $ \ Cassandra{..} -> do 249 | case ks of 250 | Keys xs -> do 251 | res <- wrapException $ C.multiget_slice (cProto, cProto) xs cp (mkPredicate s) cl 252 | return $ M.mapMaybe f res 253 | KeyRange {} -> do 254 | res <- wrapException $ 255 | C.get_range_slices (cProto, cProto) cp (mkPredicate s) (mkKeyRange ks) cl 256 | return $ collectKeySlices res 257 | where 258 | collectKeySlices :: [T.KeySlice] -> Map ByteString Row 259 | collectKeySlices xs = M.fromList $ mapMaybe collectKeySlice xs 260 | 261 | collectKeySlice (T.KeySlice (Just k) (Just xs)) = 262 | case mapM castColumn xs of 263 | Left _ -> Nothing 264 | Right xs' -> Just (k, xs') 265 | collectKeySlice _ = Nothing 266 | 267 | cp = T.ColumnParent (Just cf) Nothing 268 | f xs = 269 | case mapM castColumn xs of 270 | Left _ -> Nothing 271 | Right xs' -> Just xs' 272 | 273 | 274 | ------------------------------------------------------------------------------ 275 | -- | Insert an entire row into the db. 276 | -- 277 | -- This will do as many round-trips as necessary to insert the full 278 | -- row. Please keep in mind that each column and each column of each 279 | -- super-column is sent to the server one by one. 280 | -- 281 | -- > insert "testCF" "row1" ONE [packCol ("column key", "some column content")] 282 | insert 283 | :: (MonadCassandra m) 284 | => ColumnFamily 285 | -> ByteString 286 | -- ^ Row key 287 | -> ConsistencyLevel 288 | -> [Column] 289 | -- ^ best way to make these columns is through "packCol" 290 | -> m () 291 | insert cf k cl row = withCassandraPool $ \ Cassandra{..} -> do 292 | let insCol cp c = do 293 | c' <- mkThriftCol c 294 | wrapException $ C.insert (cProto, cProto) k cp c' cl 295 | forM_ row $ \ c -> do 296 | case c of 297 | Column{} -> do 298 | let cp = T.ColumnParent (Just cf) Nothing 299 | insCol cp c 300 | SuperColumn cn cols -> do 301 | let cp = T.ColumnParent (Just cf) (Just cn) 302 | mapM_ (insCol cp) cols 303 | 304 | 305 | ------------------------------------------------------------------------------- 306 | -- | Pack key-value pair into 'Column' form ready to be written to Cassandra 307 | packCol :: CasType k => (k, ByteString) -> Column 308 | packCol (k, v) = col (packKey k) v 309 | 310 | 311 | ------------------------------------------------------------------------------- 312 | -- | Unpack a Cassandra 'Column' into a more convenient (k,v) form 313 | unpackCol :: CasType k => Column -> (k, Value) 314 | unpackCol (Column k v _ _) = (decodeCas k, v) 315 | unpackCol _ = error "unpackcol unimplemented for SuperColumn types" 316 | 317 | 318 | ------------------------------------------------------------------------------- 319 | -- | Pack a column key into binary, ready for submission to Cassandra 320 | packKey :: CasType a => a -> ByteString 321 | packKey = encodeCas 322 | 323 | ------------------------------------------------------------------------------ 324 | -- | Delete an entire row, specific columns or a specific sub-set of columns 325 | -- within a SuperColumn. 326 | delete 327 | :: (MonadCassandra m) 328 | => ColumnFamily 329 | -- ^ In 'ColumnFamily' 330 | -> Key 331 | -- ^ Key to be deleted 332 | -> Selector 333 | -- ^ Columns to be deleted 334 | -> ConsistencyLevel 335 | -> m () 336 | delete cf k s cl = withCassandraPool $ \ Cassandra {..} -> do 337 | now <- getTime 338 | wrapException $ case s of 339 | All -> C.remove (cProto, cProto) k cpAll now cl 340 | ColNames cs -> forM_ cs $ \c -> do 341 | C.remove (cProto, cProto) k (cpCol c) now cl 342 | SupNames sn cs -> forM_ cs $ \c -> do 343 | C.remove (cProto, cProto) k (cpSCol sn c) now cl 344 | Range{} -> error "delete: Range delete not implemented" 345 | where 346 | -- wipe out the entire row 347 | cpAll = T.ColumnPath (Just cf) Nothing Nothing 348 | 349 | -- just a single column 350 | cpCol name = T.ColumnPath (Just cf) Nothing (Just (encodeCas name)) 351 | 352 | -- scope column by supercol 353 | cpSCol sc name = T.ColumnPath (Just cf) (Just (encodeCas sc)) (Just (encodeCas name)) 354 | 355 | 356 | 357 | ------------------------------------------------------------------------------ 358 | -- | Wrap exceptions of the underlying thrift library into the 359 | -- exception types defined here. 360 | wrapException :: IO a -> IO a 361 | wrapException a = f 362 | where 363 | f = a 364 | `catch` (\ (T.NotFoundException) -> throwM NotFoundException) 365 | `catch` (\ (T.InvalidRequestException e) -> 366 | throwM . InvalidRequestException $ maybe "" id e) 367 | `catch` (\ T.UnavailableException -> throwM UnavailableException) 368 | `catch` (\ T.TimedOutException -> throwM TimedOutException) 369 | `catch` (\ (T.AuthenticationException e) -> 370 | throwM . AuthenticationException $ maybe "" id e) 371 | `catch` (\ (T.AuthorizationException e) -> 372 | throwM . AuthorizationException $ maybe "" id e) 373 | `catch` (\ T.SchemaDisagreementException -> throwM SchemaDisagreementException) 374 | 375 | 376 | ------------------------------------------------------------------------------- 377 | -- | Make exceptions implicit. 378 | throwing :: IO (Either CassandraException a) -> IO a 379 | throwing f = do 380 | res <- f 381 | case res of 382 | Left e -> throwM e 383 | Right a -> return a 384 | 385 | 386 | -- | 'retrying' with direct cassandra support. Server-related failures 387 | -- will be retried. 388 | -- 389 | -- 'UnavailableException', 'TimedOutException' and 390 | -- 'SchemaDisagreementException' will be automatically retried. 391 | retryCas :: (MonadMask m, MonadIO m) 392 | => RetryPolicy 393 | -- ^ For default settings, just use 'def' 394 | -> m a 395 | -- ^ Action to perform 396 | -> m a 397 | retryCas set f = R.recovering set [casRetryH, networkRetryH] (const f) 398 | -------------------------------------------------------------------------------- /src/Database/Cassandra/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternGuards #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Database.Cassandra.JSON 12 | -- Copyright : Ozgun Ataman 13 | -- License : BSD3 14 | -- 15 | -- Maintainer : Ozgun Ataman 16 | -- Stability : experimental 17 | -- 18 | -- This module has been deprecated and will be removed in version 0.7. 19 | -- Every bit of functionality here is also available in the 20 | -- Database.Cassandra.Marshall module, which is what you should use instead. 21 | ---------------------------------------------------------------------------- 22 | 23 | module Database.Cassandra.JSON 24 | ( 25 | 26 | -- * Connection 27 | CPool 28 | , Server 29 | , defServer 30 | , defServers 31 | , KeySpace 32 | , createCassandraPool 33 | 34 | -- * MonadCassandra Typeclass 35 | , MonadCassandra (..) 36 | , Cas 37 | , runCas 38 | , transCas 39 | , mapCassandra 40 | 41 | -- * Cassandra Operations 42 | , get 43 | , get_ 44 | , getCol 45 | , getMulti 46 | , insertCol 47 | , insertColTTL 48 | , modify 49 | , modify_ 50 | , delete 51 | 52 | -- * Necessary Types 53 | , RowKey 54 | , ColumnName 55 | , ModifyOperation (..) 56 | , ColumnFamily 57 | , ConsistencyLevel (..) 58 | , CassandraException (..) 59 | 60 | -- * Filtering 61 | , Selector (..) 62 | , range 63 | , boundless 64 | , Order(..) 65 | , reverseOrder 66 | , KeySelector (..) 67 | , KeyRangeType (..) 68 | 69 | -- * Helpers 70 | , CKey (..) 71 | , fromColKey' 72 | 73 | -- * Cassandra Column Key Types 74 | , module Database.Cassandra.Pack 75 | 76 | ) where 77 | 78 | ------------------------------------------------------------------------------- 79 | import Control.Exception 80 | import Control.Monad 81 | import Data.Aeson as A 82 | import Data.Aeson.Parser (value) 83 | import qualified Data.Attoparsec as Atto (IResult (..), parse) 84 | import qualified Data.ByteString.Char8 as B 85 | import Data.ByteString.Lazy.Char8 (ByteString) 86 | import qualified Data.ByteString.Lazy.Char8 as LB 87 | import Data.Int (Int32) 88 | import Data.Map (Map) 89 | import qualified Data.Map as M 90 | import Prelude hiding (catch) 91 | ------------------------------------------------------------------------------- 92 | import Database.Cassandra.Basic hiding (KeySelector (..), delete, 93 | get, getCol, getMulti) 94 | import qualified Database.Cassandra.Basic as CB 95 | import Database.Cassandra.Pack 96 | ------------------------------------------------------------------------------- 97 | 98 | 99 | 100 | ------------------------------------------------------------------------------- 101 | -- | Convert regular column to a key-value pair 102 | col2val :: (FromJSON a, CasType k) => Column -> (k, a) 103 | col2val c = f $ unpackCol c 104 | where 105 | f (k, val) = (k, maybe err id $ unMarshallJSON' val) 106 | err = error "Value can't be parsed from JSON." 107 | col2val _ = error "col2val is not implemented for SuperColumns" 108 | 109 | 110 | 111 | ------------------------------------------------------------------------------ 112 | -- | Possible outcomes of a modify operation 113 | data ModifyOperation a = 114 | Update a 115 | | Delete 116 | | DoNothing 117 | deriving (Eq,Show,Ord,Read) 118 | 119 | 120 | ------------------------------------------------------------------------------- 121 | type RowKey = ByteString 122 | 123 | 124 | ------------------------------------------------------------------------------ 125 | -- | A modify function that will fetch a specific column, apply modification 126 | -- function on it and save results back to Cassandra. 127 | -- 128 | -- A 'b' side value is returned for computational convenience. 129 | -- 130 | -- This is intended to be a workhorse function, in that you should be 131 | -- able to do all kinds of relatively straightforward operations just 132 | -- using this function. 133 | -- 134 | -- This method may throw a 'CassandraException' for all exceptions other than 135 | -- 'NotFoundException'. 136 | modify 137 | :: (MonadCassandra m, ToJSON a, FromJSON a, CasType k) 138 | => ColumnFamily 139 | -> RowKey 140 | -> k 141 | -- ^ Column name; anything in CasType 142 | -> ConsistencyLevel 143 | -- ^ Read quorum 144 | -> ConsistencyLevel 145 | -- ^ Write quorum 146 | -> (Maybe a -> m (ModifyOperation a, b)) 147 | -- ^ Modification function. Called with 'Just' the value if present, 148 | -- 'Nothing' otherwise. 149 | -> m b 150 | -- ^ Return the decided 'ModifyOperation' and its execution outcome 151 | modify cf k cn rcl wcl f = 152 | let 153 | cn' = encodeCas cn 154 | execF prev = do 155 | (fres, b) <- f prev 156 | case fres of 157 | Update a -> insert cf k wcl [col cn' (marshallJSON' a)] 158 | Delete -> CB.delete cf k (ColNames [cn']) wcl 159 | DoNothing -> return () 160 | return b 161 | in do 162 | res <- CB.getCol cf k cn' rcl 163 | case res of 164 | Nothing -> execF Nothing 165 | Just Column{..} -> execF (unMarshallJSON' colVal) 166 | Just SuperColumn{} -> throw $ 167 | OperationNotSupported "modify not implemented for SuperColumn" 168 | 169 | 170 | ------------------------------------------------------------------------------ 171 | -- | Same as 'modify' but does not offer a side value. 172 | -- 173 | -- This method may throw a 'CassandraException' for all exceptions other than 174 | -- 'NotFoundException'. 175 | modify_ 176 | :: (MonadCassandra m, ToJSON a, FromJSON a, CasType k) 177 | => ColumnFamily 178 | -> RowKey 179 | -> k 180 | -- ^ Column name; anything in CasType 181 | -> ConsistencyLevel 182 | -- ^ Read quorum 183 | -> ConsistencyLevel 184 | -- ^ Write quorum 185 | -> (Maybe a -> m (ModifyOperation a)) 186 | -- ^ Modification function. Called with 'Just' the value if present, 187 | -- 'Nothing' otherwise. 188 | -> m () 189 | modify_ cf k cn rcl wcl f = 190 | let 191 | f' prev = do 192 | op <- f prev 193 | return (op, ()) 194 | in do 195 | modify cf k cn rcl wcl f' 196 | return () 197 | 198 | 199 | ------------------------------------------------------------------------------- 200 | -- Simple insertion function making use of typeclasses 201 | insertCol 202 | :: (MonadCassandra m, ToJSON a, CasType k) 203 | => ColumnFamily 204 | -> RowKey 205 | -> k 206 | -- ^ Column name. See 'CasType' for what you can use here. 207 | -> ConsistencyLevel 208 | -> a -- ^ Content 209 | -> m () 210 | insertCol cf rk cn cl a = 211 | insert cf rk cl [packCol (cn, marshallJSON' a)] 212 | 213 | 214 | 215 | ------------------------------------------------------------------------------- 216 | -- Simple insertion function making use of typeclasses 217 | insertColTTL 218 | :: (MonadCassandra m, ToJSON a, CasType k) 219 | => ColumnFamily 220 | -> RowKey 221 | -> k 222 | -- ^ Column name. See 'CasType' for what you can use here. 223 | -> ConsistencyLevel 224 | -> a 225 | -- ^ Content 226 | -> Int32 227 | -- ^ TTL for this column 228 | -> m () 229 | insertColTTL cf rk cn cl a ttl = insert cf rk cl [column] 230 | where 231 | column = Column (packKey cn) (marshallJSON' a) Nothing (Just ttl) 232 | 233 | 234 | ------------------------------------------------------------------------------ 235 | -- | An arbitrary get operation - slice with 'Selector'. 236 | -- 237 | -- Internally based on Basic.get. Table is assumed to be a regular 238 | -- ColumnFamily and contents of returned columns are cast into the 239 | -- target type. 240 | get 241 | :: (MonadCassandra m, FromJSON a, CasType k) 242 | => ColumnFamily 243 | -> RowKey 244 | -> Selector 245 | -- ^ A slice selector 246 | -> ConsistencyLevel 247 | -> m [(k, a)] 248 | -- ^ List of key-value pairs. See 'CasType' for what key types you can use. 249 | get cf k s cl = do 250 | res <- CB.get cf k s cl 251 | return $ map col2val res 252 | 253 | 254 | ------------------------------------------------------------------------------- 255 | -- | A version of 'get' that discards the column names for the common 256 | -- scenario. Useful because you would otherwise be forced to manually 257 | -- supply type signatures to get rid of the 'CasType' ambiguity. 258 | get_ 259 | :: (MonadCassandra m, FromJSON a) 260 | => ColumnFamily 261 | -> RowKey 262 | -> Selector 263 | -- ^ A slice selector 264 | -> ConsistencyLevel 265 | -> m [a] 266 | get_ cf k s cl = do 267 | (res :: [(LB.ByteString, a)]) <- get cf k s cl 268 | return $ map snd res 269 | 270 | 271 | ------------------------------------------------------------------------------- 272 | data KeySelector 273 | = Keys [RowKey] 274 | | KeyRange KeyRangeType RowKey RowKey Int32 275 | 276 | 277 | ------------------------------------------------------------------------------- 278 | ksToBasicKS :: KeySelector -> CB.KeySelector 279 | ksToBasicKS (Keys k) = CB.Keys $ map toColKey k 280 | ksToBasicKS (KeyRange ty fr to i) = CB.KeyRange ty (toColKey fr) (toColKey to) i 281 | 282 | 283 | ------------------------------------------------------------------------------- 284 | -- | Get a slice of columns from multiple rows at once. Note that 285 | -- since we are auto-serializing from JSON, all the columns must be of 286 | -- the same data type. 287 | getMulti 288 | :: (MonadCassandra m, FromJSON a) 289 | => ColumnFamily 290 | -> KeySelector 291 | -> Selector 292 | -> ConsistencyLevel 293 | -> m (Map RowKey [(ColumnName, a)]) 294 | getMulti cf ks s cl = do 295 | res <- CB.getMulti cf (ksToBasicKS ks) s cl 296 | return . M.fromList . map conv . M.toList $ res 297 | where 298 | conv (k, row) = (k, map col2val row) 299 | 300 | 301 | ------------------------------------------------------------------------------- 302 | -- | Get a single column from a single row 303 | getCol 304 | :: (MonadCassandra m, FromJSON a, CasType k) 305 | => ColumnFamily 306 | -> RowKey 307 | -> k 308 | -- ^ Column name; anything in 'CasType' 309 | -> ConsistencyLevel 310 | -> m (Maybe a) 311 | getCol cf rk ck cl = do 312 | res <- CB.getCol cf rk (encodeCas ck) cl 313 | case res of 314 | Nothing -> return Nothing 315 | Just res' -> do 316 | let (_ :: ByteString, x) = col2val res' 317 | return $ Just x 318 | 319 | 320 | ------------------------------------------------------------------------------ 321 | -- | Same as the 'delete' in the 'Cassandra.Basic' module, except that 322 | -- it throws an exception rather than returning an explicit Either 323 | -- value. 324 | delete 325 | :: (MonadCassandra m) 326 | =>ColumnFamily 327 | -- ^ In 'ColumnFamily' 328 | -> RowKey 329 | -- ^ Key to be deleted 330 | -> Selector 331 | -- ^ Columns to be deleted 332 | -> ConsistencyLevel 333 | -> m () 334 | delete cf k s cl = CB.delete cf k s cl 335 | 336 | 337 | ------------------------------------------------------------------------------ 338 | -- | Lazy 'marshallJSON' 339 | marshallJSON' :: ToJSON a => a -> ByteString 340 | marshallJSON' = LB.fromChunks . return . marshallJSON 341 | 342 | 343 | ------------------------------------------------------------------------------ 344 | -- | Encode JSON 345 | marshallJSON :: ToJSON a => a -> B.ByteString 346 | marshallJSON = B.concat . LB.toChunks . A.encode 347 | 348 | 349 | ------------------------------------------------------------------------------ 350 | -- | Lazy 'unMarshallJSON' 351 | unMarshallJSON' :: FromJSON a => ByteString -> Maybe a 352 | unMarshallJSON' = unMarshallJSON . B.concat . LB.toChunks 353 | 354 | 355 | ------------------------------------------------------------------------------ 356 | -- | Decode JSON 357 | unMarshallJSON :: FromJSON a => B.ByteString -> Maybe a 358 | unMarshallJSON = pJson 359 | where 360 | pJson bs = val 361 | where 362 | js = Atto.parse value bs 363 | val = case js of 364 | Atto.Done _ r -> case fromJSON r of 365 | Error e -> error $ "JSON err: " ++ show e 366 | Success a -> a 367 | _ -> Nothing 368 | -------------------------------------------------------------------------------- /src/Database/Cassandra/Marshall.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE PatternGuards #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | 13 | 14 | ----------------------------------------------------------------------------- 15 | -- | 16 | -- Module : 17 | -- Copyright : (C) 2013 Ozgun Ataman 18 | -- License : All Rights Reserved 19 | -- 20 | -- Maintainer : Ozgun Ataman 21 | -- Stability : experimental 22 | -- 23 | -- Defines Cassandra operations for persistence of complex Haskell 24 | -- data objects with custom-selected but implicitly performed 25 | -- serialization. 26 | -- 27 | -- The main design choice is to require a dictionary dictating 28 | -- marshalling/serialization policy for every operation, rather than a 29 | -- typeclass that can be instantiated once. 30 | ---------------------------------------------------------------------------- 31 | 32 | module Database.Cassandra.Marshall 33 | ( 34 | 35 | -- * Connection 36 | CPool 37 | , Server 38 | , defServer 39 | , defServers 40 | , KeySpace 41 | , createCassandraPool 42 | 43 | -- * MonadCassandra Typeclass 44 | , MonadCassandra (..) 45 | , Cas 46 | , runCas 47 | , transCas 48 | , mapCassandra 49 | 50 | -- * Haskell Record Marshalling 51 | 52 | , Marshall (..) 53 | , casShow 54 | , casJSON 55 | -- , casBinary 56 | , casSerialize 57 | , casSafeCopy 58 | 59 | -- * Cassandra Operations 60 | , get 61 | , get_ 62 | , getCol 63 | , getMulti 64 | , insertCol 65 | , insertColTTL 66 | , modify 67 | , modify_ 68 | , delete 69 | 70 | -- * Retrying Queries 71 | , CB.retryCas 72 | , casRetryH 73 | 74 | -- * Necessary Types 75 | , RowKey 76 | , ColumnName 77 | , ModifyOperation (..) 78 | , ColumnFamily 79 | , ConsistencyLevel (..) 80 | , CassandraException (..) 81 | 82 | -- * Filtering 83 | , Selector (..) 84 | , range 85 | , boundless 86 | , Order(..) 87 | , reverseOrder 88 | , KeySelector (..) 89 | , KeyRangeType (..) 90 | 91 | 92 | -- * Pagination 93 | , PageResult (..) 94 | , pIsDry 95 | , pIsDone 96 | , pHasMore 97 | , paginate 98 | , paginateSource 99 | , pageToSource 100 | 101 | -- * Helpers 102 | , CKey (..) 103 | , fromColKey' 104 | 105 | -- * Cassandra Column Key Types 106 | , module Database.Cassandra.Pack 107 | ) where 108 | 109 | ------------------------------------------------------------------------------- 110 | import Control.Error 111 | import Control.Monad 112 | import Control.Monad.Catch 113 | import Control.Monad.Trans 114 | import Control.Retry as R 115 | import qualified Data.Aeson as A 116 | import Data.ByteString.Lazy.Char8 (ByteString) 117 | import qualified Data.ByteString.Lazy.Char8 as LB 118 | import Data.Conduit 119 | import qualified Data.Conduit.List as C 120 | import Data.Int (Int32) 121 | import Data.Map (Map) 122 | import qualified Data.Map as M 123 | import qualified Data.SafeCopy as SC 124 | import qualified Data.Serialize as SL 125 | import Prelude 126 | ------------------------------------------------------------------------------- 127 | import Database.Cassandra.Basic hiding (KeySelector (..), delete, 128 | get, getCol, getMulti) 129 | import qualified Database.Cassandra.Basic as CB 130 | import Database.Cassandra.Pack 131 | import Database.Cassandra.Types 132 | ------------------------------------------------------------------------------- 133 | 134 | 135 | -- | A Haskell dictionary containing a pair of encode/decode 136 | -- functions. 137 | -- 138 | -- This is the main design choice in this module. We require that each 139 | -- operation takes an explicit marshalling policy rather than a 140 | -- typeclass which makes it possible to do it in a single way per data 141 | -- type. 142 | -- 143 | -- You can create your own objects of this type with great ease. Just 144 | -- look at one of the examples here ('casJSON', 'casSerialize', etc.) 145 | data Marshall a = Marshall { 146 | marshallEncode :: a -> ByteString 147 | -- ^ An encoding function 148 | , marshallDecode :: ByteString -> Either String a 149 | -- ^ A decoding function 150 | } 151 | 152 | 153 | -- | Marshall data using JSON encoding. Good interoperability, but not 154 | -- very efficient for data storage. 155 | casJSON :: (A.ToJSON a, A.FromJSON a) => Marshall a 156 | casJSON = Marshall A.encode A.eitherDecode 157 | 158 | 159 | -- | Marshall data using 'Show' and 'Read'. Not meant for serious production cases. 160 | casShow :: (Show a, Read a) => Marshall a 161 | casShow = Marshall 162 | (LB.pack . show) 163 | (readErr "casShow can't read cassandra value" . LB.unpack) 164 | 165 | 166 | -- -- | Marshall data using the 'Binary' instance. This is one of the 167 | -- -- efficient methods available. 168 | -- casBinary :: BN.Binary a => Marshall a 169 | -- casBinary = Marshall BN.encode dec 170 | -- where 171 | -- dec bs = case BN.runGetOrFail BN.get bs of 172 | -- Left (_,_,err) -> Left err 173 | -- Right (_,_,a) -> Right a 174 | 175 | 176 | -- | Marshall data using the 'SafeCopy' instance. This is quite well 177 | -- suited for production because it is both very efficient and 178 | -- provides a systematic way to migrate your data types over time. 179 | casSafeCopy :: SC.SafeCopy a => Marshall a 180 | casSafeCopy = Marshall (SL.runPutLazy . SC.safePut) (SL.runGetLazy SC.safeGet) 181 | 182 | 183 | -- | Marshall data using the 'Serialize' instance. Like 'Binary', 184 | -- 'Serialize' is very efficient. 185 | casSerialize :: SL.Serialize a => Marshall a 186 | casSerialize = Marshall SL.encodeLazy SL.decodeLazy 187 | 188 | 189 | ------------------------------------------------------------------------------ 190 | -- | A modify function that will fetch a specific column, apply modification 191 | -- function on it and save results back to Cassandra. 192 | -- 193 | -- A 'b' side value is returned for computational convenience. 194 | -- 195 | -- This is intended to be a workhorse function, in that you should be 196 | -- able to do all kinds of relatively straightforward operations just 197 | -- using this function. 198 | -- 199 | -- This method may throw a 'CassandraException' for all exceptions other than 200 | -- 'NotFoundException'. 201 | modify 202 | :: (MonadCassandra m, MonadThrow m, CasType k) 203 | => Marshall a 204 | -- ^ A serialization methodology. Example: 'casJSON' 205 | -> ColumnFamily 206 | -> RowKey 207 | -> k 208 | -- ^ Column name; anything in CasType 209 | -> ConsistencyLevel 210 | -- ^ Read quorum 211 | -> ConsistencyLevel 212 | -- ^ Write quorum 213 | -> (Maybe a -> m (ModifyOperation a, b)) 214 | -- ^ Modification function. Called with 'Just' the value if present, 215 | -- 'Nothing' otherwise. 216 | -> m b 217 | -- ^ Return the decided 'ModifyOperation' and its execution outcome 218 | modify Marshall{..} cf k cn rcl wcl f = 219 | let 220 | cn' = encodeCas cn 221 | execF prev = do 222 | (fres, b) <- f prev 223 | case fres of 224 | Update a -> insert cf k wcl [col cn' (marshallEncode a)] 225 | Delete -> CB.delete cf k (ColNames [cn']) wcl 226 | DoNothing -> return () 227 | return b 228 | in do 229 | res <- CB.getCol cf k cn' rcl 230 | case res of 231 | Nothing -> execF Nothing 232 | Just Column{..} -> execF (hush $ marshallDecode colVal) 233 | Just SuperColumn{} -> throwM $ 234 | OperationNotSupported "modify not implemented for SuperColumn" 235 | 236 | 237 | ------------------------------------------------------------------------------ 238 | -- | Same as 'modify' but does not offer a side value. 239 | -- 240 | -- This method may throw a 'CassandraException' for all exceptions other than 241 | -- 'NotFoundException'. 242 | modify_ 243 | :: (MonadCassandra m, CasType k, MonadThrow m) 244 | => Marshall a 245 | -> ColumnFamily 246 | -> RowKey 247 | -> k 248 | -- ^ Column name; anything in CasType 249 | -> ConsistencyLevel 250 | -- ^ Read quorum 251 | -> ConsistencyLevel 252 | -- ^ Write quorum 253 | -> (Maybe a -> m (ModifyOperation a)) 254 | -- ^ Modification function. Called with 'Just' the value if present, 255 | -- 'Nothing' otherwise. 256 | -> m () 257 | modify_ m cf k cn rcl wcl f = 258 | let 259 | f' prev = do 260 | op <- f prev 261 | return (op, ()) 262 | in do 263 | modify m cf k cn rcl wcl f' 264 | return () 265 | 266 | 267 | ------------------------------------------------------------------------------- 268 | -- Simple insertion function making use of typeclasses 269 | insertCol 270 | :: (MonadCassandra m, CasType k) 271 | => Marshall a 272 | -> ColumnFamily 273 | -> RowKey 274 | -> k 275 | -- ^ Column name. See 'CasType' for what you can use here. 276 | -> ConsistencyLevel 277 | -> a -- ^ Content 278 | -> m () 279 | insertCol Marshall{..} cf rk cn cl a = 280 | insert cf rk cl [packCol (cn, marshallEncode a)] 281 | 282 | 283 | 284 | ------------------------------------------------------------------------------- 285 | -- Simple insertion function making use of typeclasses 286 | insertColTTL 287 | :: (MonadCassandra m, CasType k) 288 | => Marshall a 289 | -> ColumnFamily 290 | -> RowKey 291 | -> k 292 | -- ^ Column name. See 'CasType' for what you can use here. 293 | -> ConsistencyLevel 294 | -> a 295 | -- ^ Content 296 | -> Int32 297 | -- ^ TTL for this column 298 | -> m () 299 | insertColTTL Marshall{..} cf rk cn cl a ttl = insert cf rk cl [column] 300 | where 301 | column = Column (packKey cn) (marshallEncode a) Nothing (Just ttl) 302 | 303 | 304 | ------------------------------------------------------------------------------ 305 | -- | An arbitrary get operation - slice with 'Selector'. 306 | -- 307 | -- Internally based on Basic.get. Table is assumed to be a regular 308 | -- ColumnFamily and contents of returned columns are cast into the 309 | -- target type. 310 | get 311 | :: (MonadCassandra m, CasType k) 312 | => Marshall a 313 | -> ColumnFamily 314 | -> RowKey 315 | -> Selector 316 | -- ^ A slice selector 317 | -> ConsistencyLevel 318 | -> m [(k, a)] 319 | -- ^ List of key-value pairs. See 'CasType' for what key types you can use. 320 | get m cf k s cl = do 321 | res <- CB.get cf k s cl 322 | return $ map (col2val m) res 323 | 324 | 325 | ------------------------------------------------------------------------------- 326 | -- | A version of 'get' that discards the column names for the common 327 | -- scenario. Useful because you would otherwise be forced to manually 328 | -- supply type signatures to get rid of the 'CasType' ambiguity. 329 | get_ 330 | :: (MonadCassandra m) 331 | => Marshall a 332 | -> ColumnFamily 333 | -> RowKey 334 | -> Selector 335 | -- ^ A slice selector 336 | -> ConsistencyLevel 337 | -> m [a] 338 | get_ m cf k s cl = do 339 | (res :: [(LB.ByteString, a)]) <- get m cf k s cl 340 | return $ map snd res 341 | 342 | 343 | ------------------------------------------------------------------------------- 344 | ksToBasicKS :: KeySelector -> CB.KeySelector 345 | ksToBasicKS (Keys k) = CB.Keys $ map toColKey k 346 | ksToBasicKS (KeyRange ty fr to i) = CB.KeyRange ty (toColKey fr) (toColKey to) i 347 | 348 | 349 | ------------------------------------------------------------------------------- 350 | -- | Get a slice of columns from multiple rows at once. Note that 351 | -- since we are auto-serializing from JSON, all the columns must be of 352 | -- the same data type. 353 | getMulti 354 | :: (MonadCassandra m) 355 | => Marshall a 356 | -> ColumnFamily 357 | -> KeySelector 358 | -> Selector 359 | -> ConsistencyLevel 360 | -> m (Map RowKey [(ColumnName, a)]) 361 | getMulti m cf ks s cl = do 362 | res <- CB.getMulti cf (ksToBasicKS ks) s cl 363 | return . M.fromList . map conv . M.toList $ res 364 | where 365 | conv (k, row) = (k, map (col2val m) row) 366 | 367 | 368 | ------------------------------------------------------------------------------- 369 | -- | Get a single column from a single row 370 | getCol 371 | :: (MonadCassandra m, CasType k) 372 | => Marshall a 373 | -> ColumnFamily 374 | -> RowKey 375 | -> k 376 | -- ^ Column name; anything in 'CasType' 377 | -> ConsistencyLevel 378 | -> m (Maybe a) 379 | getCol m cf rk ck cl = do 380 | res <- CB.getCol cf rk (encodeCas ck) cl 381 | case res of 382 | Nothing -> return Nothing 383 | Just res' -> do 384 | let (_ :: ByteString, x) = col2val m res' 385 | return $ Just x 386 | 387 | 388 | ------------------------------------------------------------------------------ 389 | -- | Same as the 'delete' in the 'Cassandra.Basic' module, except that 390 | -- it throws an exception rather than returning an explicit Either 391 | -- value. 392 | delete 393 | :: (MonadCassandra m) 394 | => ColumnFamily 395 | -- ^ In 'ColumnFamily' 396 | -> RowKey 397 | -- ^ Key to be deleted 398 | -> Selector 399 | -- ^ Columns to be deleted 400 | -> ConsistencyLevel 401 | -> m () 402 | delete cf k s cl = CB.delete cf k s cl 403 | 404 | 405 | ------------------------------------------------------------------------------- 406 | -- | Convert regular column to a key-value pair 407 | col2val :: CasType k => Marshall a -> Column -> (k, a) 408 | col2val Marshall{..} c = f $ unpackCol c 409 | where 410 | f (k, val) = (k, either err id $ marshallDecode val) 411 | err s = error $ "Cassandra Marshall: Value can't be decoded: " ++ s 412 | col2val _ _ = error "col2val is not implemented for SuperColumns" 413 | 414 | 415 | 416 | ------------------------------------------------------------------------------- 417 | -- | Paginate over columns in a given key, repeatedly applying the 418 | -- given 'Selector'. The 'Selector' must be a 'Range' selector, or 419 | -- else this funtion will raise an exception. 420 | paginate 421 | :: (MonadCassandra m, MonadMask m, CasType k) 422 | => Marshall a 423 | -- ^ Serialization strategy 424 | -> ColumnFamily 425 | -> RowKey 426 | -- ^ Paginate columns of this row 427 | -> Selector 428 | -- ^ 'Range' selector to initially and repeatedly apply. 429 | -> ConsistencyLevel 430 | -> RetryPolicy 431 | -- ^ Retry strategy for each underlying Cassandra call 432 | -> m (PageResult m (k, a)) 433 | paginate m cf k rng@(Range _ to ord per) cl retry = do 434 | cs <- reverse `liftM` retryCas retry (get m cf k rng cl) 435 | case cs of 436 | [] -> return $ PDone [] 437 | [a] -> return $ PDone [a] 438 | _ -> 439 | let cont = paginate m cf k (Range (Just cn) to ord per) cl retry 440 | (cn, _) = head cs 441 | in return $ PMore (reverse (drop 1 cs)) cont 442 | paginate _ _ _ _ _ _ = error "Must call paginate with a Range selector" 443 | 444 | 445 | 446 | ------------------------------------------------------------------------------- 447 | -- | Convenience layer: Convert a pagination scheme to a conduit 'Source'. 448 | pageToSource :: (Monad m) => PageResult m a -> Source m a 449 | pageToSource (PDone as) = C.sourceList as 450 | pageToSource (PMore as m) = C.sourceList as >> lift m >>= pageToSource 451 | 452 | 453 | ------------------------------------------------------------------------------- 454 | -- | Just like 'paginate', but we instead return a conduit 'Source'. 455 | paginateSource 456 | :: (CasType k, MonadCassandra m, MonadMask m) 457 | => Marshall a 458 | -> ColumnFamily 459 | -> RowKey 460 | -> Selector 461 | -> ConsistencyLevel 462 | -> RetryPolicy 463 | -> Source m (k, a) 464 | paginateSource m cf k rng cl r = do 465 | buf <- lift $ paginate m cf k rng cl r 466 | pageToSource buf 467 | 468 | -------------------------------------------------------------------------------- /src/Database/Cassandra/Pack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-| A Collection of utilities for binary packing values into Bytestring |-} 7 | 8 | module Database.Cassandra.Pack 9 | ( CasType (..) 10 | , TAscii (..) 11 | , TBytes (..) 12 | , TCounter (..) 13 | , TInt32 (..) 14 | , TInt64 (..) 15 | , TUtf8 (..) 16 | , TUUID (..) 17 | , TLong (..) 18 | , TTimeStamp (..) 19 | , toTimeStamp 20 | , fromTimeStamp 21 | 22 | , Exclusive (..) 23 | , Single (..) 24 | , SliceStart (..) 25 | ) where 26 | 27 | ------------------------------------------------------------------------------- 28 | import Control.Applicative 29 | import Data.Binary 30 | import Data.Binary.Get 31 | import Data.Binary.Put 32 | import qualified Data.ByteString.Char8 as B 33 | import Data.ByteString.Lazy.Char8 (ByteString) 34 | import qualified Data.ByteString.Lazy.Char8 as LB 35 | import Data.Char 36 | import Data.Int 37 | import Data.Text (Text) 38 | import qualified Data.Text as T 39 | import qualified Data.Text.Encoding as T 40 | import qualified Data.Text.Lazy as LT 41 | import qualified Data.Text.Lazy.Encoding as LT 42 | import Data.Time 43 | import Data.Time 44 | import Data.Time.Clock.POSIX 45 | import GHC.Int 46 | ------------------------------------------------------------------------------- 47 | 48 | 49 | 50 | ------------------------------------------------------------------------------- 51 | newtype TAscii = TAscii { getAscii :: ByteString } deriving (Eq,Show,Read,Ord) 52 | newtype TBytes = TBytes { getTBytes :: ByteString } deriving (Eq,Show,Read,Ord) 53 | newtype TCounter = TCounter { getCounter :: ByteString } deriving (Eq,Show,Read,Ord) 54 | newtype TInt32 = TInt32 { getInt32 :: Int32 } deriving (Eq,Show,Read,Ord) 55 | newtype TInt64 = TInt64 { getInt64 :: Int64 } 56 | deriving (Eq,Show,Read,Ord,Enum,Real,Integral,Num) 57 | newtype TUUID = TUUID { getUUID :: ByteString } deriving (Eq,Show,Read,Ord) 58 | newtype TLong = TLong { getLong :: Integer } 59 | deriving (Eq,Show,Read,Ord,Enum,Real,Integral,Num) 60 | newtype TUtf8 = TUtf8 { getUtf8 :: Text } deriving (Eq,Show,Read,Ord) 61 | 62 | 63 | -- | Timestamp that stores micro-seconds since epoch as 'TLong' underneath. 64 | newtype TTimeStamp = TTimeStamp { getTimeStamp :: TLong } 65 | deriving (Eq,Show,Read,Ord,Enum,Num,Real,Integral,CasType) 66 | 67 | 68 | -- | Convert commonly used 'UTCTime' to 'TTimeStamp'. 69 | -- 70 | -- First converts to seconds since epoch (POSIX seconds), then 71 | -- multiplies by a million and floors the resulting value. The value, 72 | -- therefore, is in micro-seconds and is accurate to within a 73 | -- microsecond. 74 | toTimeStamp :: UTCTime -> TTimeStamp 75 | toTimeStamp utc = fromIntegral . floor . (* 1e6) $ utcTimeToPOSIXSeconds utc 76 | 77 | 78 | fromTimeStamp :: TTimeStamp -> UTCTime 79 | fromTimeStamp (TTimeStamp (TLong i)) = 80 | posixSecondsToUTCTime $ realToFrac $ fromIntegral i / (1e6) 81 | 82 | 83 | ------------------------------------------------------------------------------- 84 | -- | This typeclass defines and maps to haskell types that Cassandra 85 | -- natively knows about and uses in sorting and potentially validating 86 | -- column key values. 87 | -- 88 | -- All column keys are eventually sent to and received from Cassandra 89 | -- in binary form. This typeclass allows us to map some Haskell type 90 | -- definitions to their binary representation. The correct binary 91 | -- serialization is handled for you behind the scenes. 92 | -- 93 | -- For simplest cases, just use one of the string-like instances, e.g. 94 | -- 'ByteString', 'String' or 'Text'. Please keep in mind that these 95 | -- are just mapped to untyped BytesType. 96 | -- 97 | -- Remember that for special column types, such as 'TLong', to have 98 | -- any effect, your ColumnFamily must have been created with that 99 | -- comparator or validator. Otherwise you're just encoding/decoding 100 | -- integer values without any Cassandra support for sorting or 101 | -- correctness. 102 | -- 103 | -- The Python library pycassa has a pretty good tutorial to learn more. 104 | -- 105 | -- Tuple instances support fixed ComponentType columns. Example: 106 | -- 107 | -- > insert "testCF" "row1" [packCol ((TLong 124, TAscii "Hello"), "some content")] 108 | class CasType a where 109 | encodeCas :: a -> ByteString 110 | decodeCas :: ByteString -> a 111 | 112 | 113 | instance CasType B.ByteString where 114 | encodeCas = fromStrict 115 | decodeCas = toStrict 116 | 117 | 118 | instance CasType String where 119 | encodeCas = LB.pack 120 | decodeCas = LB.unpack 121 | 122 | 123 | instance CasType LT.Text where 124 | encodeCas = encodeCas . LT.encodeUtf8 125 | decodeCas = LT.decodeUtf8 126 | 127 | 128 | instance CasType T.Text where 129 | encodeCas = encodeCas . LT.fromChunks . return 130 | decodeCas = T.concat . LT.toChunks . decodeCas 131 | 132 | 133 | instance CasType LB.ByteString where 134 | encodeCas = id 135 | decodeCas = id 136 | 137 | 138 | instance CasType TAscii where 139 | encodeCas = getAscii 140 | decodeCas = TAscii 141 | 142 | 143 | instance CasType TBytes where 144 | encodeCas = getTBytes 145 | decodeCas = TBytes 146 | 147 | 148 | instance CasType TCounter where 149 | encodeCas = getCounter 150 | decodeCas = TCounter 151 | 152 | 153 | ------------------------------------------------------------------------------- 154 | -- | Pack as a 4 byte number 155 | instance CasType TInt32 where 156 | encodeCas = runPut . putWord32be . fromIntegral . getInt32 157 | decodeCas = TInt32 . fromIntegral . runGet getWord32be 158 | 159 | 160 | ------------------------------------------------------------------------------- 161 | -- | Pack as an 8 byte number - same as 'TLong' 162 | instance CasType TInt64 where 163 | encodeCas = runPut . putWord64be . fromIntegral . getInt64 164 | decodeCas = TInt64 . fromIntegral . runGet getWord64be 165 | 166 | 167 | ------------------------------------------------------------------------------- 168 | instance CasType Int32 where 169 | encodeCas = encodeCas . TInt32 . fromIntegral 170 | decodeCas = fromIntegral . getInt32 . decodeCas 171 | 172 | 173 | ------------------------------------------------------------------------------- 174 | instance CasType Int64 where 175 | encodeCas = encodeCas . TInt64 . fromIntegral 176 | decodeCas = fromIntegral . getInt64 . decodeCas 177 | 178 | 179 | ------------------------------------------------------------------------------- 180 | -- | Assumed to be a 64-bit Int and encoded as such. 181 | instance CasType Int where 182 | encodeCas = encodeCas . TInt64 . fromIntegral 183 | decodeCas = fromIntegral . getInt64 . decodeCas 184 | 185 | 186 | ------------------------------------------------------------------------------- 187 | -- | Pack as an 8 byte unsigned number; negative signs are lost. Maps 188 | -- to 'LongType'. 189 | instance CasType TLong where 190 | encodeCas = runPut . putWord64be . fromIntegral . getLong 191 | decodeCas = TLong . fromIntegral . runGet getWord64be 192 | 193 | 194 | ------------------------------------------------------------------------------- 195 | -- | Encode and decode as Utf8 'Text' 196 | instance CasType TUtf8 where 197 | encodeCas = LB.fromChunks . return . T.encodeUtf8 . getUtf8 198 | decodeCas = TUtf8 . T.decodeUtf8 . B.concat . LB.toChunks 199 | 200 | 201 | ------------------------------------------------------------------------------- 202 | -- | Encode days as 'LongType' via 'TLong'. 203 | instance CasType Day where 204 | encodeCas = encodeCas . TLong . toModifiedJulianDay 205 | decodeCas = ModifiedJulianDay . getLong . decodeCas 206 | 207 | 208 | -- | Via 'TTimeStamp', which is via 'TLong' 209 | instance CasType UTCTime where 210 | encodeCas = encodeCas . toTimeStamp 211 | decodeCas = fromTimeStamp . decodeCas 212 | 213 | 214 | ------------------------------------------------------------------------------- 215 | -- | Use the 'Single' wrapper when querying only with the first of a 216 | -- two or more field CompositeType. 217 | instance (CasType a) => CasType (Single a) where 218 | encodeCas (Single a) = runPut $ putSegment a end 219 | 220 | decodeCas bs = flip runGet bs $ Single <$> getSegment 221 | 222 | 223 | ------------------------------------------------------------------------------- 224 | -- | Composite types - see Cassandra or pycassa docs to understand 225 | instance (CasType a, CasType b) => CasType (a,b) where 226 | encodeCas (a, b) = runPut $ do 227 | putSegment a sep 228 | putSegment b end 229 | 230 | decodeCas bs = flip runGet bs $ (,) 231 | <$> getSegment 232 | <*> getSegment 233 | 234 | 235 | instance (CasType a, CasType b, CasType c) => CasType (a,b,c) where 236 | encodeCas (a, b, c) = runPut $ do 237 | putSegment a sep 238 | putSegment b sep 239 | putSegment c end 240 | 241 | decodeCas bs = flip runGet bs $ (,,) 242 | <$> getSegment 243 | <*> getSegment 244 | <*> getSegment 245 | 246 | 247 | instance (CasType a, CasType b, CasType c, CasType d) => CasType (a,b,c,d) where 248 | encodeCas (a, b, c, d) = runPut $ do 249 | putSegment a sep 250 | putSegment b sep 251 | putSegment c sep 252 | putSegment d end 253 | 254 | decodeCas bs = flip runGet bs $ (,,,) 255 | <$> getSegment 256 | <*> getSegment 257 | <*> getSegment 258 | <*> getSegment 259 | 260 | 261 | ------------------ 262 | -- Slice Starts -- 263 | ------------------ 264 | 265 | 266 | 267 | instance (CasType a) => CasType (SliceStart (Single a)) where 268 | encodeCas (SliceStart (Single a)) = runPut $ do 269 | putSegment a exc 270 | decodeCas bs = flip runGet bs $ (SliceStart . Single) <$> getSegment 271 | 272 | 273 | ------------------------------------------------------------------------------- 274 | -- | Composite types - see Cassandra or pycassa docs to understand 275 | instance (CasType a, CasType b) => CasType (SliceStart (a,b)) where 276 | encodeCas (SliceStart (a, b)) = runPut $ do 277 | putSegment a sep 278 | putSegment b exc 279 | 280 | decodeCas bs = SliceStart . flip runGet bs $ (,) 281 | <$> getSegment 282 | <*> getSegment 283 | 284 | 285 | instance (CasType a, CasType b, CasType c) => CasType (SliceStart (a,b,c)) where 286 | encodeCas (SliceStart (a, b, c)) = runPut $ do 287 | putSegment a sep 288 | putSegment b sep 289 | putSegment c exc 290 | 291 | decodeCas bs = SliceStart . flip runGet bs $ (,,) 292 | <$> getSegment 293 | <*> getSegment 294 | <*> getSegment 295 | 296 | 297 | instance (CasType a, CasType b, CasType c, CasType d) => 298 | CasType (SliceStart (a,b,c,d)) where 299 | encodeCas (SliceStart (a, b, c, d)) = runPut $ do 300 | putSegment a sep 301 | putSegment b sep 302 | putSegment c sep 303 | putSegment d exc 304 | 305 | decodeCas bs = SliceStart . flip runGet bs $ (,,,) 306 | <$> getSegment 307 | <*> getSegment 308 | <*> getSegment 309 | <*> getSegment 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | ----------------------- 321 | -- Exclusive Columns -- 322 | ----------------------- 323 | 324 | 325 | instance CasType a => CasType (Exclusive (Single a)) where 326 | encodeCas (Exclusive (Single a)) = runPut $ do 327 | putSegment a exc 328 | 329 | decodeCas = Exclusive . decodeCas 330 | 331 | 332 | instance (CasType a, CasType b) => CasType (a, Exclusive b) where 333 | encodeCas (a, Exclusive b) = runPut $ do 334 | putSegment a sep 335 | putSegment b exc 336 | 337 | decodeCas bs = flip runGet bs $ (,) 338 | <$> getSegment 339 | <*> (Exclusive <$> getSegment) 340 | 341 | 342 | instance (CasType a, CasType b, CasType c) => CasType (a, b, Exclusive c) where 343 | encodeCas (a, b, Exclusive c) = runPut $ do 344 | putSegment a sep 345 | putSegment b sep 346 | putSegment c exc 347 | 348 | decodeCas bs = flip runGet bs $ (,,) 349 | <$> getSegment 350 | <*> getSegment 351 | <*> (Exclusive <$> getSegment) 352 | 353 | 354 | instance (CasType a, CasType b, CasType c, CasType d) => CasType (a, b, c, Exclusive d) where 355 | encodeCas (a, b, c, Exclusive d) = runPut $ do 356 | putSegment a sep 357 | putSegment b sep 358 | putSegment c sep 359 | putSegment d exc 360 | 361 | decodeCas bs = flip runGet bs $ (,,,) 362 | <$> getSegment 363 | <*> getSegment 364 | <*> getSegment 365 | <*> (Exclusive <$> getSegment) 366 | 367 | 368 | -- instance CasType a => CasType [a] where 369 | -- encodeCas as = runPut $ do 370 | -- mapM (flip putSegment sep) $ init as 371 | -- putSegment (last as) end 372 | 373 | 374 | ------------------------------------------------------------------------------- 375 | -- | Exclusive tag for composite column. You may tag the end of a 376 | -- composite range with this to make the range exclusive. See pycassa 377 | -- documentation for more information. 378 | newtype Exclusive a = Exclusive a deriving (Eq,Show,Read,Ord) 379 | 380 | 381 | ------------------------------------------------------------------------------- 382 | -- | Use the Single wrapper when you want to refer only to the first 383 | -- coolumn of a CompositeType column. 384 | newtype Single a = Single a deriving (Eq,Show,Read,Ord) 385 | 386 | 387 | ------------------------------------------------------------------------------- 388 | -- | Wrap your composite columns in this type when you're starting an 389 | -- inclusive column slice. 390 | newtype SliceStart a = SliceStart a deriving (Eq,Show,Read,Ord) 391 | 392 | 393 | -- | composite columns are a pain 394 | -- need to write 2 byte length, n byte body, 1 byte separator 395 | -- 396 | -- from pycassa: 397 | -- The composite format for each component is: 398 | -- 399 | -- 2 bytes | ? bytes | 1 byte 400 | 401 | 402 | ------------------------------------------------------------------------------- 403 | putBytes :: B.ByteString -> Put 404 | putBytes b = do 405 | putLen b 406 | putByteString b 407 | 408 | 409 | ------------------------------------------------------------------------------- 410 | getBytes' :: Get B.ByteString 411 | getBytes' = getLen >>= getBytes 412 | 413 | 414 | ------------------------------------------------------------------------------- 415 | getLen :: Get Int 416 | getLen = fromIntegral `fmap` getWord16be 417 | 418 | 419 | ------------------------------------------------------------------------------- 420 | putLen :: B.ByteString -> Put 421 | putLen b = putWord16be . fromIntegral $ (B.length b) 422 | 423 | 424 | 425 | ------------------------------------------------------------------------------- 426 | toStrict :: ByteString -> B.ByteString 427 | toStrict = B.concat . LB.toChunks 428 | 429 | 430 | ------------------------------------------------------------------------------- 431 | fromStrict :: B.ByteString -> ByteString 432 | fromStrict = LB.fromChunks . return 433 | 434 | 435 | ------------------------------------------------------------------------------- 436 | getSegment :: CasType a => Get a 437 | getSegment = do 438 | a <- (decodeCas . fromStrict) <$> getBytes' 439 | getWord8 -- discard separator character 440 | return a 441 | 442 | 443 | ------------------------------------------------------------------------------- 444 | putSegment :: CasType a => a -> PutM b -> PutM b 445 | putSegment a f = do 446 | putBytes . toStrict $ encodeCas a 447 | f 448 | 449 | -- | When end point is exclusive 450 | exc :: Put 451 | exc = putWord8 . fromIntegral $ ord '\xff' 452 | 453 | -- | Regular (inclusive) end point 454 | end :: Put 455 | end = putWord8 . fromIntegral $ ord '\x01' 456 | 457 | -- | Separator between composite parts 458 | sep :: Put 459 | sep = putWord8 . fromIntegral $ ord '\x00' 460 | 461 | -------------------------------------------------------------------------------- /src/Database/Cassandra/Pool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE PackageImports #-} 4 | {-# LANGUAGE PatternGuards #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module Database.Cassandra.Pool 8 | ( CPool 9 | , Server 10 | , defServer 11 | , defServers 12 | , KeySpace 13 | , Cassandra (..) 14 | , createCassandraPool 15 | , withResource 16 | 17 | -- * Low Level Utilities 18 | , openThrift 19 | ) where 20 | 21 | ------------------------------------------------------------------------------ 22 | import Control.Applicative ((<$>)) 23 | import Control.Arrow 24 | import Control.Concurrent 25 | import Control.Concurrent.STM 26 | import Control.Exception (SomeException, 27 | handle, 28 | onException) 29 | import Control.Monad (forM_, forever, 30 | join, liftM2, 31 | unless, when) 32 | import Data.ByteString (ByteString) 33 | import Data.List (find, nub, 34 | partition) 35 | import Data.Maybe 36 | import Data.Pool 37 | import Data.Set (Set) 38 | import qualified Data.Set as S 39 | import Data.Time.Clock (NominalDiffTime, 40 | UTCTime, 41 | diffUTCTime, 42 | getCurrentTime) 43 | import qualified Database.Cassandra.Thrift.Cassandra_Client as C 44 | import qualified Database.Cassandra.Thrift.Cassandra_Types as C 45 | import Network 46 | import Prelude hiding (catch) 47 | import System.IO (Handle (..), 48 | hClose) 49 | import System.Mem.Weak (addFinalizer) 50 | import Thrift.Protocol.Binary 51 | import Thrift.Transport 52 | import Thrift.Transport.Framed 53 | import Thrift.Transport.Handle 54 | ------------------------------------------------------------------------------ 55 | 56 | 57 | ------------------------------------------------------------------------------ 58 | -- | A round-robin pool of cassandra connections 59 | type CPool = Pool Cassandra 60 | 61 | 62 | ------------------------------------------------------------------------------ 63 | -- | A (ServerName, Port) tuple 64 | type Server = (HostName, Int) 65 | 66 | 67 | -- | A localhost server with default configuration 68 | defServer :: Server 69 | defServer = ("127.0.0.1", 9160) 70 | 71 | 72 | -- | A single localhost server with default configuration 73 | defServers :: [Server] 74 | defServers = [defServer] 75 | 76 | 77 | ------------------------------------------------------------------------------ 78 | type KeySpace = String 79 | 80 | 81 | ------------------------------------------------------------------------------ 82 | data Cassandra = Cassandra { 83 | cHandle :: Handle 84 | , cFramed :: FramedTransport Handle 85 | , cProto :: BinaryProtocol (FramedTransport Handle) 86 | } 87 | 88 | 89 | 90 | -- | Create a pool of connections to a cluster of Cassandra boxes 91 | -- 92 | -- Each box in the cluster will get up to n connections. The pool will send 93 | -- queries in round-robin fashion to balance load on each box in the cluster. 94 | createCassandraPool 95 | :: [Server] 96 | -- ^ List of servers to connect to 97 | -> Int 98 | -- ^ Number of stripes to maintain 99 | -> Int 100 | -- ^ Max connections per stripe 101 | -> NominalDiffTime 102 | -- ^ Kill each connection after this many seconds 103 | -> KeySpace 104 | -- ^ Each pool operates on a single KeySpace 105 | -> IO CPool 106 | createCassandraPool servers numStripes perStripe maxIdle ks = do 107 | sring <- newTVarIO $ mkRing servers 108 | pool <- createPool (cr 4 sring) dest numStripes maxIdle perStripe 109 | -- forkIO (serverDiscoveryThread sring ks pool) 110 | return pool 111 | where 112 | cr :: Int -> ServerRing -> IO Cassandra 113 | cr n sring = do 114 | s@(host, p) <- atomically $ do 115 | ring@Ring{..} <- readTVar sring 116 | writeTVar sring (next ring) 117 | return current 118 | 119 | handle (handler n sring s) $ do 120 | (h,ft,proto) <- openThrift host p 121 | C.set_keyspace (proto, proto) ks 122 | return $ Cassandra h ft proto 123 | 124 | handler :: Int -> ServerRing -> Server -> SomeException -> IO Cassandra 125 | handler 0 _ _ e = error $ "Can't connect to cassandra after several tries: " ++ show e 126 | handler n sring server e = do 127 | 128 | -- we need a temporary removal system for servers; something 129 | -- with a TTL just removing them from ring is dangerous, what if 130 | -- the network is partitioned for a little while? 131 | 132 | -- modifyServers sring (removeServer server) 133 | 134 | -- wait 100ms to avoid crazy loops 135 | threadDelay 100000 136 | cr (n-1) sring 137 | 138 | dest h = hClose $ cHandle h 139 | 140 | 141 | ------------------------------------------------------------------------------- 142 | -- | Open underlying thrift connection 143 | openThrift host port = do 144 | h <- hOpen (host, PortNumber (fromIntegral port)) 145 | ft <- openFramedTransport h 146 | let p = BinaryProtocol ft 147 | return (h, ft, p) 148 | 149 | 150 | ------------------------------------------------------------------------------ 151 | modifyServers :: TVar (Ring a) -> (Ring a -> Ring a) -> IO () 152 | modifyServers sring f = atomically $ do 153 | ring@Ring{..} <- readTVar sring 154 | writeTVar sring $ f ring 155 | return () 156 | 157 | 158 | ------------------------------------------------------------------------------ 159 | serverDiscoveryThread :: TVar (Ring Server) 160 | -> String 161 | -> Pool Cassandra 162 | -> IO b 163 | serverDiscoveryThread sring ks pool = forever $ do 164 | withResource pool (updateServers sring ks) 165 | threadDelay 60000000 166 | 167 | 168 | ------------------------------------------------------------------------------ 169 | updateServers :: TVar (Ring Server) -> String -> Cassandra -> IO () 170 | updateServers sring ks (Cassandra _ _ p) = do 171 | ranges <- C.describe_ring (p,p) ks 172 | let hosts = concat $ catMaybes $ map C.f_TokenRange_endpoints ranges 173 | servers = nub $ map (\e -> first (const e) defServer) hosts 174 | -- putStrLn $ "Cassy: Discovered new servers: " ++ show servers 175 | modifyServers sring (addNewServers servers) 176 | 177 | 178 | ------------------------------------------------------------------------------ 179 | type ServerRing = TVar (Ring Server) 180 | 181 | 182 | ------------------------------------------------------------------------------ 183 | data Ring a = Ring { 184 | allItems :: Set a 185 | , current :: !a 186 | , used :: [a] 187 | , upcoming :: [a] 188 | } 189 | 190 | 191 | ------------------------------------------------------------------------------ 192 | mkRing [] = error "Can't make a ring from empty list" 193 | mkRing all@(a:as) = Ring (S.fromList all) a [] as 194 | 195 | 196 | ------------------------------------------------------------------------------ 197 | next :: Ring a -> Ring a 198 | next Ring{..} 199 | | (n:rest) <- upcoming 200 | = Ring allItems n (current : used) rest 201 | next Ring{..} 202 | | (n:rest) <- reverse (current : used) 203 | = Ring allItems n [] rest 204 | 205 | 206 | ------------------------------------------------------------------------------ 207 | removeServer :: Ord a => a -> Ring a -> Ring a 208 | removeServer s r@Ring{..} 209 | | s `S.member` allItems = Ring all' cur' [] up' 210 | | otherwise = r 211 | where 212 | all' = S.delete s allItems 213 | cur' : up' = S.toList all' 214 | 215 | 216 | ------------------------------------------------------------------------------ 217 | addNewServers :: [Server] -> Ring Server -> Ring Server 218 | addNewServers servers Ring{..} = Ring all' current' used' (new ++ upcoming') 219 | where 220 | all' = S.fromList servers 221 | new = S.toList $ all' S.\\ allItems 222 | used' = filter (`S.member` all') used 223 | (current':upcoming') = filter (`S.member` all') (current:upcoming) 224 | 225 | 226 | -------------------------------------------------------------------------------- /src/Database/Cassandra/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE PatternGuards #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | 11 | module Database.Cassandra.Types where 12 | 13 | ------------------------------------------------------------------------------- 14 | import Control.Exception (IOException) 15 | import Control.Monad 16 | import Control.Monad.Catch 17 | import qualified Data.ByteString.Char8 as B 18 | import Data.ByteString.Lazy (ByteString) 19 | import qualified Data.ByteString.Lazy.Char8 as LB 20 | import Data.Default 21 | import Data.Generics 22 | import Data.Int (Int32, Int64) 23 | import Data.List 24 | import Data.Text (Text) 25 | import qualified Data.Text as T 26 | import qualified Data.Text.Encoding as T 27 | import qualified Data.Text.Lazy as LT 28 | import qualified Data.Text.Lazy.Encoding as LT 29 | import Data.Time 30 | import Data.Time.Clock.POSIX 31 | import qualified Database.Cassandra.Thrift.Cassandra_Types as C 32 | ------------------------------------------------------------------------------- 33 | import Database.Cassandra.Pack 34 | ------------------------------------------------------------------------------- 35 | 36 | 37 | ------------------------------------------------------------------------------ 38 | -- | Possible outcomes of a modify operation 39 | data ModifyOperation a = 40 | Update a 41 | | Delete 42 | | DoNothing 43 | deriving (Eq,Show,Ord,Read) 44 | 45 | 46 | -- | A 'Key' range selector to use with 'getMulti'. 47 | data KeySelector = 48 | Keys [Key] 49 | -- ^ Just a list of keys to get 50 | | KeyRange KeyRangeType Key Key Int32 51 | -- ^ A range of keys to get. Remember that RandomPartitioner ranges may not 52 | -- mean much as keys are randomly assigned to nodes. 53 | deriving (Show) 54 | 55 | 56 | -- | Encodes the Key vs. Token options in the thrift API. 57 | -- 58 | -- 'InclusiveRange' ranges are just plain intuitive range queries. 59 | -- 'WrapAround' ranges are also inclusive, but they wrap around the ring. 60 | data KeyRangeType = InclusiveRange | WrapAround 61 | deriving (Show) 62 | 63 | 64 | mkKeyRange (KeyRange ty st end cnt) = case ty of 65 | InclusiveRange -> C.KeyRange (Just st) (Just end) Nothing Nothing (Just cnt) 66 | WrapAround -> C.KeyRange Nothing Nothing (Just $ LB.unpack st) (Just $ LB.unpack end) (Just cnt) 67 | 68 | 69 | ------------------------------------------------------------------------------- 70 | -- | A column selector/filter statement for queries. 71 | -- 72 | -- Remember that SuperColumns are always fully deserialized, so we don't offer 73 | -- a way to filter columns within a 'SuperColumn'. 74 | -- 75 | -- Column names and ranges are specified by any type that can be 76 | -- packed into a Cassandra column using the 'CasType' typeclass. 77 | data Selector = 78 | All 79 | -- ^ Return everything in 'Row' 80 | | forall a. CasType a => ColNames [a] 81 | -- ^ Return specific columns or super-columns depending on the 'ColumnFamily' 82 | | forall a b. (CasType a, CasType b) => SupNames a [b] 83 | -- ^ When deleting specific columns in a super column 84 | | forall a b. (CasType a, CasType b) => Range { 85 | rangeStart :: Maybe a 86 | , rangeEnd :: Maybe b 87 | , rangeOrder :: Order 88 | , rangeLimit :: Int32 89 | } 90 | -- ^ Return a range of columns or super-columns. 91 | 92 | ------------------------------------------------------------------------------- 93 | -- | A default starting point for range 'Selector'. Use this so you 94 | -- don't run into ambiguous type variables when using Nothing. 95 | -- 96 | -- > range = Range (Nothing :: Maybe ByteString) (Nothing :: Maybe ByteString) Regular 1024 97 | range = Range (Nothing :: Maybe ByteString) (Nothing :: Maybe ByteString) Regular 1024 98 | 99 | 100 | boundless :: Maybe ByteString 101 | boundless = Nothing 102 | 103 | 104 | 105 | instance Default Selector where 106 | def = All 107 | 108 | instance Show Selector where 109 | show All = "All" 110 | show (ColNames cns) = concat 111 | ["ColNames: ", intercalate ", " $ map showCas cns] 112 | show (SupNames cn cns) = concat 113 | ["SuperCol: ", showCas cn, "; Cols: ", intercalate ", " (map showCas cns)] 114 | show (Range a b order i) = concat 115 | [ "Range from ", maybe "Nothing" showCas a, " to ", maybe "Nothing" showCas b 116 | , " order ", show order, " max ", show i, " items." ] 117 | 118 | 119 | ------------------------------------------------------------------------------- 120 | showCas :: CasType a => a -> String 121 | showCas t = LB.unpack . encodeCas $ t 122 | 123 | 124 | ------------------------------------------------------------------------------- 125 | mkPredicate :: Selector -> C.SlicePredicate 126 | mkPredicate s = 127 | let 128 | allRange = C.SliceRange (Just "") (Just "") (Just False) (Just 50000) 129 | in case s of 130 | All -> C.SlicePredicate Nothing (Just allRange) 131 | ColNames ks -> C.SlicePredicate (Just (map encodeCas ks)) Nothing 132 | Range st end ord cnt -> 133 | let 134 | st' = fmap encodeCas st `mplus` Just "" 135 | end' = fmap encodeCas end `mplus` Just "" 136 | in C.SlicePredicate Nothing 137 | (Just (C.SliceRange st' end' (Just $ renderOrd ord) (Just cnt))) 138 | 139 | 140 | 141 | ------------------------------------------------------------------------------ 142 | -- | Order in a range query 143 | data Order = Regular | Reversed 144 | deriving (Show) 145 | 146 | 147 | ------------------------------------------------------------------------------- 148 | renderOrd Regular = False 149 | renderOrd Reversed = True 150 | 151 | 152 | ------------------------------------------------------------------------------- 153 | reverseOrder Regular = Reversed 154 | reverseOrder _ = Regular 155 | 156 | 157 | type ColumnFamily = String 158 | 159 | 160 | type Key = ByteString 161 | type RowKey = Key 162 | 163 | 164 | type ColumnName = ByteString 165 | 166 | 167 | type Value = ByteString 168 | 169 | 170 | ------------------------------------------------------------------------------ 171 | -- | A Column is either a single key-value pair or a SuperColumn with an 172 | -- arbitrary number of key-value pairs 173 | data Column = 174 | SuperColumn ColumnName [Column] 175 | | Column { 176 | colKey :: ColumnName 177 | , colVal :: Value 178 | , colTS :: Maybe Int64 179 | -- ^ Last update timestamp; will be overridden during write/update ops 180 | , colTTL :: Maybe Int32 181 | -- ^ A TTL after which Cassandra will erase the column 182 | } 183 | deriving (Eq,Show,Read,Ord) 184 | 185 | 186 | ------------------------------------------------------------------------------ 187 | -- | A full row is simply a sequence of columns 188 | type Row = [Column] 189 | 190 | 191 | ------------------------------------------------------------------------------ 192 | -- | A short-hand for creating key-value 'Column' values. This is 193 | -- pretty low level; you probably want to use 'packCol'. 194 | col :: ByteString -> ByteString -> Column 195 | col k v = Column k v Nothing Nothing 196 | 197 | 198 | mkThriftCol :: Column -> IO C.Column 199 | mkThriftCol Column{..} = do 200 | now <- getTime 201 | return $ C.Column (Just colKey) (Just colVal) (Just now) colTTL 202 | mkThriftCol _ = error "mkThriftCol can only process regular columns." 203 | 204 | 205 | castColumn :: C.ColumnOrSuperColumn -> Either CassandraException Column 206 | castColumn x | Just c <- C.f_ColumnOrSuperColumn_column x = castCol c 207 | | Just c <- C.f_ColumnOrSuperColumn_super_column x = castSuperCol c 208 | castColumn _ = 209 | Left $ ConversionException "castColumn: Unsupported/unexpected ColumnOrSuperColumn type" 210 | 211 | 212 | castCol :: C.Column -> Either CassandraException Column 213 | castCol c 214 | | Just nm <- C.f_Column_name c 215 | , Just val <- C.f_Column_value c 216 | , Just ts <- C.f_Column_timestamp c 217 | , ttl <- C.f_Column_ttl c 218 | = Right $ Column nm val (Just ts) ttl 219 | castCol _ = Left $ ConversionException "Can't parse Column" 220 | 221 | 222 | castSuperCol :: C.SuperColumn -> Either CassandraException Column 223 | castSuperCol c 224 | | Just nm <- C.f_SuperColumn_name c 225 | , Just cols <- C.f_SuperColumn_columns c 226 | , Right cols' <- mapM castCol cols 227 | = Right $ SuperColumn nm cols' 228 | castSuperCol _ = Left $ ConversionException "Can't parse SuperColumn" 229 | 230 | 231 | data CassandraException = 232 | NotFoundException 233 | | InvalidRequestException String 234 | | UnavailableException 235 | | TimedOutException 236 | | AuthenticationException String 237 | | AuthorizationException String 238 | | SchemaDisagreementException 239 | | ConversionException String 240 | | OperationNotSupported String 241 | deriving (Eq,Show,Read,Ord,Data,Typeable) 242 | 243 | 244 | instance Exception CassandraException 245 | 246 | 247 | -- | Exception handler that returns @True@ for errors that may be 248 | -- resolved after a retry. So they are good candidates for 'retrying' 249 | -- queries. 250 | casRetryH :: Monad m => a -> Handler m Bool 251 | casRetryH = const $ Handler $ return . casShouldRetry 252 | 253 | 254 | ------------------------------------------------------------------------------- 255 | -- | Whether we recommend that you retry a given exception. 256 | casShouldRetry :: CassandraException -> Bool 257 | casShouldRetry e = case e of 258 | UnavailableException{} -> True 259 | TimedOutException{} -> True 260 | SchemaDisagreementException{} -> True 261 | _ -> False 262 | 263 | 264 | 265 | -- | 'IOException's should be retried 266 | networkRetryH :: Monad m => a -> Handler m Bool 267 | networkRetryH = const $ Handler $ \ (_ :: IOException) -> return True 268 | 269 | 270 | ------------------------------------------------------------------------------ 271 | -- | Cassandra is VERY sensitive to its timestamp values. As a convention, 272 | -- timestamps are always in microseconds 273 | getTime :: IO Int64 274 | getTime = do 275 | t <- getPOSIXTime 276 | return . fromIntegral . floor $ t * 1000000 277 | 278 | 279 | ---------------- 280 | -- Pagination -- 281 | ---------------- 282 | 283 | 284 | ------------------------------------------------------------------------------- 285 | -- | Describes the result of a single pagination action 286 | data PageResult m a 287 | = PDone { pCache :: [a] } 288 | -- ^ Done, this is all I have. 289 | | PMore { pCache :: [a], pMore :: m (PageResult m a) } 290 | -- ^ Here's a batch and there is more when you call the action. 291 | 292 | 293 | 294 | 295 | ------------------------------------------------------------------------------- 296 | pIsDry x = pIsDone x && null (pCache x) 297 | 298 | ------------------------------------------------------------------------------- 299 | pIsDone PDone{} = True 300 | pIsDone _ = False 301 | 302 | 303 | ------------------------------------------------------------------------------- 304 | pHasMore PMore{} = True 305 | pHasMore _ = False 306 | 307 | 308 | ------------------------------------------------------------------------------- 309 | instance Monad m => Functor (PageResult m) where 310 | fmap f (PDone as) = PDone (fmap f as) 311 | fmap f (PMore as m) = PMore (fmap f as) m' 312 | where 313 | m' = liftM (fmap f) m 314 | 315 | 316 | 317 | -------------------- 318 | -- CKey Typeclass -- 319 | -------------------- 320 | 321 | ------------------------------------------------------------------------------ 322 | -- | A typeclass to enable using any string-like type for row and column keys 323 | class CKey a where 324 | toColKey :: a -> ByteString 325 | fromColKey :: ByteString -> Either String a 326 | 327 | 328 | ------------------------------------------------------------------------------- 329 | -- | Raise an error if conversion fails 330 | fromColKey' :: CKey a => ByteString -> a 331 | fromColKey' = either error id . fromColKey 332 | 333 | 334 | ------------------------------------------------------------------------------- 335 | -- | For easy composite keys, just serialize your data type to a list 336 | -- of bytestrings, we'll concat them and turn them into column keys. 337 | instance CKey [B.ByteString] where 338 | toColKey xs = LB.intercalate ":" $ map toColKey xs 339 | fromColKey str = mapM fromColKey $ LB.split ':' str 340 | 341 | 342 | instance CKey String where 343 | toColKey = LB.pack 344 | fromColKey = return . LB.unpack 345 | 346 | 347 | instance CKey LT.Text where 348 | toColKey = LT.encodeUtf8 349 | fromColKey = return `fmap` LT.decodeUtf8 350 | 351 | 352 | instance CKey T.Text where 353 | toColKey = toColKey . LT.fromChunks . return 354 | fromColKey = fmap (T.concat . LT.toChunks) . fromColKey 355 | 356 | 357 | instance CKey B.ByteString where 358 | toColKey = LB.fromChunks . return 359 | fromColKey = fmap (B.concat . LB.toChunks) . fromColKey 360 | 361 | 362 | instance CKey ByteString where 363 | toColKey = id 364 | fromColKey = return 365 | 366 | 367 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Main where 9 | 10 | 11 | ------------------------------------------------------------------------------- 12 | import Control.Applicative 13 | import qualified Data.ByteString.Char8 as B 14 | import qualified Data.ByteString.Lazy.Char8 as LB 15 | import Data.DeriveTH 16 | import qualified Data.Map as M 17 | import qualified Data.Text as T 18 | import qualified Database.Cassandra.Thrift.Cassandra_Client as C 19 | import Database.Cassandra.Thrift.Cassandra_Types (ConsistencyLevel (..)) 20 | import Database.Cassandra.Thrift.Cassandra_Types as T 21 | import System.IO.Unsafe 22 | import Test.Framework (defaultMain, 23 | testGroup) 24 | import Test.Framework.Providers.HUnit 25 | import Test.Framework.Providers.QuickCheck2 (testProperty) 26 | import Test.HUnit 27 | import Test.QuickCheck 28 | import Test.QuickCheck.Property 29 | 30 | ------------------------------------------------------------------------------- 31 | import Database.Cassandra.Basic 32 | import Database.Cassandra.Pack 33 | import Database.Cassandra.Pool 34 | ------------------------------------------------------------------------------- 35 | 36 | 37 | 38 | main = do 39 | pool <- mkTestConn 40 | defaultMain $ tests pool 41 | 42 | 43 | tests pool = [testGroup "packTests" (packTests pool)] 44 | 45 | 46 | packTests pool = 47 | [ testProperty "cas type marshalling long" prop_casTypeLong 48 | , testProperty "cas type marshalling ascii" prop_casTypeAscii 49 | , testProperty "cas type marshalling ascii" prop_casTypeInt32 50 | , testProperty "cas type marshalling composite" prop_casTypeComp 51 | , testCase "cas live test - composite get/set" test_composite_col 52 | , testCase "cas live - set comp + single col slice" test_composite_slice 53 | -- , testProperty "cas live test read/write QC" (prop_composite_col_readWrite pool) 54 | ] 55 | 56 | 57 | deriving instance Arbitrary TAscii 58 | deriving instance Arbitrary TBytes 59 | deriving instance Arbitrary TCounter 60 | deriving instance Arbitrary TInt32 61 | deriving instance Arbitrary TInt64 62 | deriving instance Arbitrary TUUID 63 | deriving instance Arbitrary TLong 64 | deriving instance Arbitrary TUtf8 65 | deriving instance Arbitrary a => Arbitrary (Exclusive a) 66 | 67 | 68 | instance Arbitrary T.Text where 69 | arbitrary = T.pack <$> arbitrary 70 | 71 | 72 | instance Arbitrary LB.ByteString where 73 | arbitrary = LB.pack <$> arbitrary 74 | 75 | 76 | prop_casTypeAscii :: TAscii -> Bool 77 | prop_casTypeAscii a = (decodeCas . encodeCas) a == a 78 | 79 | 80 | prop_casTypeLong :: TLong -> Property 81 | prop_casTypeLong a@(TLong n) = n >= 0 ==> (decodeCas . encodeCas) a == a 82 | 83 | 84 | prop_casTypeInt32 :: TInt32 -> Bool 85 | prop_casTypeInt32 a = (decodeCas . encodeCas) a == a 86 | 87 | 88 | 89 | prop_casTypeComp :: (TAscii, TBytes, TInt32, TUtf8) -> Property 90 | prop_casTypeComp a = whenFail err $ a == a' 91 | where 92 | a' = (decodeCas . encodeCas) a 93 | err = print $ "Decoded back into: " ++ show a' 94 | 95 | 96 | 97 | prop_casTypeExcComp :: (TAscii, TBytes, TInt32, Exclusive TUtf8) -> Property 98 | prop_casTypeExcComp a = whenFail err $ a == a' 99 | where 100 | a' = (decodeCas . encodeCas) a 101 | err = print $ "Decoded back into: " ++ show a' 102 | 103 | 104 | 105 | 106 | newKS = KsDef { 107 | f_KsDef_name = Just "testing" 108 | , f_KsDef_strategy_class = Just "org.apache.cassandra.locator.NetworkTopologyStrategy" 109 | , f_KsDef_strategy_options = Just (M.fromList [("datacenter1","1")]) 110 | , f_KsDef_replication_factor = Nothing 111 | , f_KsDef_cf_defs = Nothing 112 | , f_KsDef_durable_writes = Just True 113 | } 114 | 115 | 116 | mkTestConn = createCassandraPool [("127.0.0.1", 9160)] 2 2 300 "testing" 117 | 118 | 119 | ------------------------------------------------------------------------------- 120 | test_composite_col = do 121 | pool <- mkTestConn 122 | res <- runCas pool $ do 123 | insert "testing" "row1" ONE [packCol content] 124 | getCol "testing" "row1" (packKey key) ONE 125 | assertEqual "composite get-set" (Just content) (fmap unpackCol res) 126 | where 127 | key = (TLong 125, TBytes "oklahoma") 128 | content = (key, "asdf") 129 | 130 | 131 | ------------------------------------------------------------------------------- 132 | test_composite_slice = do 133 | pool <- mkTestConn 134 | xs <- runCas pool $ do 135 | insert "testing" "row2" ONE [packCol (key, content)] 136 | get "testing" "row2" slice ONE 137 | let (res :: [((TLong, TBytes), LB.ByteString)]) = map unpackCol xs 138 | 139 | assertEqual "composite single col slice" content (snd . head $ res) 140 | where 141 | key = (TLong 125, TBytes "oklahoma") 142 | content = "asdf" 143 | slice = Range (Just (Exclusive (Single (TLong 125)))) 144 | (Just (Single (TLong 125))) 145 | -- (Just (Single (TLong 127))) 146 | Regular 147 | 100 148 | -- slice = Range (Just (TLong 125, TBytes "")) (Just (TLong 125, TBytes "zzzzz")) Regular 100 149 | 150 | 151 | ------------------------------------------------------------------------------- 152 | -- | test quick-check generated pairs for composite column 153 | prop_composite_col_readWrite :: CPool -> ((TLong, TBytes), LB.ByteString) -> Property 154 | prop_composite_col_readWrite pool content@(k@(TLong i, _),v) = i >= 0 ==> 155 | unsafePerformIO $ do 156 | res <- runCas pool $ do 157 | insert "testing" "row" ONE [packCol content] 158 | getCol "testing" "row" (packKey k) ONE 159 | return $ (Just content) == fmap unpackCol res 160 | 161 | 162 | 163 | 164 | -------------------------------------------------------------------------------- /test/Test.py: -------------------------------------------------------------------------------- 1 | from pycassa.types import * 2 | from pycassa.system_manager import * 3 | from pycassa.pool import ConnectionPool 4 | from pycassa.columnfamily import ColumnFamily 5 | 6 | 7 | def create_ks(): 8 | # create test keyspace 9 | sys = SystemManager() 10 | comparator = CompositeType(LongType(), BytesType()) 11 | sys.create_column_family("testing", "testing", comparator_type=comparator) 12 | 13 | 14 | 15 | pool = ConnectionPool('testing') 16 | cf = ColumnFamily(pool, 'testing') 17 | 18 | 19 | # Check the column added by the Haskell test script 20 | # print [k for k in cf.get_range()] 21 | # cf.insert("row2", {(125, 'oklahoma'): 'asdf'}) 22 | 23 | print cf.get('row1') 24 | print cf.get('row2') 25 | # should see: OrderedDict([((125, 'oklahoma'), 'asdf')]) 26 | 27 | --------------------------------------------------------------------------------