ms-tds 0.1.0.2 → 0.1.0.3

raw patch · 9 files changed

+175/−296 lines, 9 filesdep +crypto-randomdep +template-haskelldep ~binaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: crypto-random, template-haskell

Dependency ranges changed: binary

API changes (from Hackage documentation)

Files

• ms-tds.cabal +8/−4
• src/Database/Tds/Message.hs +10/−1
• src/Database/Tds/Message/Client.hs +1/−1
• src/Database/Tds/Message/DataStream.hs +18/−18
• src/Database/Tds/Message/Prelogin.hs +2/−1
• src/Database/Tds/Message/Server.hs +2/−1
• src/Database/Tds/Primitives/Decimal.hs +85/−135
• src/Database/Tds/Primitives/Fixed.hs +31/−122
• src/Database/Tds/Transport.hs +18/−13

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1cdf9ff7b298d7db7c17d324be7f9387fbcc28b4b989329cf96751a8e3ae7c96+-- hash: 7a16a4896946efbb08b77d4048e4df5747570955336beaa0212bc14a8260c7cc  name:           ms-tds-version:        0.1.0.2+version:        0.1.0.3 synopsis:       TDS Protocol implemented in Haskell description:    Please see the README on GitHub at <https://github.com/mitsuji/ms-tds#readme> category:       Database@@ -50,11 +50,13 @@   build-depends:       array     , base >=4.7 && <5-    , binary+    , binary >=0.8.1.0     , bytestring+    , crypto-random     , data-default-class     , mtl     , network+    , template-haskell     , text     , time     , tls@@ -74,12 +76,14 @@   build-depends:       array     , base >=4.7 && <5-    , binary+    , binary >=0.8.1.0     , bytestring+    , crypto-random     , data-default-class     , ms-tds     , mtl     , network+    , template-haskell     , text     , time     , tls

@@ -104,6 +104,14 @@                             , Scale (..)                             , Decimal (..)                             , Money (..)+                            , decimal0,decimal1,decimal2,decimal3,decimal4+                            , decimal5,decimal6,decimal7,decimal8,decimal9+                            , decimal10,decimal11,decimal12,decimal13,decimal14+                            , decimal15,decimal16,decimal17,decimal18,decimal19+                            , decimal20,decimal21,decimal22,decimal23,decimal24+                            , decimal25,decimal26,decimal27,decimal28,decimal29+                            , decimal30,decimal31,decimal32,decimal33,decimal34+                            , decimal35,decimal36,decimal37,decimal38                                                          , Collation (..)                             , Collation32 (..)@@ -125,7 +133,8 @@                                                          ) where -import Data.Monoid((<>))+import Data.Monoid((<>),mempty)+import Control.Applicative((<$>),(<*>))  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB

@@ -23,7 +23,7 @@                                                                        ) where -import Data.Monoid((<>))+import Data.Monoid((<>),mempty)  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB

