module Database.Cassandra.Pack
( CasType (..)
, TAscii (..)
, TBytes (..)
, TCounter (..)
, TInt32 (..)
, TInt64 (..)
, TUtf8 (..)
, TUUID (..)
, TLong (..)
, TTimeStamp (..)
, toTimeStamp
, fromTimeStamp
, Exclusive (..)
, Single (..)
, SliceStart (..)
) where
import Control.Applicative
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char
import Data.Int
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Time
import Data.Time
import Data.Time.Clock.POSIX
import GHC.Int
newtype TAscii = TAscii { getAscii :: ByteString } deriving (Eq,Show,Read,Ord)
newtype TBytes = TBytes { getTBytes :: ByteString } deriving (Eq,Show,Read,Ord)
newtype TCounter = TCounter { getCounter :: ByteString } deriving (Eq,Show,Read,Ord)
newtype TInt32 = TInt32 { getInt32 :: Int32 } deriving (Eq,Show,Read,Ord)
newtype TInt64 = TInt64 { getInt64 :: Int64 }
deriving (Eq,Show,Read,Ord,Enum,Real,Integral,Num)
newtype TUUID = TUUID { getUUID :: ByteString } deriving (Eq,Show,Read,Ord)
newtype TLong = TLong { getLong :: Integer }
deriving (Eq,Show,Read,Ord,Enum,Real,Integral,Num)
newtype TUtf8 = TUtf8 { getUtf8 :: Text } deriving (Eq,Show,Read,Ord)
newtype TTimeStamp = TTimeStamp { getTimeStamp :: TLong }
deriving (Eq,Show,Read,Ord,Enum,Num,Real,Integral,CasType)
toTimeStamp :: UTCTime -> TTimeStamp
toTimeStamp utc = fromIntegral . floor . (* 1e6) $ utcTimeToPOSIXSeconds utc
fromTimeStamp :: TTimeStamp -> UTCTime
fromTimeStamp (TTimeStamp (TLong i)) =
posixSecondsToUTCTime $ realToFrac $ fromIntegral i / (1e6)
class CasType a where
encodeCas :: a -> ByteString
decodeCas :: ByteString -> a
instance CasType B.ByteString where
encodeCas = fromStrict
decodeCas = toStrict
instance CasType String where
encodeCas = LB.pack
decodeCas = LB.unpack
instance CasType LT.Text where
encodeCas = encodeCas . LT.encodeUtf8
decodeCas = LT.decodeUtf8
instance CasType T.Text where
encodeCas = encodeCas . LT.fromChunks . return
decodeCas = T.concat . LT.toChunks . decodeCas
instance CasType LB.ByteString where
encodeCas = id
decodeCas = id
instance CasType TAscii where
encodeCas = getAscii
decodeCas = TAscii
instance CasType TBytes where
encodeCas = getTBytes
decodeCas = TBytes
instance CasType TCounter where
encodeCas = getCounter
decodeCas = TCounter
instance CasType TInt32 where
encodeCas = runPut . putWord32be . fromIntegral . getInt32
decodeCas = TInt32 . fromIntegral . runGet getWord32be
instance CasType TInt64 where
encodeCas = runPut . putWord64be . fromIntegral . getInt64
decodeCas = TInt64 . fromIntegral . runGet getWord64be
instance CasType Int32 where
encodeCas = encodeCas . TInt32 . fromIntegral
decodeCas = fromIntegral . getInt32 . decodeCas
instance CasType Int64 where
encodeCas = encodeCas . TInt64 . fromIntegral
decodeCas = fromIntegral . getInt64 . decodeCas
instance CasType Int where
encodeCas = encodeCas . TInt64 . fromIntegral
decodeCas = fromIntegral . getInt64 . decodeCas
instance CasType TLong where
encodeCas = runPut . putWord64be . fromIntegral . getLong
decodeCas = TLong . fromIntegral . runGet getWord64be
instance CasType TUtf8 where
encodeCas = LB.fromChunks . return . T.encodeUtf8 . getUtf8
decodeCas = TUtf8 . T.decodeUtf8 . B.concat . LB.toChunks
instance CasType Day where
encodeCas = encodeCas . TLong . toModifiedJulianDay
decodeCas = ModifiedJulianDay . getLong . decodeCas
instance CasType UTCTime where
encodeCas = encodeCas . toTimeStamp
decodeCas = fromTimeStamp . decodeCas
instance (CasType a) => CasType (Single a) where
encodeCas (Single a) = runPut $ putSegment a end
decodeCas bs = flip runGet bs $ Single <$> getSegment
instance (CasType a, CasType b) => CasType (a,b) where
encodeCas (a, b) = runPut $ do
putSegment a sep
putSegment b end
decodeCas bs = flip runGet bs $ (,)
<$> getSegment
<*> getSegment
instance (CasType a, CasType b, CasType c) => CasType (a,b,c) where
encodeCas (a, b, c) = runPut $ do
putSegment a sep
putSegment b sep
putSegment c end
decodeCas bs = flip runGet bs $ (,,)
<$> getSegment
<*> getSegment
<*> getSegment
instance (CasType a, CasType b, CasType c, CasType d) => CasType (a,b,c,d) where
encodeCas (a, b, c, d) = runPut $ do
putSegment a sep
putSegment b sep
putSegment c sep
putSegment d end
decodeCas bs = flip runGet bs $ (,,,)
<$> getSegment
<*> getSegment
<*> getSegment
<*> getSegment
instance (CasType a) => CasType (SliceStart (Single a)) where
encodeCas (SliceStart (Single a)) = runPut $ do
putSegment a exc
decodeCas bs = flip runGet bs $ (SliceStart . Single) <$> getSegment
instance (CasType a, CasType b) => CasType (SliceStart (a,b)) where
encodeCas (SliceStart (a, b)) = runPut $ do
putSegment a sep
putSegment b exc
decodeCas bs = SliceStart . flip runGet bs $ (,)
<$> getSegment
<*> getSegment
instance (CasType a, CasType b, CasType c) => CasType (SliceStart (a,b,c)) where
encodeCas (SliceStart (a, b, c)) = runPut $ do
putSegment a sep
putSegment b sep
putSegment c exc
decodeCas bs = SliceStart . flip runGet bs $ (,,)
<$> getSegment
<*> getSegment
<*> getSegment
instance (CasType a, CasType b, CasType c, CasType d) =>
CasType (SliceStart (a,b,c,d)) where
encodeCas (SliceStart (a, b, c, d)) = runPut $ do
putSegment a sep
putSegment b sep
putSegment c sep
putSegment d exc
decodeCas bs = SliceStart . flip runGet bs $ (,,,)
<$> getSegment
<*> getSegment
<*> getSegment
<*> getSegment
instance CasType a => CasType (Exclusive (Single a)) where
encodeCas (Exclusive (Single a)) = runPut $ do
putSegment a exc
decodeCas = Exclusive . decodeCas
instance (CasType a, CasType b) => CasType (a, Exclusive b) where
encodeCas (a, Exclusive b) = runPut $ do
putSegment a sep
putSegment b exc
decodeCas bs = flip runGet bs $ (,)
<$> getSegment
<*> (Exclusive <$> getSegment)
instance (CasType a, CasType b, CasType c) => CasType (a, b, Exclusive c) where
encodeCas (a, b, Exclusive c) = runPut $ do
putSegment a sep
putSegment b sep
putSegment c exc
decodeCas bs = flip runGet bs $ (,,)
<$> getSegment
<*> getSegment
<*> (Exclusive <$> getSegment)
instance (CasType a, CasType b, CasType c, CasType d) => CasType (a, b, c, Exclusive d) where
encodeCas (a, b, c, Exclusive d) = runPut $ do
putSegment a sep
putSegment b sep
putSegment c sep
putSegment d exc
decodeCas bs = flip runGet bs $ (,,,)
<$> getSegment
<*> getSegment
<*> getSegment
<*> (Exclusive <$> getSegment)
newtype Exclusive a = Exclusive a deriving (Eq,Show,Read,Ord)
newtype Single a = Single a deriving (Eq,Show,Read,Ord)
newtype SliceStart a = SliceStart a deriving (Eq,Show,Read,Ord)
putBytes :: B.ByteString -> Put
putBytes b = do
putLen b
putByteString b
getBytes' :: Get B.ByteString
getBytes' = getLen >>= getBytes
getLen :: Get Int
getLen = fromIntegral `fmap` getWord16be
putLen :: B.ByteString -> Put
putLen b = putWord16be . fromIntegral $ (B.length b)
toStrict :: ByteString -> B.ByteString
toStrict = B.concat . LB.toChunks
fromStrict :: B.ByteString -> ByteString
fromStrict = LB.fromChunks . return
getSegment :: CasType a => Get a
getSegment = do
a <- (decodeCas . fromStrict) <$> getBytes'
getWord8
return a
putSegment :: CasType a => a -> PutM b -> PutM b
putSegment a f = do
putBytes . toStrict $ encodeCas a
f
exc :: Put
exc = putWord8 . fromIntegral $ ord '\xff'
end :: Put
end = putWord8 . fromIntegral $ ord '\x01'
sep :: Put
sep = putWord8 . fromIntegral $ ord '\x00'