diff --git a/cassy.cabal b/cassy.cabal --- a/cassy.cabal +++ b/cassy.cabal @@ -1,5 +1,5 @@ Name: cassy -Version: 0.3.2 +Version: 0.4 Synopsis: A high level driver for the Cassandra datastore License: BSD3 License-file: LICENSE @@ -41,7 +41,7 @@ -- Extra-source-files: -Cabal-version: >=1.2 +Cabal-version: >=1.8 @@ -53,8 +53,7 @@ Database.Cassandra.Pool Database.Cassandra.Types Database.Cassandra.Pack - - -- Packages needed in order to build this package. + Build-depends: base >= 4 && < 5 , bytestring @@ -62,7 +61,7 @@ , containers , network , time - , transformers + , mtl , stm , syb , text @@ -71,14 +70,37 @@ , Thrift >= 0.6 , cassandra-thrift >= 0.8 , resource-pool + , errors + , data-default - Extensions: - TypeSynonymInstances - FlexibleInstances - - -- Modules not exported by this package. - -- Other-modules: - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: - + +test-suite test + type: exitcode-stdio-1.0 + main-is: Test.hs + ghc-options: -Wall + hs-source-dirs: test src + Build-depends: + base >= 4 && < 5 + , bytestring + , binary + , containers + , network + , time + , mtl + , stm + , syb + , text + , attoparsec >= 0.10 && < 0.11 + , aeson + , Thrift >= 0.6 + , cassandra-thrift >= 0.8 + , resource-pool + , errors + , data-default + + , test-framework >= 0.6 + , test-framework-quickcheck2 >= 0.2.12.2 + , test-framework-hunit >= 0.2.7 + , QuickCheck + , HUnit + , derive diff --git a/src/Database/Cassandra/Basic.hs b/src/Database/Cassandra/Basic.hs --- a/src/Database/Cassandra/Basic.hs +++ b/src/Database/Cassandra/Basic.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} -module Database.Cassandra.Basic +module Database.Cassandra.Basic ( @@ -15,7 +19,7 @@ , defServers , KeySpace , createCassandraPool - + -- * MonadCassandra Typeclass , MonadCassandra (..) , Cas (..) @@ -30,7 +34,9 @@ -- * Filtering , Selector(..) + , range , Order(..) + , reverseOrder , KeySelector(..) , KeyRangeType(..) @@ -49,12 +55,27 @@ , Value , Column(..) , col + , packCol + , unpackCol + , packKey , Row , ConsistencyLevel(..) -- * Helpers , CKey (..) - , packLong + , fromColKey' + + -- * Working with column types + , CasType (..) + , TAscii (..) + , TBytes (..) + , TCounter (..) + , TInt (..) + , TInt32 (..) + , TUtf8 (..) + , TUUID (..) + , TLong (..) + , Exclusive (..) ) where @@ -62,14 +83,13 @@ import Control.Applicative import Control.Exception import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader +import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (mapMaybe) import qualified Database.Cassandra.Thrift.Cassandra_Client as C -import Database.Cassandra.Thrift.Cassandra_Types (ConsistencyLevel (..)) +import Database.Cassandra.Thrift.Cassandra_Types (ConsistencyLevel(..)) import qualified Database.Cassandra.Thrift.Cassandra_Types as T import Prelude hiding (catch) ------------------------------------------------------------------------------- @@ -90,7 +110,7 @@ -- flip runCas pool $ do -- get "CF1" "CF1" All ONE -- getCol "CF1" "darak" "eben" ONE --- insert "CF1" "test1" ONE [col "col1" "val1", col "col2" "val2"] +-- insert "CF1" "test1" ONE [col "col1" "val1", col "col2" "val2"] -- get "CF1" "CF1" All ONE >>= liftIO . print -- get "CF1" "not here" All ONE >>= liftIO . print -- delete "CF1" "CF1" (ColNames ["col2"]) ONE @@ -119,37 +139,37 @@ ------------------------------------------------------------------------------- -newtype Cas a = Cas { unCas :: ReaderT CPool IO a } - deriving (Functor,Applicative,Monad,MonadIO) +type Cas a = ReaderT CPool IO a ------------------------------------------------------------------------------- -- | Main running function when using the ad-hoc Cas monad. Just write -- your cassandra actions within the 'Cas' monad and supply them with -- a 'CPool' to execute. -runCas :: Cas a -> CPool -> IO a -runCas f p = runReaderT (unCas f) p +runCas :: CPool -> Cas a -> IO a +runCas = flip runReaderT ------------------------------------------------------------------------------- -instance MonadCassandra Cas where - getCassandraPool = Cas ask +instance (MonadIO m) => MonadCassandra (ReaderT CPool m) where + getCassandraPool = ask ------------------------------------------------------------------------------ -- | Get a single key-column value. -getCol - :: (MonadCassandra m) - => ColumnFamily - -> Key +getCol + :: (MonadCassandra m, CasType k) + => ColumnFamily + -> ByteString -- ^ Row key - -> ColumnName - -- ^ Column/SuperColumn name - -> ConsistencyLevel + -> k + -- ^ Column/SuperColumn key; see 'CasType' for what it can be. Use + -- ByteString in the simple case. + -> ConsistencyLevel -- ^ Read quorum -> m (Maybe Column) getCol cf k cn cl = do - res <- get cf k (ColNames [cn]) cl + res <- get cf k (ColNames [encodeCas cn]) cl case res of [] -> return Nothing x:_ -> return $ Just x @@ -157,16 +177,16 @@ ------------------------------------------------------------------------------ -- | An arbitrary get operation - slice with 'Selector' -get +get :: (MonadCassandra m) - => ColumnFamily + => ColumnFamily -- ^ in ColumnFamily - -> Key + -> ByteString -- ^ Row key to get - -> Selector + -> Selector -- ^ Slice columns with selector - -> ConsistencyLevel - -> m Row + -> ConsistencyLevel + -> m [Column] get cf k s cl = withCassandraPool $ \ Cassandra{..} -> do res <- wrapException $ C.get_slice (cProto, cProto) k cp (mkPredicate s) cl throwing . return $ mapM castColumn res @@ -176,14 +196,14 @@ ------------------------------------------------------------------------------ -- | Do multiple 'get's in one DB hit -getMulti +getMulti :: (MonadCassandra m) - => ColumnFamily + => ColumnFamily -> KeySelector -- ^ A selection of rows to fetch in one hit - -> Selector + -> Selector -- ^ Subject to column selector conditions - -> ConsistencyLevel + -> ConsistencyLevel -> m (Map ByteString Row) -- ^ A Map from Row keys to 'Row's is returned getMulti cf ks s cl = withCassandraPool $ \ Cassandra{..} -> do @@ -192,21 +212,21 @@ res <- wrapException $ C.multiget_slice (cProto, cProto) xs cp (mkPredicate s) cl return $ M.mapMaybe f res KeyRange {} -> do - res <- wrapException $ + res <- wrapException $ C.get_range_slices (cProto, cProto) cp (mkPredicate s) (mkKeyRange ks) cl return $ collectKeySlices res where collectKeySlices :: [T.KeySlice] -> Map ByteString Row collectKeySlices xs = M.fromList $ mapMaybe collectKeySlice xs - collectKeySlice (T.KeySlice (Just k) (Just xs)) = + collectKeySlice (T.KeySlice (Just k) (Just xs)) = case mapM castColumn xs of Left _ -> Nothing Right xs' -> Just (k, xs') collectKeySlice _ = Nothing cp = T.ColumnParent (Just cf) Nothing - f xs = + f xs = case mapM castColumn xs of Left _ -> Nothing Right xs' -> Just xs' @@ -218,12 +238,16 @@ -- This will do as many round-trips as necessary to insert the full -- row. Please keep in mind that each column and each column of each -- super-column is sent to the server one by one. +-- +-- > insert "testCF" "row1" ONE [packCol ("column key", "some column content")] insert :: (MonadCassandra m) => ColumnFamily - -> Key + -> ByteString + -- ^ Row key -> ConsistencyLevel - -> Row + -> [Column] + -- ^ best way to make these columns is through "packCol" -> m () insert cf k cl row = withCassandraPool $ \ Cassandra{..} -> do let insCol cp c = do @@ -237,12 +261,30 @@ SuperColumn cn cols -> do let cp = T.ColumnParent (Just cf) (Just cn) mapM_ (insCol cp) cols - + +------------------------------------------------------------------------------- +-- | Pack key-value pair into 'Column' form ready to be written to Cassandra +packCol :: CasType k => (k, ByteString) -> Column +packCol (k, v) = col (packKey k) v + + +------------------------------------------------------------------------------- +-- | Unpack a Cassandra 'Column' into a more convenient (k,v) form +unpackCol :: CasType k => Column -> (k, Value) +unpackCol (Column k v _ _) = (decodeCas k, v) +unpackCol _ = error "unpackcol unimplemented for SuperColumn types" + + +------------------------------------------------------------------------------- +-- | Pack a column key into binary, ready for submission to Cassandra +packKey :: CasType a => a -> ByteString +packKey = encodeCas + ------------------------------------------------------------------------------ -- | Delete an entire row, specific columns or a specific sub-set of columns -- within a SuperColumn. -delete +delete :: (MonadCassandra m) => ColumnFamily -- ^ In 'ColumnFamily' @@ -266,28 +308,28 @@ cpAll = T.ColumnPath (Just cf) Nothing Nothing -- just a single column - cpCol name = T.ColumnPath (Just cf) Nothing (Just name) + cpCol name = T.ColumnPath (Just cf) Nothing (Just (encodeCas name)) -- scope column by supercol - cpSCol sc name = T.ColumnPath (Just cf) (Just sc) (Just name) - + cpSCol sc name = T.ColumnPath (Just cf) (Just (encodeCas sc)) (Just (encodeCas name)) + ------------------------------------------------------------------------------ -- | Wrap exceptions of the underlying thrift library into the -- exception types defined here. wrapException :: IO a -> IO a wrapException a = f - where + where f = a `catch` (\ (T.NotFoundException) -> throw NotFoundException) - `catch` (\ (T.InvalidRequestException e) -> + `catch` (\ (T.InvalidRequestException e) -> throw . InvalidRequestException $ maybe "" id e) `catch` (\ T.UnavailableException -> throw UnavailableException) `catch` (\ T.TimedOutException -> throw TimedOutException) - `catch` (\ (T.AuthenticationException e) -> + `catch` (\ (T.AuthenticationException e) -> throw . AuthenticationException $ maybe "" id e) - `catch` (\ (T.AuthorizationException e) -> + `catch` (\ (T.AuthorizationException e) -> throw . AuthorizationException $ maybe "" id e) `catch` (\ T.SchemaDisagreementException -> throw SchemaDisagreementException) diff --git a/src/Database/Cassandra/JSON.hs b/src/Database/Cassandra/JSON.hs --- a/src/Database/Cassandra/JSON.hs +++ b/src/Database/Cassandra/JSON.hs @@ -1,45 +1,46 @@ -{-# LANGUAGE PatternGuards, - NamedFieldPuns, - OverloadedStrings, - TypeSynonymInstances, - ScopedTypeVariables, - FlexibleInstances, - ExistentialQuantification, - RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} {-| A higher level module for working with Cassandra. - + All row and column keys are standardized to be of strict types. Row keys are Text, while Column keys are ByteString. This might change in the future and we may revert to entirely ByteString keys. - + Serialization and de-serialization of Column values are taken care of automatically using the ToJSON and FromJSON typeclasses. -} -module Database.Cassandra.JSON - ( - +module Database.Cassandra.JSON + ( + -- * Connection CPool - , Server (..) + , Server , defServer , defServers - , KeySpace (..) + , KeySpace , createCassandraPool -- * MonadCassandra Typeclass , MonadCassandra (..) - , Cas (..) + , Cas , runCas -- * Cassandra Operations , get - , getCol + , get_ + , getCol , getMulti , insertCol , modify @@ -50,17 +51,33 @@ , RowKey , ColumnName , ModifyOperation (..) - , ColumnFamily (..) + , ColumnFamily , ConsistencyLevel (..) , CassandraException (..) + + -- * Filtering , Selector (..) + , range + , Order(..) + , reverseOrder , KeySelector (..) , KeyRangeType (..) - + -- * Helpers , CKey (..) - , packLong - + , fromColKey' + + -- * Working with column types + , CasType (..) + , TAscii (..) + , TBytes (..) + , TCounter (..) + , TInt (..) + , TInt32 (..) + , TUtf8 (..) + , TUUID (..) + , TLong (..) + , Exclusive (..) ) where ------------------------------------------------------------------------------- @@ -72,39 +89,31 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Int (Int32, Int64) +import Data.Int (Int32) import Data.Map (Map) import qualified Data.Map as M -import qualified Data.Text as T -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Network import Prelude hiding (catch) ------------------------------------------------------------------------------- -import Database.Cassandra.Basic hiding (get, getCol, delete, KeySelector (..), - getMulti) +import Database.Cassandra.Basic hiding (KeySelector(..), delete, get, getCol, getMulti) import qualified Database.Cassandra.Basic as CB -import Database.Cassandra.Pool -import Database.Cassandra.Types hiding (KeySelector (..), ColumnName) -import Database.Cassandra.Pack ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | Convert regular column to a key-value pair -col2val :: (FromJSON a) => Column -> (ColumnName, a) -col2val (Column nm val _ _) = (fromBS nm, maybe err id $ unMarshallJSON' val) - where err = error "Value can't be parsed from JSON." +col2val :: (FromJSON a, CasType k) => Column -> (k, a) +col2val c = f $ unpackCol c + where + f (k, val) = (k, maybe err id $ unMarshallJSON' val) + err = error "Value can't be parsed from JSON." col2val _ = error "col2val is not implemented for SuperColumns" ------------------------------------------------------------------------------ --- | Possible outcomes of a modify operation -data ModifyOperation a = +-- | Possible outcomes of a modify operation +data ModifyOperation a = Update a | Delete | DoNothing @@ -112,12 +121,12 @@ ------------------------------------------------------------------------------- -type RowKey = Text +type RowKey = ByteString ------------------------------------------------------------------------------ -- | A modify function that will fetch a specific column, apply modification --- function on it and save results back to Cassandra. +-- function on it and save results back to Cassandra. -- -- A 'b' side value is returned for computational convenience. -- @@ -128,10 +137,11 @@ -- This method may throw a 'CassandraException' for all exceptions other than -- 'NotFoundException'. modify - :: (MonadCassandra m, ToJSON a, FromJSON a) + :: (MonadCassandra m, ToJSON a, FromJSON a, CasType k) => ColumnFamily -> RowKey - -> ColumnName + -> k + -- ^ Column name; anything in CasType -> ConsistencyLevel -- ^ Read quorum -> ConsistencyLevel @@ -141,25 +151,23 @@ -- 'Nothing' otherwise. -> m b -- ^ Return the decided 'ModifyOperation' and its execution outcome -modify cf k cn rcl wcl f = +modify cf k cn rcl wcl f = let - k' = toBS k - cn' = toBS cn + k' = toColKey k + cn' = encodeCas cn execF prev = do (fres, b) <- f prev case fres of - (Update a) -> - insert cf k' wcl [col cn' (marshallJSON' a)] - (Delete) -> - CB.delete cf k' (ColNames [cn']) wcl - (DoNothing) -> return () + Update a -> insert cf k' wcl [col cn' (marshallJSON' a)] + Delete -> CB.delete cf k' (ColNames [cn']) wcl + DoNothing -> return () return b in do res <- CB.getCol cf k' cn' rcl case res of - Nothing -> execF Nothing - Just Column{..} -> execF (unMarshallJSON' colVal) - Just SuperColumn{..} -> throw $ + Nothing -> execF Nothing + Just Column{..} -> execF (unMarshallJSON' colVal) + Just SuperColumn{..} -> throw $ OperationNotSupported "modify not implemented for SuperColumn" @@ -169,10 +177,11 @@ -- This method may throw a 'CassandraException' for all exceptions other than -- 'NotFoundException'. modify_ - :: (MonadCassandra m, ToJSON a, FromJSON a) + :: (MonadCassandra m, ToJSON a, FromJSON a, CasType k) => ColumnFamily -> RowKey - -> ColumnName + -> k + -- ^ Column name; anything in CasType -> ConsistencyLevel -- ^ Read quorum -> ConsistencyLevel @@ -181,7 +190,7 @@ -- ^ Modification function. Called with 'Just' the value if present, -- 'Nothing' otherwise. -> m () -modify_ cf k cn rcl wcl f = +modify_ cf k cn rcl wcl f = let f' prev = do op <- f prev @@ -194,15 +203,16 @@ ------------------------------------------------------------------------------- -- Simple insertion function making use of typeclasses insertCol - :: (MonadCassandra m, ToJSON a) - => ColumnFamily + :: (MonadCassandra m, ToJSON a, CasType k) + => ColumnFamily -> RowKey - -> ColumnName + -> k + -- ^ Column name. See 'CasType' for what you can use here. -> ConsistencyLevel -> a -- ^ Content -> m () -insertCol cf k cn cl a = - insert cf (toBS k) cl [col (toBS cn) (marshallJSON' a)] +insertCol cf rk cn cl a = + insert cf (toColKey rk) cl [packCol (cn, marshallJSON' a)] ------------------------------------------------------------------------------ @@ -212,61 +222,82 @@ -- ColumnFamily and contents of returned columns are cast into the -- target type. get - :: (MonadCassandra m, FromJSON a) + :: (MonadCassandra m, FromJSON a, CasType k) => ColumnFamily -> RowKey -> Selector + -- ^ A slice selector -> ConsistencyLevel - -> m [(ColumnName, a)] + -> m [(k, a)] + -- ^ List of key-value pairs. See 'CasType' for what key types you can use. get cf k s cl = do - res <- CB.get cf (toBS k) s cl + res <- CB.get cf (toColKey k) s cl return $ map col2val res ------------------------------------------------------------------------------- -data KeySelector +-- | A version of 'get' that discards the column names for the common +-- scenario. Useful because you would otherwise be forced to manually +-- supply type signatures to get rid of the 'CasType' ambiguity. +get_ + :: (MonadCassandra m, FromJSON a) + => ColumnFamily + -> RowKey + -> Selector + -- ^ A slice selector + -> ConsistencyLevel + -> m [a] +get_ cf k s cl = do + (res :: [(LB.ByteString, a)]) <- get cf k s cl + return $ map snd res + + +------------------------------------------------------------------------------- +data KeySelector = Keys [RowKey] | KeyRange KeyRangeType RowKey RowKey Int32 ------------------------------------------------------------------------------- -ksToBasicKS (Keys k) = CB.Keys $ map toBS k -ksToBasicKS (KeyRange ty fr to i) = CB.KeyRange ty (toBS fr) (toBS to) i +ksToBasicKS :: KeySelector -> CB.KeySelector +ksToBasicKS (Keys k) = CB.Keys $ map toColKey k +ksToBasicKS (KeyRange ty fr to i) = CB.KeyRange ty (toColKey fr) (toColKey to) i ------------------------------------------------------------------------------- -- | Get a slice of columns from multiple rows at once. Note that -- since we are auto-serializing from JSON, all the columns must be of -- the same data type. -getMulti +getMulti :: (MonadCassandra m, FromJSON a) => ColumnFamily - -> KeySelector - -> Selector + -> KeySelector + -> Selector -> ConsistencyLevel -> m (Map RowKey [(ColumnName, a)]) getMulti cf ks s cl = do res <- CB.getMulti cf (ksToBasicKS ks) s cl return . M.fromList . map conv . M.toList $ res where - conv (k, row) = (fromBS k, map col2val row) - + conv (k, row) = (fromColKey' k, map col2val row) + ------------------------------------------------------------------------------- -- | Get a single column from a single row getCol - :: (MonadCassandra m, FromJSON a) + :: (MonadCassandra m, FromJSON a, CasType k) => ColumnFamily -> RowKey - -> ColumnName + -> k + -- ^ Column name; anything in 'CasType' -> ConsistencyLevel -> m (Maybe a) getCol cf rk ck cl = do - res <- CB.getCol cf (toBS rk) (toBS ck) cl + res <- CB.getCol cf (toColKey rk) (encodeCas ck) cl case res of Nothing -> return Nothing Just res' -> do - let (_, x) = col2val res' + let (_ :: ByteString, x) = col2val res' return $ Just x @@ -274,7 +305,7 @@ -- | Same as the 'delete' in the 'Cassandra.Basic' module, except that -- it throws an exception rather than returning an explicit Either -- value. -delete +delete :: (MonadCassandra m) =>ColumnFamily -- ^ In 'ColumnFamily' @@ -284,7 +315,7 @@ -- ^ Columns to be deleted -> ConsistencyLevel -> m () -delete cf k s cl = CB.delete cf (toBS k) s cl +delete cf k s cl = CB.delete cf (toColKey k) s cl ------------------------------------------------------------------------------ @@ -294,7 +325,7 @@ ------------------------------------------------------------------------------ --- | Encode JSON +-- | Encode JSON marshallJSON :: ToJSON a => a -> B.ByteString marshallJSON = B.concat . LB.toChunks . A.encode @@ -302,13 +333,13 @@ ------------------------------------------------------------------------------ -- | Lazy 'unMarshallJSON' unMarshallJSON' :: FromJSON a => ByteString -> Maybe a -unMarshallJSON' = unMarshallJSON . B.concat . LB.toChunks +unMarshallJSON' = unMarshallJSON . B.concat . LB.toChunks ------------------------------------------------------------------------------ --- | Decode JSON +-- | Decode JSON unMarshallJSON :: FromJSON a => B.ByteString -> Maybe a -unMarshallJSON = pJson - where +unMarshallJSON = pJson + where pJson bs = val where js = Atto.parse value bs diff --git a/src/Database/Cassandra/Pack.hs b/src/Database/Cassandra/Pack.hs --- a/src/Database/Cassandra/Pack.hs +++ b/src/Database/Cassandra/Pack.hs @@ -1,17 +1,321 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE RankNTypes #-} + {-| A Collection of utilities for binary packing values into Bytestring |-} module Database.Cassandra.Pack - ( packLong + ( CasType (..) + , TAscii (..) + , TBytes (..) + , TCounter (..) + , TInt (..) + , TInt32 (..) + , TUtf8 (..) + , TUUID (..) + , TLong (..) + , Exclusive (..) + , Single (..) ) where ------------------------------------------------------------------------------- -import qualified Data.Binary.Put as BN +import Control.Applicative +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Char +import Data.Int +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT ------------------------------------------------------------------------------- + ------------------------------------------------------------------------------- --- | Pack any integral value into LongType -packLong :: Integral a => a -> ByteString -packLong = BN.runPut . BN.putWord64be . fromIntegral +newtype TAscii = TAscii { getAscii :: ByteString } deriving (Eq,Show,Read,Ord) +newtype TBytes = TBytes { getTBytes :: ByteString } deriving (Eq,Show,Read,Ord) +newtype TCounter = TCounter { getCounter :: ByteString } deriving (Eq,Show,Read,Ord) +newtype TInt32 = TInt32 { getInt32 :: Int32 } deriving (Eq,Show,Read,Ord) +newtype TInt = TInt { getInt :: Integer } deriving (Eq,Show,Read,Ord) +newtype TUUID = TUUID { getUUID :: ByteString } deriving (Eq,Show,Read,Ord) +newtype TLong = TLong { getLong :: Integer } deriving (Eq,Show,Read,Ord) +newtype TUtf8 = TUtf8 { getUtf8 :: Text } deriving (Eq,Show,Read,Ord) + + +------------------------------------------------------------------------------- +-- | This typeclass defines and maps to haskell types that Cassandra +-- natively knows about and uses in sorting and potentially validating +-- column key values. +-- +-- All column keys are eventually sent to and received from Cassandra +-- in binary form. This typeclass allows us to map some Haskell type +-- definitions to their binary representation. The correct binary +-- serialization is handled for you behind the scenes. +-- +-- For simplest cases, just use one of the string-like instances, e.g. +-- 'ByteString', 'String' or 'Text'. Please keep in mind that these +-- are just mapped to untyped BytesType. +-- +-- Remember that for special column types, such as 'TLong', to have +-- any effect, your ColumnFamily must have been created with that +-- comparator or validator. Otherwise you're just encoding/decoding +-- integer values without any Cassandra support for sorting or +-- correctness. +-- +-- The Python library pycassa has a pretty good tutorial to learn more. +-- +-- Tuple instances support fixed ComponentType columns. Example: +-- +-- > insert "testCF" "row1" [packCol ((TLong 124, TAscii "Hello"), "some content")] +class CasType a where + encodeCas :: a -> ByteString + decodeCas :: ByteString -> a + + +instance CasType B.ByteString where + encodeCas = fromStrict + decodeCas = toStrict + + +instance CasType String where + encodeCas = LB.pack + decodeCas = LB.unpack + + +instance CasType LT.Text where + encodeCas = encodeCas . LT.encodeUtf8 + decodeCas = LT.decodeUtf8 + + +instance CasType T.Text where + encodeCas = encodeCas . LT.fromChunks . return + decodeCas = T.concat . LT.toChunks . decodeCas + + +instance CasType LB.ByteString where + encodeCas = id + decodeCas = id + + +instance CasType TAscii where + encodeCas = getAscii + decodeCas = TAscii + + +instance CasType TBytes where + encodeCas = getTBytes + decodeCas = TBytes + + +instance CasType TCounter where + encodeCas = getCounter + decodeCas = TCounter + + +------------------------------------------------------------------------------- +-- | Pack as a 4 byte number +instance CasType TInt32 where + encodeCas = runPut . putWord32be . fromIntegral . getInt32 + decodeCas = TInt32 . fromIntegral . runGet getWord32be + + +------------------------------------------------------------------------------- +-- | Pack as an 8 byte number - same as 'TLong' +instance CasType TInt where + encodeCas = runPut . putWord64be . fromIntegral . getInt + decodeCas = TInt . fromIntegral . runGet getWord64be + +instance CasType Int where + encodeCas = encodeCas . TInt . fromIntegral + decodeCas = fromIntegral . getInt . decodeCas + +------------------------------------------------------------------------------- +-- | Pack as an 8 byte unsigned number; negative signs are lost. +instance CasType TLong where + encodeCas = runPut . putWord64be . fromIntegral . getLong + decodeCas = TLong . fromIntegral . runGet getWord64be + + +------------------------------------------------------------------------------- +-- | Encode and decode as Utf8 'Text' +instance CasType TUtf8 where + encodeCas = LB.fromChunks . return . T.encodeUtf8 . getUtf8 + decodeCas = TUtf8 . T.decodeUtf8 . B.concat . LB.toChunks + + +------------------------------------------------------------------------------- +-- | Use the 'Single' wrapper when querying only with the first of a +-- two or more field CompositeType. +instance (CasType a) => CasType (Single a) where + encodeCas a = runPut $ do + putSegment a end + + decodeCas bs = flip runGet bs $ Single <$> getSegment + +------------------------------------------------------------------------------- +-- | Composite types - see Cassandra or pycassa docs to understand +instance (CasType a, CasType b) => CasType (a,b) where + encodeCas (a, b) = runPut $ do + putSegment a sep + putSegment b end + + decodeCas bs = flip runGet bs $ (,) + <$> getSegment + <*> getSegment + + +instance (CasType a, CasType b, CasType c) => CasType (a,b,c) where + encodeCas (a, b, c) = runPut $ do + putSegment a sep + putSegment b sep + putSegment c end + + decodeCas bs = flip runGet bs $ (,,) + <$> getSegment + <*> getSegment + <*> getSegment + + +instance (CasType a, CasType b, CasType c, CasType d) => CasType (a,b,c,d) where + encodeCas (a, b, c, d) = runPut $ do + putSegment a sep + putSegment b sep + putSegment c sep + putSegment d end + + decodeCas bs = flip runGet bs $ (,,,) + <$> getSegment + <*> getSegment + <*> getSegment + <*> getSegment + + +instance (CasType a, CasType b) => CasType (a, Exclusive b) where + encodeCas (a, Exclusive b) = runPut $ do + putSegment a sep + putSegment b exc + + decodeCas bs = flip runGet bs $ (,) + <$> getSegment + <*> (Exclusive <$> getSegment) + + +instance (CasType a, CasType b, CasType c) => CasType (a, b, Exclusive c) where + encodeCas (a, b, Exclusive c) = runPut $ do + putSegment a sep + putSegment b sep + putSegment c exc + + decodeCas bs = flip runGet bs $ (,,) + <$> getSegment + <*> getSegment + <*> (Exclusive <$> getSegment) + + +instance (CasType a, CasType b, CasType c, CasType d) => CasType (a, b, c, Exclusive d) where + encodeCas (a, b, c, Exclusive d) = runPut $ do + putSegment a sep + putSegment b sep + putSegment c sep + putSegment d exc + + decodeCas bs = flip runGet bs $ (,,,) + <$> getSegment + <*> getSegment + <*> getSegment + <*> (Exclusive <$> getSegment) + + +-- instance CasType a => CasType [a] where +-- encodeCas as = runPut $ do +-- mapM (flip putSegment sep) $ init as +-- putSegment (last as) end + + +------------------------------------------------------------------------------- +-- | Exclusive tag for composite column. You may tag the end of a +-- composite range with this to make the range exclusive. See pycassa +-- documentation for more information. +newtype Exclusive a = Exclusive a deriving (Eq,Show,Read,Ord) + + +------------------------------------------------------------------------------- +-- | Use the Single wrapper when you want to refer only to the first +-- coolumn of a CompositeType column. +newtype Single a = Single a deriving (Eq,Show,Read,Ord) + + +-- | composite columns are a pain +-- need to write 2 byte length, n byte body, 1 byte separator +-- +-- from pycassa: +-- The composite format for each component is: +-- +-- 2 bytes | ? bytes | 1 byte + + +------------------------------------------------------------------------------- +putBytes :: B.ByteString -> Put +putBytes b = do + putLen b + putByteString b + + +------------------------------------------------------------------------------- +getBytes' :: Get B.ByteString +getBytes' = getLen >>= getBytes + + +------------------------------------------------------------------------------- +getLen :: Get Int +getLen = fromIntegral `fmap` getWord16be + + +------------------------------------------------------------------------------- +putLen :: B.ByteString -> Put +putLen b = putWord16be . fromIntegral $ (B.length b) + + + +------------------------------------------------------------------------------- +toStrict :: ByteString -> B.ByteString +toStrict = B.concat . LB.toChunks + + +------------------------------------------------------------------------------- +fromStrict :: B.ByteString -> ByteString +fromStrict = LB.fromChunks . return + + +------------------------------------------------------------------------------- +getSegment :: CasType a => Get a +getSegment = do + a <- (decodeCas . fromStrict) <$> getBytes' + getWord8 -- discard separator character + return a + + +------------------------------------------------------------------------------- +putSegment :: CasType a => a -> PutM b -> PutM b +putSegment a f = do + putBytes . toStrict $ encodeCas a + f + +-- | When end point is exclusive +exc :: Put +exc = putWord8 . fromIntegral $ ord '\xff' + +-- | Regular (inclusive) end point +end :: Put +end = putWord8 . fromIntegral $ ord '\x01' + +-- | Separator between composite parts +sep :: Put +sep = putWord8 . fromIntegral $ ord '\x00' diff --git a/src/Database/Cassandra/Pool.hs b/src/Database/Cassandra/Pool.hs --- a/src/Database/Cassandra/Pool.hs +++ b/src/Database/Cassandra/Pool.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE PatternGuards, NamedFieldPuns, RecordWildCards #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} -module Database.Cassandra.Pool +module Database.Cassandra.Pool ( CPool , Server , defServer @@ -10,28 +12,36 @@ , Cassandra (..) , createCassandraPool , withResource + + -- * Low Level Utilities + , openThrift ) where -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Control.Concurrent.STM -import Control.Exception (SomeException, catch, onException) -import Control.Monad (forM_, forever, join, liftM2, unless, when) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString (ByteString) -import Data.List (partition) -import "resource-pool" Data.Pool -import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +------------------------------------------------------------------------------ +import Control.Applicative ((<$>)) +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception (SomeException, handle, onException) +import Control.Monad (forM_, forever, join, liftM2, unless, when) +import Data.ByteString (ByteString) +import Data.List (find, nub, partition) +import Data.Maybe +import Data.Pool +import Data.Set (Set) +import qualified Data.Set as S +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import qualified Database.Cassandra.Thrift.Cassandra_Client as C -import Network -import Prelude hiding (catch) -import System.IO (hClose, Handle(..)) -import System.Mem.Weak (addFinalizer) -import Thrift.Protocol.Binary -import Thrift.Transport -import Thrift.Transport.Framed -import Thrift.Transport.Handle -------------------------------------------------------------------------------- +import qualified Database.Cassandra.Thrift.Cassandra_Types as C +import Network +import Prelude hiding (catch) +import System.IO (Handle(..), hClose) +import System.Mem.Weak (addFinalizer) +import Thrift.Protocol.Binary +import Thrift.Transport +import Thrift.Transport.Framed +import Thrift.Transport.Handle +------------------------------------------------------------------------------ ------------------------------------------------------------------------------ @@ -39,7 +49,7 @@ type CPool = Pool Cassandra -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ -- | A (ServerName, Port) tuple type Server = (HostName, Int) @@ -54,11 +64,11 @@ defServers = [defServer] -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ type KeySpace = String -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ data Cassandra = Cassandra { cHandle :: Handle , cFramed :: FramedTransport Handle @@ -71,7 +81,7 @@ -- -- Each box in the cluster will get up to n connections. The pool will send -- queries in round-robin fashion to balance load on each box in the cluster. -createCassandraPool +createCassandraPool :: [Server] -- ^ List of servers to connect to -> Int @@ -85,50 +95,112 @@ -> IO CPool createCassandraPool servers numStripes perStripe maxIdle ks = do sring <- newTVarIO $ mkRing servers - createPool (cr sring) dest numStripes maxIdle perStripe + pool <- createPool (cr sring) dest numStripes maxIdle perStripe + forkIO (serverDiscoveryThread sring ks pool) + return pool where cr :: ServerRing -> IO Cassandra cr sring = do - server <- atomically $ do + s@(host, p) <- atomically $ do ring@Ring{..} <- readTVar sring - writeTVar sring $ next ring + writeTVar sring (next ring) return current - crCon server - - crCon :: Server -> IO Cassandra - crCon (host, p) = do - h <- hOpen (host, PortNumber (fromIntegral p)) - ft <- openFramedTransport h - let p = BinaryProtocol ft - C.set_keyspace (p,p) ks - return $ Cassandra h ft p - dest h = hClose $ cHandle h + handle (handler sring s) $ do + (h,ft,proto) <- openThrift host p + C.set_keyspace (proto, proto) ks + return $ Cassandra h ft proto + handler :: ServerRing -> Server -> SomeException -> IO Cassandra + handler sring server e = do + modifyServers sring (removeServer server) + cr sring + dest h = hClose $ cHandle h + + ------------------------------------------------------------------------------- +-- | Open underlying thrift connection +openThrift host port = do + h <- hOpen (host, PortNumber (fromIntegral port)) + ft <- openFramedTransport h + let p = BinaryProtocol ft + return (h, ft, p) + + +------------------------------------------------------------------------------ +modifyServers :: TVar (Ring a) -> (Ring a -> Ring a) -> IO () +modifyServers sring f = atomically $ do + ring@Ring{..} <- readTVar sring + writeTVar sring $ f ring + return () + + +------------------------------------------------------------------------------ +serverDiscoveryThread :: TVar (Ring Server) + -> String + -> Pool Cassandra + -> IO b +serverDiscoveryThread sring ks pool = forever $ do + withResource pool (updateServers sring ks) + threadDelay 60000000 + + +------------------------------------------------------------------------------ +updateServers :: TVar (Ring Server) -> String -> Cassandra -> IO () +updateServers sring ks (Cassandra _ _ p) = do + ranges <- C.describe_ring (p,p) ks + let hosts = concat $ catMaybes $ map C.f_TokenRange_endpoints ranges + servers = nub $ map (\e -> first (const e) defServer) hosts + -- putStrLn $ "Cassy: Discovered new servers: " ++ show servers + modifyServers sring (addNewServers servers) + + +------------------------------------------------------------------------------ type ServerRing = TVar (Ring Server) -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ data Ring a = Ring { - current :: !a + allItems :: Set a + , current :: !a , used :: [a] , upcoming :: [a] } -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ mkRing [] = error "Can't make a ring from empty list" -mkRing (a:as) = Ring a [] as +mkRing (a:as) = Ring S.empty a [] as -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ next :: Ring a -> Ring a -next Ring{..} +next Ring{..} | (n:rest) <- upcoming - = Ring n (current : used) rest -next Ring{..} + = Ring allItems n (current : used) rest +next Ring{..} | (n:rest) <- reverse (current : used) - = Ring n [] rest + = Ring allItems n [] rest + + +------------------------------------------------------------------------------ +removeServer :: Ord a => a -> Ring a -> Ring a +removeServer s r@Ring{..} + | s `S.member` allItems = Ring (S.delete s allItems) current' used' upcoming' + | otherwise = r + where + used' = filter (/=s) used + (current':upcoming') = filter (/=s) (current:upcoming) + + +------------------------------------------------------------------------------ +addNewServers :: [Server] -> Ring Server -> Ring Server +addNewServers servers Ring{..} = Ring all' current' used' (new ++ upcoming') + where + all' = S.fromList servers + new = S.toList $ all' S.\\ allItems + used' = filter (`S.member` all') used + (current':upcoming') = filter (`S.member` all') (current:upcoming) + diff --git a/src/Database/Cassandra/Types.hs b/src/Database/Cassandra/Types.hs --- a/src/Database/Cassandra/Types.hs +++ b/src/Database/Cassandra/Types.hs @@ -1,31 +1,40 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternGuards, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} module Database.Cassandra.Types where ------------------------------------------------------------------------------- +import Control.Error import Control.Exception import Control.Monad -import qualified Data.ByteString.Char8 as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Default import Data.Generics -import Data.Int (Int32, Int64) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT +import Data.Int (Int32, Int64) +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT import Data.Time import Data.Time.Clock.POSIX import qualified Database.Cassandra.Thrift.Cassandra_Types as C ------------------------------------------------------------------------------- +import Database.Cassandra.Pack +------------------------------------------------------------------------------- -- | A 'Key' range selector to use with 'getMulti'. -data KeySelector = +data KeySelector = Keys [Key] -- ^ Just a list of keys to get | KeyRange KeyRangeType Key Key Int32 @@ -34,7 +43,7 @@ deriving (Show) --- | Encodes the Key vs. Token options in the thrift API. +-- | Encodes the Key vs. Token options in the thrift API. -- -- 'InclusiveRange' ranges are just plain intuitive range queries. -- 'WrapAround' ranges are also inclusive, but they wrap around the ring. @@ -46,34 +55,71 @@ InclusiveRange -> C.KeyRange (Just st) (Just end) Nothing Nothing (Just cnt) WrapAround -> C.KeyRange Nothing Nothing (Just $ LB.unpack st) (Just $ LB.unpack end) (Just cnt) + +------------------------------------------------------------------------------- -- | A column selector/filter statement for queries. -- -- Remember that SuperColumns are always fully deserialized, so we don't offer -- a way to filter columns within a 'SuperColumn'. -data Selector = +-- +-- Column names and ranges are specified by any type that can be +-- packed into a Cassandra column using the 'CasType' typeclass. +data Selector = All -- ^ Return everything in 'Row' - | ColNames [ColumnName] + | forall a. CasType a => ColNames [a] -- ^ Return specific columns or super-columns depending on the 'ColumnFamily' - | SupNames ColumnName [ColumnName] + | forall a b. (CasType a, CasType b) => SupNames a [b] -- ^ When deleting specific columns in a super column - | Range (Maybe ColumnName) (Maybe ColumnName) Order Int32 - -- ^ Return a range of columns or super-columns - deriving (Show) + | forall a b. (CasType a, CasType b) => Range { + rangeStart :: Maybe a + , rangeEnd :: Maybe b + , rangeOrder :: Order + , rangeLimit :: Int32 + } + -- ^ Return a range of columns or super-columns. +------------------------------------------------------------------------------- +-- | A default starting point for range 'Selector'. Use this so you +-- don't run into ambiguous type variables when using Nothing. +-- +-- > range = Range (Nothing :: Maybe ByteString) (Nothing :: Maybe ByteString) Regular 1024 +range = Range (Nothing :: Maybe ByteString) (Nothing :: Maybe ByteString) Regular 1024 + + +instance Default Selector where + def = All + +instance Show Selector where + show All = "All" + show (ColNames cns) = concat + ["ColNames: ", intercalate ", " $ map showCas cns] + show (SupNames cn cns) = concat + ["SuperCol: ", showCas cn, "; Cols: ", intercalate ", " (map showCas cns)] + show (Range a b order i) = concat + [ "Range from ", maybe "Nothing" showCas a, " to ", maybe "Nothing" showCas b + , " order ", show order, " max ", show i, " items." ] + + +------------------------------------------------------------------------------- +showCas :: CasType a => a -> String +showCas t = LB.unpack . encodeCas $ t + + +------------------------------------------------------------------------------- mkPredicate :: Selector -> C.SlicePredicate -mkPredicate s = +mkPredicate s = let - allRange = C.SliceRange (Just "") (Just "") (Just False) (Just 100) + allRange = C.SliceRange (Just "") (Just "") (Just False) (Just 5000) in case s of All -> C.SlicePredicate Nothing (Just allRange) - ColNames ks -> C.SlicePredicate (Just ks) Nothing - Range st end ord cnt -> + ColNames ks -> C.SlicePredicate (Just (map encodeCas ks)) Nothing + Range st end ord cnt -> let - st' = st `mplus` Just "" - end' = end `mplus` Just "" - in C.SlicePredicate Nothing + st' = fmap encodeCas st `mplus` Just "" + end' = fmap encodeCas end `mplus` Just "" + in C.SlicePredicate Nothing (Just (C.SliceRange st' end' (Just $ renderOrd ord) (Just cnt))) @@ -83,10 +129,17 @@ data Order = Regular | Reversed deriving (Show) + +------------------------------------------------------------------------------- renderOrd Regular = False renderOrd Reversed = True +------------------------------------------------------------------------------- +reverseOrder Regular = Reversed +reverseOrder _ = Regular + + type ColumnFamily = String @@ -102,7 +155,7 @@ ------------------------------------------------------------------------------ -- | A Column is either a single key-value pair or a SuperColumn with an -- arbitrary number of key-value pairs -data Column = +data Column = SuperColumn ColumnName [Column] | Column { colKey :: ColumnName @@ -121,7 +174,8 @@ ------------------------------------------------------------------------------ --- | A short-hand for creating key-value 'Column' values +-- | A short-hand for creating key-value 'Column' values. This is +-- pretty low level; you probably want to use 'packCol'. col :: ByteString -> ByteString -> Column col k v = Column k v Nothing Nothing @@ -136,12 +190,12 @@ castColumn :: C.ColumnOrSuperColumn -> Either CassandraException Column castColumn x | Just c <- C.f_ColumnOrSuperColumn_column x = castCol c | Just c <- C.f_ColumnOrSuperColumn_super_column x = castSuperCol c -castColumn _ = +castColumn _ = Left $ ConversionException "castColumn: Unsupported/unexpected ColumnOrSuperColumn type" castCol :: C.Column -> Either CassandraException Column -castCol c +castCol c | Just nm <- C.f_Column_name c , Just val <- C.f_Column_value c , Just ts <- C.f_Column_timestamp c @@ -151,7 +205,7 @@ castSuperCol :: C.SuperColumn -> Either CassandraException Column -castSuperCol c +castSuperCol c | Just nm <- C.f_SuperColumn_name c , Just cols <- C.f_SuperColumn_columns c , Right cols' <- mapM castCol cols @@ -159,7 +213,7 @@ castSuperCol _ = Left $ ConversionException "Can't parse SuperColumn" -data CassandraException = +data CassandraException = NotFoundException | InvalidRequestException String | UnavailableException @@ -192,27 +246,46 @@ ------------------------------------------------------------------------------ -- | A typeclass to enable using any string-like type for row and column keys class CKey a where - toBS :: a -> ByteString - fromBS :: ByteString -> a + toColKey :: a -> ByteString + fromColKey :: ByteString -> Either String a + +------------------------------------------------------------------------------- +-- | Raise an error if conversion fails +fromColKey' :: CKey a => ByteString -> a +fromColKey' = either error id . fromColKey + + +------------------------------------------------------------------------------- +-- | For easy composite keys, just serialize your data type to a list +-- of bytestrings, we'll concat them and turn them into column keys. +instance CKey [B.ByteString] where + toColKey xs = LB.intercalate ":" $ map toColKey xs + fromColKey str = mapM fromColKey $ LB.split ':' str + + instance CKey String where - toBS = LB.pack - fromBS = LB.unpack + toColKey = LB.pack + fromColKey = return . LB.unpack + instance CKey LT.Text where - toBS = LT.encodeUtf8 - fromBS = LT.decodeUtf8 + toColKey = LT.encodeUtf8 + fromColKey = return `fmap` LT.decodeUtf8 + instance CKey T.Text where - toBS = toBS . LT.fromChunks . return - fromBS = T.concat . LT.toChunks . fromBS + toColKey = toColKey . LT.fromChunks . return + fromColKey = fmap (T.concat . LT.toChunks) . fromColKey + instance CKey B.ByteString where - toBS = LB.fromChunks . return - fromBS = B.concat . LB.toChunks . fromBS + toColKey = LB.fromChunks . return + fromColKey = fmap (B.concat . LB.toChunks) . fromColKey + instance CKey ByteString where - toBS = id - fromBS = id + toColKey = id + fromColKey = return diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + + +------------------------------------------------------------------------------- +import Control.Applicative +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.DeriveTH +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Database.Cassandra.Thrift.Cassandra_Client as C +import Database.Cassandra.Thrift.Cassandra_Types (ConsistencyLevel(..)) +import Database.Cassandra.Thrift.Cassandra_Types as T +import System.IO.Unsafe +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.QuickCheck +import Test.QuickCheck.Property + +------------------------------------------------------------------------------- +import Database.Cassandra.Basic +import Database.Cassandra.Pack +import Database.Cassandra.Pool +------------------------------------------------------------------------------- + + + +main = do + pool <- mkTestConn + defaultMain $ tests pool + + +tests pool = [testGroup "packTests" (packTests pool)] + + +packTests pool = + [ testProperty "cas type marshalling long" prop_casTypeLong + , testProperty "cas type marshalling ascii" prop_casTypeAscii + , testProperty "cas type marshalling ascii" prop_casTypeInt32 + , testProperty "cas type marshalling composite" prop_casTypeComp + , testCase "cas live test - composite get/set" test_composite_col + , testProperty "cas live test read/write QC" (prop_composite_col_readWrite pool) + ] + + +deriving instance Arbitrary TAscii +deriving instance Arbitrary TBytes +deriving instance Arbitrary TCounter +deriving instance Arbitrary TInt32 +deriving instance Arbitrary TInt +deriving instance Arbitrary TUUID +deriving instance Arbitrary TLong +deriving instance Arbitrary TUtf8 +deriving instance Arbitrary a => Arbitrary (Exclusive a) + + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + + +instance Arbitrary LB.ByteString where + arbitrary = LB.pack <$> arbitrary + + +prop_casTypeAscii :: TAscii -> Bool +prop_casTypeAscii a = (decodeCas . encodeCas) a == a + + +prop_casTypeLong :: TLong -> Property +prop_casTypeLong a@(TLong n) = n >= 0 ==> (decodeCas . encodeCas) a == a + + +prop_casTypeInt32 :: TInt32 -> Bool +prop_casTypeInt32 a = (decodeCas . encodeCas) a == a + + + +prop_casTypeComp :: (TAscii, TBytes, TInt32, TUtf8) -> Property +prop_casTypeComp a = whenFail err $ a == a' + where + a' = (decodeCas . encodeCas) a + err = print $ "Decoded back into: " ++ show a' + + + +prop_casTypeExcComp :: (TAscii, TBytes, TInt32, Exclusive TUtf8) -> Property +prop_casTypeExcComp a = whenFail err $ a == a' + where + a' = (decodeCas . encodeCas) a + err = print $ "Decoded back into: " ++ show a' + + + + +newKS = KsDef { + f_KsDef_name = Just "testing" + , f_KsDef_strategy_class = Just "org.apache.cassandra.locator.NetworkTopologyStrategy" + , f_KsDef_strategy_options = Just (M.fromList [("datacenter1","1")]) + , f_KsDef_replication_factor = Nothing + , f_KsDef_cf_defs = Nothing + , f_KsDef_durable_writes = Just True + } + + +mkTestConn = createCassandraPool [("127.0.0.1", 9160)] 2 2 300 "testing" + + +------------------------------------------------------------------------------- +test_composite_col = do + pool <- mkTestConn + res <- runCas pool $ do + insert "testing" "row1" ONE [packCol content] + getCol "testing" "row1" (packKey key) ONE + assertEqual "composite get-set" (Just content) (fmap unpackCol res) + where + key = (TLong 125, TBytes "oklahoma") + content = (key, "asdf") + + +------------------------------------------------------------------------------- +-- | test quick-check generated pairs for composite column +prop_composite_col_readWrite :: CPool -> ((TLong, TBytes), LB.ByteString) -> Property +prop_composite_col_readWrite pool content@(k@(TLong i, _),v) = i >= 0 ==> + unsafePerformIO $ do + res <- runCas pool $ do + insert "testing" "row" ONE [packCol content] + getCol "testing" "row" (packKey k) ONE + return $ (Just content) == fmap unpackCol res + + +