@@ -13,6 +13,7 @@                                        ) where  import Data.Monoid((<>))+import Control.Applicative((<$>),(<*>))  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB@@ -685,15 +686,16 @@  -- https://msdn.microsoft.com/en-us/library/ee780893.aspx -- [MEMO] sign byte + signed bytes-getDecimal :: Int -> Precision -> Scale -> Get Decimal-getDecimal len p s = -  bytesToDecimal p s <$> Get.getWord8 <*> (Get.getByteString $ fromIntegral $ len -1)+getDecimal :: Int -> Scale -> Get Decimal+getDecimal len s = +  bytesToDecimal s <$> Get.getWord8 <*> (Get.getByteString $ fromIntegral $ len -1) -putDecimal :: Decimal -> Put-putDecimal dec = do -- [TODO] test-  let (s,bs) = decimalToBytes dec+putDecimal :: TypeInfo -> Decimal -> Put+putDecimal (TIDecimalN p _) dec = do -- [TODO] test+  let (s,bs) = decimalToBytes p dec   Put.putWord8 s   Put.putByteString bs+putDecimal (TINumericN p s) dec = putDecimal (TIDecimalN p s) dec   @@ -806,14 +808,13 @@  instance Data Decimal where   fromRawBytes ti (Just bs) = withValidDecimal ti $ \vt ->-    let (p,s) = ps vt-    in runGet (getDecimal (fromIntegral $ LB.length bs) p s) bs+    runGet (getDecimal (fromIntegral $ LB.length bs) (scale vt)) bs     where-      ps :: TypeInfo -> (Precision,Scale)-      ps (TIDecimalN p s) = (p,s)-      ps (TINumericN p s) = (p,s)+      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 dec+  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@@ -895,13 +896,12 @@  instance Data (Maybe Decimal) where   fromRawBytes ti rb = withValidDecimal ti $ \vt ->-    let (p,s) = ps vt-    in (\bs -> runGet (getDecimal (fromIntegral $ LB.length bs) p s) bs) <$> rb+    (\bs -> runGet (getDecimal (fromIntegral $ LB.length bs) (scale vt)) bs) <$> rb     where-      ps :: TypeInfo -> (Precision,Scale)-      ps (TIDecimalN p s) = (p,s)-      ps (TINumericN p s) = (p,s)-  toRawBytes ti dec = withValidDecimal ti $ \_ -> runPut . putDecimal <$> dec+      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

@@ -14,7 +14,8 @@                                      , Nonce (..)                                      ) where -import Data.Monoid((<>))+import Data.Monoid((<>),mempty)+import Control.Applicative((<$>),(<*>))  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB

@@ -64,7 +64,8 @@                                     ) where -import Data.Monoid((<>))+import Data.Monoid((<>),mempty)+import Control.Applicative((<$>),(<*>))  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB

