module Database.Cassandra.JSON
(
CPool
, Server(..)
, defServer
, defServers
, KeySpace(..)
, createCassandraPool
, CKey(..)
, ModifyOperation(..)
, ColumnFamily(..)
, ConsistencyLevel(..)
, CassandraException(..)
, get
, getCol
, insertCol
, modify
, modify_
, delete
) 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.Map (Map)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Network
import Prelude hiding (catch)
import Database.Cassandra.Basic hiding (get, getCol, delete)
import qualified Database.Cassandra.Basic as CB
import Database.Cassandra.Pool
import Database.Cassandra.Types
class CKey a where
toBS :: a -> ByteString
fromBS :: ByteString -> a
instance CKey String where
toBS = LB.pack
fromBS = LB.unpack
instance CKey LT.Text where
toBS = LT.encodeUtf8
fromBS = LT.decodeUtf8
instance CKey T.Text where
toBS = toBS . LT.fromChunks . return
fromBS = T.concat . LT.toChunks . fromBS
instance CKey B.ByteString where
toBS = LB.fromChunks . return
fromBS = B.concat . LB.toChunks . fromBS
instance CKey ByteString where
toBS = id
fromBS = id
col2val :: (CKey colKey, FromJSON a) => Column -> (colKey, 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)
modify
:: (CKey rowKey, CKey colKey, ToJSON a, FromJSON a)
=> CPool
-> ColumnFamily
-> rowKey
-> colKey
-> ConsistencyLevel
-> ConsistencyLevel
-> (Maybe a -> IO (ModifyOperation a, b))
-> IO b
modify cp cf k cn rcl wcl f =
let
k' = toBS k
cn' = toBS cn
execF prev = do
(fres, b) <- f prev
dbres <- case fres of
(Update a) ->
insert cp cf k' wcl [col cn' (marshallJSON' a)]
(Delete) ->
CB.delete cp cf k' (ColNames [cn']) wcl
(DoNothing) -> return $ Right ()
case dbres of
Left e -> throw e
Right _ -> return b
in do
res <- CB.getCol cp cf k' cn' rcl
case res of
Left NotFoundException -> execF Nothing
Left e -> throw e
Right Column{..} -> execF (unMarshallJSON' colVal)
Right SuperColumn{..} -> throw $
OperationNotSupported "modify not implemented for SuperColumn"
modify_
:: (CKey rowKey, CKey colKey, ToJSON a, FromJSON a)
=> CPool
-> ColumnFamily
-> rowKey
-> colKey
-> ConsistencyLevel
-> ConsistencyLevel
-> (Maybe a -> IO (ModifyOperation a))
-> IO ()
modify_ cp cf k cn rcl wcl f =
let
f' prev = do
op <- f prev
return (op, ())
in do
modify cp cf k cn rcl wcl f'
return ()
insertCol
:: (CKey rowKey, CKey colKey, ToJSON a)
=> CPool -> ColumnFamily
-> rowKey
-> colKey
-> ConsistencyLevel
-> a
-> IO ()
insertCol cp cf k cn cl a =
throwing $ insert cp cf (toBS k) cl [col (toBS cn) (marshallJSON' a)]
get
:: (CKey rowKey, CKey colKey, FromJSON a)
=> CPool -> ColumnFamily
-> rowKey
-> Selector
-> ConsistencyLevel
-> IO [(colKey, a)]
get cp cf k s cl = do
res <- throwing $ CB.get cp cf (toBS k) s cl
return $ map col2val res
getCol
:: (CKey rowKey, CKey colKey, FromJSON a)
=> CPool -> ColumnFamily
-> rowKey
-> colKey
-> ConsistencyLevel
-> IO (Maybe a)
getCol cp cf rk ck cl = do
res <- CB.getCol cp cf (toBS rk) (toBS ck) cl
case res of
Left NotFoundException -> return Nothing
Left e -> throw e
Right a ->
let (_ :: ByteString, x) = col2val a
in return $ Just x
delete
:: (CKey rowKey)
=> CPool
-> ColumnFamily
-> rowKey
-> Selector
-> ConsistencyLevel
-> IO ()
delete p cf k s cl = throwing $ CB.delete p 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