{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Tds.Message.DataStream ( TypeInfo (..)
, RawBytes (..)
, getRawBytes
, putRawBytes
, Data (..)
) where
import Data.Monoid((<>))
import Control.Applicative((<$>),(<*>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
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.Word (Word8(..),Word16(..),Word32(..),Word64(..))
import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))
import Data.Binary (Put(..),Get(..),Binary(..))
import qualified Data.Binary.Put as Put
import qualified Data.Binary.Get as Get
import Data.Time (UTCTime(..))
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID
import Database.Tds.Primitives.Null
import Database.Tds.Primitives.Money
import Database.Tds.Primitives.DateTime
import Database.Tds.Primitives.Float
import Database.Tds.Primitives.Decimal
import Database.Tds.Primitives.Collation
data TypeInfo = TINull
| TIBit
| TIInt1
| TIInt2
| TIInt4
| TIInt8
| TIMoney4
| TIMoney8
| TIDateTime4
| TIDateTime8
| TIFlt4
| TIFlt8
| TIBitN
| TIIntN1
| TIIntN2
| TIIntN4
| TIIntN8
| TIMoneyN4
| TIMoneyN8
| TIDateTimeN4
| TIDateTimeN8
| TIFltN4
| TIFltN8
| TIGUID
| TIDecimalN !Precision !Scale
| TINumericN !Precision !Scale
| TIChar !Word8
| TIVarChar !Word8
| TIBigChar !Word16 !Collation
| TIBigVarChar !Word16 !Collation
| TIText !Word32 !Collation
| TINChar !Word16 !Collation
| TINVarChar !Word16 !Collation
| TINText !Word32 !Collation
| TIBinary !Word8
| TIVarBinary !Word8
| TIBigBinary !Word16
| TIBigVarBinary !Word16
| TIImage !Word32
deriving (Show)
getTypeInfo :: Get TypeInfo
getTypeInfo = f =<< Get.getWord8
where
f :: Word8 -> Get TypeInfo
f 0x1f = return TINull
f 0x32 = return TIBit
f 0x30 = return TIInt1
f 0x34 = return TIInt2
f 0x38 = return TIInt4
f 0x7f = return TIInt8
f 0x7a = return TIMoney4
f 0x3c = return TIMoney8
f 0x3a = return TIDateTime4
f 0x3d = return TIDateTime8
f 0x3b = return TIFlt4
f 0x3e = return TIFlt8
f 0x68 = do
_ <- Get.getWord8
return TIBitN
f 0x26 = do
len <- Get.getWord8
case len of
1 -> return TIIntN1
2 -> return TIIntN2
4 -> return TIIntN4
8 -> return TIIntN8
_ -> fail "getTypeInfo: invalid data length"
f 0x6e = do
len <- Get.getWord8
case len of
4 -> return TIMoneyN4
8 -> return TIMoneyN8
_ -> fail "getTypeInfo: invalid data length"
f 0x6f = do
len <- Get.getWord8
case len of
4 -> return TIDateTimeN4
8 -> return TIDateTimeN8
_ -> fail "getTypeInfo: invalid data length"
f 0x6d = do
len <- Get.getWord8
case len of
4 -> return TIFltN4
8 -> return TIFltN8
_ -> fail "getTypeInfo: invalid data length"
f 0x24 = do
len <- Get.getWord8
case len of
16 -> return TIGUID
_ -> fail "getTypeInfo: invalid data length"
f 0x37 = f 0x6a
f 0x6a = do
_ <- Get.getWord8
TIDecimalN <$> Get.getWord8
<*> Get.getWord8
f 0x3f = f 0x6c
f 0x6c = do
_ <- Get.getWord8
TINumericN <$> Get.getWord8
<*> Get.getWord8
f 0x2f = TIChar <$> Get.getWord8
f 0x27 = TIVarChar <$> Get.getWord8
f 0xaf = TIBigChar <$> Get.getWord16le
<*> getCollation
f 0xa7 = TIBigVarChar <$> Get.getWord16le
<*> getCollation
f 0x23 = TIText <$> Get.getWord32le
<*> getCollation
f 0xef = TINChar <$> Get.getWord16le
<*> getCollation
f 0xe7 = TINVarChar <$> Get.getWord16le
<*> getCollation
f 0x63 = TINText <$> Get.getWord32le
<*> getCollation
f 0x2d = TIBinary <$> Get.getWord8
f 0x25 = TIVarBinary <$> Get.getWord8
f 0xad = TIBigBinary <$> Get.getWord16le
f 0xa5 = TIBigVarBinary <$> Get.getWord16le
f 0x22 = TIImage <$> Get.getWord32le
putTypeInfo :: TypeInfo -> Put
putTypeInfo (TINull ) = Put.putWord8 0x1f
putTypeInfo (TIBit ) = Put.putWord8 0x32
putTypeInfo (TIInt1 ) = Put.putWord8 0x30
putTypeInfo (TIInt2 ) = Put.putWord8 0x34
putTypeInfo (TIInt4 ) = Put.putWord8 0x38
putTypeInfo (TIInt8 ) = Put.putWord8 0x7f
putTypeInfo (TIMoney4 ) = Put.putWord8 0x7a
putTypeInfo (TIMoney8 ) = Put.putWord8 0x3c
putTypeInfo (TIDateTime4) = Put.putWord8 0x3a
putTypeInfo (TIDateTime8) = Put.putWord8 0x3d
putTypeInfo (TIFlt4 ) = Put.putWord8 0x3b
putTypeInfo (TIFlt8 ) = Put.putWord8 0x3e
putTypeInfo (TIBitN ) = Put.putWord8 0x68 >> Put.putWord8 1
putTypeInfo (TIIntN1 ) = Put.putWord8 0x26 >> Put.putWord8 1
putTypeInfo (TIIntN2 ) = Put.putWord8 0x26 >> Put.putWord8 2
putTypeInfo (TIIntN4 ) = Put.putWord8 0x26 >> Put.putWord8 4
putTypeInfo (TIIntN8 ) = Put.putWord8 0x26 >> Put.putWord8 8
putTypeInfo (TIMoneyN4 ) = Put.putWord8 0x6e >> Put.putWord8 4
putTypeInfo (TIMoneyN8 ) = Put.putWord8 0x6e >> Put.putWord8 8
putTypeInfo (TIDateTimeN4) = Put.putWord8 0x6f >> Put.putWord8 4
putTypeInfo (TIDateTimeN8) = Put.putWord8 0x6f >> Put.putWord8 8
putTypeInfo (TIFltN4 ) = Put.putWord8 0x6d >> Put.putWord8 4
putTypeInfo (TIFltN8 ) = Put.putWord8 0x6d >> Put.putWord8 8
putTypeInfo (TIGUID) = Put.putWord8 0x24 >> Put.putWord8 16
putTypeInfo (TIDecimalN p s) = do
Put.putWord8 0x6a
Put.putWord8 $ precisionToLen p
Put.putWord8 p
Put.putWord8 s
putTypeInfo (TINumericN p s) = do
Put.putWord8 0x6c
Put.putWord8 $ precisionToLen p
Put.putWord8 p
Put.putWord8 s
putTypeInfo (TIChar len) = do
Put.putWord8 0x2f
Put.putWord8 len
putTypeInfo (TIVarChar len) = do
Put.putWord8 0x27
Put.putWord8 len
putTypeInfo (TIBigChar len col) = do
Put.putWord8 0xaf
Put.putWord16le len
putCollation col
putTypeInfo (TIBigVarChar len col) = do
Put.putWord8 0xa7
Put.putWord16le len
putCollation col
putTypeInfo (TIText len col) = do
Put.putWord8 0x23
Put.putWord32le len
putCollation col
putTypeInfo (TINChar len col) = do
Put.putWord8 0xef
Put.putWord16le len
putCollation col
putTypeInfo (TINVarChar len col) = do
Put.putWord8 0xe7
Put.putWord16le len
putCollation col
putTypeInfo (TINText len col) = do
Put.putWord8 0x63
Put.putWord32le len
putCollation col
putTypeInfo (TIBinary len) = do
Put.putWord8 0x2d
Put.putWord8 len
putTypeInfo (TIVarBinary len) = do
Put.putWord8 0x25
Put.putWord8 len
putTypeInfo (TIBigBinary len) = do
Put.putWord8 0xad
Put.putWord16le len
putTypeInfo (TIBigVarBinary len) = do
Put.putWord8 0xa5
Put.putWord16le len
putTypeInfo (TIImage len) = do
Put.putWord8 0x22
Put.putWord32le len
instance Binary TypeInfo where
put = putTypeInfo
get = getTypeInfo
type RawBytes = Maybe LB.ByteString
getRawBytes :: TypeInfo -> Get RawBytes
getRawBytes = f
where
get8n :: Get RawBytes
get8n = do
len <- Get.getWord8
if len == 0
then return Nothing
else Just <$> (Get.getLazyByteString $ fromIntegral len)
get8s :: Get RawBytes
get8s = do
len <- Get.getWord8
if len == 0xff
then return Nothing
else Just <$> (Get.getLazyByteString $ fromIntegral len)
get16s :: Get RawBytes
get16s = do
len <- Get.getWord16le
if len == 0xffff
then return Nothing
else Just <$> (Get.getLazyByteString $ fromIntegral len)
get32s :: Get RawBytes
get32s = do
len <- Get.getWord32le
if len == 0xffffffff
then return Nothing
else Just <$> (Get.getLazyByteString $ fromIntegral len)
f :: TypeInfo -> Get RawBytes
f TINull = return Nothing
f TIBit = Just <$> Get.getLazyByteString 1
f TIInt1 = Just <$> Get.getLazyByteString 1
f TIInt2 = Just <$> Get.getLazyByteString 2
f TIInt4 = Just <$> Get.getLazyByteString 4
f TIInt8 = Just <$> Get.getLazyByteString 8
f TIMoney4 = Just <$> Get.getLazyByteString 4
f TIMoney8 = Just <$> Get.getLazyByteString 8
f TIDateTime4 = Just <$> Get.getLazyByteString 4
f TIDateTime8 = Just <$> Get.getLazyByteString 8
f TIFlt4 = Just <$> Get.getLazyByteString 4
f TIFlt8 = Just <$> Get.getLazyByteString 8
f TIBitN = get8n
f TIIntN1 = get8n
f TIIntN2 = get8n
f TIIntN4 = get8n
f TIIntN8 = get8n
f TIMoneyN4 = get8n
f TIMoneyN8 = get8n
f TIDateTimeN4 = get8n
f TIDateTimeN8 = get8n
f TIFltN4 = get8n
f TIFltN8 = get8n
f TIGUID = get8n
f (TIDecimalN _ _) = get8n
f (TINumericN _ _) = get8n
f (TIChar _) = get8s
f (TIVarChar _) = get8s
f (TIBigChar _ _) = get16s
f (TIBigVarChar _ _) = get16s
f (TIText _ _) = get32s
f (TINChar _ _) = get16s
f (TINVarChar _ _) = get16s
f (TINText _ _) = get32s
f (TIBinary _) = get8s
f (TIVarBinary _) = get8s
f (TIBigBinary _) = get16s
f (TIBigVarBinary _) = get16s
f (TIImage _) = get32s
putRawBytes :: TypeInfo -> RawBytes -> Put
putRawBytes = g
where
put8n :: RawBytes -> Put
put8n Nothing = Put.putWord8 0
put8n (Just bs) = do
Put.putWord8 $ fromIntegral $ LB.length bs
Put.putLazyByteString bs
put8s :: RawBytes -> Put
put8s Nothing = Put.putWord8 0xff
put8s (Just bs) = do
Put.putWord8 $ fromIntegral $ LB.length bs
Put.putLazyByteString bs
put16s :: RawBytes -> Put
put16s Nothing = Put.putWord16le 0xffff
put16s (Just bs) = do
Put.putWord16le $ fromIntegral $ LB.length bs
Put.putLazyByteString bs
put32s :: RawBytes -> Put
put32s Nothing = Put.putWord32le 0xffffffff
put32s (Just bs) = do
Put.putWord32le $ fromIntegral $ LB.length bs
Put.putLazyByteString bs
g :: TypeInfo -> RawBytes -> Put
g TINull _ = return ()
g TIBit Nothing = error "putRawBytes: Nothing is not convertible to TIBit"
g TIInt1 Nothing = error "putRawBytes: Nothing is not convertible to TIInt1"
g TIInt2 Nothing = error "putRawBytes: Nothing is not convertible to TIInt2"
g TIInt4 Nothing = error "putRawBytes: Nothing is not convertible to TIInt4"
g TIInt8 Nothing = error "putRawBytes: Nothing is not convertible to TIInt8"
g TIMoney4 Nothing = error "putRawBytes: Nothing is not convertible to TIMoney4"
g TIMoney8 Nothing = error "putRawBytes: Nothing is not convertible to TIMoney8"
g TIDateTime4 Nothing = error "putRawBytes: Nothing is not convertible to TIDateTime4"
g TIDateTime8 Nothing = error "putRawBytes: Nothing is not convertible to TIDateTime8"
g TIFlt4 Nothing = error "putRawBytes: Nothing is not convertible to TIFlt4"
g TIFlt8 Nothing = error "putRawBytes: Nothing is not convertible to TIFlt8"
g TIBit (Just bs) = Put.putLazyByteString bs
g TIInt1 (Just bs) = Put.putLazyByteString bs
g TIInt2 (Just bs) = Put.putLazyByteString bs
g TIInt4 (Just bs) = Put.putLazyByteString bs
g TIInt8 (Just bs) = Put.putLazyByteString bs
g TIMoney4 (Just bs) = Put.putLazyByteString bs
g TIMoney8 (Just bs) = Put.putLazyByteString bs
g TIDateTime4 (Just bs) = Put.putLazyByteString bs
g TIDateTime8 (Just bs) = Put.putLazyByteString bs
g TIFlt4 (Just bs) = Put.putLazyByteString bs
g TIFlt8 (Just bs) = Put.putLazyByteString bs
g TIBitN rb = put8n rb
g TIIntN1 rb = put8n rb
g TIIntN2 rb = put8n rb
g TIIntN4 rb = put8n rb
g TIIntN8 rb = put8n rb
g TIMoneyN4 rb = put8n rb
g TIMoneyN8 rb = put8n rb
g TIDateTimeN4 rb = put8n rb
g TIDateTimeN8 rb = put8n rb
g TIFltN4 rb = put8n rb
g TIFltN8 rb = put8n rb
g TIGUID rb = put8n rb
g (TIDecimalN _ _) rb = put8n rb
g (TINumericN _ _) rb = put8n rb
g (TIChar _) rb = put8s rb
g (TIVarChar _) rb = put8s rb
g (TIBigChar _ _) rb = put16s rb
g (TIBigVarChar _ _) rb = put16s rb
g (TIText _ _) rb = put32s rb
g (TINChar _ _) rb = put16s rb
g (TINVarChar _ _) rb = put16s rb
g (TINText _ _) rb = put32s rb
g (TIBinary _) rb = put8s rb
g (TIVarBinary _) rb = put8s rb
g (TIBigBinary _) rb = put16s rb
g (TIBigVarBinary _) rb = put16s rb
g (TIImage _) rb = put32s rb
withValidNull :: TypeInfo -> (TypeInfo -> a) -> a
withValidNull = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@TINull g = g ti
f ti _ = error $ "withValidNull: " <> (show ti) <> " is not convertible from/to Null"
withValidIntegral :: String -> TypeInfo -> (TypeInfo -> a) -> a
withValidIntegral ht = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@TIBit g = g ti
f ti@TIInt1 g = g ti
f ti@TIInt2 g = g ti
f ti@TIInt4 g = g ti
f ti@TIInt8 g = g ti
f ti@TIBitN g = g ti
f ti@TIIntN1 g = g ti
f ti@TIIntN2 g = g ti
f ti@TIIntN4 g = g ti
f ti@TIIntN8 g = g ti
f ti _ = error $ "withValidIntegral: " <> (show ti) <> " is not convertible from/to " <> ht
withValidBool = withValidIntegral "Bool"
withValidInt = withValidIntegral "Int"
withValidInteger = withValidIntegral "Integer"
isIntegralN :: TypeInfo -> Bool
isIntegralN = f
where
f :: TypeInfo -> Bool
f TIBit = False
f TIInt1 = False
f TIInt2 = False
f TIInt4 = False
f TIInt8 = False
f TIBitN = True
f TIIntN1 = True
f TIIntN2 = True
f TIIntN4 = True
f TIIntN8 = True
getIntegral :: Integral a => TypeInfo -> Get a
getIntegral TIBit = fromIntegral <$> Get.getWord8
getIntegral TIInt1 = fromIntegral <$> Get.getInt8
getIntegral TIInt2 = fromIntegral <$> Get.getInt16le
getIntegral TIInt4 = fromIntegral <$> Get.getInt32le
getIntegral TIInt8 = fromIntegral <$> Get.getInt64le
getIntegral TIBitN = getIntegral TIBit
getIntegral TIIntN1 = getIntegral TIInt1
getIntegral TIIntN2 = getIntegral TIInt2
getIntegral TIIntN4 = getIntegral TIInt4
getIntegral TIIntN8 = getIntegral TIInt8
putIntegral :: Integral a => TypeInfo -> a -> Put
putIntegral TIBit i = Put.putWord8 $ fromIntegral i
putIntegral TIInt1 i = Put.putInt8 $ fromIntegral i
putIntegral TIInt2 i = Put.putInt16le $ fromIntegral i
putIntegral TIInt4 i = Put.putInt32le $ fromIntegral i
putIntegral TIInt8 i = Put.putInt64le $ fromIntegral i
putIntegral TIBitN i = putIntegral TIBit i
putIntegral TIIntN1 i = putIntegral TIInt1 i
putIntegral TIIntN2 i = putIntegral TIInt2 i
putIntegral TIIntN4 i = putIntegral TIInt4 i
putIntegral TIIntN8 i = putIntegral TIInt8 i
withValidMoney :: TypeInfo -> (TypeInfo -> a) -> a
withValidMoney = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@TIMoney4 g = g ti
f ti@TIMoney8 g = g ti
f ti@TIMoneyN4 g = g ti
f ti@TIMoneyN8 g = g ti
f ti _ = error $ "withValidMoney: " <> (show ti) <> " is not convertible from/to Money"
isMoneyN :: TypeInfo -> Bool
isMoneyN = f
where
f :: TypeInfo -> Bool
f TIMoney4 = False
f TIMoney8 = False
f TIMoneyN4 = True
f TIMoneyN8 = True
getMoney :: TypeInfo -> Get Money
getMoney TIMoney4 = bytesToMoney4 <$> Get.getInt32le
getMoney TIMoney8 = bytesToMoney8 <$> Get.getInt32le <*> Get.getInt32le
getMoney TIMoneyN4 = getMoney TIMoney4
getMoney TIMoneyN8 = getMoney TIMoney8
putMoney :: TypeInfo -> Money -> Put
putMoney TIMoney4 f = Put.putInt32le $ moneyToBytes4 f
putMoney TIMoney8 f = do
let (m,l) = moneyToBytes8 f
Put.putInt32le m
Put.putInt32le l
putMoney TIMoneyN4 f = putMoney TIMoney4 f
putMoney TIMoneyN8 f = putMoney TIMoney8 f
withValidUTCTime :: TypeInfo -> (TypeInfo -> a) -> a
withValidUTCTime = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@TIDateTime4 g = g ti
f ti@TIDateTime8 g = g ti
f ti@TIDateTimeN4 g = g ti
f ti@TIDateTimeN8 g = g ti
f ti _ = error $ "withValidUTCTime: " <> (show ti) <> " is not convertible from/to UTCTime"
isUTCTimeN :: TypeInfo -> Bool
isUTCTimeN = f
where
f :: TypeInfo -> Bool
f TIDateTime4 = False
f TIDateTime8 = False
f TIDateTimeN4 = True
f TIDateTimeN8 = True
getUTCTime :: TypeInfo -> Get UTCTime
getUTCTime TIDateTime4 = bytesToUtc4 <$> Get.getWord16le <*> Get.getWord16le
getUTCTime TIDateTime8 = bytesToUtc8 <$> Get.getInt32le <*> Get.getWord32le
getUTCTime TIDateTimeN4 = getUTCTime TIDateTime4
getUTCTime TIDateTimeN8 = getUTCTime TIDateTime8
putUTCTime :: TypeInfo -> UTCTime -> Put
putUTCTime TIDateTime4 time = do
let (wday,wmin) = utcToBytes4 time
Put.putWord16le wday
Put.putWord16le wmin
putUTCTime TIDateTime8 time = do
let (iday,w3hsec) = utcToBytes8 time
Put.putInt32le iday
Put.putWord32le w3hsec
putUTCTime TIDateTimeN4 time = putUTCTime TIDateTime4 time
putUTCTime TIDateTimeN8 time = putUTCTime TIDateTime8 time
withValidFloat' :: String -> TypeInfo -> (TypeInfo -> a) -> a
withValidFloat' hn = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@TIFlt4 g = g ti
f ti@TIFlt8 g = g ti
f ti@TIFltN4 g = g ti
f ti@TIFltN8 g = g ti
f ti _ = error $ "withValidFloat': " <> (show ti) <> " is not convertible from/to " <> hn
withValidFloat = withValidFloat' "Float"
withValidDouble = withValidFloat' "Double"
isFloatN :: TypeInfo -> Bool
isFloatN = f
where
f :: TypeInfo -> Bool
f TIFlt4 = False
f TIFlt8 = False
f TIFltN4 = True
f TIFltN8 = True
getFloat :: Fractional a => TypeInfo -> Get a
getFloat TIFlt4 = realToFrac . wordToFloat <$> Get.getWord32le
getFloat TIFlt8 = realToFrac . wordToDouble <$> Get.getWord64le
getFloat TIFltN4 = getFloat TIFlt4
getFloat TIFltN8 = getFloat TIFlt8
putFloat :: Real a => TypeInfo -> a -> Put
putFloat TIFlt4 f = Put.putWord32le $ floatToWord $ realToFrac f
putFloat TIFlt8 f = Put.putWord64le $ doubleToWord $ realToFrac f
putFloat TIFltN4 f = putFloat TIFlt4 f
putFloat TIFltN8 f = putFloat TIFlt8 f
withValidDecimal :: TypeInfo -> (TypeInfo -> a) -> a
withValidDecimal = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@(TIDecimalN _ _) g = g ti
f ti@(TINumericN _ _) g = g ti
f ti _ = error $ "withValidDecimal: " <> (show ti) <> " is not convertible from/to Decimal"
getDecimal :: Int -> Scale -> Get Decimal
getDecimal len s =
bytesToDecimal s <$> Get.getWord8 <*> (Get.getByteString $ fromIntegral $ len -1)
putDecimal :: TypeInfo -> Decimal -> Put
putDecimal (TIDecimalN p _) dec = do
let (s,bs) = decimalToBytes p dec
Put.putWord8 s
Put.putByteString bs
putDecimal (TINumericN p s) dec = putDecimal (TIDecimalN p s) dec
withValidUUID :: TypeInfo -> (TypeInfo -> a) -> a
withValidUUID = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@TIGUID g = g ti
f ti _ = error $ "withValidUUID: " <> (show ti) <> " is not convertible from/to UUID"
withValidByteString :: TypeInfo -> (TypeInfo -> a) -> a
withValidByteString = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@(TIChar _) g = g ti
f ti@(TIVarChar _) g = g ti
f ti@(TIBigChar _ _) g = g ti
f ti@(TIBigVarChar _ _) g = g ti
f ti@(TIText _ _) g = g ti
f ti@(TIBinary _) g = g ti
f ti@(TIVarBinary _) g = g ti
f ti@(TIBigBinary _) g = g ti
f ti@(TIBigVarBinary _) g = g ti
f ti@(TIImage _) g = g ti
f ti _ = error $ "withValidByteString: " <> (show ti) <> " is not convertible from/to ByteString"
withValidText :: TypeInfo -> (TypeInfo -> a) -> a
withValidText = f
where
f :: TypeInfo -> (TypeInfo -> a) -> a
f ti@(TINChar _ _) g = g ti
f ti@(TINVarChar _ _) g = g ti
f ti@(TINText _ _) g = g ti
f ti _ = error $ "withValidText: " <> (show ti) <> " is not convertible from/to Text"
runGet :: Get a -> LB.ByteString -> a
runGet f bs = Get.runGet f bs
runPut :: Put -> LB.ByteString
runPut f = Put.runPut f
runGetBool :: TypeInfo -> LB.ByteString -> Bool
runGetBool ti bs = (/=0) $ runGet (getIntegral ti) bs
runPutBool :: TypeInfo -> Bool -> LB.ByteString
runPutBool ti b = runPut $ putIntegral ti $ if b then 1 else 0
class Data a where
fromRawBytes :: TypeInfo -> RawBytes -> a
toRawBytes :: TypeInfo -> a -> RawBytes
instance Data Null where
fromRawBytes ti rb = withValidNull ti $ \_ -> f rb
where
f Nothing = Null
f _ = error "Null.fromRawBytes: non-Null value is not convertible to Null"
toRawBytes ti _ = withValidNull ti $ \_ -> Nothing
instance Data Bool where
fromRawBytes ti (Just bs) = withValidBool ti $ \vt -> runGetBool vt bs
fromRawBytes ti Nothing = withValidBool ti $ \_ -> error "Bool.fromRawBytes: Null value is not convertible to Bool"
toRawBytes ti b = withValidBool ti $ \vt -> Just $ runPutBool vt b
instance Data Int where
fromRawBytes ti (Just bs) = withValidInt ti $ \vt -> runGet (getIntegral vt) bs
fromRawBytes ti Nothing = withValidInt ti $ \_ -> error "Int.fromRawBytes: Null value is not convertible to Int"
toRawBytes ti i = withValidInt ti $ \vt -> Just $ runPut $ putIntegral vt i
instance Data Integer where
fromRawBytes ti (Just bs) = withValidInteger ti $ \vt -> runGet (getIntegral vt) bs
fromRawBytes ti Nothing = withValidInteger ti $ \_ -> error "Integer.fromRawBytes: Null value is not convertible to Integer"
toRawBytes ti i = withValidInteger ti $ \vt -> Just $ runPut $ putIntegral vt i
instance Data Money where
fromRawBytes ti (Just bs) = withValidMoney ti $ \vt -> runGet (getMoney vt) bs
fromRawBytes ti Nothing = withValidMoney ti $ \_-> error "Money.fromRawBytes: Null value is not convertible to Money"
toRawBytes ti m = withValidMoney ti $ \vt -> Just $ runPut $ putMoney vt m
instance Data UTCTime where
fromRawBytes ti (Just bs) = withValidUTCTime ti $ \vt -> runGet (getUTCTime vt) bs
fromRawBytes ti Nothing = withValidUTCTime ti $ \vt -> error "UTCTime.fromRawBytes: Null value is not convertible to UTCTime"
toRawBytes ti dt = withValidUTCTime ti $ \vt -> Just $ runPut $ putUTCTime vt dt
instance Data Float where
fromRawBytes ti (Just bs) = withValidFloat ti $ \vt -> runGet (getFloat ti) bs
fromRawBytes ti Nothing = withValidFloat ti $ \_ -> error "Float.fromRawBytes: Null value is not convertible to Float"
toRawBytes ti f = withValidFloat ti $ \vt -> Just $ runPut $ putFloat vt f
instance Data Double where
fromRawBytes ti (Just bs) = withValidDouble ti $ \vt -> runGet (getFloat ti) bs
fromRawBytes ti Nothing = withValidDouble ti $ \_ -> error "Double.fromRawBytes: Null value is not convertible to Double"
toRawBytes ti f = withValidDouble ti $ \vt -> Just $ runPut $ putFloat vt f
instance Data Decimal where
fromRawBytes ti (Just bs) = withValidDecimal ti $ \vt ->
runGet (getDecimal (fromIntegral $ LB.length bs) (scale vt)) bs
where
scale :: TypeInfo -> Scale
scale (TIDecimalN _ s) = s
scale (TINumericN _ s) = s
fromRawBytes ti Nothing = withValidDecimal ti $ \_ -> error "Decimal.fromRawBytes: Null value is not convertible to Decimal"
toRawBytes ti dec = withValidDecimal ti $ \_ -> Just $ runPut $ putDecimal ti dec
instance Data UUID where
fromRawBytes ti (Just bs) = withValidUUID ti $ \_ -> case UUID.fromByteString bs of
Nothing -> error "UUID.fromRawBytes: UUID.fromBtyteString error"
Just (uuid) -> uuid
fromRawBytes ti Nothing = withValidUUID ti $ \_ -> error "UUID.fromRawBytes: Null value is not convertible to UUID"
toRawBytes ti uuid = withValidUUID ti $ \_ -> Just $ UUID.toByteString uuid
instance Data B.ByteString where
fromRawBytes ti (Just bs) = withValidByteString ti $ \_ -> LB.toStrict bs
fromRawBytes ti Nothing = withValidByteString ti $ \_ -> error "ByteString.fromRawBytes: Null value is not convertible to ByteString"
toRawBytes ti bs = withValidByteString ti $ \_ -> Just $ LB.fromStrict bs
instance Data T.Text where
fromRawBytes ti (Just bs) = withValidText ti $ \_ -> T.decodeUtf16LE $ LB.toStrict bs
fromRawBytes ti Nothing = withValidText ti $ \_ -> error "Text.fromRawBytes: Null value is not convertible to Text"
toRawBytes ti t = withValidText ti $ \_ -> Just $ LB.fromStrict $ T.encodeUtf16LE t
instance Data LB.ByteString where
fromRawBytes ti (Just bs) = withValidByteString ti $ \_ -> bs
fromRawBytes ti Nothing = withValidByteString ti $ \_ -> error "ByteString.fromRawBytes: Null value is not convertible to ByteString"
toRawBytes ti bs = withValidByteString ti $ \_ -> Just bs
instance Data LT.Text where
fromRawBytes ti (Just bs) = withValidText ti $ \_ -> LT.decodeUtf16LE bs
fromRawBytes ti Nothing = withValidText ti $ \_ -> error "Text.fromRawBytes: Null value is not convertible to Text"
toRawBytes ti t = withValidText ti $ \_ -> Just $ LT.encodeUtf16LE t
instance Data (Maybe Bool) where
fromRawBytes ti rb = withValidBool ti $ \vt -> runGetBool vt <$> rb
toRawBytes ti b = withValidBool ti $ \vt ->
case b of
Nothing | (not . isIntegralN) vt -> error $ "(Maybe Bool).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPutBool vt <$> b
instance Data (Maybe Int) where
fromRawBytes ti rb = withValidInt ti $ \vt -> (runGet (getIntegral vt)) <$> rb
toRawBytes ti i = withValidInt ti $ \vt ->
case i of
Nothing | (not . isIntegralN) vt -> error $ "(Maybe Int).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPut . (putIntegral vt) <$> i
instance Data (Maybe Integer) where
fromRawBytes ti rb = withValidInteger ti $ \vt -> (runGet (getIntegral vt)) <$> rb
toRawBytes ti i = withValidInteger ti $ \vt->
case i of
Nothing | (not . isIntegralN) vt -> error $ "(Maybe Integer).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPut . (putIntegral vt) <$> i
instance Data (Maybe Money) where
fromRawBytes ti rb = withValidMoney ti $ \vt -> (runGet (getMoney vt)) <$> rb
toRawBytes ti m = withValidMoney ti $ \vt ->
case m of
Nothing | (not . isMoneyN) vt -> error $ "(Maybe Money).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPut . (putMoney vt) <$> m
instance Data (Maybe UTCTime) where
fromRawBytes ti rb = withValidUTCTime ti $ \vt -> (runGet (getUTCTime vt)) <$> rb
toRawBytes ti dt = withValidUTCTime ti $ \vt ->
case dt of
Nothing | (not . isUTCTimeN) vt -> error $ "(Maybe UTCTime).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPut . (putUTCTime vt) <$> dt
instance Data (Maybe Float) where
fromRawBytes ti rb = withValidFloat ti $ \vt -> (runGet (getFloat vt)) <$> rb
toRawBytes ti f = withValidFloat ti $ \vt ->
case f of
Nothing | (not . isFloatN) vt -> error $ "(Maybe Float).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPut . (putFloat vt) <$> f
instance Data (Maybe Double) where
fromRawBytes ti rb = withValidDouble ti $ \vt -> (runGet (getFloat vt)) <$> rb
toRawBytes ti f = withValidDouble ti $ \vt ->
case f of
Nothing | (not . isFloatN) vt -> error $ "(Maybe Double).toRawBytes: Nothing is not convertible to " <> (show vt)
_ -> runPut . (putFloat vt) <$> f
instance Data (Maybe Decimal) where
fromRawBytes ti rb = withValidDecimal ti $ \vt ->
(\bs -> runGet (getDecimal (fromIntegral $ LB.length bs) (scale vt)) bs) <$> rb
where
scale :: TypeInfo -> Scale
scale (TIDecimalN _ s) = s
scale (TINumericN _ s) = s
toRawBytes ti dec = withValidDecimal ti $ \_ -> runPut . putDecimal ti <$> dec
instance Data (Maybe UUID) where
fromRawBytes ti rb = withValidUUID ti $ \_ -> f <$> rb
where
f :: LB.ByteString -> UUID
f bs = case UUID.fromByteString bs of
Nothing -> error "(Maybe UUID).fromRawBytes: UUID.fromBtyteString error"
Just (uuid) -> uuid
toRawBytes ti m = withValidUUID ti $ \_ -> UUID.toByteString <$> m
instance Data (Maybe B.ByteString) where
fromRawBytes ti rb = withValidByteString ti $ \_ -> LB.toStrict <$> rb
toRawBytes ti bs = withValidByteString ti $ \_ -> LB.fromStrict <$> bs
instance Data (Maybe T.Text) where
fromRawBytes ti rb = withValidText ti $ \_ -> T.decodeUtf16LE . LB.toStrict <$> rb
toRawBytes ti t = withValidText ti $ \_ -> LB.fromStrict . T.encodeUtf16LE <$> t
instance Data (Maybe LB.ByteString) where
fromRawBytes ti rb = withValidByteString ti $ \_ -> rb
toRawBytes ti bs = withValidByteString ti $ \_ -> bs
instance Data (Maybe LT.Text) where
fromRawBytes ti rb = withValidText ti $ \_ -> LT.decodeUtf16LE <$> rb
toRawBytes ti t = withValidText ti $ \_ -> LT.encodeUtf16LE <$> t