@@ -1,4 +1,6 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} -- https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/5e02042c-a741-4b5a-b91d-af5e236c5252  module Database.Tds.Primitives.Decimal ( Precision (..)@@ -7,8 +9,17 @@                                        , precisionToLen                                        , bytesToDecimal                                        , decimalToBytes+                                       , decimal0,decimal1,decimal2,decimal3,decimal4+                                       , decimal5,decimal6,decimal7,decimal8,decimal9+                                       , decimal10,decimal11,decimal12,decimal13,decimal14+                                       , decimal15,decimal16,decimal17,decimal18,decimal19+                                       , decimal20,decimal21,decimal22,decimal23,decimal24+                                       , decimal25,decimal26,decimal27,decimal28,decimal29+                                       , decimal30,decimal31,decimal32,decimal33,decimal34+                                       , decimal35,decimal36,decimal37,decimal38                                        ) where +import Data.Monoid ((<>)) import Data.Word (Word8(..)) import Data.Int (Int32(..)) import Data.Fixed (Fixed(..))@@ -16,6 +27,9 @@ import qualified Data.ByteString as B import Database.Tds.Primitives.Fixed +import Language.Haskell.TH+import Language.Haskell.TH.Syntax (returnQ)+ type Precision = Word8 type Scale = Word8 @@ -30,56 +44,37 @@     _ -> error "precisionToLen: invalid Precision"  --- [MEMO] Correctness is not sure...--- [TODO] Test-data Decimal = DecimalS0 !Precision !Fixed0-             | DecimalS1 !Precision !Fixed1-             | DecimalS2 !Precision !Fixed2-             | DecimalS3 !Precision !Fixed3-             | DecimalS4 !Precision !Fixed4-             | DecimalS5 !Precision !Fixed5-             | DecimalS6 !Precision !Fixed6-             | DecimalS7 !Precision !Fixed7-             | DecimalS8 !Precision !Fixed8-             | DecimalS9 !Precision !Fixed9-             | DecimalS10 !Precision !Fixed10-             | DecimalS11 !Precision !Fixed11-             | DecimalS12 !Precision !Fixed12-             | DecimalS13 !Precision !Fixed13-             | DecimalS14 !Precision !Fixed14-             | DecimalS15 !Precision !Fixed15-             | DecimalS16 !Precision !Fixed16-             | DecimalS17 !Precision !Fixed17-             | DecimalS18 !Precision !Fixed18-             | DecimalS19 !Precision !Fixed19-             | DecimalS20 !Precision !Fixed20-             | DecimalS21 !Precision !Fixed21-             | DecimalS22 !Precision !Fixed22-             | DecimalS23 !Precision !Fixed23-             | DecimalS24 !Precision !Fixed24-             | DecimalS25 !Precision !Fixed25-             | DecimalS26 !Precision !Fixed26-             | DecimalS27 !Precision !Fixed27-             | DecimalS28 !Precision !Fixed28-             | DecimalS29 !Precision !Fixed29-             | DecimalS30 !Precision !Fixed30-             | DecimalS31 !Precision !Fixed31-             | DecimalS32 !Precision !Fixed32-             | DecimalS33 !Precision !Fixed33-             | DecimalS34 !Precision !Fixed34-             | DecimalS35 !Precision !Fixed35-             | DecimalS36 !Precision !Fixed36-             | DecimalS37 !Precision !Fixed37-             | DecimalS38 !Precision !Fixed38-             deriving (Show)+-- data Decimal = DecimalS0 !Fixed0+--             ...+--             | DecimalS38 !Fixed38+--             deriving (Show)+#if MIN_VERSION_template_haskell(2,12,0)+returnQ [+  DataD [] (mkName "Decimal") [] Nothing+  ((flip map) [0..38] $ \i -> NormalC (mkName $ "DecimalS" <> show i) [(Bang NoSourceUnpackedness SourceStrict,ConT (mkName $ "Fixed" <> show i))] )+  [DerivClause Nothing [ConT ''Show]]+  ]+#elif MIN_VERSION_template_haskell(2,11,0)+returnQ [+  DataD [] (mkName "Decimal") [] Nothing+  ((flip map) [0..38] $ \i -> NormalC (mkName $ "DecimalS" <> show i) [(Bang NoSourceUnpackedness SourceStrict,ConT (mkName $ "Fixed" <> show i))] )+  [ConT ''Show]+  ]+#else+returnQ [+  DataD [] (mkName "Decimal") []+  ((flip map) [0..38] $ \i -> NormalC (mkName $ "DecimalS" <> show i) [(IsStrict,ConT (mkName $ "Fixed" <> show i))] )+  [''Show]+  ]+#endif  -bytesToDecimal :: Precision -> Scale -> Word8 -> B.ByteString -> Decimal-bytesToDecimal p s sign bs =+bytesToDecimal :: Scale -> Word8 -> B.ByteString -> Decimal+bytesToDecimal s sign bs =   let     sign' = if sign == 0x01 then 1 else -1     i = bytesToInteger bs-  in integerToDecimal p s $ sign' * i+  in integerToDecimal s $ sign' * i   -- [MEMO] signed, little endian@@ -88,55 +83,23 @@   where     f a b = a `shift` 8 .|. fromIntegral b -integerToDecimal :: Precision -> Scale -> Integer -> Decimal-integerToDecimal p s i =-  case s of-    0 -> DecimalS0 p $ MkFixed i -    1 -> DecimalS1 p $ MkFixed i -    2 -> DecimalS2 p $ MkFixed i -    3 -> DecimalS3 p $ MkFixed i -    4 -> DecimalS4 p $ MkFixed i -    5 -> DecimalS5 p $ MkFixed i -    6 -> DecimalS6 p $ MkFixed i -    7 -> DecimalS7 p $ MkFixed i -    8 -> DecimalS8 p $ MkFixed i -    9 -> DecimalS9 p $ MkFixed i +integerToDecimal :: Scale -> Integer -> Decimal+integerToDecimal s i =+--  case s of+--    0 -> DecimalS0 $ MkFixed i+--    ...+--    38 -> DecimalS38 $ MkFixed i+--    _ -> error "integerToDecimal: invalid scale"+  $(returnQ $ CaseE (VarE 's) $+     (+       (flip map) [0..38] $ \j ->+         Match (LitP $ IntegerL j) (NormalB $ AppE (ConE $ mkName $ "DecimalS" <> show j) $ AppE (ConE $ mkName "MkFixed") (VarE 'i) ) []+     )+     <> [Match WildP (NormalB $ AppE (VarE 'error) (LitE $ StringL "integerToDecimal: invalid scale")) []]+   ) -    10 -> DecimalS10 p $ MkFixed i-    11 -> DecimalS11 p $ MkFixed i-    12 -> DecimalS12 p $ MkFixed i-    13 -> DecimalS13 p $ MkFixed i-    14 -> DecimalS14 p $ MkFixed i-    15 -> DecimalS15 p $ MkFixed i-    16 -> DecimalS16 p $ MkFixed i-    17 -> DecimalS17 p $ MkFixed i-    18 -> DecimalS18 p $ MkFixed i-    19 -> DecimalS19 p $ MkFixed i -    20 -> DecimalS20 p $ MkFixed i-    21 -> DecimalS21 p $ MkFixed i-    22 -> DecimalS22 p $ MkFixed i-    23 -> DecimalS23 p $ MkFixed i-    24 -> DecimalS24 p $ MkFixed i-    25 -> DecimalS25 p $ MkFixed i-    26 -> DecimalS26 p $ MkFixed i-    27 -> DecimalS27 p $ MkFixed i-    28 -> DecimalS28 p $ MkFixed i-    29 -> DecimalS29 p $ MkFixed i -    30 -> DecimalS30 p $ MkFixed i-    31 -> DecimalS31 p $ MkFixed i-    32 -> DecimalS32 p $ MkFixed i-    33 -> DecimalS33 p $ MkFixed i-    34 -> DecimalS34 p $ MkFixed i-    35 -> DecimalS35 p $ MkFixed i-    36 -> DecimalS36 p $ MkFixed i-    37 -> DecimalS37 p $ MkFixed i-    38 -> DecimalS38 p $ MkFixed i--    _ -> error "integerToDecimal: invalid scale"-- -- [MEMO] signed, little endian integerToBytes :: Word8 -> Integer -> B.ByteString integerToBytes len i = B.pack $ f len i@@ -149,54 +112,41 @@       in (fromIntegral m) : f (len-1) d  -decimalToBytes :: Decimal -> (Word8,B.ByteString)-decimalToBytes dec =+--    int :: Decimal -> Integer+--    int (DecimalS0  (MkFixed i)) = i+--    ...+--    int (DecimalS38 (MkFixed i)) = i+returnQ [+  (FunD $ mkName "int")+  $ (flip map) [0..38] $ \j->+      Clause [ConP (mkName $ "DecimalS" <> show j) [ConP (mkName "MkFixed") [VarP $ mkName "i"]]]+      (NormalB $ VarE $ mkName "i")+      []+  ]++decimalToBytes :: Precision -> Decimal -> (Word8,B.ByteString)+decimalToBytes p dec =   let-    (p,i) = int dec+    i = int dec     sign = if signum i == -1 then 0x00 else 0x01     bs = integerToBytes (precisionToLen p) $ abs i   in (sign,bs)-  where-    int :: Decimal -> (Precision,Integer)-    int (DecimalS0  p (MkFixed i)) =  (p,i)-    int (DecimalS1  p (MkFixed i)) =  (p,i)-    int (DecimalS2  p (MkFixed i)) =  (p,i)-    int (DecimalS3  p (MkFixed i)) =  (p,i)-    int (DecimalS4  p (MkFixed i)) =  (p,i)-    int (DecimalS5  p (MkFixed i)) =  (p,i)-    int (DecimalS6  p (MkFixed i)) =  (p,i)-    int (DecimalS7  p (MkFixed i)) =  (p,i)-    int (DecimalS8  p (MkFixed i)) =  (p,i)-    int (DecimalS9  p (MkFixed i)) =  (p,i)-    int (DecimalS10 p (MkFixed i)) =  (p,i)-    int (DecimalS11 p (MkFixed i)) =  (p,i)-    int (DecimalS12 p (MkFixed i)) =  (p,i)-    int (DecimalS13 p (MkFixed i)) =  (p,i)-    int (DecimalS14 p (MkFixed i)) =  (p,i)-    int (DecimalS15 p (MkFixed i)) =  (p,i)-    int (DecimalS16 p (MkFixed i)) =  (p,i)-    int (DecimalS17 p (MkFixed i)) =  (p,i)-    int (DecimalS18 p (MkFixed i)) =  (p,i)-    int (DecimalS19 p (MkFixed i)) =  (p,i)-    int (DecimalS20 p (MkFixed i)) =  (p,i)-    int (DecimalS21 p (MkFixed i)) =  (p,i)-    int (DecimalS22 p (MkFixed i)) =  (p,i)-    int (DecimalS23 p (MkFixed i)) =  (p,i)-    int (DecimalS24 p (MkFixed i)) =  (p,i)-    int (DecimalS25 p (MkFixed i)) =  (p,i)-    int (DecimalS26 p (MkFixed i)) =  (p,i)-    int (DecimalS27 p (MkFixed i)) =  (p,i)-    int (DecimalS28 p (MkFixed i)) =  (p,i)-    int (DecimalS29 p (MkFixed i)) =  (p,i)-    int (DecimalS30 p (MkFixed i)) =  (p,i)-    int (DecimalS31 p (MkFixed i)) =  (p,i)-    int (DecimalS32 p (MkFixed i)) =  (p,i)-    int (DecimalS33 p (MkFixed i)) =  (p,i)-    int (DecimalS34 p (MkFixed i)) =  (p,i)-    int (DecimalS35 p (MkFixed i)) =  (p,i)-    int (DecimalS36 p (MkFixed i)) =  (p,i)-    int (DecimalS37 p (MkFixed i)) =  (p,i)-    int (DecimalS38 p (MkFixed i)) =  (p,i) +++-- decimal0 :: Decimal -> Fixed0+-- decimal0 (DecimalS0 f) = f+-- decimal0 _ = error "decimal0: scale mismatch"+returnQ $ (flip map) [0..38] $ \i ->+  (FunD $ mkName $ "decimal" <> show i)+  [+    Clause [ConP (mkName $ "DecimalS" <> show i) [VarP $ mkName "f"]]+    (NormalB $ VarE $ mkName "f")+    []+  ,+    Clause [WildP]+    (NormalB $ AppE (VarE 'error) (LitE $ StringL $ "decimal" <> show i <> ": scale mismatch"))+    []+  ]  

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+ module Database.Tds.Primitives.Fixed ( Fixed0 (..)                                      , Fixed1 (..)                                      , Fixed2 (..)@@ -79,134 +82,40 @@                                      ) where  +import Data.Monoid ((<>))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (returnQ) import Data.Fixed (HasResolution(..),Fixed(..)) -data Exp0-data Exp1-data Exp2-data Exp3-data Exp4-data Exp5-data Exp6-data Exp7-data Exp8-data Exp9 -data Exp10-data Exp11-data Exp12-data Exp13-data Exp14-data Exp15-data Exp16-data Exp17-data Exp18-data Exp19+-- data Exp0+-- ...+-- data Exp38+#if MIN_VERSION_template_haskell(2,11,0)+returnQ $ (flip map) [0..38] $ \i -> DataD [] (mkName $ "Exp" <> (show i)) [] Nothing [] []+#else+returnQ $ (flip map) [0..38] $ \i -> DataD [] (mkName $ "Exp" <> (show i)) [] [] []+#endif -data Exp20-data Exp21-data Exp22-data Exp23-data Exp24-data Exp25-data Exp26-data Exp27-data Exp28-data Exp29 -data Exp30-data Exp31-data Exp32-data Exp33-data Exp34-data Exp35-data Exp36-data Exp37-data Exp38+-- instance HasResolution Exp0 where resolution _  = 1+-- ...+-- instance HasResolution Exp38 where resolution _ = 100000000000000000000000000000000000000+#if MIN_VERSION_template_haskell(2,11,0)+returnQ $ (flip map) [0..38] $ \i ->+  InstanceD Nothing [] (AppT (ConT ''HasResolution) (ConT $ (mkName $ "Exp" <> (show i))))+  [FunD 'resolution [Clause [WildP] (NormalB (LitE (IntegerL (10^i)))) []]]+#else+returnQ $ (flip map) [0..38] $ \i ->+  InstanceD [] (AppT (ConT ''HasResolution) (ConT $ (mkName $ "Exp" <> (show i))))+  [FunD 'resolution [Clause [WildP] (NormalB (LitE (IntegerL (10^i)))) []]]+#endif -instance HasResolution Exp0 where resolution _  = 1-instance HasResolution Exp1 where resolution _  = 10-instance HasResolution Exp2 where resolution _  = 100-instance HasResolution Exp3 where resolution _  = 1000-instance HasResolution Exp4 where resolution _  = 10000-instance HasResolution Exp5 where resolution _  = 100000-instance HasResolution Exp6 where resolution _  = 1000000-instance HasResolution Exp7 where resolution _  = 10000000-instance HasResolution Exp8 where resolution _  = 100000000-instance HasResolution Exp9 where resolution _  = 1000000000 -instance HasResolution Exp10 where resolution _ = 10000000000-instance HasResolution Exp11 where resolution _ = 100000000000-instance HasResolution Exp12 where resolution _ = 1000000000000-instance HasResolution Exp13 where resolution _ = 10000000000000-instance HasResolution Exp14 where resolution _ = 100000000000000-instance HasResolution Exp15 where resolution _ = 1000000000000000-instance HasResolution Exp16 where resolution _ = 10000000000000000-instance HasResolution Exp17 where resolution _ = 100000000000000000-instance HasResolution Exp18 where resolution _ = 1000000000000000000-instance HasResolution Exp19 where resolution _ = 10000000000000000000--instance HasResolution Exp20 where resolution _ = 100000000000000000000-instance HasResolution Exp21 where resolution _ = 1000000000000000000000-instance HasResolution Exp22 where resolution _ = 10000000000000000000000-instance HasResolution Exp23 where resolution _ = 100000000000000000000000-instance HasResolution Exp24 where resolution _ = 1000000000000000000000000-instance HasResolution Exp25 where resolution _ = 10000000000000000000000000-instance HasResolution Exp26 where resolution _ = 100000000000000000000000000-instance HasResolution Exp27 where resolution _ = 1000000000000000000000000000-instance HasResolution Exp28 where resolution _ = 10000000000000000000000000000-instance HasResolution Exp29 where resolution _ = 100000000000000000000000000000--instance HasResolution Exp30 where resolution _ = 1000000000000000000000000000000-instance HasResolution Exp31 where resolution _ = 10000000000000000000000000000000-instance HasResolution Exp32 where resolution _ = 100000000000000000000000000000000-instance HasResolution Exp33 where resolution _ = 1000000000000000000000000000000000-instance HasResolution Exp34 where resolution _ = 10000000000000000000000000000000000-instance HasResolution Exp35 where resolution _ = 100000000000000000000000000000000000-instance HasResolution Exp36 where resolution _ = 1000000000000000000000000000000000000-instance HasResolution Exp37 where resolution _ = 10000000000000000000000000000000000000-instance HasResolution Exp38 where resolution _ = 100000000000000000000000000000000000000--type Fixed0 = Fixed Exp0-type Fixed1 = Fixed Exp1-type Fixed2 = Fixed Exp2-type Fixed3 = Fixed Exp3-type Fixed4 = Fixed Exp4-type Fixed5 = Fixed Exp5-type Fixed6 = Fixed Exp6-type Fixed7 = Fixed Exp7-type Fixed8 = Fixed Exp8-type Fixed9 = Fixed Exp9--type Fixed10 = Fixed Exp10-type Fixed11 = Fixed Exp11-type Fixed12 = Fixed Exp12-type Fixed13 = Fixed Exp13-type Fixed14 = Fixed Exp14-type Fixed15 = Fixed Exp15-type Fixed16 = Fixed Exp16-type Fixed17 = Fixed Exp17-type Fixed18 = Fixed Exp18-type Fixed19 = Fixed Exp19--type Fixed20 = Fixed Exp20-type Fixed21 = Fixed Exp21-type Fixed22 = Fixed Exp22-type Fixed23 = Fixed Exp23-type Fixed24 = Fixed Exp24-type Fixed25 = Fixed Exp25-type Fixed26 = Fixed Exp26-type Fixed27 = Fixed Exp27-type Fixed28 = Fixed Exp28-type Fixed29 = Fixed Exp29+-- type Fixed0 = Fixed Exp0+-- ...+-- type Fixed38 = Fixed Exp38+returnQ $ (flip map) [0..38] $ \i -> TySynD (mkName $ "Fixed" <> (show i)) [] $+                                     AppT (ConT ''Fixed) (ConT $ mkName $ "Exp" <> (show i)) -type Fixed30 = Fixed Exp30-type Fixed31 = Fixed Exp31-type Fixed32 = Fixed Exp32-type Fixed33 = Fixed Exp33-type Fixed34 = Fixed Exp34-type Fixed35 = Fixed Exp35-type Fixed36 = Fixed Exp36-type Fixed37 = Fixed Exp37-type Fixed38 = Fixed Exp38 

