diff --git a/ms-tds.cabal b/ms-tds.cabal --- a/ms-tds.cabal +++ b/ms-tds.cabal @@ -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 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 diff --git a/src/Database/Tds/Message.hs b/src/Database/Tds/Message.hs --- a/src/Database/Tds/Message.hs +++ b/src/Database/Tds/Message.hs @@ -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 diff --git a/src/Database/Tds/Message/Client.hs b/src/Database/Tds/Message/Client.hs --- a/src/Database/Tds/Message/Client.hs +++ b/src/Database/Tds/Message/Client.hs @@ -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 diff --git a/src/Database/Tds/Message/DataStream.hs b/src/Database/Tds/Message/DataStream.hs --- a/src/Database/Tds/Message/DataStream.hs +++ b/src/Database/Tds/Message/DataStream.hs @@ -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 diff --git a/src/Database/Tds/Message/Prelogin.hs b/src/Database/Tds/Message/Prelogin.hs --- a/src/Database/Tds/Message/Prelogin.hs +++ b/src/Database/Tds/Message/Prelogin.hs @@ -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 diff --git a/src/Database/Tds/Message/Server.hs b/src/Database/Tds/Message/Server.hs --- a/src/Database/Tds/Message/Server.hs +++ b/src/Database/Tds/Message/Server.hs @@ -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 diff --git a/src/Database/Tds/Primitives/Decimal.hs b/src/Database/Tds/Primitives/Decimal.hs --- a/src/Database/Tds/Primitives/Decimal.hs +++ b/src/Database/Tds/Primitives/Decimal.hs @@ -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")) + [] + ] diff --git a/src/Database/Tds/Primitives/Fixed.hs b/src/Database/Tds/Primitives/Fixed.hs --- a/src/Database/Tds/Primitives/Fixed.hs +++ b/src/Database/Tds/Primitives/Fixed.hs @@ -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 diff --git a/src/Database/Tds/Transport.hs b/src/Database/Tds/Transport.hs --- a/src/Database/Tds/Transport.hs +++ b/src/Database/Tds/Transport.hs @@ -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