ms-tds 0.1.0.0 → 0.1.0.1
raw patch · 5 files changed
+202/−180 lines, 5 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Database.Tds.Message: Login7 :: !Word32 -> !Word32 -> !Word32 -> !Word32 -> !Word8 -> !Word8 -> !Word8 -> !Word8 -> !Word32 -> !Collation32 -> !Text -> !Text -> !Word32 -> !ByteString -> !Text -> !Text -> !Text -> !Text -> !Text -> !Text -> Login7
+ Database.Tds.Message: Login7 :: !Word32 -> !Word32 -> !Word32 -> !Word32 -> !Word8 -> !Word8 -> !Word8 -> !Word8 -> !Int32 -> !Collation32 -> !Text -> !Text -> !Word32 -> !ByteString -> !Text -> !Text -> !Text -> !Text -> !Text -> !Text -> Login7
- Database.Tds.Message: TSTabName :: TokenStream
+ Database.Tds.Message: TSTabName :: ![[Text]] -> TokenStream
- Database.Tds.Message: [l7TimeZone] :: Login7 -> !Word32
+ Database.Tds.Message: [l7TimeZone] :: Login7 -> !Int32
Files
- README.md +1/−1
- ms-tds.cabal +4/−2
- src/Database/Tds/Message/Client.hs +6/−4
- src/Database/Tds/Message/DataStream.hs +155/−160
- src/Database/Tds/Message/Server.hs +36/−13
README.md view
@@ -31,7 +31,7 @@ * 7.1 Revision 1 (SQL Server 2000 SP1 and later) -* Tested with SQL Server 2008 R2+* Tested with SQL Server 2008 R2, SQL Server 2014
ms-tds.cabal view
@@ -4,11 +4,13 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0882fb2272f167b6bbf45e2945afdaa18166e53c206f1b97c6ecea2801c611d6+-- hash: 153790241105911a205f4c88096f32d522fbb3262222de0f525f2f958a5dad79 name: ms-tds-version: 0.1.0.0+version: 0.1.0.1+synopsis: TDS Protocol implemented in Haskell description: Please see the README on GitHub at <https://github.com/mitsuji/ms-tds#readme>+category: Database homepage: https://github.com/mitsuji/ms-tds#readme bug-reports: https://github.com/mitsuji/ms-tds/issues author: Takamasa Mitsuji
src/Database/Tds/Message/Client.hs view
@@ -57,7 +57,7 @@ , l7OptionFlags2 :: !Word8 , l7OptionFlags3 :: !Word8 , l7TypeFlags :: !Word8- , l7TimeZone :: !Word32+ , l7TimeZone :: !Int32 , l7Collation :: !Collation32 , l7CltIntName :: !T.Text , l7Language :: !T.Text@@ -81,9 +81,11 @@ , l7OptionFlags2 = 0 , l7OptionFlags3 = 0 , l7TypeFlags = 0- , l7TimeZone = -120+-- , l7TimeZone = -120+ , l7TimeZone = 0 -- , l7Collation = 0x36040000- , l7Collation = 0x1104d000+-- , l7Collation = 0x1104d000+ , l7Collation = 0x00000000 , l7CltIntName = T.pack "DB-Library" -- "OLEDB", "ODBC" , l7Language = mempty -- , l7Language = T.pack "us_english"@@ -202,7 +204,7 @@ -- Put.putWord8 $ 0x02 + 0x01 -- flag2 Put.putWord8 $ l7TypeFlags x -- sql type Put.putWord8 $ l7OptionFlags3 x -- flag3- Put.putWord32le $ l7TimeZone x -- tz+ Put.putInt32le $ l7TimeZone x -- tz Put.putWord32be $ l7Collation x -- collation -- Put.putWord32be $ 0x09040000 -- collation
src/Database/Tds/Message/DataStream.hs view
@@ -485,37 +485,34 @@ -validNull :: TypeInfo -> a -> a-validNull = f+withValidNull :: TypeInfo -> (TypeInfo -> a) -> a+withValidNull = f where- f :: TypeInfo -> a -> a- f TINull x = x- f ti _ = error $ "validNull: " <> (show ti) <> " is not convertible from/to Null"+ f :: TypeInfo -> (TypeInfo -> a) -> a+ f ti@TINull g = g ti+ f ti _ = error $ "withValidNull: " <> (show ti) <> " is not convertible from/to Null" -validIntegral :: String -> TypeInfo -> a -> a-validIntegral ht ti x = f ti x+withValidIntegral :: String -> TypeInfo -> (TypeInfo -> a) -> a+withValidIntegral ht = f where- f :: TypeInfo -> a -> a- f TIBit x = x- f TIInt1 x = x- f TIInt2 x = x- f TIInt4 x = x- f TIInt8 x = x- f TIBitN x = x- f TIIntN1 x = x- f TIIntN2 x = x - f TIIntN4 x = x- f TIIntN8 x = x- f _ _ = error $ "validIntegral: " <> (show ti) <> " is not convertible from/to " <> ht+ 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 -validBool = validIntegral "Bool"-validInt = validIntegral "Int"-validInteger = validIntegral "Integer"-validMaybeBool = validIntegral "(Maybe Bool)"-validMaybeInt = validIntegral "(Maybe Int)"-validMaybeInteger = validIntegral "(Maybe Integer)"+withValidBool = withValidIntegral "Bool"+withValidInt = withValidIntegral "Int"+withValidInteger = withValidIntegral "Integer" isIntegralN :: TypeInfo -> Bool isIntegralN = f@@ -561,15 +558,15 @@ -validMoney :: TypeInfo -> a -> a-validMoney = f+withValidMoney :: TypeInfo -> (TypeInfo -> a) -> a+withValidMoney = f where- f :: TypeInfo -> a -> a- f TIMoney4 x = x- f TIMoney8 x = x- f TIMoneyN4 x = x- f TIMoneyN8 x = x- f ti _ = error $ "validMoney: " <> (show ti) <> " is not convertible from/to Money"+ 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@@ -598,15 +595,15 @@ -validUTCTime :: TypeInfo -> a -> a-validUTCTime = f+withValidUTCTime :: TypeInfo -> (TypeInfo -> a) -> a+withValidUTCTime = f where- f :: TypeInfo -> a -> a- f TIDateTime4 x = x- f TIDateTime8 x = x- f TIDateTimeN4 x = x- f TIDateTimeN8 x = x- f ti _ = error $ "validUTCTime: " <> (show ti) <> " is not convertible from/to UTCTime"+ 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@@ -638,20 +635,18 @@ -validFloat' :: String -> TypeInfo -> a -> a-validFloat' hn ti x = f ti x+withValidFloat' :: String -> TypeInfo -> (TypeInfo -> a) -> a+withValidFloat' hn = f where- f :: TypeInfo -> a -> a- f TIFlt4 x = x- f TIFlt8 x = x- f TIFltN4 x = x- f TIFltN8 x = x- f ti _ = error $ "validFloat': " <> (show ti) <> " is not convertible from/to " <> hn+ 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 -validFloat = validFloat' "Float"-validDouble = validFloat' "Double"-validMaybeFloat = validFloat' "(Maybe Float)"-validMaybeDouble = validFloat' "(Maybe Double)"+withValidFloat = withValidFloat' "Float"+withValidDouble = withValidFloat' "Double" isFloatN :: TypeInfo -> Bool isFloatN = f@@ -677,13 +672,13 @@ -validDecimal :: TypeInfo -> a -> a-validDecimal = f+withValidDecimal :: TypeInfo -> (TypeInfo -> a) -> a+withValidDecimal = f where- f :: TypeInfo -> a -> a- f (TIDecimalN _ _) x = x- f (TINumericN _ _) x = x- f ti _ = error $ "validDecimal: " <> (show ti) <> " is not convertible from/to Decimal"+ 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" -- https://msdn.microsoft.com/en-us/library/ee780893.aspx -- [MEMO] sign byte + signed bytes@@ -700,43 +695,43 @@ -validUUID :: TypeInfo -> a -> a-validUUID = f+withValidUUID :: TypeInfo -> (TypeInfo -> a) -> a+withValidUUID = f where- f :: TypeInfo -> a -> a- f TIGUID x = x- f ti _ = error $ "validUUID: " <> (show ti) <> " is not convertible from/to UUID"+ f :: TypeInfo -> (TypeInfo -> a) -> a+ f ti@TIGUID g = g ti+ f ti _ = error $ "withValidUUID: " <> (show ti) <> " is not convertible from/to UUID" -validByteString :: TypeInfo -> a -> a-validByteString = f+withValidByteString :: TypeInfo -> (TypeInfo -> a) -> a+withValidByteString = f where- f :: TypeInfo -> a -> a- f (TIChar _) x = x- f (TIVarChar _) x = x- f (TIBigChar _ _) x = x- f (TIBigVarChar _ _) x = x- f (TIText _ _) x = x- f (TIBinary _) x = x- f (TIVarBinary _) x = x- f (TIBigBinary _) x = x- f (TIBigVarBinary _) x = x- f (TIImage _) x = x- f ti _ = error $ "validByteString: " <> (show ti) <> " is not convertible from/to ByteString"+ 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" -validText :: TypeInfo -> a -> a-validText = f+withValidText :: TypeInfo -> (TypeInfo -> a) -> a+withValidText = f where- f :: TypeInfo -> a -> a- f (TINChar _ _) x = x- f (TINVarChar _ _) x = x- f (TINText _ _) x= x- f ti _ = error $ "validText: " <> (show ti) <> " is not convertible from/to Text"+ 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" @@ -764,151 +759,151 @@ instance Data Null where- fromRawBytes ti rb = validNull ti $ f rb+ 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 _ = validNull ti $ Nothing+ toRawBytes ti _ = withValidNull ti $ \_ -> Nothing instance Data Bool where- fromRawBytes ti (Just bs) = validBool ti $ runGetBool ti bs- fromRawBytes ti Nothing = validBool ti $ error "Bool.fromRawBytes: Null value is not convertible to Bool"- toRawBytes ti b = validBool ti $ Just $ runPutBool ti b+ 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) = validInt ti $ runGet (getIntegral ti) bs- fromRawBytes ti Nothing = validInt ti $ error "Int.fromRawBytes: Null value is not convertible to Int"- toRawBytes ti i = validInt ti $ Just $ runPut $ putIntegral ti i+ 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) = validInteger ti $ runGet (getIntegral ti) bs- fromRawBytes ti Nothing = validInteger ti $ error "Integer.fromRawBytes: Null value is not convertible to Integer"- toRawBytes ti i = validInteger ti $ Just $ runPut $ putIntegral ti i+ 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) = validMoney ti $ runGet (getMoney ti) bs- fromRawBytes ti Nothing = validMoney ti $ error "Money.fromRawBytes: Null value is not convertible to Money"- toRawBytes ti m = validMoney ti $ Just $ runPut $ putMoney ti m+ 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) = validUTCTime ti $ runGet (getUTCTime ti) bs- fromRawBytes ti Nothing = validUTCTime ti $ error "UTCTime.fromRawBytes: Null value is not convertible to UTCTime"- toRawBytes ti dt = validUTCTime ti $ Just $ runPut $ putUTCTime ti dt+ 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) = validFloat ti $ runGet (getFloat ti) bs- fromRawBytes ti Nothing = validFloat ti $ error "Float.fromRawBytes: Null value is not convertible to Float"- toRawBytes ti f = validFloat ti $ Just $ runPut $ putFloat ti f+ 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) = validDouble ti $ runGet (getFloat ti) bs- fromRawBytes ti Nothing = validDouble ti $ error "Double.fromRawBytes: Null value is not convertible to Double"- toRawBytes ti f = validDouble ti $ Just $ runPut $ putFloat ti f+ 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) = validDecimal ti $- let (p,s) = ps ti+ fromRawBytes ti (Just bs) = withValidDecimal ti $ \vt ->+ let (p,s) = ps vt in runGet (getDecimal (B.length bs) p s) bs where ps :: TypeInfo -> (Precision,Scale) ps (TIDecimalN p s) = (p,s) ps (TINumericN p s) = (p,s)- fromRawBytes ti Nothing = validDecimal ti $ error "Decimal.fromRawBytes: Null value is not convertible to Decimal"- toRawBytes ti dec = validDecimal ti $ Just $ runPut $ putDecimal dec+ fromRawBytes ti Nothing = withValidDecimal ti $ \_ -> error "Decimal.fromRawBytes: Null value is not convertible to Decimal"+ toRawBytes ti dec = withValidDecimal ti $ \_ -> Just $ runPut $ putDecimal dec instance Data UUID where- fromRawBytes ti (Just bs) = validUUID ti $ case UUID.fromByteString $ LB.fromStrict bs of- Nothing -> error "UUID.fromRawBytes: UUID.fromBtyteString error"- Just (uuid) -> uuid- fromRawBytes ti Nothing = validUUID ti $ error "UUID.fromRawBytes: Null value is not convertible to UUID"- toRawBytes ti uuid = validUUID ti $ Just $ LB.toStrict $ UUID.toByteString uuid+ fromRawBytes ti (Just bs) = withValidUUID ti $ \_ -> case UUID.fromByteString $ LB.fromStrict 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 $ LB.toStrict $ UUID.toByteString uuid instance Data B.ByteString where- fromRawBytes ti (Just bs) = validByteString ti $ bs- fromRawBytes ti Nothing = validByteString ti $ error "ByteString.fromRawBytes: Null value is not convertible to ByteString"- toRawBytes ti bs = validByteString ti $ Just $ bs+ 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 T.Text where- fromRawBytes ti (Just bs) = validText ti $ T.decodeUtf16LE bs- fromRawBytes ti Nothing = validText ti $ error "Text.fromRawBytes: Null value is not convertible to Text"- toRawBytes ti t = validText ti $ Just $ T.encodeUtf16LE t+ fromRawBytes ti (Just bs) = withValidText ti $ \_ -> T.decodeUtf16LE bs+ fromRawBytes ti Nothing = withValidText ti $ \_ -> error "Text.fromRawBytes: Null value is not convertible to Text"+ toRawBytes ti t = withValidText ti $ \_ -> Just $ T.encodeUtf16LE t instance Data (Maybe Bool) where- fromRawBytes ti rb = validMaybeBool ti $ runGetBool ti <$> rb- toRawBytes ti b = validMaybeBool ti $+ fromRawBytes ti rb = withValidBool ti $ \vt -> runGetBool vt <$> rb+ toRawBytes ti b = withValidBool ti $ \vt -> case b of- Nothing | (not . isIntegralN) ti -> error $ "(Maybe Bool).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPutBool ti <$> b+ 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 = validMaybeInt ti $ (runGet (getIntegral ti)) <$> rb- toRawBytes ti i = validMaybeInt ti $+ fromRawBytes ti rb = withValidInt ti $ \vt -> (runGet (getIntegral vt)) <$> rb+ toRawBytes ti i = withValidInt ti $ \vt -> case i of- Nothing | (not . isIntegralN) ti -> error $ "(Maybe Int).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPut . (putIntegral ti) <$> i+ 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 = validMaybeInteger ti $ (runGet (getIntegral ti)) <$> rb- toRawBytes ti i = validMaybeInteger ti $+ fromRawBytes ti rb = withValidInteger ti $ \vt -> (runGet (getIntegral vt)) <$> rb+ toRawBytes ti i = withValidInteger ti $ \vt-> case i of- Nothing | (not . isIntegralN) ti -> error $ "(Maybe Integer).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPut . (putIntegral ti) <$> i+ 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 = validMoney ti $ (runGet (getMoney ti)) <$> rb- toRawBytes ti m = validMoney ti $+ fromRawBytes ti rb = withValidMoney ti $ \vt -> (runGet (getMoney vt)) <$> rb+ toRawBytes ti m = withValidMoney ti $ \vt -> case m of- Nothing | (not . isMoneyN) ti -> error $ "(Maybe Money).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPut . (putMoney ti) <$> m+ 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 = validUTCTime ti $ (runGet (getUTCTime ti)) <$> rb- toRawBytes ti dt = validUTCTime ti $+ fromRawBytes ti rb = withValidUTCTime ti $ \vt -> (runGet (getUTCTime vt)) <$> rb+ toRawBytes ti dt = withValidUTCTime ti $ \vt -> case dt of- Nothing | (not . isUTCTimeN) ti -> error $ "(Maybe UTCTime).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPut . (putUTCTime ti) <$> dt+ 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 = validMaybeFloat ti $ (runGet (getFloat ti)) <$> rb- toRawBytes ti f = validMaybeFloat ti $+ fromRawBytes ti rb = withValidFloat ti $ \vt -> (runGet (getFloat vt)) <$> rb+ toRawBytes ti f = withValidFloat ti $ \vt -> case f of- Nothing | (not . isFloatN) ti -> error $ "(Maybe Float).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPut . (putFloat ti) <$> f+ 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 = validMaybeDouble ti $ (runGet (getFloat ti)) <$> rb- toRawBytes ti f = validMaybeDouble ti $+ fromRawBytes ti rb = withValidDouble ti $ \vt -> (runGet (getFloat vt)) <$> rb+ toRawBytes ti f = withValidDouble ti $ \vt -> case f of- Nothing | (not . isFloatN) ti -> error $ "(Maybe Double).toRawBytes: Nothing is not convertible to " <> (show ti)- _ -> runPut . (putFloat ti) <$> f+ 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 = validDecimal ti $- let (p,s) = ps ti+ fromRawBytes ti rb = withValidDecimal ti $ \vt ->+ let (p,s) = ps vt in (\bs -> runGet (getDecimal (B.length bs) p s) bs) <$> rb where ps :: TypeInfo -> (Precision,Scale) ps (TIDecimalN p s) = (p,s) ps (TINumericN p s) = (p,s)- toRawBytes ti dec = validDecimal ti $ runPut . putDecimal <$> dec+ toRawBytes ti dec = withValidDecimal ti $ \_ -> runPut . putDecimal <$> dec instance Data (Maybe UUID) where- fromRawBytes ti rb = validUUID ti $ f <$> rb+ fromRawBytes ti rb = withValidUUID ti $ \_ -> f <$> rb where f :: B.ByteString -> UUID f bs = case UUID.fromByteString $ LB.fromStrict bs of Nothing -> error "(Maybe UUID).fromRawBytes: UUID.fromBtyteString error" Just (uuid) -> uuid- toRawBytes ti m = validUUID ti $ (LB.toStrict . UUID.toByteString) <$> m+ toRawBytes ti m = withValidUUID ti $ \_ -> (LB.toStrict . UUID.toByteString) <$> m instance Data (Maybe B.ByteString) where- fromRawBytes ti rb = validByteString ti $ rb- toRawBytes ti bs = validByteString ti $ bs+ fromRawBytes ti rb = withValidByteString ti $ \_ -> rb+ toRawBytes ti bs = withValidByteString ti $ \_ -> bs instance Data (Maybe T.Text) where- fromRawBytes ti rb = validText ti $ T.decodeUtf16LE <$> rb - toRawBytes ti t = validText ti $ T.encodeUtf16LE <$> t+ fromRawBytes ti rb = withValidText ti $ \_ -> T.decodeUtf16LE <$> rb + toRawBytes ti t = withValidText ti $ \_ -> T.encodeUtf16LE <$> t
src/Database/Tds/Message/Server.hs view
@@ -123,7 +123,7 @@ deriving (Show) -data MetaData = MetaData !(Maybe ColMetaData) !(Maybe AltMetaData) !(Maybe Offset)+data MetaData = MetaData !(Maybe ColMetaData) !(Maybe AltMetaData) deriving (Show) @@ -204,7 +204,7 @@ | TSSSPI !B.ByteString - | TSTabName + | TSTabName ![[T.Text]] | TSOther !Word8 @@ -226,7 +226,7 @@ 0xaa -> lift getError 0xab -> lift getInfo 0xad -> lift getLoginAck- 0x78 -> getOffsetS+ 0x78 -> lift getOffset 0xa9 -> lift getOrder 0x79 -> lift getReturnStatus 0xac -> lift getReturnValue@@ -242,7 +242,7 @@ getAltRow :: Get TokenStream -- [TODO] implementation, SQL statement that generates totals getAltRow = return TSAltRow - getColInfo :: Get TokenStream -- [TODO] test, sp_cursoropen, and sp_cursorfetch+ getColInfo :: Get TokenStream getColInfo = do len <- fromIntegral <$> Get.getWord16le bs <- Get.getLazyByteString len@@ -277,7 +277,7 @@ if cols == 0xffff then return $ TSColMetaData Nothing else do cmd <- lift $ Just . ColMetaData <$> getColumnDatas (fromIntegral cols) 0- modify $ \(MetaData _ mamd mofs) -> (MetaData cmd mamd mofs)+ modify $ \(MetaData _ mamd) -> (MetaData cmd mamd) return $ TSColMetaData cmd where getColumnDatas :: Int -> Int -> Get [MetaColumnData]@@ -397,10 +397,9 @@ return $ TSLoginAck interface tdsVer server servVer - getOffsetS :: StateT MetaData Get TokenStream -- [TODO] test- getOffsetS = do- ofs <- lift $ Offset <$> Get.getWord16le <*> Get.getWord16le- modify $ \(MetaData mcmd mamd _) -> (MetaData mcmd mamd (Just ofs))+ getOffset :: Get TokenStream -- [TODO] test+ getOffset = do+ ofs <- Offset <$> Get.getWord16le <*> Get.getWord16le return $ TSOffset ofs getOrder :: Get TokenStream@@ -429,7 +428,7 @@ getRowS :: StateT MetaData Get TokenStream getRowS = do -- [TODO] error check- Just (ColMetaData colDatas) <- (\(MetaData mcmd mamd mofs) -> mcmd) <$> Control.Monad.State.get+ Just (ColMetaData colDatas) <- (\(MetaData mcmd mamd) -> mcmd) <$> Control.Monad.State.get datas <- lift $ mapM (getColumnData . (\(MetaColumnData _ _ ti _ _) -> ti)) colDatas return $ TSRow datas where@@ -464,9 +463,33 @@ bs <- getByteString len return $ TSSSPI bs - getTabName :: Get TokenStream -- [TODO] test, sp_cursoropen- getTabName = return $ TSTabName+ getTabName :: Get TokenStream+ getTabName = do+ len <- fromIntegral <$> Get.getWord16le+ bs <- Get.getLazyByteString len+ return $ TSTabName $ Get.runGet (getAllTableNames len) bs+ where+ getAllTableNames :: Int64 -> Get [[T.Text]]+ getAllTableNames len = f+ where+ f :: Get [[T.Text]]+ f = do+ br <- Get.bytesRead+ if br >= len+ then return []+ else do x <- getTableName+ xs <-f+ return $ x:xs + getTableName :: Get [T.Text]+ getTableName = do+ numParts <- fromIntegral <$> Get.getWord8+ names <- mapM (\_ -> getText16 ) [1..numParts]+ return names+ + + + getOther :: Word8 -> Get TokenStream@@ -531,7 +554,7 @@ getTokenStreams :: Get TokenStreams getTokenStreams = do- rs <- (evalStateT getTokenStreamsS) (MetaData Nothing Nothing Nothing)+ rs <- (evalStateT getTokenStreamsS) (MetaData Nothing Nothing) return $ TokenStreams rs