module Database.Cassandra.JSON
(
CPool
, Server (..)
, defServer
, defServers
, KeySpace (..)
, createCassandraPool
, MonadCassandra (..)
, Cas (..)
, runCas
, get
, getCol
, getMulti
, insertCol
, modify
, modify_
, delete
, RowKey
, ColumnName
, ModifyOperation (..)
, ColumnFamily (..)
, ConsistencyLevel (..)
, CassandraException (..)
, Selector (..)
, KeySelector (..)
, KeyRangeType (..)
, CKey (..)
, packLong
) where
import Control.Exception
import Control.Monad
import Data.Aeson as A
import Data.Aeson.Parser (value)
import qualified Data.Attoparsec as Atto (IResult(..), parse)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int32, Int64)
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Network
import Prelude hiding (catch)
import Database.Cassandra.Basic hiding (get, getCol, delete, KeySelector (..),
getMulti)
import qualified Database.Cassandra.Basic as CB
import Database.Cassandra.Pool
import Database.Cassandra.Types hiding (KeySelector (..), ColumnName)
import Database.Cassandra.Pack
col2val :: (FromJSON a) => Column -> (ColumnName, a)
col2val (Column nm val _ _) = (fromBS nm, maybe err id $ unMarshallJSON' val)
where err = error "Value can't be parsed from JSON."
col2val _ = error "col2val is not implemented for SuperColumns"
data ModifyOperation a =
Update a
| Delete
| DoNothing
deriving (Eq,Show,Ord,Read)
type RowKey = Text
modify
:: (MonadCassandra m, ToJSON a, FromJSON a)
=> ColumnFamily
-> RowKey
-> ColumnName
-> ConsistencyLevel
-> ConsistencyLevel
-> (Maybe a -> m (ModifyOperation a, b))
-> m b
modify cf k cn rcl wcl f =
let
k' = toBS k
cn' = toBS cn
execF prev = do
(fres, b) <- f prev
case fres of
(Update a) ->
insert cf k' wcl [col cn' (marshallJSON' a)]
(Delete) ->
CB.delete cf k' (ColNames [cn']) wcl
(DoNothing) -> return ()
return b
in do
res <- CB.getCol cf k' cn' rcl
case res of
Nothing -> execF Nothing
Just Column{..} -> execF (unMarshallJSON' colVal)
Just SuperColumn{..} -> throw $
OperationNotSupported "modify not implemented for SuperColumn"
modify_
:: (MonadCassandra m, ToJSON a, FromJSON a)
=> ColumnFamily
-> RowKey
-> ColumnName
-> ConsistencyLevel
-> ConsistencyLevel
-> (Maybe a -> m (ModifyOperation a))
-> m ()
modify_ cf k cn rcl wcl f =
let
f' prev = do
op <- f prev
return (op, ())
in do
modify cf k cn rcl wcl f'
return ()
insertCol
:: (MonadCassandra m, ToJSON a)
=> ColumnFamily
-> RowKey
-> ColumnName
-> ConsistencyLevel
-> a
-> m ()
insertCol cf k cn cl a =
insert cf (toBS k) cl [col (toBS cn) (marshallJSON' a)]
get
:: (MonadCassandra m, FromJSON a)
=> ColumnFamily
-> RowKey
-> Selector
-> ConsistencyLevel
-> m [(ColumnName, a)]
get cf k s cl = do
res <- CB.get cf (toBS k) s cl
return $ map col2val res
data KeySelector
= Keys [RowKey]
| KeyRange KeyRangeType RowKey RowKey Int32
ksToBasicKS (Keys k) = CB.Keys $ map toBS k
ksToBasicKS (KeyRange ty fr to i) = CB.KeyRange ty (toBS fr) (toBS to) i
getMulti
:: (MonadCassandra m, FromJSON a)
=> ColumnFamily
-> KeySelector
-> Selector
-> ConsistencyLevel
-> m (Map RowKey [(ColumnName, a)])
getMulti cf ks s cl = do
res <- CB.getMulti cf (ksToBasicKS ks) s cl
return . M.fromList . map conv . M.toList $ res
where
conv (k, row) = (fromBS k, map col2val row)
getCol
:: (MonadCassandra m, FromJSON a)
=> ColumnFamily
-> RowKey
-> ColumnName
-> ConsistencyLevel
-> m (Maybe a)
getCol cf rk ck cl = do
res <- CB.getCol cf (toBS rk) (toBS ck) cl
case res of
Nothing -> return Nothing
Just res' -> do
let (_, x) = col2val res'
return $ Just x
delete
:: (MonadCassandra m)
=>ColumnFamily
-> RowKey
-> Selector
-> ConsistencyLevel
-> m ()
delete cf k s cl = CB.delete cf (toBS k) s cl
marshallJSON' :: ToJSON a => a -> ByteString
marshallJSON' = LB.fromChunks . return . marshallJSON
marshallJSON :: ToJSON a => a -> B.ByteString
marshallJSON = B.concat . LB.toChunks . A.encode
unMarshallJSON' :: FromJSON a => ByteString -> Maybe a
unMarshallJSON' = unMarshallJSON . B.concat . LB.toChunks
unMarshallJSON :: FromJSON a => B.ByteString -> Maybe a
unMarshallJSON = pJson
where
pJson bs = val
where
js = Atto.parse value bs
val = case js of
Atto.Done _ r -> case fromJSON r of
Error e -> error $ "JSON err: " ++ show e
Success a -> a
_ -> Nothing