@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}  module Database.Tds.Transport (contextNew) where -import Data.Monoid((<>))+import Data.Monoid((<>),mempty)+import Control.Applicative((<$>),(<*>))  import Network.Socket (Socket,close) import Network.Socket.ByteString (recv,sendAll)@@ -14,24 +16,32 @@ import Data.Default.Class (def) import qualified Network.TLS as TLS import Network.TLS (ClientParams(..),Supported(..),Shared(..),ValidationCache(..),ValidationCacheResult(..))-import Network.TLS.Extra.Cipher (ciphersuite_default)+import Network.TLS.Extra.Cipher (ciphersuite_strong) import Data.X509.CertificateStore (CertificateStore(..)) import System.X509 (getSystemCertificateStore)  import Control.Concurrent(MVar(..),newMVar,readMVar,modifyMVar_)  import Database.Tds.Message.Header+#if !MIN_VERSION_tls(1,3,0)+import Crypto.Random(createEntropyPool,cprgCreate,SystemRNG(..))+#endif   -- | [\[MS-TDS\] 3.2.5.2 Sent TLS/SSL Negotiation Packet State](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/d62e225b-d865-4ccc-8f73-de1ef49e30d4)-contextNew :: Socket -> TLS.HostName -> IO TLS.Context+contextNew :: Socket -> String -> IO TLS.Context contextNew sock host = do   certStore <- getSystemCertificateStore   sock' <- newSecureSocket sock-  TLS.contextNew sock' $ getTlsParams host certStore-  +#if MIN_VERSION_tls(1,3,0)+  TLS.contextNew (getBackend sock') (getTlsParams host certStore)+#else+  pool <- createEntropyPool+  TLS.contextNew (getBackend sock') (getTlsParams host certStore) (cprgCreate pool :: SystemRNG)+#endif  + data SecureSocket = SecureSocket{ getSocket::Socket                                 , getSendBuff::MVar B.ByteString                                 , getSendStep::MVar Int@@ -40,10 +50,7 @@                      newSecureSocket sock = SecureSocket sock <$> newMVar mempty <*> newMVar 0 <*> newMVar mempty --instance TLS.HasBackend SecureSocket where-    initializeBackend sock' = return ()-    getBackend sock' = TLS.Backend flush (close sock) sendAll' recvAll+getBackend sock' = TLS.Backend flush (close sock) sendAll' recvAll       where         sock = getSocket sock'               @@ -102,13 +109,11 @@                 modifyMVar_ (getRecvBuff sock') (\_ -> return $ B.drop len buff)                 return bs -           -getTlsParams :: TLS.HostName -> CertificateStore -> ClientParams+getTlsParams :: String -> CertificateStore -> ClientParams getTlsParams host store =   (TLS.defaultParamsClient host mempty) { clientSupported = def { supportedVersions = [TLS.TLS10]-                                                                , supportedCiphers = ciphersuite_default-                                                                , supportedEmptyPacket = False+                                                                , supportedCiphers = ciphersuite_strong                                                                 }                                         , clientShared = def { sharedCAStore = store                                                              , sharedValidationCache = validateCache