├── .gitignore ├── .travis.yml ├── Database └── Cassandra │ └── CQL.hs ├── LICENSE ├── README.md ├── Setup.hs ├── cassandra-cql.cabal ├── changelog.md └── tests ├── .gitignore ├── Main.hs ├── create_keyspace.cql ├── example-autocreate-keyspace.hs ├── example-trans.hs ├── example.hs ├── test-decimal.hs ├── test-double.hs ├── test-float.hs ├── test-inet.hs ├── test-list.hs ├── test-pool.hs ├── test-set.hs ├── test-timestamp.hs ├── test-timeuuid.hs └── test-varint.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *~ 4 | dist/ 5 | cabal.sandbox.config 6 | .cabal-sandbox/ 7 | dist-newstyle/ 8 | cabal.project.local 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | notifications: 3 | email: false 4 | -------------------------------------------------------------------------------- /Database/Cassandra/CQL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, 2 | FlexibleInstances, DeriveDataTypeable, UndecidableInstances, 3 | BangPatterns, OverlappingInstances, DataKinds, GADTs, KindSignatures, NamedFieldPuns #-} 4 | -- | Haskell client for Cassandra's CQL protocol 5 | -- 6 | -- For examples, take a look at the /tests/ directory in the source archive. 7 | -- 8 | -- Here's the correspondence between CQL and Haskell types: 9 | -- 10 | -- * ascii - 'Ascii' (newtype of 'ByteString') 11 | -- 12 | -- * bigint - 'Int64' 13 | -- 14 | -- * blob - 'ByteString' 15 | -- 16 | -- * boolean - 'Bool' 17 | -- 18 | -- * counter - 'Counter' 19 | -- 20 | -- * decimal - 'Decimal' 21 | -- 22 | -- * double - 'Double' 23 | -- 24 | -- * float - 'Float' 25 | -- 26 | -- * int - 'Int' 27 | -- 28 | -- * text / varchar - 'Text' 29 | -- 30 | -- * timestamp - 'UTCTime' 31 | -- 32 | -- * uuid - 'UUID' 33 | -- 34 | -- * varint - 'Integer' 35 | -- 36 | -- * timeuuid - 'TimeUUID' 37 | -- 38 | -- * inet - 'SockAddr' 39 | -- 40 | -- * list\ - [a] 41 | -- 42 | -- * map\ - 'Map' a b 43 | -- 44 | -- * set\ - 'Set' b 45 | -- 46 | -- * tuple - '(a,b) 47 | -- 48 | -- * UDT 49 | -- 50 | -- ...and you can define your own 'CasType' instances to extend these types, which is 51 | -- a very powerful way to write your code. 52 | -- 53 | -- One way to do things is to specify your queries with a type signature, like this: 54 | -- 55 | -- > createSongs :: Query Schema () () 56 | -- > createSongs = "create table songs (id uuid PRIMARY KEY, title text, artist text, comment text)" 57 | -- > 58 | -- > insertSong :: Query Write (UUID, Text, Text, Maybe Text) () 59 | -- > insertSong = "insert into songs (id, title, artist, comment) values (?, ?, ?)" 60 | -- > 61 | -- > getOneSong :: Query Rows UUID (Text, Text, Maybe Text) 62 | -- > getOneSong = "select title, artist, comment from songs where id=?" 63 | -- 64 | -- The three type parameters are the query type ('Schema', 'Write' or 'Rows') followed by the 65 | -- input and output types, which are given as tuples whose constituent types must match 66 | -- the ones in the query CQL. If you do not match them correctly, you'll get a runtime 67 | -- error when you execute the query. If you do, then the query becomes completely type 68 | -- safe. 69 | -- 70 | -- Types can be 'Maybe' types, in which case you can read and write a Cassandra \'null\' 71 | -- in the table. Cassandra allows any column to be null, but you can lock this out by 72 | -- specifying non-Maybe types. 73 | -- 74 | -- The query types are: 75 | -- 76 | -- * 'Schema' for modifications to the schema. The output tuple type must be (). 77 | -- 78 | -- * 'Write' for row inserts and updates, and such. The output tuple type must be (). 79 | -- 80 | -- * 'Rows' for selects that give a list of rows in response. 81 | -- 82 | -- The functions to use for these query types are 'executeSchema', 83 | -- 'executeWrite', 'executeTrans' and 'executeRows' or 'executeRow' 84 | -- respectively. 85 | -- 86 | -- The following pattern seems to work very well, especially along with your own 'CasType' 87 | -- instances, because it gives you a place to neatly add marshalling details that keeps 88 | -- away from the body of your code. 89 | -- 90 | -- > insertSong :: UUID -> Text -> Text -> Maybe Text -> Cas () 91 | -- > insertSong id title artist comment = executeWrite QUORUM q (id, title, artist, comment) 92 | -- > where q = "insert into songs (id, title, artist, comment) values (?, ?, ?, ?)" 93 | -- 94 | -- Incidentally, here's Haskell's little-known multi-line string syntax. 95 | -- You escape it using \\ and then another \\ where the string starts again. 96 | -- 97 | -- > str = "multi\ 98 | -- > \line" 99 | -- 100 | -- (gives \"multiline\") 101 | -- 102 | -- /To do/ 103 | -- 104 | -- * Add the ability to easily run queries in parallel. 105 | -- * Add support for batch queries. 106 | -- * Add support for query paging. 107 | 108 | module Database.Cassandra.CQL ( 109 | -- * Initialization 110 | Server, 111 | Keyspace(..), 112 | Pool, 113 | newPool, 114 | newPool', 115 | defaultConfig, 116 | -- * Cassandra monad 117 | MonadCassandra(..), 118 | Cas, 119 | runCas, 120 | CassandraException(..), 121 | CassandraCommsError(..), 122 | TransportDirection(..), 123 | -- * Auth 124 | Authentication (..), 125 | -- * Queries 126 | Query, 127 | Style(..), 128 | query, 129 | -- * Executing queries 130 | Consistency(..), 131 | Change(..), 132 | executeSchema, 133 | executeSchemaVoid, 134 | executeWrite, 135 | executeRows, 136 | executeRow, 137 | executeTrans, 138 | -- * Value types 139 | Ascii(..), 140 | Counter(..), 141 | TimeUUID(..), 142 | metadataTypes, 143 | CasType(..), 144 | CasValues(..), 145 | -- * Lower-level interfaces 146 | executeRaw, 147 | Result(..), 148 | TableSpec(..), 149 | ColumnSpec(..), 150 | Metadata(..), 151 | CType(..), 152 | Table(..), 153 | PreparedQueryID(..), 154 | serverStats, 155 | ServerStat(..), 156 | PoolConfig(..), 157 | -- * Misc for UDTs 158 | getOption, 159 | putOption, 160 | getString, 161 | putString 162 | ) where 163 | 164 | import Control.Applicative 165 | import Control.Concurrent (threadDelay, forkIO) 166 | import Control.Concurrent.STM 167 | import Control.Exception (IOException, SomeException, MaskingState(..), throwIO, getMaskingState) 168 | import Control.Monad.Catch 169 | import Control.Monad.Reader 170 | import Control.Monad.State hiding (get, put) 171 | import qualified Control.Monad.RWS 172 | import qualified Control.Monad.Error 173 | import qualified Control.Monad.Writer 174 | import Crypto.Hash (hash, Digest, SHA1) 175 | import Data.Bits 176 | import Data.ByteString (ByteString) 177 | import qualified Data.ByteString.Char8 as C8BS 178 | import qualified Data.ByteString as B 179 | import qualified Data.ByteString.Lazy as L 180 | import Data.Data 181 | import Data.Decimal 182 | import Data.Either (lefts) 183 | import Data.Int 184 | import Data.List 185 | import Data.Map (Map) 186 | import qualified Data.Map as M 187 | import Data.Maybe 188 | import qualified Data.Foldable as F 189 | import Data.Monoid (Monoid) 190 | import qualified Data.Sequence as Seq 191 | import Data.Serialize hiding (Result) 192 | import Data.Set (Set) 193 | import qualified Data.Set as S 194 | import qualified Data.Pool as P 195 | import Data.String 196 | import Data.Text (Text) 197 | import qualified Data.Text as T 198 | import qualified Data.Text.Encoding as T 199 | import Data.Time.Calendar 200 | import Data.Time.Clock 201 | import Data.Typeable () 202 | import Data.UUID (UUID) 203 | import qualified Data.UUID as UUID 204 | import Data.Word 205 | import Network.Socket (Socket, HostName, ServiceName, getAddrInfo, socket, AddrInfo(..), 206 | connect, sClose, SockAddr(..), SocketType(..), defaultHints) 207 | import Network.Socket.ByteString (sendAll, recv) 208 | import Numeric 209 | import Unsafe.Coerce 210 | import Data.Function (on) 211 | import Data.Monoid ((<>)) 212 | import Data.Fixed (Pico) 213 | import System.Timeout (timeout) 214 | import System.Log.Logger (debugM, warningM) 215 | 216 | import Debug.Trace 217 | 218 | defaultConnectionTimeout :: NominalDiffTime 219 | defaultConnectionTimeout = 10 220 | 221 | defaultIoTimeout :: NominalDiffTime 222 | defaultIoTimeout = 300 223 | 224 | defaultSessionCreateTimeout :: NominalDiffTime 225 | defaultSessionCreateTimeout = 20 226 | 227 | defaultBackoffOnError :: NominalDiffTime 228 | defaultBackoffOnError = 60 229 | 230 | defaultMaxSessionIdleTime :: NominalDiffTime 231 | defaultMaxSessionIdleTime = 60 232 | 233 | defaultMaxSessions :: Int 234 | defaultMaxSessions = 20 235 | 236 | 237 | type Server = (HostName, ServiceName) 238 | 239 | data ActiveSession = ActiveSession { 240 | actServer :: Server, 241 | actSocket :: Socket, 242 | actIoTimeout :: NominalDiffTime, 243 | actQueryCache :: Map QueryID PreparedQuery 244 | } 245 | 246 | 247 | data Session = Session { 248 | sessServerIndex :: Int, 249 | sessServer :: Server, 250 | sessSocket :: Socket 251 | } 252 | 253 | 254 | data ServerState = ServerState { 255 | ssServer :: Server, 256 | ssOrdinal :: Int, 257 | ssSessionCount :: Int, 258 | ssLastError :: Maybe UTCTime, 259 | ssAvailable :: Bool 260 | } deriving (Show, Eq) 261 | 262 | instance Ord ServerState where 263 | compare = 264 | let compareCount = compare `on` ssSessionCount 265 | tieBreaker = compare `on` ssOrdinal 266 | in compareCount <> tieBreaker 267 | 268 | 269 | data PoolConfig = PoolConfig { 270 | piServers :: [Server], 271 | piKeyspace :: Keyspace, 272 | piKeyspaceConfig :: Maybe Text, 273 | piAuth :: Maybe Authentication, 274 | piSessionCreateTimeout :: NominalDiffTime, 275 | piConnectionTimeout :: NominalDiffTime, 276 | piIoTimeout :: NominalDiffTime, 277 | piBackoffOnError :: NominalDiffTime, 278 | piMaxSessionIdleTime :: NominalDiffTime, 279 | piMaxSessions :: Int 280 | } 281 | 282 | data PoolState = PoolState { 283 | psConfig :: PoolConfig, 284 | psServers :: TVar (Seq.Seq ServerState) 285 | } 286 | 287 | -- | Exported stats for a server. 288 | data ServerStat = ServerStat { 289 | statServer :: Server, 290 | statSessionCount :: Int, 291 | statAvailable :: Bool 292 | } deriving (Show) 293 | 294 | newtype Pool = Pool (PoolState, P.Pool Session) 295 | 296 | class MonadCatch m => MonadCassandra m where 297 | getCassandraPool :: m Pool 298 | 299 | instance MonadCassandra m => MonadCassandra (Control.Monad.Reader.ReaderT a m) where 300 | getCassandraPool = lift getCassandraPool 301 | 302 | instance MonadCassandra m => MonadCassandra (Control.Monad.State.StateT a m) where 303 | getCassandraPool = lift getCassandraPool 304 | 305 | instance (MonadCassandra m, Control.Monad.Error.Error e) => MonadCassandra (Control.Monad.Error.ErrorT e m) where 306 | getCassandraPool = lift getCassandraPool 307 | 308 | instance (MonadCassandra m, Monoid a) => MonadCassandra (Control.Monad.Writer.WriterT a m) where 309 | getCassandraPool = lift getCassandraPool 310 | 311 | instance (MonadCassandra m, Monoid w) => MonadCassandra (Control.Monad.RWS.RWST r w s m) where 312 | getCassandraPool = lift getCassandraPool 313 | 314 | 315 | 316 | defaultConfig :: [Server] -> Keyspace -> Maybe Authentication -> PoolConfig 317 | defaultConfig servers keyspace auth = PoolConfig { 318 | piServers = servers, 319 | piKeyspace = keyspace, 320 | piKeyspaceConfig = Nothing, 321 | piAuth = auth, 322 | piSessionCreateTimeout = defaultSessionCreateTimeout, 323 | piConnectionTimeout = defaultConnectionTimeout, 324 | piIoTimeout = defaultIoTimeout, 325 | piBackoffOnError = defaultBackoffOnError, 326 | piMaxSessionIdleTime = defaultMaxSessionIdleTime, 327 | piMaxSessions = defaultMaxSessions 328 | } 329 | 330 | 331 | -- | Construct a pool of Cassandra connections. 332 | newPool :: [Server] -> Keyspace -> Maybe Authentication -> IO Pool 333 | newPool servers keyspace auth = newPool' $ defaultConfig servers keyspace auth 334 | 335 | newPool' :: PoolConfig -> IO Pool 336 | newPool' config@PoolConfig { piServers, piMaxSessions, piMaxSessionIdleTime } = do 337 | when (null piServers) $ throwIO $ userError "at least one server required" 338 | 339 | -- TODO: Shuffle ordinals 340 | let servers = Seq.fromList $ map (\(s, idx) -> ServerState s idx 0 Nothing True) $ zip piServers [0..] 341 | servers' <- atomically $ newTVar servers 342 | 343 | let poolState = PoolState { 344 | psConfig = config, 345 | psServers = servers' 346 | } 347 | 348 | sessions <- P.createPool (newSession poolState) (destroySession poolState) 1 piMaxSessionIdleTime piMaxSessions 349 | 350 | let pool = Pool (poolState, sessions) 351 | 352 | _ <- forkIO $ poolWatch pool 353 | 354 | return pool 355 | 356 | 357 | poolWatch :: Pool -> IO () 358 | poolWatch (Pool (PoolState { psConfig, psServers }, _)) = do 359 | 360 | let loop = do 361 | cutoff <- (piBackoffOnError psConfig `addUTCTime`) <$> getCurrentTime 362 | 363 | debugM "Database.Cassandra.CQL.poolWatch" "starting" 364 | sleepTil <- atomically $ do 365 | servers <- readTVar psServers 366 | 367 | let availableAgain = filter (((&&) <$> (not . ssAvailable) <*> (maybe False (<= cutoff) . ssLastError)) . snd) (zip [0..] $ F.toList servers) 368 | servers' = F.foldr' (\(idx, server) accum -> Seq.update idx server { ssAvailable = True } accum) servers availableAgain 369 | nextWakeup = F.foldr' (\s nwu -> if not (ssAvailable s) && maybe False (<= nwu) (ssLastError s) 370 | then fromJust . ssLastError $ s 371 | else nwu) cutoff servers' 372 | 373 | writeTVar psServers servers' 374 | 375 | return nextWakeup 376 | 377 | 378 | delay <- (sleepTil `diffUTCTime`) <$> getCurrentTime 379 | 380 | statusDump <- atomically $ readTVar psServers 381 | debugM "Database.Cassandra.CQL.poolWatch" $ "completed : delaying for " ++ show delay ++ ", server states : " ++ show statusDump 382 | 383 | threadDelay (floor $ delay * 1000000) 384 | loop 385 | 386 | loop 387 | 388 | 389 | serverStats :: Pool -> IO [ServerStat] 390 | serverStats (Pool (PoolState { psServers }, _)) = atomically $ do 391 | servers <- readTVar psServers 392 | return $ map (\ServerState { ssServer, ssSessionCount, ssAvailable } -> ServerStat { statServer = ssServer, statSessionCount = ssSessionCount, statAvailable = ssAvailable }) (F.toList servers) 393 | 394 | 395 | 396 | 397 | newSession :: PoolState -> IO Session 398 | newSession poolState@PoolState { psConfig, psServers } = do 399 | debugM "Database.Cassandra.CQL.nextSession" "starting" 400 | 401 | maskingState <- getMaskingState 402 | when (maskingState == Unmasked) $ throwIO $ userError "caller MUST mask async exceptions before attempting to create a session" 403 | 404 | startTime <- getCurrentTime 405 | 406 | let giveUpAt = piSessionCreateTimeout psConfig `addUTCTime` startTime 407 | 408 | loop = do 409 | timeLeft <- (giveUpAt `diffUTCTime`) <$> getCurrentTime 410 | 411 | when (timeLeft <= 0) $ throwIO NoAvailableServers 412 | 413 | debugM "Database.Cassandra.CQL.newSession" "starting attempt to create a new session" 414 | sessionZ <- timeout ((floor $ timeLeft * 1000000) :: Int) makeSession 415 | `catches` [ Handler $ (\(e :: CassandraCommsError) -> do 416 | warningM "Database.Cassandra.CQL.newSession" $ "failed to create a session due to temporary error (will retry) : " ++ show e 417 | return Nothing), 418 | Handler $ (\(e :: SomeException) -> do 419 | warningM "Database.Cassandra.CQL.newSession" $ "failed to create a session due to permanent error (will rethrow) : " ++ show e 420 | throwIO e) 421 | ] 422 | 423 | case sessionZ of 424 | Just session -> return session 425 | Nothing -> loop 426 | 427 | makeSession = bracketOnError chooseServer restoreCount setup 428 | 429 | chooseServer = atomically $ do 430 | servers <- readTVar psServers 431 | 432 | let available = filter (ssAvailable . snd) (zip [0..] $ F.toList servers) 433 | 434 | if null available 435 | then retry 436 | else do 437 | let (idx, best @ ServerState { ssSessionCount }) = minimumBy (compare `on` snd) available 438 | updatedBest = best { ssSessionCount = ssSessionCount + 1 } 439 | 440 | modifyTVar' psServers (Seq.update idx updatedBest) 441 | return (updatedBest, idx) 442 | 443 | 444 | restoreCount (_, idx) = do 445 | now <- getCurrentTime 446 | atomically $ modifyTVar' psServers (Seq.adjust (\s -> s { ssSessionCount = ssSessionCount s - 1, ssLastError = Just now, ssAvailable = False }) idx) 447 | 448 | 449 | setup (ServerState { ssServer }, idx) = setupConnection poolState idx ssServer 450 | 451 | loop 452 | 453 | 454 | 455 | destroySession :: PoolState -> Session -> IO () 456 | destroySession PoolState { psServers } Session { sessSocket, sessServerIndex } = mask $ \restore -> do 457 | atomically $ modifyTVar' psServers (Seq.adjust (\s -> s { ssSessionCount = ssSessionCount s - 1 }) sessServerIndex) 458 | restore (sClose sessSocket) 459 | 460 | 461 | 462 | setupConnection :: PoolState -> Int -> Server -> IO Session 463 | setupConnection PoolState { psConfig } serverIndex server = do 464 | let hints = defaultHints { addrSocketType = Stream } 465 | (host, service) = server 466 | 467 | debugM "Database.Cassandra.CQL.setupConnection" $ "attempting to connect to " ++ host 468 | 469 | startTime <- getCurrentTime 470 | 471 | ais <- getAddrInfo (Just hints) (Just host) (Just service) 472 | 473 | bracketOnError (connectSocket startTime ais) (maybe (return ()) sClose) buildSession 474 | 475 | where connectSocket startTime ais = 476 | foldM (\mSocket ai -> do 477 | case mSocket of 478 | 479 | Nothing -> do 480 | 481 | let tryConnect = do 482 | debugM "Database.Cassandra.CQL.setupConnection" $ "trying address " ++ show ai 483 | 484 | -- No need to use 'bracketOnError' here because we are already masked. 485 | s <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) 486 | mConn <- timeout ((floor $ (piConnectionTimeout psConfig) * 1000000) :: Int) (connect s (addrAddress ai)) `onException` sClose s 487 | case mConn of 488 | Nothing -> sClose s >> return Nothing 489 | Just _ -> return $ Just s 490 | 491 | now <- getCurrentTime 492 | 493 | if now `diffUTCTime` startTime >= piConnectionTimeout psConfig 494 | then return Nothing 495 | else tryConnect `catch` (\ (e :: SomeException) -> do 496 | debugM "Database.Cassandra.CQL.setupConnection" $ "failed to connect to address " ++ show ai ++ " : " ++ show e 497 | return Nothing 498 | ) 499 | 500 | Just _ -> return mSocket 501 | ) Nothing ais 502 | 503 | 504 | buildSession (Just s) = do 505 | debugM "Database.Cassandra.CQL.setupConnection" $ "made connection, now attempting setup for socket " ++ show s 506 | 507 | let active = Session { 508 | sessServerIndex = serverIndex, 509 | sessServer = server, 510 | sessSocket = s 511 | } 512 | 513 | evalStateT (introduce psConfig) (activeSession psConfig active) 514 | 515 | return active 516 | 517 | buildSession Nothing = throwIO NoAvailableServers 518 | 519 | 520 | data Flag = Compression | Tracing 521 | deriving Show 522 | 523 | putFlags :: [Flag] -> Put 524 | putFlags flags = putWord8 $ foldl' (+) 0 $ map toWord8 flags 525 | where 526 | toWord8 Compression = 0x01 527 | toWord8 Tracing = 0x02 528 | 529 | getFlags :: Get [Flag] 530 | getFlags = do 531 | flagsB <- getWord8 532 | return $ case flagsB .&. 3 of 533 | 0 -> [] 534 | 1 -> [Compression] 535 | 2 -> [Tracing] 536 | 3 -> [Compression, Tracing] 537 | _ -> error "recvFrame impossible" 538 | 539 | data Opcode = ERROR | STARTUP | READY | AUTHENTICATE | OPTIONS | SUPPORTED 540 | | QUERY | RESULT | PREPARE | EXECUTE | REGISTER | EVENT | BATCH 541 | | AUTH_CHALLENGE | AUTH_RESPONSE | AUTH_SUCCESS 542 | deriving (Eq, Show) 543 | 544 | instance Serialize Opcode where 545 | put op = putWord8 $ case op of 546 | ERROR -> 0x00 547 | STARTUP -> 0x01 548 | READY -> 0x02 549 | AUTHENTICATE -> 0x03 550 | OPTIONS -> 0x05 551 | SUPPORTED -> 0x06 552 | QUERY -> 0x07 553 | RESULT -> 0x08 554 | PREPARE -> 0x09 555 | EXECUTE -> 0x0a 556 | REGISTER -> 0x0b 557 | EVENT -> 0x0c 558 | BATCH -> 0x0d 559 | AUTH_CHALLENGE -> 0x0e 560 | AUTH_RESPONSE -> 0x0f 561 | AUTH_SUCCESS -> 0x10 562 | get = do 563 | w <- getWord8 564 | case w of 565 | 0x00 -> return ERROR 566 | 0x01 -> return STARTUP 567 | 0x02 -> return READY 568 | 0x03 -> return AUTHENTICATE 569 | 0x05 -> return OPTIONS 570 | 0x06 -> return SUPPORTED 571 | 0x07 -> return QUERY 572 | 0x08 -> return RESULT 573 | 0x09 -> return PREPARE 574 | 0x0a -> return EXECUTE 575 | 0x0b -> return REGISTER 576 | 0x0c -> return EVENT 577 | 0x0d -> return BATCH 578 | 0x0e -> return AUTH_CHALLENGE 579 | 0x0f -> return AUTH_RESPONSE 580 | 0x10 -> return AUTH_SUCCESS 581 | _ -> fail $ "unknown opcode 0x"++showHex w "" 582 | 583 | data Frame a = Frame { 584 | _frFlags :: [Flag], 585 | _frStream :: Int16, 586 | frOpcode :: Opcode, 587 | frBody :: a 588 | } 589 | deriving Show 590 | 591 | timeout' :: NominalDiffTime -> IO a -> IO a 592 | timeout' to = timeout (floor $ to * 1000000) >=> maybe (throwIO CoordinatorTimeout) return 593 | 594 | recvAll :: NominalDiffTime -> Socket -> Int -> IO ByteString 595 | recvAll ioTimeout s n = timeout' ioTimeout $ do 596 | bs <- recv s n 597 | when (B.null bs) $ throwM ShortRead 598 | let left = n - B.length bs 599 | if left == 0 600 | then return bs 601 | else do 602 | bs' <- recvAll ioTimeout s left 603 | return (bs `B.append` bs') 604 | 605 | protocolVersion :: Word8 606 | protocolVersion = 3 607 | 608 | recvFrame :: Text -> StateT ActiveSession IO (Frame ByteString) 609 | recvFrame qt = do 610 | s <- gets actSocket 611 | ioTimeout <- gets actIoTimeout 612 | hdrBs <- liftIO $ recvAll ioTimeout s 9 613 | case runGet parseHeader hdrBs of 614 | Left err -> throwM $ LocalProtocolError ("recvFrame: " `T.append` T.pack err) qt 615 | Right (ver0, flags, stream, opcode, length) -> do 616 | let ver = ver0 .&. 0x7f 617 | when (ver /= protocolVersion) $ 618 | throwM $ LocalProtocolError ("unexpected version " `T.append` T.pack (show ver)) qt 619 | body <- if length == 0 620 | then pure B.empty 621 | else liftIO $ recvAll ioTimeout s (fromIntegral length) 622 | --liftIO $ putStrLn $ hexdump 0 (C.unpack $ hdrBs `B.append` body) 623 | return $ Frame flags stream opcode body 624 | `catch` \exc -> throwM $ CassandraIOException exc 625 | where 626 | parseHeader = do 627 | ver <- getWord8 628 | flags <- getFlags 629 | stream <- fromIntegral <$> getWord16be 630 | opcode <- get 631 | length <- getWord32be 632 | return (ver, flags, stream, opcode, length) 633 | 634 | sendFrame :: Frame ByteString -> StateT ActiveSession IO () 635 | sendFrame (Frame flags stream opcode body) = do 636 | let bs = runPut $ do 637 | putWord8 protocolVersion 638 | putFlags flags 639 | putWord16be (fromIntegral stream) 640 | put opcode 641 | putWord32be $ fromIntegral $ B.length body 642 | putByteString body 643 | --liftIO $ putStrLn $ hexdump 0 (C.unpack bs) 644 | s <- gets actSocket 645 | ioTimeout <- gets actIoTimeout 646 | liftIO $ timeout' ioTimeout $ sendAll s bs 647 | `catch` \exc -> throwM $ CassandraIOException exc 648 | 649 | class ProtoElt a where 650 | getElt :: Get a 651 | putElt :: a -> Put 652 | 653 | encodeElt :: ProtoElt a => a -> ByteString 654 | encodeElt = runPut . putElt 655 | 656 | encodeCas :: CasType a => a -> ByteString 657 | encodeCas = runPut . putCas 658 | 659 | decodeElt :: ProtoElt a => ByteString -> Either String a 660 | decodeElt bs = runGet getElt bs 661 | 662 | decodeCas :: CasType a => ByteString -> Either String a 663 | decodeCas bs = runGet getCas bs 664 | 665 | decodeEltM :: (ProtoElt a, MonadIO m, MonadThrow m) => Text -> ByteString -> Text -> m a 666 | decodeEltM what bs qt = 667 | case decodeElt bs of 668 | Left err -> throwM $ LocalProtocolError 669 | ("can't parse" `T.append` what `T.append` ": " `T.append` T.pack err) qt 670 | Right res -> return res 671 | 672 | newtype Long a = Long { unLong :: a } deriving (Eq, Ord, Show, Read) 673 | 674 | instance Functor Long where 675 | f `fmap` Long a = Long (f a) 676 | 677 | newtype Short a = Short { unShort :: a } deriving (Eq, Ord, Show, Read) 678 | 679 | instance Functor Short where 680 | f `fmap` Short a = Short (f a) 681 | 682 | instance ProtoElt (Map Text Text) where 683 | putElt = putElt . M.assocs 684 | getElt = M.fromList <$> getElt 685 | 686 | instance ProtoElt [(Text, Text)] where 687 | putElt pairs = do 688 | putWord16be (fromIntegral $ length pairs) 689 | forM_ pairs $ \(key, value) -> do 690 | putElt key 691 | putElt value 692 | getElt = do 693 | n <- getWord16be 694 | replicateM (fromIntegral n) $ do 695 | key <- getElt 696 | value <- getElt 697 | return (key, value) 698 | 699 | instance ProtoElt Text where 700 | putElt = putElt . T.encodeUtf8 701 | getElt = T.decodeUtf8 <$> getElt 702 | 703 | instance ProtoElt (Long Text) where 704 | putElt = putElt . fmap T.encodeUtf8 705 | getElt = fmap T.decodeUtf8 <$> getElt 706 | 707 | instance ProtoElt ByteString where 708 | putElt bs = do 709 | putWord16be (fromIntegral $ B.length bs) 710 | putByteString bs 711 | getElt = do 712 | len <- getWord16be 713 | getByteString (fromIntegral len) 714 | 715 | instance ProtoElt (Long ByteString) where 716 | putElt (Long bs) = do 717 | putWord32be (fromIntegral $ B.length bs) 718 | putByteString bs 719 | getElt = do 720 | len <- getWord32be 721 | Long <$> getByteString (fromIntegral len) 722 | 723 | data TransportDirection = TransportSending | TransportReceiving 724 | deriving (Eq, Show) 725 | 726 | -- | An exception that indicates an error originating in the Cassandra server. 727 | data CassandraException = ServerError Text Text 728 | | ProtocolError Text Text 729 | | BadCredentials Text Text 730 | | UnavailableException Text Consistency Int Int Text 731 | | Overloaded Text Text 732 | | IsBootstrapping Text Text 733 | | TruncateError Text Text 734 | | WriteTimeout Text Consistency Int Int Text Text 735 | | ReadTimeout Text Consistency Int Int Bool Text 736 | | SyntaxError Text Text 737 | | Unauthorized Text Text 738 | | Invalid Text Text 739 | | ConfigError Text Text 740 | | AlreadyExists Text Keyspace Table Text 741 | | Unprepared Text PreparedQueryID Text 742 | deriving (Show, Typeable) 743 | 744 | instance Exception CassandraException where 745 | 746 | -- | All errors at the communications level are reported with this exception 747 | -- ('IOException's from socket I/O are always wrapped), and this exception 748 | -- typically would mean that a retry is warranted. 749 | -- 750 | -- Note that this exception isn't guaranteed to be a transient one, so a limit 751 | -- on the number of retries is likely to be a good idea. 752 | -- 'LocalProtocolError' probably indicates a corrupted database or driver 753 | -- bug. 754 | data CassandraCommsError = AuthenticationException Text 755 | | LocalProtocolError Text Text 756 | | MissingAuthenticationError Text Text 757 | | ValueMarshallingException TransportDirection Text Text 758 | | CassandraIOException IOException 759 | | CreateKeyspaceError Text Text 760 | | ShortRead 761 | | NoAvailableServers 762 | | CoordinatorTimeout 763 | deriving (Show, Typeable) 764 | 765 | instance Exception CassandraCommsError 766 | 767 | throwError :: MonadCatch m => Text -> ByteString -> m a 768 | throwError qt bs = do 769 | case runGet parseError bs of 770 | Left err -> throwM $ LocalProtocolError ("failed to parse error: " `T.append` T.pack err) qt 771 | Right exc -> throwM exc 772 | where 773 | parseError :: Get CassandraException 774 | parseError = do 775 | code <- getWord32be 776 | case code of 777 | 0x0000 -> ServerError <$> getElt <*> pure qt 778 | 0x000A -> ProtocolError <$> getElt <*> pure qt 779 | 0x0100 -> BadCredentials <$> getElt <*> pure qt 780 | 0x1000 -> UnavailableException <$> getElt <*> getElt 781 | <*> (fromIntegral <$> getWord32be) 782 | <*> (fromIntegral <$> getWord32be) <*> pure qt 783 | 0x1001 -> Overloaded <$> getElt <*> pure qt 784 | 0x1002 -> IsBootstrapping <$> getElt <*> pure qt 785 | 0x1003 -> TruncateError <$> getElt <*> pure qt 786 | 0x1100 -> WriteTimeout <$> getElt <*> getElt 787 | <*> (fromIntegral <$> getWord32be) 788 | <*> (fromIntegral <$> getWord32be) 789 | <*> getElt <*> pure qt 790 | 0x1200 -> ReadTimeout <$> getElt <*> getElt 791 | <*> (fromIntegral <$> getWord32be) 792 | <*> (fromIntegral <$> getWord32be) 793 | <*> ((/=0) <$> getWord8) <*> pure qt 794 | 0x2000 -> SyntaxError <$> getElt <*> pure qt 795 | 0x2100 -> Unauthorized <$> getElt <*> pure qt 796 | 0x2200 -> Invalid <$> getElt <*> pure qt 797 | 0x2300 -> ConfigError <$> getElt <*> pure qt 798 | 0x2400 -> AlreadyExists <$> getElt <*> getElt <*> getElt <*> pure qt 799 | 0x2500 -> Unprepared <$> getElt <*> getElt <*> pure qt 800 | _ -> fail $ "unknown error code 0x"++showHex code "" 801 | 802 | 803 | type UserId = String 804 | type Password = String 805 | data Authentication = PasswordAuthenticator UserId Password 806 | type Credentials = Long ByteString 807 | 808 | authCredentials :: Authentication -> Credentials 809 | authCredentials (PasswordAuthenticator user password) = Long $ C8BS.pack $ "\0" ++ user ++ "\0" ++ password 810 | 811 | authenticate :: Authentication -> StateT ActiveSession IO () 812 | authenticate auth = do 813 | let qt = "" 814 | sendFrame $ Frame [] 0 AUTH_RESPONSE $ encodeElt $ authCredentials auth 815 | fr2 <- recvFrame qt 816 | case frOpcode fr2 of 817 | AUTH_SUCCESS -> return () 818 | ERROR -> throwError qt (frBody fr2) 819 | op -> throwM $ LocalProtocolError ("introduce: unexpected opcode " `T.append` T.pack (show op)) qt 820 | 821 | introduce :: PoolConfig -> StateT ActiveSession IO () 822 | introduce PoolConfig { piKeyspace, piKeyspaceConfig, piAuth } = do 823 | let qt = "" 824 | sendFrame $ Frame [] 0 STARTUP $ encodeElt $ ([("CQL_VERSION", "3.0.0")] :: [(Text, Text)]) 825 | fr <- recvFrame qt 826 | case frOpcode fr of 827 | AUTHENTICATE -> maybe 828 | (throwM $ MissingAuthenticationError "introduce: server expects auth but none provided" "") 829 | authenticate piAuth 830 | READY -> return () 831 | ERROR -> throwError qt (frBody fr) 832 | op -> throwM $ LocalProtocolError ("introduce: unexpected opcode " `T.append` T.pack (show op)) qt 833 | 834 | let Keyspace ksName = piKeyspace 835 | 836 | case piKeyspaceConfig of 837 | Nothing -> return () 838 | Just cfg -> do 839 | let q = query $ cfg :: Query Schema () () 840 | res <- executeInternal q () QUORUM 841 | case res of 842 | SchemaChange _ _ _ -> return () 843 | _ -> throwM $ CreateKeyspaceError ("introduce: failed to create a keyspace: " `T.append` T.pack (show res)) (queryText q) 844 | 845 | let q = query $ "USE " `T.append` ksName :: Query Rows () () 846 | res <- executeInternal q () ONE 847 | case res of 848 | SetKeyspace ks -> return () 849 | _ -> throwM $ LocalProtocolError ("introduce: expected SetKeyspace, but got " `T.append` T.pack (show res)) (queryText q) 850 | 851 | -- TODO Should we have to add the MonadIO constraint? 852 | withSession :: (MonadCassandra m, MonadIO m) => (Pool -> StateT ActiveSession IO a) -> m a 853 | withSession code = do 854 | pool@(Pool (PoolState { psConfig }, sessions)) <- getCassandraPool 855 | 856 | liftIO $ mask $ \restore -> do 857 | (session, local') <- P.takeResource sessions 858 | 859 | a <- restore (evalStateT (code pool) (activeSession psConfig session)) 860 | `catches` 861 | [ Handler $ \(exc :: CassandraException) -> P.putResource local' session >> throwIO exc, 862 | Handler $ \(exc :: SomeException) -> P.destroyResource sessions local' session >> throwIO exc 863 | ] 864 | 865 | P.putResource local' session 866 | 867 | return a 868 | 869 | activeSession :: PoolConfig -> Session -> ActiveSession 870 | activeSession poolConfig session = ActiveSession { 871 | actServer = sessServer session, 872 | actSocket = sessSocket session, 873 | actIoTimeout = piIoTimeout poolConfig, 874 | actQueryCache = M.empty 875 | } 876 | 877 | -- | The name of a Cassandra keyspace. See the Cassandra documentation for more 878 | -- information. 879 | newtype Keyspace = Keyspace Text 880 | deriving (Eq, Ord, Show, IsString, ProtoElt) 881 | 882 | -- | The name of a Cassandra table (a.k.a. column family). 883 | newtype Table = Table Text 884 | deriving (Eq, Ord, Show, IsString, ProtoElt) 885 | 886 | -- | A fully qualified identification of a table that includes the 'Keyspace'. 887 | data TableSpec = TableSpec Keyspace Table 888 | deriving (Eq, Ord, Show) 889 | 890 | instance ProtoElt TableSpec where 891 | putElt _ = error "formatting TableSpec is not implemented" 892 | getElt = TableSpec <$> getElt <*> getElt 893 | 894 | -- | Information about a table column. 895 | data ColumnSpec = ColumnSpec TableSpec Text CType 896 | deriving Show 897 | 898 | -- | The specification of a list of result set columns. 899 | data Metadata = Metadata [ColumnSpec] 900 | deriving Show 901 | 902 | -- | Cassandra data types as used in metadata. 903 | data CType = CCustom Text 904 | | CAscii 905 | | CBigint 906 | | CBlob 907 | | CBoolean 908 | | CCounter 909 | | CDecimal 910 | | CDouble 911 | | CFloat 912 | | CInt 913 | | CText 914 | | CTimestamp 915 | | CUuid 916 | | CVarint 917 | | CTimeuuid 918 | | CInet 919 | | CList CType 920 | | CMap CType CType 921 | | CSet CType 922 | | CMaybe CType 923 | | CUDT [CType] 924 | | CTuple [CType] 925 | deriving (Eq) 926 | 927 | instance Show CType where 928 | show ct = case ct of 929 | CCustom name -> T.unpack name 930 | CAscii -> "ascii" 931 | CBigint -> "bigint" 932 | CBlob -> "blob" 933 | CBoolean -> "boolean" 934 | CCounter -> "counter" 935 | CDecimal -> "decimal" 936 | CDouble -> "double" 937 | CFloat -> "float" 938 | CInt -> "int" 939 | CText -> "text" 940 | CTimestamp -> "timestamp" 941 | CUuid -> "uuid" 942 | CVarint -> "varint" 943 | CTimeuuid -> "timeuuid" 944 | CInet -> "inet" 945 | CList t -> "list<"++show t++">" 946 | CMap t1 t2 -> "map<"++show t1++","++show t2++">" 947 | CSet t -> "set<"++show t++">" 948 | CMaybe t -> "nullable "++show t 949 | CUDT ts -> "udt<" ++ (intercalate "," $ fmap show ts) ++ ">" 950 | CTuple ts -> "tuple<" ++ (intercalate "," $ fmap show ts) ++ ">" 951 | 952 | equivalent :: CType -> CType -> Bool 953 | equivalent (CTuple a) (CTuple b) = all (\ (x,y) -> x `equivalent` y) $ zip a b 954 | equivalent (CMaybe a) (CMaybe b) = a == b 955 | equivalent (CMaybe a) b = a == b 956 | equivalent a (CMaybe b) = a == b 957 | equivalent a b = a == b 958 | 959 | -- | A type class for types that can be used in query arguments or column values in 960 | -- returned results. 961 | -- 962 | -- To define your own newtypes for Cassandra data, you only need to define 'getCas', 963 | -- 'putCas' and 'casType', like this: 964 | -- 965 | -- > newtype UserId = UserId UUID deriving (Eq, Show) 966 | -- > 967 | -- > instance CasType UserId where 968 | -- > getCas = UserId <$> getCas 969 | -- > putCas (UserId i) = putCas i 970 | -- > casType (UserId i) = casType i 971 | -- 972 | -- The same can be done more simply using the /GeneralizedNewtypeDeriving/ language 973 | -- extension, e.g. 974 | -- 975 | -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-} 976 | -- > 977 | -- > ... 978 | -- > newtype UserId = UserId UUID deriving (Eq, Show, CasType) 979 | -- 980 | -- If you have a more complex type you want to store as a Cassandra blob, you could 981 | -- write an instance like this (assuming it's an instance of the /cereal/ package's 982 | -- 'Serialize' class): 983 | -- 984 | -- > instance CasType User where 985 | -- > getCas = decode . unBlob <$> getCas 986 | -- > putCas = putCas . Blob . encode 987 | -- > casType _ = CBlob 988 | 989 | class CasType a where 990 | getCas :: Get a 991 | putCas :: a -> Put 992 | -- | For a given Haskell type given as ('undefined' :: a), tell the caller how Cassandra 993 | -- represents it. 994 | casType :: a -> CType 995 | casNothing :: a 996 | casNothing = error "casNothing impossible" 997 | casObliterate :: a -> ByteString -> Maybe ByteString 998 | casObliterate _ bs = Just bs 999 | 1000 | instance CasType a => CasType (Maybe a) where 1001 | getCas = Just <$> getCas 1002 | putCas Nothing = return () 1003 | putCas (Just a) = putCas a 1004 | casType _ = CMaybe (casType (undefined :: a)) 1005 | casNothing = Nothing 1006 | casObliterate (Just a) bs = Just bs 1007 | casObliterate Nothing _ = Nothing 1008 | 1009 | -- | If you wrap this round a 'ByteString', it will be treated as an 1010 | -- /ascii/ type instead of /blob/ (if it was a plain 'ByteString' 1011 | -- type). Note that the bytes must indeed be in the range of ASCII. 1012 | -- This is your responsibility when constructing this newtype. 1013 | newtype Ascii = Ascii { unAscii :: ByteString } 1014 | deriving (Eq, Ord, Show) 1015 | 1016 | instance CasType Ascii where 1017 | getCas = Ascii <$> (getByteString =<< remaining) 1018 | putCas = putByteString . unAscii 1019 | casType _ = CAscii 1020 | 1021 | instance CasType Int64 where 1022 | getCas = fromIntegral <$> getWord64be 1023 | putCas = putWord64be . fromIntegral 1024 | casType _ = CBigint 1025 | 1026 | instance CasType ByteString where 1027 | getCas = getByteString =<< remaining 1028 | putCas bs = putByteString bs 1029 | casType _ = CBlob 1030 | 1031 | instance CasType Bool where 1032 | getCas = (/= 0) <$> getWord8 1033 | putCas True = putWord8 1 1034 | putCas False = putWord8 0 1035 | casType _ = CBoolean 1036 | 1037 | -- | A Cassandra distributed counter value. 1038 | newtype Counter = Counter { unCounter :: Int64 } 1039 | deriving (Eq, Ord, Show, Read) 1040 | 1041 | instance CasType Counter where 1042 | getCas = Counter . fromIntegral <$> getWord64be 1043 | putCas (Counter c) = putWord64be (fromIntegral c) 1044 | casType _ = CCounter 1045 | 1046 | instance CasType Integer where 1047 | getCas = do 1048 | ws <- B.unpack <$> (getByteString =<< remaining) 1049 | return $ 1050 | if null ws 1051 | then 0 1052 | else 1053 | let i = foldl' (\i w -> i `shiftL` 8 + fromIntegral w) 0 ws 1054 | in if head ws >= 0x80 1055 | then i - 1 `shiftL` (length ws * 8) 1056 | else i 1057 | putCas i = putByteString . B.pack $ 1058 | if i < 0 1059 | then encodeNeg $ positivize 0x80 i 1060 | else encodePos i 1061 | where 1062 | encodePos :: Integer -> [Word8] 1063 | encodePos i = reverse $ enc i 1064 | where 1065 | enc i | i == 0 = [0] 1066 | enc i | i < 0x80 = [fromIntegral i] 1067 | enc i = fromIntegral i : enc (i `shiftR` 8) 1068 | encodeNeg :: Integer -> [Word8] 1069 | encodeNeg i = reverse $ enc i 1070 | where 1071 | enc i | i == 0 = [] 1072 | enc i | i < 0x100 = [fromIntegral i] 1073 | enc i = fromIntegral i : enc (i `shiftR` 8) 1074 | positivize :: Integer -> Integer -> Integer 1075 | positivize bits i = case bits + i of 1076 | i' | i' >= 0 -> i' + bits 1077 | _ -> positivize (bits `shiftL` 8) i 1078 | casType _ = CVarint 1079 | 1080 | instance CasType Decimal where 1081 | getCas = Decimal <$> (fromIntegral . min 0xff <$> getWord32be) <*> getCas 1082 | putCas (Decimal places mantissa) = do 1083 | putWord32be (fromIntegral places) 1084 | putCas mantissa 1085 | casType _ = CDecimal 1086 | 1087 | instance CasType Double where 1088 | getCas = unsafeCoerce <$> getWord64be 1089 | putCas dbl = putWord64be (unsafeCoerce dbl) 1090 | casType _ = CDouble 1091 | 1092 | instance CasType Float where 1093 | getCas = unsafeCoerce <$> getWord32be 1094 | putCas dbl = putWord32be (unsafeCoerce dbl) 1095 | casType _ = CFloat 1096 | 1097 | epoch :: UTCTime 1098 | epoch = UTCTime (fromGregorian 1970 1 1) 0 1099 | 1100 | instance CasType UTCTime where 1101 | getCas = do 1102 | ms <- getWord64be 1103 | let difft = realToFrac $ (fromIntegral ms :: Pico) / 1000 1104 | return $ addUTCTime difft epoch 1105 | putCas utc = do 1106 | let seconds = realToFrac $ diffUTCTime utc epoch :: Pico 1107 | ms = round (seconds * 1000) :: Word64 1108 | putWord64be ms 1109 | casType _ = CTimestamp 1110 | 1111 | instance CasType Int where 1112 | getCas = fromIntegral <$> getWord32be 1113 | putCas = putWord32be . fromIntegral 1114 | casType _ = CInt 1115 | 1116 | instance CasType Text where 1117 | getCas = T.decodeUtf8 <$> (getByteString =<< remaining) 1118 | putCas = putByteString . T.encodeUtf8 1119 | casType _ = CText 1120 | 1121 | instance CasType UUID where 1122 | getCas = do 1123 | mUUID <- UUID.fromByteString . L.fromStrict <$> (getByteString =<< remaining) 1124 | case mUUID of 1125 | Just uuid -> return uuid 1126 | Nothing -> fail "malformed UUID" 1127 | putCas = putByteString . L.toStrict . UUID.toByteString 1128 | casType _ = CUuid 1129 | 1130 | -- | If you wrap this round a 'UUID' then it is treated as a /timeuuid/ type instead of 1131 | -- /uuid/ (if it was a plain 'UUID' type). 1132 | newtype TimeUUID = TimeUUID { unTimeUUID :: UUID } deriving (Eq, Data, Ord, Read, Show, Typeable) 1133 | 1134 | instance CasType TimeUUID where 1135 | getCas = TimeUUID <$> getCas 1136 | putCas (TimeUUID uuid) = putCas uuid 1137 | casType _ = CTimeuuid 1138 | 1139 | instance CasType SockAddr where 1140 | getCas = do 1141 | len <- remaining 1142 | case len of 1143 | 4 -> SockAddrInet 0 <$> getWord32le 1144 | 16 -> do 1145 | a <- getWord32be 1146 | b <- getWord32be 1147 | c <- getWord32be 1148 | d <- getWord32be 1149 | return $ SockAddrInet6 0 0 (a,b,c,d) 0 1150 | _ -> fail "malformed Inet" 1151 | putCas sa = do 1152 | case sa of 1153 | SockAddrInet _ w -> putWord32le w 1154 | SockAddrInet6 _ _ (a,b,c,d) _ -> putWord32be a >> putWord32be b 1155 | >> putWord32be c >> putWord32be d 1156 | _ -> fail $ "address type not supported in formatting Inet: " ++ show sa 1157 | casType _ = CInet 1158 | 1159 | instance CasType a => CasType [a] where 1160 | getCas = do 1161 | n <- getWord32be 1162 | replicateM (fromIntegral n) $ do 1163 | len <- getWord32be 1164 | bs <- getByteString (fromIntegral len) 1165 | case decodeCas bs of 1166 | Left err -> fail err 1167 | Right x -> return x 1168 | putCas xs = do 1169 | putWord32be (fromIntegral $ length xs) 1170 | forM_ xs $ \x -> do 1171 | let bs = encodeCas x 1172 | putWord32be (fromIntegral $ B.length bs) 1173 | putByteString bs 1174 | casType _ = CList (casType (undefined :: a)) 1175 | 1176 | instance (CasType a, Ord a) => CasType (Set a) where 1177 | getCas = S.fromList <$> getCas 1178 | putCas = putCas . S.toList 1179 | casType _ = CSet (casType (undefined :: a)) 1180 | 1181 | instance (CasType a, Ord a, CasType b) => CasType (Map a b) where 1182 | getCas = do 1183 | n <- getWord32be 1184 | items <- replicateM (fromIntegral n) $ do 1185 | len_a <- getWord32be 1186 | bs_a <- getByteString (fromIntegral len_a) 1187 | a <- case decodeCas bs_a of 1188 | Left err -> fail err 1189 | Right x -> return x 1190 | len_b <- getWord32be 1191 | bs_b <- getByteString (fromIntegral len_b) 1192 | b <- case decodeCas bs_b of 1193 | Left err -> fail err 1194 | Right x -> return x 1195 | return (a,b) 1196 | return $ M.fromList items 1197 | putCas m = do 1198 | let items = M.toList m 1199 | putWord32be (fromIntegral $ length items) 1200 | forM_ items $ \(a,b) -> do 1201 | putOption a 1202 | putOption b 1203 | casType _ = CMap (casType (undefined :: a)) (casType (undefined :: b)) 1204 | 1205 | getString :: Get Text 1206 | getString = do 1207 | len <- getWord16be 1208 | bs <- getByteString (fromIntegral len) 1209 | return $ T.decodeUtf8 bs 1210 | 1211 | putString :: Text -> Put 1212 | putString x = do 1213 | putWord16be (fromIntegral $ B.length val) 1214 | putByteString val 1215 | where 1216 | val = T.encodeUtf8 x 1217 | 1218 | getOption :: CasType a => Get a 1219 | getOption = do 1220 | len <- getWord32be 1221 | bs <- getByteString (fromIntegral len) 1222 | case decodeCas bs of 1223 | Left err -> fail err 1224 | Right x -> return x 1225 | 1226 | putOption :: CasType a => a -> Put 1227 | putOption x = do 1228 | let bs = encodeCas x 1229 | putWord32be (fromIntegral $ B.length bs) 1230 | putByteString bs 1231 | 1232 | instance (CasType a, CasType b) => CasType (a,b) where 1233 | getCas = do 1234 | x <- getOption 1235 | y <- getOption 1236 | return (x,y) 1237 | putCas (x,y) = do 1238 | putOption x 1239 | putOption y 1240 | casType _ = CTuple [casType (undefined :: a), casType (undefined :: b)] 1241 | 1242 | instance (CasType a, CasType b, CasType c) => CasType(a,b,c) where 1243 | getCas = do 1244 | x <- getOption 1245 | y <- getOption 1246 | z <- getOption 1247 | return (x,y,z) 1248 | putCas (x,y,z) = do 1249 | putOption x 1250 | putOption y 1251 | putOption z 1252 | casType _ = CTuple [casType (undefined :: a), casType (undefined :: b), casType (undefined :: c)] 1253 | 1254 | instance (CasType a,CasType b, CasType c, CasType d) => CasType(a,b,c,d) where 1255 | getCas = do 1256 | w <- getOption 1257 | x <- getOption 1258 | y <- getOption 1259 | z <- getOption 1260 | return (w,x,y,z) 1261 | putCas (w,x,y,z) = do 1262 | putOption w 1263 | putOption x 1264 | putOption y 1265 | putOption z 1266 | casType _ = CTuple [casType (undefined :: a), casType (undefined :: b), casType (undefined :: c), casType (undefined :: d)] 1267 | 1268 | instance (CasType a,CasType b, CasType c, CasType d, CasType e) => CasType(a,b,c,d,e) where 1269 | getCas = do 1270 | v <- getOption 1271 | w <- getOption 1272 | x <- getOption 1273 | y <- getOption 1274 | z <- getOption 1275 | return (v,w,x,y,z) 1276 | putCas (v,w,x,y,z) = do 1277 | putOption v 1278 | putOption w 1279 | putOption x 1280 | putOption y 1281 | putOption z 1282 | casType _ = CTuple [casType (undefined :: a), casType (undefined :: b), casType (undefined :: c), casType (undefined :: d), casType (undefined :: e)] 1283 | 1284 | instance ProtoElt CType where 1285 | putElt _ = error "formatting CType is not implemented" 1286 | getElt = do 1287 | op <- getWord16be 1288 | case op of 1289 | 0x0000 -> CCustom <$> getElt 1290 | 0x0001 -> pure CAscii 1291 | 0x0002 -> pure CBigint 1292 | 0x0003 -> pure CBlob 1293 | 0x0004 -> pure CBoolean 1294 | 0x0005 -> pure CCounter 1295 | 0x0006 -> pure CDecimal 1296 | 0x0007 -> pure CDouble 1297 | 0x0008 -> pure CFloat 1298 | 0x0009 -> pure CInt 1299 | --0x000a -> pure CVarchar -- Server seems to use CText even when 'varchar' is specified 1300 | -- i.e. they're interchangeable in the CQL and always 1301 | -- 'text' in the protocol. 1302 | 0x000b -> pure CTimestamp 1303 | 0x000c -> pure CUuid 1304 | 0x000d -> pure CText 1305 | 0x000e -> pure CVarint 1306 | 0x000f -> pure CTimeuuid 1307 | 0x0010 -> pure CInet 1308 | 0x0020 -> CList <$> getElt 1309 | 0x0021 -> CMap <$> getElt <*> getElt 1310 | 0x0022 -> CSet <$> getElt 1311 | 0x0030 -> CUDT <$> getEltUdt 1312 | 0x0031 -> CTuple <$> getElt 1313 | _ -> fail $ "unknown data type code 0x"++showHex op "" 1314 | 1315 | getEltUdt = do 1316 | _ <- getString 1317 | _ <- getString 1318 | n <- getWord16be 1319 | replicateM (fromIntegral n) $ do 1320 | _ <- getString 1321 | getElt 1322 | 1323 | instance ProtoElt Metadata where 1324 | putElt _ = error "formatting Metadata is not implemented" 1325 | getElt = do 1326 | flags <- getWord32be 1327 | colCount <- fromIntegral <$> getWord32be 1328 | gtSpec <- if (flags .&. 1) /= 0 then Just <$> getElt 1329 | else pure Nothing 1330 | cols <- replicateM colCount $ do 1331 | tSpec <- case gtSpec of 1332 | Just spec -> pure spec 1333 | Nothing -> getElt 1334 | ColumnSpec tSpec <$> getElt <*> getElt 1335 | return $ Metadata cols 1336 | 1337 | instance ProtoElt [CType] where 1338 | getElt = do 1339 | n <- getWord16be 1340 | replicateM (fromIntegral n) getElt 1341 | putElt x = do 1342 | putWord16be (fromIntegral $ length x) 1343 | forM_ x putElt 1344 | 1345 | newtype PreparedQueryID = PreparedQueryID ByteString 1346 | deriving (Eq, Ord, Show, ProtoElt) 1347 | 1348 | newtype QueryID = QueryID (Digest SHA1) 1349 | deriving (Eq, Ord, Show) 1350 | 1351 | -- | The first type argument for Query. Tells us what kind of query it is. 1352 | data Style = Schema -- ^ A query that modifies the schema, such as DROP TABLE or CREATE TABLE 1353 | | Write -- ^ A query that writes data, such as an INSERT or UPDATE 1354 | | Rows -- ^ A query that returns a list of rows, such as SELECT 1355 | 1356 | -- | The text of a CQL query, along with type parameters to make the query type safe. 1357 | -- The type arguments are 'Style', followed by input and output column types for the 1358 | -- query each represented as a tuple. 1359 | -- 1360 | -- The /DataKinds/ language extension is required for 'Style'. 1361 | data Query :: Style -> * -> * -> * where 1362 | Query :: QueryID -> Text -> Query style i o 1363 | deriving Show 1364 | 1365 | queryText :: Query s i o -> Text 1366 | queryText (Query _ txt) = txt 1367 | 1368 | instance IsString (Query style i o) where 1369 | fromString = query . T.pack 1370 | 1371 | -- | Construct a query. Another way to construct one is as an overloaded string through 1372 | -- the 'IsString' instance if you turn on the /OverloadedStrings/ language extension, e.g. 1373 | -- 1374 | -- > {-# LANGUAGE OverloadedStrings #-} 1375 | -- > ... 1376 | -- > 1377 | -- > getOneSong :: Query Rows UUID (Text, Text, Maybe Text) 1378 | -- > getOneSong = "select title, artist, comment from songs where id=?" 1379 | query :: Text -> Query style i o 1380 | query cql = Query (QueryID . hash . T.encodeUtf8 $ cql) cql 1381 | 1382 | data PreparedQuery = PreparedQuery PreparedQueryID Metadata 1383 | deriving Show 1384 | 1385 | data Change = CREATED | UPDATED | DROPPED 1386 | deriving (Eq, Ord, Show) 1387 | 1388 | instance ProtoElt Change where 1389 | putElt _ = error $ "formatting Change is not implemented" 1390 | getElt = do 1391 | str <- getElt :: Get Text 1392 | case str of 1393 | "CREATED" -> pure CREATED 1394 | "UPDATED" -> pure UPDATED 1395 | "DROPPED" -> pure DROPPED 1396 | _ -> fail $ "unexpected change string: "++show str 1397 | 1398 | -- | A low-level query result used with 'executeRaw'. 1399 | data Result vs = Void 1400 | | RowsResult Metadata [vs] 1401 | | SetKeyspace Text 1402 | | Prepared PreparedQueryID Metadata 1403 | | SchemaChange Change Keyspace Table 1404 | deriving Show 1405 | 1406 | instance Functor Result where 1407 | f `fmap` Void = Void 1408 | f `fmap` RowsResult meta rows = RowsResult meta (f `fmap` rows) 1409 | f `fmap` SetKeyspace ks = SetKeyspace ks 1410 | f `fmap` Prepared pqid meta = Prepared pqid meta 1411 | f `fmap` SchemaChange ch ks t = SchemaChange ch ks t 1412 | 1413 | instance ProtoElt (Result [Maybe ByteString]) where 1414 | putElt _ = error "formatting RESULT is not implemented" 1415 | getElt = do 1416 | kind <- getWord32be 1417 | case kind of 1418 | 0x0001 -> pure Void 1419 | 0x0002 -> do 1420 | meta@(Metadata colSpecs) <- getElt 1421 | let colCount = length colSpecs 1422 | rowCount <- fromIntegral <$> getWord32be 1423 | rows <- replicateM rowCount $ replicateM colCount $ do 1424 | len <- getWord32be 1425 | if len == 0xffffffff 1426 | then return Nothing 1427 | else Just <$> getByteString (fromIntegral len) 1428 | return $ RowsResult meta rows 1429 | 0x0003 -> SetKeyspace <$> getElt 1430 | 0x0004 -> Prepared <$> getElt <*> getElt 1431 | 0x0005 -> SchemaChange <$> getElt <*> getElt <*> getElt 1432 | _ -> fail $ "bad result kind: 0x"++showHex kind "" 1433 | 1434 | prepare :: Query style i o -> StateT ActiveSession IO PreparedQuery 1435 | prepare (Query qid cql) = do 1436 | cache <- gets actQueryCache 1437 | case qid `M.lookup` cache of 1438 | Just pq -> return pq 1439 | Nothing -> do 1440 | sendFrame $ Frame [] 0 PREPARE $ encodeElt (Long cql) 1441 | fr <- recvFrame cql 1442 | case frOpcode fr of 1443 | RESULT -> do 1444 | res <- decodeEltM "RESULT" (frBody fr) cql 1445 | case (res :: Result [Maybe ByteString]) of 1446 | Prepared pqid meta -> do 1447 | let pq = PreparedQuery pqid meta 1448 | modify $ \act -> act { actQueryCache = M.insert qid pq (actQueryCache act) } 1449 | return pq 1450 | _ -> throwM $ LocalProtocolError ("prepare: unexpected result " `T.append` T.pack (show res)) cql 1451 | ERROR -> throwError cql (frBody fr) 1452 | _ -> throwM $ LocalProtocolError ("prepare: unexpected opcode " `T.append` T.pack (show (frOpcode fr))) cql 1453 | 1454 | data CodingFailure = Mismatch Int CType CType 1455 | | WrongNumber Int Int 1456 | | DecodeFailure Int String 1457 | | NullValue Int CType 1458 | 1459 | instance Show CodingFailure where 1460 | show (Mismatch i t1 t2) = "at value index "++show (i+1)++", Haskell type specifies "++show t1++", but database metadata says "++show t2 1461 | show (WrongNumber i1 i2) = "wrong number of values: Haskell type specifies "++show i1++" but database metadata says "++show i2 1462 | show (DecodeFailure i why) = "failed to decode value index "++show (i+1)++": "++why 1463 | show (NullValue i t) = "at value index "++show (i+1)++" received a null "++show t++" value but Haskell type is not a Maybe" 1464 | 1465 | class CasNested v where 1466 | encodeNested :: Int -> v -> [CType] -> Either CodingFailure [Maybe ByteString] 1467 | decodeNested :: Int -> [(CType, Maybe ByteString)] -> Either CodingFailure v 1468 | countNested :: v -> Int 1469 | 1470 | instance CasNested () where 1471 | encodeNested !i () [] = Right [] 1472 | encodeNested !i () ts = Left $ WrongNumber i (i + length ts) 1473 | decodeNested !i [] = Right () 1474 | decodeNested !i vs = Left $ WrongNumber i (i + length vs) 1475 | countNested _ = 0 1476 | 1477 | instance (CasType a, CasNested rem) => CasNested (a, rem) where 1478 | encodeNested !i (a, rem) (ta:trem) | ta `equivalent` casType a = 1479 | case encodeNested (i+1) rem trem of 1480 | Left err -> Left err 1481 | Right brem -> Right $ ba : brem 1482 | where 1483 | ba = casObliterate a . encodeCas $ a 1484 | encodeNested !i (a, _) (ta:_) = Left $ Mismatch i (casType a) ta 1485 | encodeNested !i vs [] = Left $ WrongNumber (i + countNested vs) i 1486 | decodeNested !i ((ta, mba):rem) | ta `equivalent` casType (undefined :: a) = 1487 | case (decodeCas <$> mba, casType (undefined :: a), decodeNested (i+1) rem) of 1488 | (Nothing, CMaybe _, Right arem) -> Right (casNothing, arem) 1489 | (Nothing, _, _) -> Left $ NullValue i ta 1490 | (Just (Left err), _, _) -> Left $ DecodeFailure i err 1491 | (_, _, Left err) -> Left err 1492 | (Just (Right a), _, Right arem) -> Right (a, arem) 1493 | decodeNested !i ((ta, _):rem) = Left $ Mismatch i (casType (undefined :: a)) ta 1494 | decodeNested !i [] = Left $ WrongNumber (i + 1 + countNested (undefined :: rem)) i 1495 | countNested _ = let n = 1 + countNested (undefined :: rem) 1496 | in seq n n 1497 | 1498 | -- | A type class for a tuple of 'CasType' instances, representing either a list of 1499 | -- arguments for a query, or the values in a row of returned query results. 1500 | class CasValues v where 1501 | encodeValues :: v -> [CType] -> Either CodingFailure [Maybe ByteString] 1502 | decodeValues :: [(CType, Maybe ByteString)] -> Either CodingFailure v 1503 | {- 1504 | 1505 | TODO this is the place where values get made 1506 | 1507 | To make it for a custom type you'd need to generate CasValues instances... for instance for Songs, whose type is: 1508 | 1509 | Songs 1510 | :: Data.Text.Internal.Text 1511 | -> Data.Text.Internal.Text 1512 | -> Bool 1513 | -> uuid-types-1.0.3:Data.UUID.Types.Internal.UUID 1514 | -> Int 1515 | -> Data.Text.Internal.Text 1516 | -> Songs 1517 | 1518 | The CasValue instance for Songs should look like: 1519 | 1520 | instance CasValues Songs where 1521 | decodeValues vs = do 1522 | let (a, b, c, d, e, f) = vs 1523 | Songs <$> a <*> b <*> c <*> d <*> e <*> f 1524 | 1525 | How will you apply the CasValues to what's inside of vs though? Won't 1526 | that be necessary? 1527 | 1528 | Here is the original instance for 6 values: 1529 | 1530 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1531 | CasType f) => CasValues (a, b, c, d, e, f) where 1532 | encodeValues (a, b, c, d, e, f) = 1533 | encodeNested 0 (a, (b, (c, (d, (e, (f, ())))))) 1534 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, ())))))) -> 1535 | (a, b, c, d, e, f)) <$> decodeNested 0 vs 1536 | 1537 | 1538 | -} 1539 | 1540 | instance CasValues () where 1541 | encodeValues () types = encodeNested 0 () types 1542 | decodeValues vs = decodeNested 0 vs 1543 | 1544 | instance CasType a => CasValues a where 1545 | encodeValues a = encodeNested 0 (a, ()) 1546 | decodeValues vs = (\(a, ()) -> a) <$> decodeNested 0 vs 1547 | 1548 | instance (CasType a, CasType b) => CasValues (a, b) where 1549 | encodeValues (a, b) = encodeNested 0 (a, (b, ())) 1550 | decodeValues vs = (\(a, (b, ())) -> (a, b)) <$> decodeNested 0 vs 1551 | 1552 | instance (CasType a, CasType b, CasType c) => CasValues (a, b, c) where 1553 | encodeValues (a, b, c) = encodeNested 0 (a, (b, (c, ()))) 1554 | decodeValues vs = (\(a, (b, (c, ()))) -> (a, b, c)) <$> decodeNested 0 vs 1555 | 1556 | instance (CasType a, CasType b, CasType c, CasType d) => CasValues (a, b, c, d) where 1557 | encodeValues (a, b, c, d) = encodeNested 0 (a, (b, (c, (d, ())))) 1558 | decodeValues vs = (\(a, (b, (c, (d, ())))) -> (a, b, c, d)) <$> decodeNested 0 vs 1559 | 1560 | instance (CasType a, CasType b, CasType c, CasType d, CasType e) => CasValues (a, b, c, d, e) where 1561 | encodeValues (a, b, c, d, e) = encodeNested 0 (a, (b, (c, (d, (e, ()))))) 1562 | decodeValues vs = (\(a, (b, (c, (d, (e, ()))))) -> (a, b, c, d, e)) <$> decodeNested 0 vs 1563 | 1564 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1565 | CasType f) => CasValues (a, b, c, d, e, f) where 1566 | encodeValues (a, b, c, d, e, f) = 1567 | encodeNested 0 (a, (b, (c, (d, (e, (f, ())))))) 1568 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, ())))))) -> 1569 | (a, b, c, d, e, f)) <$> decodeNested 0 vs 1570 | 1571 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1572 | CasType f, CasType g) => CasValues (a, b, c, d, e, f, g) where 1573 | encodeValues (a, b, c, d, e, f, g) = 1574 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, ()))))))) 1575 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, ()))))))) -> 1576 | (a, b, c, d, e, f, g)) <$> decodeNested 0 vs 1577 | 1578 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1579 | CasType f, CasType g, CasType h) => CasValues (a, b, c, d, e, f, g, h) where 1580 | encodeValues (a, b, c, d, e, f, g, h) = 1581 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, ())))))))) 1582 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, ())))))))) -> 1583 | (a, b, c, d, e, f, g, h)) <$> decodeNested 0 vs 1584 | 1585 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1586 | CasType f, CasType g, CasType h, CasType i) => CasValues (a, b, c, d, e, f, g, h, i) where 1587 | encodeValues (a, b, c, d, e, f, g, h, i) = 1588 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, ()))))))))) 1589 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, ()))))))))) -> 1590 | (a, b, c, d, e, f, g, h, i)) <$> decodeNested 0 vs 1591 | 1592 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1593 | CasType f, CasType g, CasType h, CasType i, CasType j) 1594 | => CasValues (a, b, c, d, e, f, g, h, i, j) where 1595 | encodeValues (a, b, c, d, e, f, g, h, i, j) = 1596 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, ())))))))))) 1597 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, ())))))))))) -> 1598 | (a, b, c, d, e, f, g, h, i, j)) <$> decodeNested 0 vs 1599 | 1600 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1601 | CasType f, CasType g, CasType h, CasType i, CasType j, 1602 | CasType k) 1603 | => CasValues (a, b, c, d, e, f, g, h, i, j, k) where 1604 | encodeValues (a, b, c, d, e, f, g, h, i, j, k) = 1605 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, ()))))))))))) 1606 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, ()))))))))))) -> 1607 | (a, b, c, d, e, f, g, h, i, j, k)) <$> decodeNested 0 vs 1608 | 1609 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1610 | CasType f, CasType g, CasType h, CasType i, CasType j, 1611 | CasType k, CasType l) 1612 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l) where 1613 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l) = 1614 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, ())))))))))))) 1615 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, ())))))))))))) -> 1616 | (a, b, c, d, e, f, g, h, i, j, k, l)) <$> decodeNested 0 vs 1617 | 1618 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1619 | CasType f, CasType g, CasType h, CasType i, CasType j, 1620 | CasType k, CasType l, CasType m) 1621 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m) where 1622 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m) = 1623 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, ()))))))))))))) 1624 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, ()))))))))))))) -> 1625 | (a, b, c, d, e, f, g, h, i, j, k, l, m)) <$> decodeNested 0 vs 1626 | 1627 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1628 | CasType f, CasType g, CasType h, CasType i, CasType j, 1629 | CasType k, CasType l, CasType m, CasType n) 1630 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where 1631 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = 1632 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, ())))))))))))))) 1633 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, ())))))))))))))) -> 1634 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) <$> decodeNested 0 vs 1635 | 1636 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1637 | CasType f, CasType g, CasType h, CasType i, CasType j, 1638 | CasType k, CasType l, CasType m, CasType n, CasType o) 1639 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where 1640 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = 1641 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, ()))))))))))))))) 1642 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, ()))))))))))))))) -> 1643 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) <$> decodeNested 0 vs 1644 | 1645 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1646 | CasType f, CasType g, CasType h, CasType i, CasType j, 1647 | CasType k, CasType l, CasType m, CasType n, CasType o, 1648 | CasType p) 1649 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where 1650 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 1651 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, ())))))))))))))))) 1652 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, ())))))))))))))))) -> 1653 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) <$> decodeNested 0 vs 1654 | 1655 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1656 | CasType f, CasType g, CasType h, CasType i, CasType j, 1657 | CasType k, CasType l, CasType m, CasType n, CasType o, 1658 | CasType p, CasType q) 1659 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) where 1660 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = 1661 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, ()))))))))))))))))) 1662 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, ()))))))))))))))))) -> 1663 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) <$> decodeNested 0 vs 1664 | 1665 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1666 | CasType f, CasType g, CasType h, CasType i, CasType j, 1667 | CasType k, CasType l, CasType m, CasType n, CasType o, 1668 | CasType p, CasType q, CasType r) 1669 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) where 1670 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = 1671 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, ())))))))))))))))))) 1672 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, ())))))))))))))))))) -> 1673 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) <$> decodeNested 0 vs 1674 | 1675 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1676 | CasType f, CasType g, CasType h, CasType i, CasType j, 1677 | CasType k, CasType l, CasType m, CasType n, CasType o, 1678 | CasType p, CasType q, CasType r, CasType s) 1679 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) where 1680 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = 1681 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, ()))))))))))))))))))) 1682 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, ()))))))))))))))))))) -> 1683 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) <$> decodeNested 0 vs 1684 | 1685 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1686 | CasType f, CasType g, CasType h, CasType i, CasType j, 1687 | CasType k, CasType l, CasType m, CasType n, CasType o, 1688 | CasType p, CasType q, CasType r, CasType s, CasType t) 1689 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) where 1690 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = 1691 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, ())))))))))))))))))))) 1692 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, ())))))))))))))))))))) -> 1693 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) <$> decodeNested 0 vs 1694 | 1695 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1696 | CasType f, CasType g, CasType h, CasType i, CasType j, 1697 | CasType k, CasType l, CasType m, CasType n, CasType o, 1698 | CasType p, CasType q, CasType r, CasType s, CasType t, 1699 | CasType u) 1700 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) where 1701 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = 1702 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t,(u, ()))))))))))))))))))))) 1703 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, ()))))))))))))))))))))) -> 1704 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)) <$> decodeNested 0 vs 1705 | 1706 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1707 | CasType f, CasType g, CasType h, CasType i, CasType j, 1708 | CasType k, CasType l, CasType m, CasType n, CasType o, 1709 | CasType p, CasType q, CasType r, CasType s, CasType t, 1710 | CasType u, CasType v) 1711 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) where 1712 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u,v) = 1713 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t,(u, (v, ())))))))))))))))))))))) 1714 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, (v, ())))))))))))))))))))))) -> 1715 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)) <$> decodeNested 0 vs 1716 | 1717 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1718 | CasType f, CasType g, CasType h, CasType i, CasType j, 1719 | CasType k, CasType l, CasType m, CasType n, CasType o, 1720 | CasType p, CasType q, CasType r, CasType s, CasType t, 1721 | CasType u, CasType v, CasType w) 1722 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) where 1723 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = 1724 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t,(u, (v, (w, ()))))))))))))))))))))))) 1725 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, (v, (w, ()))))))))))))))))))))))) -> 1726 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)) <$> decodeNested 0 vs 1727 | 1728 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1729 | CasType f, CasType g, CasType h, CasType i, CasType j, 1730 | CasType k, CasType l, CasType m, CasType n, CasType o, 1731 | CasType p, CasType q, CasType r, CasType s, CasType t, 1732 | CasType u, CasType v, CasType w, CasType x) 1733 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) where 1734 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = 1735 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t,(u, (v, (w, (x, ())))))))))))))))))))))))) 1736 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, (v, (w, (x, ())))))))))))))))))))))))) -> 1737 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)) <$> decodeNested 0 vs 1738 | 1739 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1740 | CasType f, CasType g, CasType h, CasType i, CasType j, 1741 | CasType k, CasType l, CasType m, CasType n, CasType o, 1742 | CasType p, CasType q, CasType r, CasType s, CasType t, 1743 | CasType u, CasType v, CasType w, CasType x, CasType y) 1744 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) where 1745 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = 1746 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t,(u, (v, (w, (x, (y, ()))))))))))))))))))))))))) 1747 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, (v, (w, (x, (y, ()))))))))))))))))))))))))) -> 1748 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y)) <$> decodeNested 0 vs 1749 | 1750 | instance (CasType a, CasType b, CasType c, CasType d, CasType e, 1751 | CasType f, CasType g, CasType h, CasType i, CasType j, 1752 | CasType k, CasType l, CasType m, CasType n, CasType o, 1753 | CasType p, CasType q, CasType r, CasType s, CasType t, 1754 | CasType u, CasType v, CasType w, CasType x, CasType y, 1755 | CasType z) 1756 | => CasValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) where 1757 | encodeValues (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = 1758 | encodeNested 0 (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t,(u, (v, (w, (x, (y, (z, ())))))))))))))))))))))))))) 1759 | decodeValues vs = (\(a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, (v, (w, (x, (y, (z, ())))))))))))))))))))))))))) -> 1760 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z)) <$> decodeNested 0 vs 1761 | 1762 | 1763 | -- | Cassandra consistency level. See the Cassandra documentation for an explanation. 1764 | data Consistency = ANY | ONE | TWO | THREE | QUORUM | ALL | LOCAL_QUORUM | EACH_QUORUM | SERIAL | LOCAL_SERIAL | LOCAL_ONE 1765 | deriving (Eq, Ord, Show, Bounded, Enum) 1766 | 1767 | instance ProtoElt Consistency where 1768 | putElt c = putWord16be $ case c of 1769 | ANY -> 0x0000 1770 | ONE -> 0x0001 1771 | TWO -> 0x0002 1772 | THREE -> 0x0003 1773 | QUORUM -> 0x0004 1774 | ALL -> 0x0005 1775 | LOCAL_QUORUM -> 0x0006 1776 | EACH_QUORUM -> 0x0007 1777 | SERIAL -> 0x0008 1778 | LOCAL_SERIAL -> 0x0009 1779 | LOCAL_ONE -> 0x000A 1780 | getElt = do 1781 | w <- getWord16be 1782 | case w of 1783 | 0x0000 -> pure ANY 1784 | 0x0001 -> pure ONE 1785 | 0x0002 -> pure TWO 1786 | 0x0003 -> pure THREE 1787 | 0x0004 -> pure QUORUM 1788 | 0x0005 -> pure ALL 1789 | 0x0006 -> pure LOCAL_QUORUM 1790 | 0x0007 -> pure EACH_QUORUM 1791 | 0x0008 -> pure SERIAL 1792 | 0x0009 -> pure LOCAL_SERIAL 1793 | 0x000A -> pure LOCAL_ONE 1794 | _ -> fail $ "unknown consistency value 0x"++showHex w "" 1795 | 1796 | 1797 | -- TODO can I make some function that uses results of executeRaw and allows user to provide typeclasses (including typeclasses based on their custom type) to parse it? 1798 | 1799 | f :: Result [Maybe ByteString] -> [ByteString] 1800 | f = undefined 1801 | 1802 | class Decodeable a where 1803 | mydecode :: [ByteString] -> m a 1804 | 1805 | -- execute2 :: (MonadIO m,MonadCassandra m, CasValues i) => Query style any_i any_o -> i -> Consistency -> m a 1806 | -- execute2 query i cons = do 1807 | -- res <- withSession (\_ -> executeInternal query i cons) 1808 | -- mydecode $ f res 1809 | 1810 | data MyType = MyType {x :: Int} 1811 | 1812 | g :: ByteString -> Maybe Int 1813 | g = undefined 1814 | 1815 | -- instance Decodeable MyType where 1816 | -- mydecode bs = MyType <$> g (bs !! 0) 1817 | 1818 | -- | A low-level function in case you need some rarely-used capabilities. 1819 | -- TODO Should we have to add the MonadIO constraint? 1820 | executeRaw :: (MonadIO m, MonadCassandra m, CasValues i) => 1821 | Query style any_i any_o -> i -> Consistency -> m (Result [Maybe ByteString]) 1822 | executeRaw query i cons = withSession (\_ -> executeInternal query i cons) 1823 | 1824 | executeInternal :: CasValues values => 1825 | Query style any_i any_o -> values -> Consistency -> StateT ActiveSession IO (Result [Maybe ByteString]) 1826 | executeInternal query i cons = do 1827 | (PreparedQuery pqid queryMeta) <- prepare query 1828 | values <- case encodeValues i (metadataTypes queryMeta) of 1829 | Left err -> throwM $ ValueMarshallingException TransportSending (T.pack $ show err) (queryText query) 1830 | Right values -> return values 1831 | sendFrame $ Frame [] 0 EXECUTE $ runPut $ do 1832 | putElt pqid 1833 | putElt cons 1834 | putWord8 0x01 1835 | putWord16be (fromIntegral $ length values) 1836 | forM_ values $ \mValue -> 1837 | case mValue of 1838 | Nothing -> putWord32be 0xffffffff 1839 | Just value -> do 1840 | let enc = encodeCas value 1841 | putWord32be (fromIntegral $ B.length enc) 1842 | putByteString enc 1843 | fr <- recvFrame (queryText query) 1844 | case frOpcode fr of 1845 | RESULT -> decodeEltM "RESULT" (frBody fr) (queryText query) 1846 | ERROR -> throwError (queryText query) (frBody fr) 1847 | _ -> throwM $ LocalProtocolError ("execute: unexpected opcode " `T.append` T.pack (show (frOpcode fr))) (queryText query) 1848 | 1849 | 1850 | -- executeInternalTxt :: Text -> 1851 | 1852 | -- | Execute a query that returns rows. 1853 | -- TODO Should we have to add the MonadIO constraint? 1854 | executeRows :: (MonadCassandra m, MonadIO m, CasValues i, CasValues o) => 1855 | Consistency -- ^ Consistency level of the operation 1856 | -> Query Rows i o -- ^ CQL query to execute 1857 | -> i -- ^ Input values substituted in the query 1858 | -> m [o] 1859 | executeRows cons q i = do 1860 | res <- executeRaw q i cons 1861 | case res of 1862 | RowsResult meta rows -> decodeRows q meta rows 1863 | _ -> throwM $ LocalProtocolError ("expected Rows, but got " `T.append` T.pack (show res)) (queryText q) 1864 | 1865 | 1866 | -- executeRows' :: (MonadCassandra m, MonadIO m, CasValues i, CasValues o) => 1867 | -- Consistency -- ^ Consistency level of the operation 1868 | -- -> Query Rows i o -- ^ CQL query to execute 1869 | -- -> a -- ^ Input values substituted in the query 1870 | -- -> m [a] 1871 | -- executeRows' cons q i = do 1872 | -- res <- executeRaw q i cons 1873 | -- case res of 1874 | -- RowsResult meta rows -> decodeRows q meta rows 1875 | -- _ -> throwM $ LocalProtocolError ("expected Rows, but got " `T.append` T.pack (show res)) (queryText q) 1876 | 1877 | 1878 | 1879 | -- | Execute a query that returns a Frames record 1880 | executeRowsFrames :: (MonadCassandra m, MonadIO m, CasValues i, CasValues o) => 1881 | Consistency -- ^ Consistency level of the operation 1882 | -> Query Rows i o -- ^ CQL query to execute 1883 | -> i -- ^ Input values substituted in the query 1884 | -> m [o] 1885 | executeRowsFrames cons q i = do 1886 | res <- executeRaw q i cons 1887 | case res of 1888 | RowsResult meta bytestringRows -> do 1889 | let txtRows = fmap (fmap T.decodeUtf8) <$> bytestringRows 1890 | undefined 1891 | _ -> throwM $ LocalProtocolError ("expected Rows, but got " `T.append` T.pack (show res)) (queryText q) 1892 | 1893 | 1894 | -- | Execute a lightweight transaction (CAS). 1895 | executeTrans :: (MonadIO m, MonadCassandra m, CasValues i) => 1896 | Query Write i () -- ^ CQL query to execute 1897 | -> i -- ^ Input values substituted in the query 1898 | -> Consistency -- ^ Consistency for the write operation (S in CAS). 1899 | -> m Bool 1900 | executeTrans q i c = do 1901 | res <- executeRaw q i c 1902 | case res of 1903 | RowsResult _ ((el:row):rows) -> 1904 | case decodeCas $ fromJust el of 1905 | Left s -> error $ "executeTrans: decode result failure=" ++ s 1906 | Right b -> return b 1907 | _ -> throwM $ LocalProtocolError ("expected Rows, but got " `T.append` T.pack (show res)) (queryText q) 1908 | 1909 | -- | Helper for 'executeRows' useful in situations where you are only expecting one row 1910 | -- to be returned. 1911 | executeRow :: (MonadIO m, MonadCassandra m, CasValues i, CasValues o) => 1912 | Consistency -- ^ Consistency level of the operation 1913 | -> Query Rows i o -- ^ CQL query to execute 1914 | -> i -- ^ Input values substituted in the query 1915 | -> m (Maybe o) 1916 | executeRow cons q i = do 1917 | rows <- executeRows cons q i 1918 | return $ listToMaybe rows 1919 | 1920 | getOneSong :: Query 'Rows UUID (Text, Int) 1921 | getOneSong = "select artist, timesPlayed from songs where id=?" 1922 | 1923 | 1924 | -- exMetadata = Metadata [ColumnSpec (TableSpec (Keyspace "test1") (Table "songs")) "artist" text,ColumnSpec (TableSpec (Keyspace "test1") (Table "songs")) "timesplayed" int] 1925 | exMetadata = Metadata [ColumnSpec (TableSpec (Keyspace "test1") (Table "songs")) "artist" CText,ColumnSpec (TableSpec (Keyspace "test1") (Table "songs")) "timesplayed" CInt] 1926 | 1927 | exRows0 :: [[Maybe B.ByteString]] 1928 | exRows0 = [[Just "Evanescence",Just "\NUL\NUL\ETX\US"]] 1929 | 1930 | -- decodeRows getSongs exMetadata 1931 | {- 1932 | Using example values: 1933 | 1934 | λ> decodeRows getOneSong exMetadata exRows0 1935 | [("Evanescence",799)] 1936 | -} 1937 | 1938 | decodeRows :: (MonadCatch m, CasValues values) => Query Rows any_i values -> Metadata -> [[Maybe ByteString]] -> m [values] 1939 | decodeRows query meta rows0 = do 1940 | let meta' = trace ("meta: " ++ show meta) meta 1941 | let rows0' = trace ("rows0: " ++ show rows0) rows0 1942 | let rows1 = flip map rows0' $ \cols -> decodeValues (zip (metadataTypes meta') cols) 1943 | case lefts rows1 of 1944 | (err:_) -> throwM $ ValueMarshallingException TransportReceiving (T.pack $ show err) (queryText query) 1945 | [] -> return () 1946 | let rows2 = flip map rows1 $ \(Right v) -> v 1947 | return $ rows2 1948 | 1949 | -- | Execute a write operation that returns void. 1950 | executeWrite :: (MonadIO m, MonadCassandra m, CasValues i) => 1951 | Consistency -- ^ Consistency level of the operation 1952 | -> Query Write i () -- ^ CQL query to execute 1953 | -> i -- ^ Input values substituted in the query 1954 | -> m () 1955 | executeWrite cons q i = do 1956 | res <- executeRaw q i cons 1957 | case res of 1958 | Void -> return () 1959 | _ -> throwM $ LocalProtocolError ("expected Void, but got " `T.append` T.pack (show res)) (queryText q) 1960 | 1961 | -- | Execute a schema change, such as creating or dropping a table. 1962 | executeSchema :: (MonadIO m, MonadCassandra m, CasValues i) => 1963 | Consistency -- ^ Consistency level of the operation 1964 | -> Query Schema i () -- ^ CQL query to execute 1965 | -> i -- ^ Input values substituted in the query 1966 | -> m (Change, Keyspace, Table) 1967 | executeSchema cons q i = do 1968 | res <- executeRaw q i cons 1969 | case res of 1970 | SchemaChange ch ks ta -> return (ch, ks, ta) 1971 | _ -> throwM $ LocalProtocolError ("expected SchemaChange, but got " `T.append` T.pack (show res)) (queryText q) 1972 | 1973 | -- | Executes a schema change that has a void result such as creating types 1974 | executeSchemaVoid :: (MonadIO m, MonadCassandra m, CasValues i) => 1975 | Consistency -- ^ Consistency level of the operation 1976 | -> Query Schema i () -- ^ CQL query to execute 1977 | -> i -- ^ Input values substituted in the query 1978 | -> m () 1979 | executeSchemaVoid cons q i = do 1980 | res <- executeRaw q i cons 1981 | case res of 1982 | Void -> return () 1983 | _ -> throwM $ LocalProtocolError ("expected Void, but got " `T.append` T.pack (show res)) (queryText q) 1984 | 1985 | -- | A helper for extracting the types from a metadata definition. 1986 | metadataTypes :: Metadata -> [CType] 1987 | metadataTypes (Metadata colspecs) = map (\(ColumnSpec _ _ typ) -> typ) colspecs 1988 | 1989 | -- | The monad used to run Cassandra queries in. 1990 | newtype Cas a = Cas (ReaderT Pool IO a) 1991 | deriving (Functor, Applicative, Monad, MonadIO, MonadCatch, MonadThrow) 1992 | 1993 | instance MonadCassandra Cas where 1994 | getCassandraPool = Cas ask 1995 | 1996 | -- | Execute Cassandra queries. 1997 | runCas :: Pool -> Cas a -> IO a 1998 | runCas pool (Cas code) = runReaderT code pool 1999 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Stephen Blackheath 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 Stephen Blackheath 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 | cassandra-cql [![Hackage version](https://img.shields.io/hackage/v/cassandra-cql.svg?style=flat)](https://hackage.haskell.org/package/cassandra-cql) [![Build Status](https://travis-ci.org/kayceesrk/cassandra-cql.svg?branch=master)](https://travis-ci.org/kayceesrk/cassandra-cql) 2 | ============= 3 | 4 | Haskell client for Cassandra's CQL binary protocol v2. Supports lightweight 5 | transactions and authentication. 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cassandra-cql.cabal: -------------------------------------------------------------------------------- 1 | name: cassandra-cql 2 | version: 0.6 3 | synopsis: Haskell client for Cassandra's CQL protocol 4 | description: Haskell client for Cassandra's CQL protocol. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Stephen Blackheath 8 | maintainer: http://blacksapphire.com/antispam/ 9 | copyright: (c) Stephen Blackheath 2013-2015 10 | category: Database 11 | build-type: Simple 12 | stability: alpha 13 | cabal-version: >=1.8 14 | source-repository head 15 | type: git 16 | location: https://github.com/the-real-blackh/cassandra-cql 17 | 18 | library 19 | exposed-modules: Database.Cassandra.CQL 20 | build-depends: Decimal, 21 | base, 22 | bytestring, 23 | cereal, 24 | exceptions, 25 | containers, 26 | cryptohash, 27 | hslogger, 28 | mtl, 29 | network, 30 | random, 31 | resource-pool, 32 | stm, 33 | text, 34 | time, 35 | uuid 36 | 37 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-matches 38 | -fno-warn-missing-signatures -fno-warn-orphans 39 | -fno-warn-unused-imports -fno-warn-unused-binds 40 | 41 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog for [`cassandra-cql` package](https://hackage.haskell.org/package/cassandra-cql-0.5.0.0) 2 | 3 | ## 0.6 4 | * BREAKING: The ByteString type now gets mapped to Cassandra blobs instead 5 | of ASCII. Please update all your use of (ByteString/'ascii') to use the 6 | Ascii newtype wrapper. The Blob newtype has been removed, because it 7 | introduces no new meaning. 8 | 9 | ## 0.5.0.2 10 | * Fix incorrect upper bound for base. 11 | 12 | ## 0.5.0.1 13 | * Upgrade to CQL Binary Protocol v2. 14 | * Support Cassandra lightweight transactions. 15 | 16 | ## 0.4.0.1 17 | * Add PasswordAuthenticator (thanks Curtis Carter) 18 | * Accept ghc-7.8 19 | 20 | ## 0.3.0.1 21 | * Fix socket issue on Mac. 22 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | example 2 | example-trans 3 | test-double 4 | test-float 5 | test-inet 6 | test-list 7 | test-pool 8 | test-set 9 | test-map 10 | test-timestamp 11 | test-timeuuid 12 | test-decimal 13 | test-varint 14 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Control.Monad.Catch 4 | import Control.Monad.Trans (liftIO) 5 | import Data.Int 6 | import qualified Data.List as L 7 | import Data.Map(Map) 8 | import qualified Data.Map as M 9 | import Data.Serialize hiding (Result) 10 | import Data.Text (Text) 11 | import Data.UUID 12 | import Database.Cassandra.CQL 13 | import System.Random 14 | import Test.Tasty 15 | import Test.Tasty.HUnit 16 | 17 | tupleTests :: TestTree 18 | tupleTests = testGroup "Tuple Tests" [testTupleInt2,testTuple3,testTuple4,testTuple5] 19 | 20 | testTupleInt2 :: TestTree 21 | testTupleInt2 = testCase "testTupleInt2" $ cassandraTest $ do 22 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropTupleI () 23 | liftIO . print =<< executeSchema QUORUM createTupleI () 24 | u1 <- liftIO randomIO 25 | u2 <- liftIO randomIO 26 | u3 <- liftIO randomIO 27 | executeWrite QUORUM insertI (u1, (10,11)) 28 | executeWrite QUORUM insertI (u2, (2,4)) 29 | executeWrite QUORUM insertI (u3, (900,1000)) 30 | results <- executeRows QUORUM selectI () 31 | liftIO $ do 32 | assertBool "Item Not Found" $ L.elem (u1, (10,11)) results 33 | assertBool "Item Not Found" $ L.elem (u2, (2,4)) results 34 | assertBool "Item Not Found" $ L.elem (u3, (900,1000)) results 35 | where 36 | dropTupleI :: Query Schema () () 37 | dropTupleI = "drop table tuplei" 38 | 39 | createTupleI :: Query Schema () () 40 | createTupleI = "create table tuplei (id uuid PRIMARY KEY, item tuple)" 41 | 42 | insertI :: Query Write (UUID, (Int,Int)) () 43 | insertI = "insert into tuplei (id, item) values (?, ?)" 44 | 45 | selectI :: Query Rows () (UUID,(Int,Int)) 46 | selectI = "select id,item from tuplei" 47 | 48 | testTuple3 :: TestTree 49 | testTuple3 = testCase "testTuple3" $ cassandraTest $ do 50 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropTuple3 () 51 | liftIO . print =<< executeSchema QUORUM createTuple3 () 52 | u1 <- liftIO randomIO 53 | u2 <- liftIO randomIO 54 | u3 <- liftIO randomIO 55 | let tup1 = (u1, (10,11,"Text1")) 56 | tup2 = (u2, (2,4,"Text2")) 57 | tup3 = (u3, (900,1000,"Text3")) 58 | executeWrite QUORUM insert3 tup1 59 | executeWrite QUORUM insert3 tup2 60 | executeWrite QUORUM insert3 tup3 61 | results <- executeRows QUORUM select3 () 62 | liftIO $ do 63 | assertBool "Item Not Found" $ L.elem tup1 results 64 | assertBool "Item Not Found" $ L.elem tup2 results 65 | assertBool "Item Not Found" $ L.elem tup3 results 66 | where 67 | dropTuple3 :: Query Schema () () 68 | dropTuple3 = "drop table tuple3" 69 | 70 | createTuple3 :: Query Schema () () 71 | createTuple3 = "create table tuple3 (id uuid PRIMARY KEY, item tuple)" 72 | 73 | insert3 :: Query Write (UUID, (Int,Int, Text)) () 74 | insert3 = "insert into tuple3 (id, item) values (?, ?)" 75 | 76 | select3 :: Query Rows () (UUID,(Int,Int,Text)) 77 | select3 = "select id,item from tuple3" 78 | 79 | testTuple4 :: TestTree 80 | testTuple4 = testCase "testTuple4" $ cassandraTest $ do 81 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropTuple4 () 82 | liftIO . print =<< executeSchema QUORUM createTuple4 () 83 | u1 <- liftIO randomIO 84 | u2 <- liftIO randomIO 85 | u3 <- liftIO randomIO 86 | let tup1 = (u1, (10,11,"Text1","Text4")) 87 | tup2 = (u2, (2,4,"Text2","Text5")) 88 | tup3 = (u3, (900,1000,"Text3","Text6")) 89 | executeWrite QUORUM insert4 tup1 90 | executeWrite QUORUM insert4 tup2 91 | executeWrite QUORUM insert4 tup3 92 | results <- executeRows QUORUM select4 () 93 | liftIO $ do 94 | assertBool "Item Not Found" $ L.elem tup1 results 95 | assertBool "Item Not Found" $ L.elem tup2 results 96 | assertBool "Item Not Found" $ L.elem tup3 results 97 | where 98 | dropTuple4 :: Query Schema () () 99 | dropTuple4 = "drop table tuple4" 100 | 101 | createTuple4 :: Query Schema () () 102 | createTuple4 = "create table tuple4 (id uuid PRIMARY KEY, item tuple)" 103 | 104 | insert4 :: Query Write (UUID, (Int,Int, Text,Text)) () 105 | insert4 = "insert into tuple4 (id, item) values (?, ?)" 106 | 107 | select4 :: Query Rows () (UUID,(Int,Int,Text,Text)) 108 | select4 = "select id,item from tuple4" 109 | 110 | testTuple5 :: TestTree 111 | testTuple5 = testCase "testTuple5" $ cassandraTest $ do 112 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropTuple5 () 113 | liftIO . print =<< executeSchema QUORUM createTuple5 () 114 | u1 <- liftIO randomIO 115 | u2 <- liftIO randomIO 116 | u3 <- liftIO randomIO 117 | let tup1 = (u1, (10,11,"Text1","Text4",1)) 118 | tup2 = (u2, (2,4,"Text2","Text5",2)) 119 | tup3 = (u3, (900,1000,"Text3","Text6",3)) 120 | executeWrite QUORUM insert5 tup1 121 | executeWrite QUORUM insert5 tup2 122 | executeWrite QUORUM insert5 tup3 123 | results <- executeRows QUORUM select5 () 124 | liftIO $ do 125 | assertBool "Item Not Found" $ L.elem tup1 results 126 | assertBool "Item Not Found" $ L.elem tup2 results 127 | assertBool "Item Not Found" $ L.elem tup3 results 128 | where 129 | dropTuple5 :: Query Schema () () 130 | dropTuple5 = "drop table tuple5" 131 | 132 | createTuple5 :: Query Schema () () 133 | createTuple5 = "create table tuple5 (id uuid PRIMARY KEY, item tuple)" 134 | 135 | insert5 :: Query Write (UUID, (Int,Int, Text,Text,Int)) () 136 | insert5 = "insert into tuple5 (id, item) values (?, ?)" 137 | 138 | select5 :: Query Rows () (UUID,(Int,Int,Text,Text,Int)) 139 | select5 = "select id,item from tuple5" 140 | 141 | {- UDT Tests -} 142 | 143 | data TestType = TestType { 144 | ttText :: Text, 145 | ttInt :: Int 146 | } deriving (Eq) 147 | 148 | instance CasType TestType where 149 | getCas = do 150 | x <- getOption 151 | y <- getOption 152 | return $ TestType x y 153 | putCas x = do 154 | putOption $ ttText x 155 | putOption $ ttInt x 156 | casType _ = CUDT [CText,CInt] 157 | 158 | testUDT :: TestTree 159 | testUDT = testCase "testUDT" $ cassandraTest $ do 160 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropUdt () 161 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropTable () 162 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM createUdt () 163 | liftIO . print =<< executeSchema QUORUM createTable () 164 | let x = TestType "test value" 54 165 | u1 <- liftIO randomIO 166 | executeWrite QUORUM insertUdt (u1,x) 167 | results <- executeRows QUORUM selectUdt () 168 | liftIO $ assertBool "Item not found" $ L.elem (u1,x) results 169 | where 170 | dropTable :: Query Schema () () 171 | dropTable = "drop table udt" 172 | 173 | dropUdt :: Query Schema () () 174 | dropUdt = "drop type testtype" 175 | 176 | createUdt :: Query Schema () () 177 | createUdt = "create type test.testtype(textField text, intField int)" 178 | 179 | createTable :: Query Schema () () 180 | createTable = "create table udt(id uuid PRIMARY KEY, item frozen)" 181 | 182 | insertUdt :: Query Write (UUID,TestType) () 183 | insertUdt = "insert into udt (id,item) values (?,?)" 184 | 185 | selectUdt :: Query Rows () (UUID,TestType) 186 | selectUdt = "select id,item from udt" 187 | 188 | testMap :: TestTree 189 | testMap = testCase "testMap" $ cassandraTest $ do 190 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropMaps () 191 | liftIO . print =<< executeSchema QUORUM createMaps () 192 | 193 | u1 <- liftIO randomIO 194 | u2 <- liftIO randomIO 195 | u3 <- liftIO randomIO 196 | let m1 = M.fromList [(1, "one"), (2, "two")] 197 | m2 = M.fromList [(100, "hundred"), (200, "two hundred")] 198 | m3 = M.fromList [(12, "dozen")] 199 | executeWrite QUORUM insert (u1, m1) 200 | executeWrite QUORUM insert (u2, m2) 201 | executeWrite QUORUM insert (u3, m3) 202 | 203 | results <- executeRows QUORUM select () 204 | liftIO $ do 205 | assertBool "Item not found" $ L.elem m1 results 206 | assertBool "Item not found" $ L.elem m2 results 207 | assertBool "Item not found" $ L.elem m3 results 208 | 209 | where 210 | dropMaps :: Query Schema () () 211 | dropMaps = "drop table maps" 212 | 213 | createMaps :: Query Schema () () 214 | createMaps = "create table maps (id uuid PRIMARY KEY, items map)" 215 | 216 | insert :: Query Write (UUID, Map Int Text) () 217 | insert = "insert into maps (id, items) values (?, ?)" 218 | 219 | select :: Query Rows () (Map Int Text) 220 | select = "select items from maps" 221 | 222 | cassandraTest :: Cas () -> IO () 223 | cassandraTest action = do 224 | pool <- newPool [("127.0.0.1", "9042")] "test" Nothing -- servers, keyspace, auth 225 | runCas pool action 226 | 227 | 228 | ignoreDropFailure :: Cas () -> Cas () 229 | ignoreDropFailure code = code `catch` \exc -> case exc of 230 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 231 | Invalid _ _ -> return () 232 | _ -> throwM exc 233 | 234 | allTests :: TestTree 235 | allTests = testGroup "All Tests" [tupleTests,testUDT, testMap] 236 | 237 | main :: IO () 238 | main = defaultMain allTests 239 | -------------------------------------------------------------------------------- /tests/create_keyspace.cql: -------------------------------------------------------------------------------- 1 | CREATE KEYSPACE test WITH replication = { 'class' : 'SimpleStrategy', 'replication_factor' : '1' }; 2 | -------------------------------------------------------------------------------- /tests/example-autocreate-keyspace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.Catch 6 | import Control.Monad.Trans (liftIO) 7 | import qualified Data.ByteString as B 8 | import Data.ByteString.Char8 (ByteString) 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import Data.UUID 13 | import System.Random 14 | 15 | dropSongs :: Query Schema () () 16 | dropSongs = "drop table songs" 17 | 18 | createSongs :: Query Schema () () 19 | createSongs = "create table songs (id uuid PRIMARY KEY, title ascii, artist varchar, femaleSinger boolean, timesPlayed int, comment text, recording blob)" 20 | 21 | insertSong :: Query Write (UUID, Ascii, Text, Bool, Int, Maybe Text, ByteString) () 22 | insertSong = "insert into songs (id, title, artist, femaleSinger, timesPlayed, comment, recording) values (?, ?, ?, ?, ?, ?, ?)" 23 | 24 | getSongs :: Query Rows () (UUID, Ascii, Text, Bool, Int, Maybe Text, ByteString) 25 | getSongs = "select id, title, artist, femaleSinger, timesPlayed, comment, recording from songs" 26 | 27 | getOneSong :: Query Rows UUID (Text, Int) 28 | getOneSong = "select artist, timesPlayed from songs where id=?" 29 | 30 | ignoreDropFailure :: Cas () -> Cas () 31 | ignoreDropFailure code = code `catch` \exc -> case exc of 32 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 33 | Invalid _ _ -> return () 34 | _ -> throwM exc 35 | 36 | main = do 37 | -- let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 38 | let auth = Nothing 39 | 40 | -- this config will automatically run keyspace creation cql script during each connection initializationj 41 | -- suitable for a development purposes 42 | 43 | let ksCfg = "CREATE KEYSPACE IF NOT EXISTS test1 WITH replication = { 'class' : 'SimpleStrategy', 'replication_factor' : '1' };" 44 | let poolCfg = (defaultConfig [("localhost", "9042")] "test1" auth){ piKeyspaceConfig = Just ksCfg} 45 | 46 | pool <- newPool' poolCfg -- servers, keyspace, maybe auth 47 | runCas pool $ do 48 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropSongs () 49 | liftIO . print =<< executeSchema QUORUM createSongs () 50 | 51 | u1 <- liftIO randomIO 52 | u2 <- liftIO randomIO 53 | u3 <- liftIO randomIO 54 | executeWrite QUORUM insertSong (u1, Ascii "La Grange", "ZZ Top", False, 2, Nothing, B.pack [minBound .. maxBound]) 55 | executeWrite QUORUM insertSong (u2, Ascii "Your Star", "Evanescence", True, 799, Nothing, B.pack [maxBound, (maxBound-2) .. minBound]) 56 | executeWrite QUORUM insertSong (u3, Ascii "Angel of Death", "Slayer", False, 50, Just "Singer Tom Araya", mempty) 57 | 58 | songs <- executeRows QUORUM getSongs () 59 | liftIO $ forM_ songs $ \(uuid, title, artist, female, played, mComment, recording) -> do 60 | putStrLn "" 61 | putStrLn $ "id : "++show uuid 62 | putStrLn $ "title : "++C.unpack (unAscii title) 63 | putStrLn $ "artist : "++T.unpack artist 64 | putStrLn $ "female singer : "++show female 65 | putStrLn $ "times played : "++show played 66 | putStrLn $ "comment : "++show mComment 67 | putStrLn $ "recording sz. : "++show (B.length recording) 68 | 69 | liftIO $ putStrLn "" 70 | liftIO . print =<< executeRow QUORUM getOneSong u2 71 | -------------------------------------------------------------------------------- /tests/example-trans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.ByteString.Char8 (ByteString) 8 | import qualified Data.ByteString.Char8 as C 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Data.UUID 12 | import System.Random 13 | 14 | dropSongs :: Query Schema () () 15 | dropSongs = "drop table songs" 16 | 17 | createSongs :: Query Schema () () 18 | createSongs = "create table songs (id uuid PRIMARY KEY, title ascii, artist varchar, femaleSinger boolean, timesPlayed int, comment text)" 19 | 20 | insertSong :: Query Write (UUID, ByteString, Text, Bool, Int, Maybe Text) () 21 | insertSong = "insert into songs (id, title, artist, femaleSinger, timesPlayed, comment) values (?, ?, ?, ?, ?, ?) if not exists" 22 | 23 | getSongs :: Query Rows () (UUID, ByteString, Text, Bool, Int, Maybe Text) 24 | getSongs = "select id, title, artist, femaleSinger, timesPlayed, comment from songs" 25 | 26 | getOneSong :: Query Rows UUID (Text, Int) 27 | getOneSong = "select artist, timesPlayed from songs where id=?" 28 | 29 | updateTimesPlayed :: Query Write (Int, UUID, Int) () 30 | updateTimesPlayed = "update songs set timesPlayed = ? where id= ? if timesPlayed = ?" 31 | 32 | ignoreDropFailure :: Cas () -> Cas () 33 | ignoreDropFailure code = code `catch` \exc -> case exc of 34 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 35 | Invalid _ _ -> return () 36 | _ -> throw exc 37 | 38 | main = do 39 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 40 | let auth = Nothing 41 | {- 42 | Assuming a 'test' keyspace already exists. Here's some CQL to create it: 43 | CREATE KEYSPACE test WITH replication = { 'class' : 'SimpleStrategy', 'replication_factor' : '1' }; 44 | -} 45 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, maybe auth 46 | runCas pool $ do 47 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropSongs () 48 | liftIO . print =<< executeSchema QUORUM createSongs () 49 | 50 | u1 <- liftIO randomIO 51 | u2 <- liftIO randomIO 52 | u3 <- liftIO randomIO 53 | 54 | insertSongTxn u1 "La Grange" "ZZ Top" False 2 Nothing 55 | insertSongTxn u1 "La Grange" "ZZ Top" False 2 Nothing 56 | insertSongTxn u2 "Your Star" "Evanescence" True 799 Nothing 57 | insertSongTxn u2 "Your Star" "Evanescence" True 799 Nothing 58 | insertSongTxn u3 "Angel of Death" "Slayer" False 50 (Just "Singer Tom Araya") 59 | insertSongTxn u3 "Angel of Death" "Slayer" False 50 (Just "Singer Tom Araya") 60 | 61 | songs <- executeRows QUORUM getSongs () 62 | liftIO $ forM_ songs $ \(uuid, title, artist, female, played, mComment) -> do 63 | putStrLn "" 64 | putStrLn $ "id : "++show uuid 65 | putStrLn $ "title : "++C.unpack title 66 | putStrLn $ "artist : "++T.unpack artist 67 | putStrLn $ "female singer : "++show female 68 | putStrLn $ "times played : "++show played 69 | putStrLn $ "comment : "++show mComment 70 | 71 | liftIO $ putStrLn "" 72 | liftIO . print =<< executeRow QUORUM getOneSong u2 73 | 74 | res <- executeTrans updateTimesPlayed (800,u2,799) QUORUM 75 | liftIO $ putStrLn $ "Update timesPlayed 799 to 800 : success" 76 | liftIO . print =<< executeRow QUORUM getOneSong u2 77 | 78 | res <- executeTrans updateTimesPlayed (800,u2,799) QUORUM 79 | when (not res) $ liftIO $ putStrLn $ "Update timesPlayed 799 to 800 : failed!" 80 | 81 | res <- executeTrans updateTimesPlayed (801,u2,800) QUORUM 82 | liftIO $ putStrLn $ "Update timesPlayed 800 to 801 : success" 83 | liftIO . print =<< executeRow QUORUM getOneSong u2 84 | 85 | where 86 | insertSongTxn id title artist femaleSinger timesPlayed comment = do 87 | res <- executeTrans insertSong (id, title, artist, femaleSinger, timesPlayed, comment) QUORUM 88 | when (not res) $ liftIO $ putStrLn $ "Song " ++ show id ++ " already exists." 89 | -------------------------------------------------------------------------------- /tests/example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.ByteString.Char8 (ByteString) 8 | import qualified Data.ByteString.Char8 as C 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Data.UUID 12 | import System.Random 13 | 14 | dropSongs :: Query Schema () () 15 | dropSongs = "drop table songs" 16 | 17 | createSongs :: Query Schema () () 18 | createSongs = "create table songs (id uuid PRIMARY KEY, title ascii, artist varchar, femaleSinger boolean, timesPlayed int, comment text)" 19 | 20 | insertSong :: Query Write (UUID, ByteString, Text, Bool, Int, Maybe Text) () 21 | insertSong = "insert into songs (id, title, artist, femaleSinger, timesPlayed, comment) values (?, ?, ?, ?, ?, ?)" 22 | 23 | getSongs :: Query Rows () (UUID, ByteString, Text, Bool, Int, Maybe Text) 24 | getSongs = "select id, title, artist, femaleSinger, timesPlayed, comment from songs" 25 | 26 | getOneSong :: Query Rows UUID (Text, Int) 27 | getOneSong = "select artist, timesPlayed from songs where id=?" 28 | 29 | ignoreDropFailure :: Cas () -> Cas () 30 | ignoreDropFailure code = code `catch` \exc -> case exc of 31 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 32 | Invalid _ _ -> return () 33 | _ -> throw exc 34 | 35 | main = do 36 | -- let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 37 | let auth = Nothing 38 | {- 39 | Assuming a 'test' keyspace already exists. Here's some CQL to create it: 40 | CREATE KEYSPACE test WITH replication = { 'class' : 'SimpleStrategy', 'replication_factor' : '1' }; 41 | -} 42 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, maybe auth 43 | runCas pool $ do 44 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropSongs () 45 | liftIO . print =<< executeSchema QUORUM createSongs () 46 | 47 | u1 <- liftIO randomIO 48 | u2 <- liftIO randomIO 49 | u3 <- liftIO randomIO 50 | executeWrite QUORUM insertSong (u1, "La Grange", "ZZ Top", False, 2, Nothing) 51 | executeWrite QUORUM insertSong (u2, "Your Star", "Evanescence", True, 799, Nothing) 52 | executeWrite QUORUM insertSong (u3, "Angel of Death", "Slayer", False, 50, Just "Singer Tom Araya") 53 | 54 | songs <- executeRows QUORUM getSongs () 55 | liftIO $ forM_ songs $ \(uuid, title, artist, female, played, mComment) -> do 56 | putStrLn "" 57 | putStrLn $ "id : "++show uuid 58 | putStrLn $ "title : "++C.unpack title 59 | putStrLn $ "artist : "++T.unpack artist 60 | putStrLn $ "female singer : "++show female 61 | putStrLn $ "times played : "++show played 62 | putStrLn $ "comment : "++show mComment 63 | 64 | liftIO $ putStrLn "" 65 | liftIO . print =<< executeRow QUORUM getOneSong u2 66 | -------------------------------------------------------------------------------- /tests/test-decimal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | import Data.Decimal 11 | import Data.UUID 12 | import System.Random 13 | 14 | dropLists :: Query Schema () () 15 | dropLists = "drop table decimals" 16 | 17 | createLists :: Query Schema () () 18 | createLists = "create table decimals (id uuid PRIMARY KEY, item decimal)" 19 | 20 | insert :: Query Write (UUID, Decimal) () 21 | insert = "insert into decimals (id, item) values (?, ?)" 22 | 23 | select :: Query Rows UUID Decimal 24 | select = "select item from decimals where id=?" 25 | 26 | ignoreDropFailure :: Cas () -> Cas () 27 | ignoreDropFailure code = code `catch` \exc -> case exc of 28 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 29 | Invalid _ _ -> return () 30 | _ -> throw exc 31 | 32 | main = do 33 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 34 | let auth = Nothing 35 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 36 | runCas pool $ do 37 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 38 | liftIO . print =<< executeSchema QUORUM createLists () 39 | 40 | u1 <- liftIO randomIO 41 | u2 <- liftIO randomIO 42 | u3 <- liftIO randomIO 43 | u4 <- liftIO randomIO 44 | u5 <- liftIO randomIO 45 | u6 <- liftIO randomIO 46 | u7 <- liftIO randomIO 47 | u8 <- liftIO randomIO 48 | executeWrite QUORUM insert (u1, read "0") 49 | executeWrite QUORUM insert (u2, read "1.02") 50 | executeWrite QUORUM insert (u3, read "12345678901234567890.123456789") 51 | executeWrite QUORUM insert (u4, read "-12345678901234567890.123456789") 52 | executeWrite QUORUM insert (u5, read "3.141592654") 53 | executeWrite QUORUM insert (u6, read "-3.141592654") 54 | executeWrite QUORUM insert (u7, read "-0.000000001") 55 | executeWrite QUORUM insert (u8, read "118000") 56 | 57 | let us = [u1,u2,u3,u4,u5,u6,u7, u8] 58 | forM_ us $ \u -> 59 | liftIO . print =<< executeRow QUORUM select u 60 | -------------------------------------------------------------------------------- /tests/test-double.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.ByteString.Char8 (ByteString) 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.Set (Set) 11 | import qualified Data.Set as S 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Data.UUID 15 | import System.Random 16 | 17 | dropLists :: Query Schema () () 18 | dropLists = "drop table doubles" 19 | 20 | createLists :: Query Schema () () 21 | createLists = "create table doubles (id uuid PRIMARY KEY, item double)" 22 | 23 | insert :: Query Write (UUID, Double) () 24 | insert = "insert into doubles (id, item) values (?, ?)" 25 | 26 | select :: Query Rows () Double 27 | select = "select item from doubles" 28 | 29 | ignoreDropFailure :: Cas () -> Cas () 30 | ignoreDropFailure code = code `catch` \exc -> case exc of 31 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 32 | Invalid _ _ -> return () 33 | _ -> throw exc 34 | 35 | main = do 36 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 37 | let auth = Nothing 38 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 39 | runCas pool $ do 40 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 41 | liftIO . print =<< executeSchema QUORUM createLists () 42 | 43 | u1 <- liftIO randomIO 44 | u2 <- liftIO randomIO 45 | u3 <- liftIO randomIO 46 | executeWrite QUORUM insert (u1, 100) 47 | executeWrite QUORUM insert (u2, 0.5) 48 | executeWrite QUORUM insert (u3, 3.141592654) 49 | 50 | liftIO . print =<< executeRows QUORUM select () 51 | -------------------------------------------------------------------------------- /tests/test-float.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.ByteString.Char8 (ByteString) 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.Set (Set) 11 | import qualified Data.Set as S 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Data.UUID 15 | import System.Random 16 | 17 | dropLists :: Query Schema () () 18 | dropLists = "drop table floats" 19 | 20 | createLists :: Query Schema () () 21 | createLists = "create table floats (id uuid PRIMARY KEY, item float)" 22 | 23 | insert :: Query Write (UUID, Float) () 24 | insert = "insert into floats (id, item) values (?, ?)" 25 | 26 | select :: Query Rows () Float 27 | select = "select item from floats" 28 | 29 | ignoreDropFailure :: Cas () -> Cas () 30 | ignoreDropFailure code = code `catch` \exc -> case exc of 31 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 32 | Invalid _ _ -> return () 33 | _ -> throw exc 34 | 35 | main = do 36 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 37 | let auth = Nothing 38 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 39 | runCas pool $ do 40 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 41 | liftIO . print =<< executeSchema QUORUM createLists () 42 | 43 | u1 <- liftIO randomIO 44 | u2 <- liftIO randomIO 45 | u3 <- liftIO randomIO 46 | executeWrite QUORUM insert (u1, 100) 47 | executeWrite QUORUM insert (u2, 0.5) 48 | executeWrite QUORUM insert (u3, 3.141592654) 49 | 50 | liftIO . print =<< executeRows QUORUM select () 51 | -------------------------------------------------------------------------------- /tests/test-inet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Applicative 5 | import Control.Monad 6 | import Control.Monad.CatchIO 7 | import Control.Monad.Trans (liftIO) 8 | import Data.Int 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Data.Time.Clock 12 | import Data.UUID 13 | import Network.Socket 14 | import System.Random 15 | 16 | dropLists :: Query Schema () () 17 | dropLists = "drop table inets" 18 | 19 | createLists :: Query Schema () () 20 | createLists = "create table inets (id uuid PRIMARY KEY, item inet)" 21 | 22 | insert :: Query Write (UUID, SockAddr) () 23 | insert = "insert into inets (id, item) values (?, ?)" 24 | 25 | select :: Query Rows () SockAddr 26 | select = "select item from inets" 27 | 28 | ignoreDropFailure :: Cas () -> Cas () 29 | ignoreDropFailure code = code `catch` \exc -> case exc of 30 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 31 | Invalid _ _ -> return () 32 | _ -> throw exc 33 | 34 | main = do 35 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 36 | let auth = Nothing 37 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 38 | runCas pool $ do 39 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 40 | liftIO . print =<< executeSchema QUORUM createLists () 41 | 42 | u1 <- liftIO randomIO 43 | u2 <- liftIO randomIO 44 | a1 <- liftIO $ addrAddress . head <$> getAddrInfo Nothing (Just "2406:e000:c182:1:949c:ae7d:64a1:1935") Nothing 45 | a2 <- liftIO $ addrAddress . head <$> getAddrInfo Nothing (Just "192.168.178.29") Nothing 46 | executeWrite QUORUM insert (u1, a1) 47 | executeWrite QUORUM insert (u2, a2) 48 | 49 | liftIO . print =<< executeRows QUORUM select () 50 | -------------------------------------------------------------------------------- /tests/test-list.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.ByteString.Char8 (ByteString) 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import Data.UUID 13 | import System.Random 14 | 15 | dropListsI :: Query Schema () () 16 | dropListsI = "drop table listsi" 17 | 18 | createListsI :: Query Schema () () 19 | createListsI = "create table listsi (id uuid PRIMARY KEY, items list)" 20 | 21 | insertI :: Query Write (UUID, [Int]) () 22 | insertI = "insert into listsi (id, items) values (?, ?)" 23 | 24 | selectI :: Query Rows () [Int] 25 | selectI = "select items from listsi" 26 | 27 | dropListsT :: Query Schema () () 28 | dropListsT = "drop table listst" 29 | 30 | createListsT :: Query Schema () () 31 | createListsT = "create table listst (id uuid PRIMARY KEY, items list)" 32 | 33 | insertT :: Query Write (UUID, [Text]) () 34 | insertT = "insert into listst (id, items) values (?, ?)" 35 | 36 | selectT :: Query Rows () [Text] 37 | selectT = "select items from listst" 38 | 39 | ignoreDropFailure :: Cas () -> Cas () 40 | ignoreDropFailure code = code `catch` \exc -> case exc of 41 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 42 | Invalid _ _ -> return () 43 | _ -> throw exc 44 | 45 | main = do 46 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 47 | let auth = Nothing 48 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 49 | runCas pool $ do 50 | do 51 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropListsI () 52 | liftIO . print =<< executeSchema QUORUM createListsI () 53 | 54 | u1 <- liftIO randomIO 55 | u2 <- liftIO randomIO 56 | u3 <- liftIO randomIO 57 | executeWrite QUORUM insertI (u1, [10,11,12]) 58 | executeWrite QUORUM insertI (u2, [2,4,6,8]) 59 | executeWrite QUORUM insertI (u3, [900,1000,1100]) 60 | 61 | liftIO . print =<< executeRows QUORUM selectI () 62 | 63 | do 64 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropListsT () 65 | liftIO . print =<< executeSchema QUORUM createListsT () 66 | 67 | u1 <- liftIO randomIO 68 | u2 <- liftIO randomIO 69 | u3 <- liftIO randomIO 70 | executeWrite QUORUM insertT (u1, ["dog","cat","rabbit"]) 71 | executeWrite QUORUM insertT (u2, ["carrot","tomato"]) 72 | executeWrite QUORUM insertT (u3, ["a","b","c"]) 73 | 74 | liftIO . print =<< executeRows QUORUM selectT () 75 | -------------------------------------------------------------------------------- /tests/test-pool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds, ScopedTypeVariables #-} 2 | 3 | import Control.Applicative ((<$>)) 4 | import Control.Concurrent (threadDelay, forkIO) 5 | import Control.Concurrent.MVar 6 | import Control.Exception (SomeException) 7 | import Control.Monad (replicateM, forM, unless) 8 | import Control.Monad.CatchIO (throw, catch) 9 | import Control.Monad.Trans (liftIO) 10 | import Data.Text (Text, pack) 11 | import Data.UUID (UUID) 12 | import Data.UUID.V4 (nextRandom) 13 | import Database.Cassandra.CQL 14 | import System.Log.Logger 15 | 16 | createThings :: Query Schema () () 17 | createThings = "create table if not exists things (id uuid PRIMARY KEY, val text)" 18 | 19 | insertThing :: Query Write (UUID, Text) () 20 | insertThing = "insert into things (id, val) values (?, ?)" 21 | 22 | 23 | ignoreProtocolError :: Cas () -> Cas () 24 | ignoreProtocolError code = code `catch` \exc -> case exc of 25 | LocalProtocolError _ _ -> return () 26 | _ -> throw exc 27 | 28 | simpleRetry :: IO a -> IO a 29 | simpleRetry todo = do 30 | z <- fmap Just todo `catch` (\(e :: SomeException) -> putStrLn ("exception : " ++ show e) >> return Nothing) 31 | case z of 32 | Just a -> return a 33 | Nothing -> do 34 | threadDelay 1000000 35 | simpleRetry todo 36 | 37 | -- Debug and higher goes to STDERR 38 | setupLogging :: IO () 39 | setupLogging = updateGlobalLogger rootLoggerName (setLevel DEBUG) 40 | 41 | 42 | main :: IO () 43 | main = do 44 | setupLogging 45 | 46 | -- first server should be unresponsive 47 | pool <- newPool' (defaultConfig [("172.16.0.1", "9042"), ("localhost", "9042")] "test" Nothing) { 48 | piSessionCreateTimeout = 20 49 | , piConnectionTimeout = 10 50 | , piIoTimeout = 120 51 | , piBackoffOnError = 300 52 | , piMaxSessionIdleTime = 10 53 | , piMaxSessions = 20 54 | } 55 | 56 | simpleRetry $ runCas pool $ ignoreProtocolError $ liftIO . print =<< executeSchema QUORUM createThings () 57 | 58 | let writeBatch ids = mapM_ (runCas pool . (\id' -> executeWrite QUORUM insertThing (id', pack $ show id'))) ids 59 | 60 | 61 | joinOn <- replicateM 30 newEmptyMVar 62 | 63 | -- Not properly exception safe, but good enough for a test. 64 | _ <- forM joinOn $ \j -> forkIO $ do 65 | _ <- replicateM 10 $ do 66 | putStrLn "starting batch" 67 | 68 | ids <- replicateM 100 nextRandom 69 | simpleRetry (writeBatch ids) 70 | 71 | putStrLn "finished batch" 72 | threadDelay 10000000 73 | 74 | putMVar j True 75 | 76 | mapM_ takeMVar joinOn 77 | 78 | -- wait long enough for all idle connections to be destroyed 79 | threadDelay 15000000 80 | 81 | unfinished <- filter ((/= 0) . statSessionCount) <$> serverStats pool 82 | unless (null unfinished) $ putStrLn $ "servers with outstanding sessions (should be none) : " ++ show unfinished 83 | -------------------------------------------------------------------------------- /tests/test-set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.ByteString.Char8 (ByteString) 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.Set (Set) 11 | import qualified Data.Set as S 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Data.UUID 15 | import System.Random 16 | 17 | dropLists :: Query Schema () () 18 | dropLists = "drop table sets" 19 | 20 | createLists :: Query Schema () () 21 | createLists = "create table sets (id uuid PRIMARY KEY, items set)" 22 | 23 | insert :: Query Write (UUID, Set Text) () 24 | insert = "insert into sets (id, items) values (?, ?)" 25 | 26 | select :: Query Rows () (Set Text) 27 | select = "select items from sets" 28 | 29 | ignoreDropFailure :: Cas () -> Cas () 30 | ignoreDropFailure code = code `catch` \exc -> case exc of 31 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 32 | Invalid _ _ -> return () 33 | _ -> throw exc 34 | 35 | main = do 36 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 37 | let auth = Nothing 38 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 39 | runCas pool $ do 40 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 41 | liftIO . print =<< executeSchema QUORUM createLists () 42 | 43 | u1 <- liftIO randomIO 44 | u2 <- liftIO randomIO 45 | u3 <- liftIO randomIO 46 | executeWrite QUORUM insert (u1, S.fromList ["one", "two"]) 47 | executeWrite QUORUM insert (u2, S.fromList ["hundred", "two hundred"]) 48 | executeWrite QUORUM insert (u3, S.fromList ["dozen"]) 49 | 50 | liftIO . print =<< executeRows QUORUM select () 51 | -------------------------------------------------------------------------------- /tests/test-timestamp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | import Data.Time.Clock 11 | import Data.UUID 12 | import System.Random 13 | 14 | dropLists :: Query Schema () () 15 | dropLists = "drop table timestamps" 16 | 17 | createLists :: Query Schema () () 18 | createLists = "create table timestamps (id uuid PRIMARY KEY, item timestamp)" 19 | 20 | insert :: Query Write (UUID, UTCTime) () 21 | insert = "insert into timestamps (id, item) values (?, ?)" 22 | 23 | select :: Query Rows () UTCTime 24 | select = "select item from timestamps" 25 | 26 | ignoreDropFailure :: Cas () -> Cas () 27 | ignoreDropFailure code = code `catch` \exc -> case exc of 28 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 29 | Invalid _ _ -> return () 30 | _ -> throw exc 31 | 32 | main = do 33 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 34 | let auth = Nothing 35 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 36 | runCas pool $ do 37 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 38 | liftIO . print =<< executeSchema QUORUM createLists () 39 | 40 | u1 <- liftIO randomIO 41 | t <- liftIO getCurrentTime 42 | executeWrite QUORUM insert (u1, t) 43 | 44 | liftIO . print =<< executeRows QUORUM select () 45 | -------------------------------------------------------------------------------- /tests/test-timeuuid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | import Data.Time.Clock 11 | import Data.UUID 12 | import System.Random 13 | 14 | dropLists :: Query Schema () () 15 | dropLists = "drop table timeuuids" 16 | 17 | createLists :: Query Schema () () 18 | createLists = "create table timeuuids (id uuid PRIMARY KEY, item timeuuid)" 19 | 20 | insertNow :: Query Write UUID () 21 | insertNow = "insert into timeuuids (id, item) values (?, now())" 22 | 23 | insert :: Query Write (UUID, TimeUUID) () 24 | insert = "insert into timeuuids (id, item) values (?, ?)" 25 | 26 | selectOne :: Query Rows UUID TimeUUID 27 | selectOne = "select item from timeuuids where id=?" 28 | 29 | select :: Query Rows () TimeUUID 30 | select = "select item from timeuuids" 31 | 32 | ignoreDropFailure :: Cas () -> Cas () 33 | ignoreDropFailure code = code `catch` \exc -> case exc of 34 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 35 | Invalid _ _ -> return () 36 | _ -> throw exc 37 | 38 | main = do 39 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 40 | let auth = Nothing 41 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 42 | runCas pool $ do 43 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 44 | liftIO . print =<< executeSchema QUORUM createLists () 45 | 46 | u1 <- liftIO randomIO 47 | u2 <- liftIO randomIO 48 | executeWrite QUORUM insertNow u1 49 | Just t <- executeRow QUORUM selectOne u1 50 | executeWrite QUORUM insert (u2, t) 51 | 52 | liftIO . print =<< executeRows QUORUM select () 53 | -------------------------------------------------------------------------------- /tests/test-varint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 | 3 | import Database.Cassandra.CQL 4 | import Control.Monad 5 | import Control.Monad.CatchIO 6 | import Control.Monad.Trans (liftIO) 7 | import Data.Int 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | import Data.Time.Clock 11 | import Data.UUID 12 | import System.Random 13 | 14 | dropLists :: Query Schema () () 15 | dropLists = "drop table varints" 16 | 17 | createLists :: Query Schema () () 18 | createLists = "create table varints (id uuid PRIMARY KEY, item varint)" 19 | 20 | insert :: Query Write (UUID, Integer) () 21 | insert = "insert into varints (id, item) values (?, ?)" 22 | 23 | select :: Query Rows UUID Integer 24 | select = "select item from varints where id=?" 25 | 26 | ignoreDropFailure :: Cas () -> Cas () 27 | ignoreDropFailure code = code `catch` \exc -> case exc of 28 | ConfigError _ _ -> return () -- Ignore the error if the table doesn't exist 29 | Invalid _ _ -> return () 30 | _ -> throw exc 31 | 32 | main = do 33 | --let auth = Just (PasswordAuthenticator "cassandra" "cassandra") 34 | let auth = Nothing 35 | pool <- newPool [("localhost", "9042")] "test" auth -- servers, keyspace, auth 36 | runCas pool $ do 37 | ignoreDropFailure $ liftIO . print =<< executeSchema QUORUM dropLists () 38 | liftIO . print =<< executeSchema QUORUM createLists () 39 | 40 | u1 <- liftIO randomIO 41 | u2 <- liftIO randomIO 42 | u3 <- liftIO randomIO 43 | u4 <- liftIO randomIO 44 | u5 <- liftIO randomIO 45 | u6 <- liftIO randomIO 46 | u7 <- liftIO randomIO 47 | u8 <- liftIO randomIO 48 | u9 <- liftIO randomIO 49 | u10 <- liftIO randomIO 50 | executeWrite QUORUM insert (u1, 0) 51 | executeWrite QUORUM insert (u2, -1) 52 | executeWrite QUORUM insert (u3, 12345678901234567890123456789) 53 | executeWrite QUORUM insert (u4, -12345678901234567890123456789) 54 | executeWrite QUORUM insert (u5, -65537) 55 | executeWrite QUORUM insert (u6, -65536) 56 | executeWrite QUORUM insert (u7, -65535) 57 | executeWrite QUORUM insert (u8, -32769) 58 | executeWrite QUORUM insert (u9, -32768) 59 | executeWrite QUORUM insert (u10, -32767) 60 | 61 | let us = [u1,u2,u3,u4,u5,u6,u7,u8,u9,u10] 62 | forM_ us $ \u -> 63 | liftIO . print =<< executeRow QUORUM select u 64 | --------------------------------------------------------------------------------