ms-tds 0.4.0.0 → 0.4.0.1
raw patch · 3 files changed
+52/−39 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ms-tds.cabal +21/−21
- src/Database/Tds/Message.hs +1/−1
- src/Database/Tds/Message/DataStream.hs +30/−17
ms-tds.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 39ad5bcc1d6b5813f6dc3250a9265ff3720a2d22df6fea325640a0185540a0ab+-- hash: 6b929ccf4f7917678f4bf7ee98be72ed9fd5eb5505a7379bb35387ddc1004d42 name: ms-tds-version: 0.4.0.0+version: 0.4.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@@ -28,23 +28,6 @@ location: https://github.com/mitsuji/ms-tds library- exposed-modules:- Database.Tds.Message- Database.Tds.Message.Client- Database.Tds.Message.DataStream- Database.Tds.Message.Header- Database.Tds.Message.Prelogin- Database.Tds.Message.Server- Database.Tds.Primitives.Collation- Database.Tds.Primitives.DateTime- Database.Tds.Primitives.Decimal- Database.Tds.Primitives.Fixed- Database.Tds.Primitives.Float- Database.Tds.Primitives.Money- Database.Tds.Primitives.Null- Database.Tds.Transport- other-modules:- Paths_ms_tds hs-source-dirs: src build-depends:@@ -63,13 +46,28 @@ , uuid-types , x509-store , x509-system+ exposed-modules:+ Database.Tds.Message+ Database.Tds.Message.Client+ Database.Tds.Message.DataStream+ Database.Tds.Message.Header+ Database.Tds.Message.Prelogin+ Database.Tds.Message.Server+ Database.Tds.Primitives.Collation+ Database.Tds.Primitives.DateTime+ Database.Tds.Primitives.Decimal+ Database.Tds.Primitives.Fixed+ Database.Tds.Primitives.Float+ Database.Tds.Primitives.Money+ Database.Tds.Primitives.Null+ Database.Tds.Transport+ other-modules:+ Paths_ms_tds default-language: Haskell2010 test-suite tds-test type: exitcode-stdio-1.0 main-is: Spec.hs- other-modules:- Paths_ms_tds hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -90,4 +88,6 @@ , uuid-types , x509-store , x509-system+ other-modules:+ Paths_ms_tds default-language: Haskell2010
src/Database/Tds/Message.hs view
@@ -255,6 +255,6 @@ (pt,bs) <- getMessage case pt of 0x04 -> return $ decode bs- _ -> fail "getServerMessageInstance: invalid packet type"+ _ -> fail "getServerMessage: invalid packet type"
src/Database/Tds/Message/DataStream.hs view
@@ -43,6 +43,7 @@ import Database.Tds.Primitives.Decimal import Database.Tds.Primitives.Collation +import Data.Maybe (fromJust) @@ -706,9 +707,21 @@ f ti@TIGUID g = g ti f ti _ = error $ "withValidUUID: " <> (show ti) <> " is not convertible from/to UUID" +getUUID :: TypeInfo -> Get (Maybe UUID)+getUUID _ = do+ (d1,d2,d3,d4) <- (,,,) <$> Get.getWord32le <*> Get.getWord16le <*> Get.getWord16le <*> Get.getByteString 8+ return $ UUID.fromByteString $+ runPut $ Put.putWord32be d1 >> Put.putWord16be d2 >> Put.putWord16be d3 >> Put.putByteString d4 +putUUID :: TypeInfo -> UUID -> Put+putUUID _ x = do+ let bs = UUID.toByteString x+ let (d1,d2,d3,d4) = flip runGet bs $ (,,,) <$> Get.getWord32be <*> Get.getWord16be <*> Get.getWord16be <*> Get.getByteString 8+ Put.putWord32le d1 >> Put.putWord16le d2 >> Put.putWord16le d3 >> Put.putByteString d4 ++ withValidByteString :: TypeInfo -> (TypeInfo -> a) -> a withValidByteString = f where@@ -794,32 +807,32 @@ 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"+ fromRawBytes ti Nothing = withValidUTCTime ti $ \_ -> 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 (Just bs) = withValidFloat ti $ \vt -> runGet (getFloat vt) 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 (Just bs) = withValidDouble ti $ \vt -> runGet (getFloat vt) 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 (HasResolution a) => Data (Fixed a) where- fromRawBytes ti (Just bs) = withValidFixed ti $ \vt ->+ fromRawBytes ti (Just bs) = withValidFixed ti $ \_ -> runGet (getFixed (fromIntegral $ LB.length bs)) bs fromRawBytes ti Nothing = withValidFixed ti $ \_ -> error "Fixed.fromRawBytes: Null value is not convertible to Fixed"- toRawBytes ti f = withValidFixed ti $ \_ -> Just $ runPut $ putFixed ti f+ toRawBytes ti f = withValidFixed ti $ \vt -> Just $ runPut $ putFixed vt f 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 (Just bs) = withValidUUID ti $ \vt -> case runGet (getUUID vt) 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+ toRawBytes ti uuid = withValidUUID ti $ \vt -> Just $ runPut $ putUUID vt uuid instance Data B.ByteString where fromRawBytes ti (Just bs) = withValidByteString ti $ \_ -> LB.toStrict bs@@ -899,18 +912,18 @@ instance (HasResolution a) => Data (Maybe (Fixed a)) where- fromRawBytes ti rb = withValidFixed ti $ \vt ->+ fromRawBytes ti rb = withValidFixed ti $ \_ -> (\bs -> runGet (getFixed (fromIntegral $ LB.length bs)) bs) <$> rb- toRawBytes ti f = withValidFixed ti $ \_ -> runPut . putFixed ti <$> f+ toRawBytes ti f = withValidFixed ti $ \vt -> runPut . putFixed vt <$> f instance Data (Maybe UUID) where- fromRawBytes ti rb = withValidUUID ti $ \_ -> f <$> rb+ fromRawBytes ti rb = withValidUUID ti $ \vt -> f vt <$> 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+ f :: TypeInfo -> LB.ByteString -> UUID+ f vt bs = case (runGet (getUUID vt)) bs of+ Nothing -> error "(Maybe UUID).fromRawBytes: UUID.fromBtyteString error"+ Just (uuid) -> uuid+ toRawBytes ti m = withValidUUID ti $ \vt -> runPut . putUUID vt <$> m instance Data (Maybe B.ByteString) where fromRawBytes ti rb = withValidByteString ti $ \_ -> LB.toStrict <$> rb