odbc 0.0.5 → 0.1.0

raw patch · 6 files changed

+283/−40 lines, 6 filesdep +parsecdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: parsec, template-haskell

API changes (from Hackage documentation)

Files

• README.md +17/−0
• odbc.cabal +6/−3
• src/Database/ODBC/Internal.hs +67/−28
• src/Database/ODBC/SQLServer.hs +53/−3
• src/Database/ODBC/TH.hs +88/−0
• test/Main.hs +52/−6

@@ -66,6 +66,13 @@  ## Common issues +Compilation on Linux/OS X may require a `odbcss.h` header file for type/constant definitions. To get this install the freetds package:++* [Linux example](https://github.com/fpco/odbc/blob/efe81f7c17f5ff4c1cf8937577b32f049c0dd62b/Dockerfile#L15).+* On OS X you can use `brew install freetds`.++Windows should already have this file.+ If you see an error like this:      [unixODBC][Driver Manager]Can't open lib 'ODBC Driver 13 for SQL Server' : file not found@@ -82,3 +89,13 @@ environment variable or argument, check that your input string isn't quoted e.g. `"Driver=.."` instead of `Driver=..` due to silly shell scripting quoting issues.++If you see an error like this on OS X with driver version 17,++```+libc++abi.dylib: terminating with uncaught exception of type+std::runtime_error: collate_byname::collate_byname failed to construct+for C/en_AU.UTF-8/C/C/C/C+```++use driver 13 or [see here for more detail](https://github.com/fpco/odbc/issues/17).

@@ -5,7 +5,7 @@              suite runs on OS X, Windows and Linux. copyright: FP Complete 2018 maintainer: chrisdone@fpcomplete.com-version:             0.0.5+version:             0.1.0 license:             BSD3 license-file:        LICENSE build-type:          Simple@@ -21,6 +21,7 @@    Database.ODBC.Internal    Database.ODBC.SQLServer    Database.ODBC.Conversion+   Database.ODBC.TH   default-language:  Haskell2010   if os(mingw32) || os(win32)     extra-libraries: odbc32@@ -39,7 +40,9 @@     containers,     time,     semigroups,-    transformers+    transformers,+    template-haskell,+    parsec  executable odbc   hs-source-dirs:    app@@ -56,7 +59,7 @@ test-suite test   default-language:  Haskell2010   type: exitcode-stdio-1.0-  build-depends: base, text, odbc, hspec, QuickCheck, bytestring, time+  build-depends: base, text, odbc, hspec, QuickCheck, bytestring, time, parsec   ghc-options: -threaded   hs-source-dirs: test   main-is: Main.hs

@@ -24,6 +24,7 @@   ( -- * Connect/disconnect     connect   , close+  , withConnection   , Connection     -- * Executing queries   , exec@@ -209,6 +210,16 @@         -- the connection and the env.         maybe (throwIO DatabaseAlreadyClosed) finalizeForeignPtr mstate) ++-- | Memory bracket around 'connect' and 'close'.+withConnection :: MonadUnliftIO m =>+               Text  -- ^ An ODBC connection string.+            -> (Connection -> m a) -- ^ Program that uses the ODBC connection.+            -> m a+withConnection str inner = withRunInIO $ \io ->+  withBound $ bracket (connect str) close (\h -> io (inner h))++ -- | Execute a statement on the database. exec ::      MonadIO m@@ -627,6 +638,7 @@                      (fmap                         (\frac -> fromIntegral frac / 1000000000)                         (odbc_TIMESTAMP_STRUCT_fraction timestampPtr))))))+     | colType == sql_guid -> getGuid dbc stmt i      | otherwise ->        throwIO          (UnknownDataType@@ -636,25 +648,44 @@   where     colType = columnType col +-- | Get a GUID as a binary value.+getGuid :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getGuid dbc stmt column =+  uninterruptibleMask_+    (do bufferp <- callocBytes odbcGuidBytes+        void+          (getTypedData+             dbc+             stmt+             sql_c_binary+             column+             (coerce bufferp)+             (SQLLEN odbcGuidBytes))+        !bs <- S.unsafePackMallocCStringLen (bufferp, odbcGuidBytes)+        evaluate (Just (BinaryValue (Binary bs))))+ -- | Get the column's data as a vector of CHAR. getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value) getBytesData dbc stmt column = do   mavailableBytes <- getSize dbc stmt sql_c_binary column   case mavailableBytes of     Just 0 -> pure (Just (ByteStringValue mempty))-    Just availableBytes -> do-      let allocBytes = availableBytes + 1-      bufferp <- callocBytes (fromIntegral allocBytes)-      void-        (getTypedData-           dbc-           stmt-           sql_c_binary-           column-           (coerce bufferp)-           (SQLLEN (fromIntegral allocBytes)))-      bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBytes)-      evaluate (Just (ByteStringValue bs))+    Just availableBytes ->+      uninterruptibleMask_+        (do let allocBytes = availableBytes + 1+            bufferp <- callocBytes (fromIntegral allocBytes)+            void+              (getTypedData+                 dbc+                 stmt+                 sql_c_binary+                 column+                 (coerce bufferp)+                 (SQLLEN (fromIntegral allocBytes)))+            bs <-+              S.unsafePackMallocCStringLen+                (bufferp, fromIntegral availableBytes)+            evaluate (Just (ByteStringValue bs)))     Nothing -> pure Nothing  -- | Get the column's data as raw binary.@@ -663,19 +694,22 @@   mavailableBinary <- getSize dbc stmt sql_c_binary column   case mavailableBinary of     Just 0 -> pure (Just (BinaryValue (Binary mempty)))-    Just availableBinary -> do-      let allocBinary = availableBinary-      bufferp <- callocBytes (fromIntegral allocBinary)-      void-        (getTypedData-           dbc-           stmt-           sql_c_binary-           column-           (coerce bufferp)-           (SQLLEN (fromIntegral allocBinary)))-      bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBinary)-      evaluate (Just (BinaryValue (Binary bs)))+    Just availableBinary ->+      uninterruptibleMask_+        (do let allocBinary = availableBinary+            bufferp <- callocBytes (fromIntegral allocBinary)+            void+              (getTypedData+                 dbc+                 stmt+                 sql_c_binary+                 column+                 (coerce bufferp)+                 (SQLLEN (fromIntegral allocBinary)))+            bs <-+              S.unsafePackMallocCStringLen+                (bufferp, fromIntegral availableBinary)+            evaluate (Just (BinaryValue (Binary bs))))     Nothing -> pure Nothing  -- | Get the column's data as a text string.@@ -958,6 +992,11 @@ -------------------------------------------------------------------------------- -- SQL constants +-- | hardcoded size for a GUID value,+-- https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx+odbcGuidBytes :: Integral a => a+odbcGuidBytes = 16+ -- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sql.h#L50..L51 sql_success :: RETCODE sql_success = RETCODE 0@@ -1065,8 +1104,8 @@ sql_bit :: SQLSMALLINT sql_bit = (-7) --- sql_guid :: SQLSMALLINT--- sql_guid = (-11)+sql_guid :: SQLSMALLINT+sql_guid = (-11)  -------------------------------------------------------------------------------- -- C type constants

@@ -1,3 +1,7 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -28,6 +32,8 @@   , FromValue(..)   , FromRow(..)   , Internal.Binary(..)+  , Datetime2(..)+  , Smalldatetime(..)      -- * Streaming results     -- $streaming@@ -76,6 +82,10 @@ import           GHC.Generics import           Text.Printf +#if MIN_VERSION_base(4,9,0)+import           GHC.TypeLits+#endif+ -- $building -- -- You have to compile your projects using the @-threaded@ flag to@@ -223,6 +233,27 @@ instance IsString Part where   fromString = TextPart . T.pack +-- The 'LocalTime' type has more accuracy than the @datetime@ type and+-- the @datetime2@ types can hold; so you will lose precision when you+-- insert. Use this type to indicate that you are aware of the+-- precision loss and fine with it.+--+-- <https://docs.microsoft.com/en-us/sql/t-sql/data-types/datetime2-transact-sql?view=sql-server-2017>+--+-- If you are using @smalldatetime@ in SQL Server, use instead the+-- 'Smalldatetime' type.+newtype Datetime2 = Datetime2+  { unDatetime2 :: LocalTime+  } deriving (Eq, Ord, Show, Typeable, Generic, Data, FromValue)++-- Use this type to discard higher precision than seconds in your+-- 'LocalTime' values for a schema using @smalldatetime@.+--+-- <https://docs.microsoft.com/en-us/sql/t-sql/data-types/smalldatetime-transact-sql?view=sql-server-2017>+newtype Smalldatetime = Smalldatetime+  { unSmalldatetime :: LocalTime+  } deriving (Eq, Ord, Show, Typeable, Generic, Data, FromValue)+ -------------------------------------------------------------------------------- -- Conversion to SQL @@ -309,13 +340,32 @@ instance ToSql TimeOfDay where   toSql = toSql . TimeOfDayValue +#if MIN_VERSION_base(4,9,0)+-- | You cannot use this instance. Wrap your value in either+-- 'Datetime2' or 'Smalldatetime'.+instance GHC.TypeLits.TypeError ('GHC.TypeLits.Text "Instance for LocalTime is disabled:" 'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "Wrap your value in either (Datetime2 foo) or (Smalldatetime foo).") =>+         ToSql LocalTime where+  toSql = toSql++-- | You cannot use this instance. Wrap your value in either+-- 'Datetime2' or 'Smalldatetime'.+instance GHC.TypeLits.TypeError ('GHC.TypeLits.Text "Instance for UTCTime is not possible:" 'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "SQL Server does not support time zones. "'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "You can use utcToLocalTime to make a LocalTime, and" 'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "wrap your value in either (Datetime2 foo) or (Smalldatetime foo).") =>+         ToSql UTCTime where+  toSql = toSql+#endif+ -- | Corresponds to DATETIME/DATETIME2 type of SQL Server. ----- The 'LocalTime' type has more accuracy than the @datetime@ type and+-- The 'Datetime2' type has more accuracy than the @datetime@ type and -- the @datetime2@ types can hold; so you will lose precision when you -- insert.-instance ToSql LocalTime where-  toSql = toSql . LocalTimeValue+instance ToSql Datetime2 where+  toSql = toSql . LocalTimeValue . unDatetime2++-- | Corresponds to SMALLDATETIME type of SQL Server. Precision up to+-- seconds, nothing smaller.+instance ToSql Smalldatetime where+  toSql = toSql . LocalTimeValue . unSmalldatetime  -------------------------------------------------------------------------------- -- Top-level functions

@@ -0,0 +1,88 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BangPatterns #-}+module Database.ODBC.TH+  ( sql+  , sqlFile+  , partsParser+  , Part(..)+  ) where++import           Control.DeepSeq+import           Data.Char+import           Data.List (foldl1')+import           Data.Monoid ((<>))+import           Language.Haskell.TH (Q, Exp)+import qualified Language.Haskell.TH as TH+import           Language.Haskell.TH.Quote (QuasiQuoter(..))+import           Text.Parsec+import           Text.Parsec.String++data Part+    = SqlPart !String+    | ParamName !String+    deriving (Show, Eq)++partsParser :: Parser [Part]+partsParser = many1 (self <|> param <|> part)+  where+    self = try (SqlPart "$" <$ string "$$") <?> "escaped dollar $$"+    param =+      (char '$' *>+       (ParamName <$>+        (many1 (satisfy isAlphaNum)) <?> "variable name (alpha-numeric only)")) <?>+      "parameter (e.g. $foo123)"+    part = (SqlPart <$> many1 (satisfy (/= '$'))) <?> "SQL code"+++{- | Allows SQL parameters interpolation from a SQL query. Only 'quoteExp' is+     implemented because this quote can only be used at the expression level.++@+select_some_stuff :: Text -> Int -> Query+select_some_stuff name age = [sql|select * from user where age = $age AND name = $name|]+@++     In this case, 'sql' quote will generate the code below:++@+"select * from user where age = " 'Data.Monoid.<>' 'Database.ODBC.SQLServer.toSql' age 'Data.Monoid.<>' " AND name = " 'Data.Monoid.<>' 'Database.ODBC.SQLServer.toSql' name+@+-}+sql :: QuasiQuoter+sql = QuasiQuoter { quoteExp  = buildSqlQuery "<expression>"+                  , quotePat  = ignored+                  , quoteType = ignored+                  , quoteDec  = ignored+                  }+  where+    ignored :: x -> Q a+    ignored _ = fail "sql quote can be used at the expression level only"++{- | Loads the content of a SQL query file and allows SQL parameters interpolation+     from it.++@+select_some_stuff :: Text -> Int -> Query+select_some_stuff name age = $(sqlFile "path\/to\/my\/sql\/file.sql")+@++     See 'sql' for more details.+-}+sqlFile :: FilePath -> Q Exp+sqlFile fp = do+  !str <- fmap force (TH.runIO (readFile fp))+  buildSqlQuery fp str++buildSqlQuery :: FilePath -> String -> Q Exp+buildSqlQuery fp input = do+  case parse partsParser fp input of+    Left err    -> fail $ "Parse error in SQL: " <> show err+    Right parts -> pure $ buildExp parts++buildExp :: [Part] -> Exp+buildExp = foldl1' go . fmap toExp+  where+    toExp (SqlPart s) = TH.LitE $ TH.StringL s+    toExp (ParamName name) =+      TH.AppE (TH.VarE $ TH.mkName "toSql") (TH.VarE $ TH.mkName name)+    go a b = TH.UInfixE a (TH.VarE '(<>)) b

@@ -1,3 +1,4 @@+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-}@@ -17,6 +18,7 @@ import           Control.Exception (try, onException, SomeException, catch, throwIO) import           Control.Monad import           Control.Monad.IO.Class+import           Data.Bifunctor import           Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8@@ -34,12 +36,14 @@ import           Database.ODBC.Conversion (FromValue(..)) import           Database.ODBC.Internal (Value (..), Connection, ODBCException(..), Step(..), Binary) import qualified Database.ODBC.Internal as Internal-import           Database.ODBC.SQLServer (ToSql(..))+import           Database.ODBC.SQLServer (Datetime2(..), Smalldatetime(..), ToSql(..)) import qualified Database.ODBC.SQLServer as SQLServer+import           Database.ODBC.TH (partsParser, Part(..)) import           System.Environment import           Test.Hspec import           Test.QuickCheck import           Test.QuickCheck.Monadic+import qualified Text.Parsec as Parsec import           Text.Printf  --------------------------------------------------------------------------------@@ -59,9 +63,35 @@         describe "Regression tests" regressions         describe "Data retrieval" dataRetrieval         describe "Big data" bigData)+  describe "Database.ODBC.SQLServer" (describe "Conversion to SQL" conversionTo)+  describe "Database.ODBC.TH" thparser++thparser :: SpecWith ()+thparser =   describe-    "Database.ODBC.SQLServer"-    (describe "Conversion to SQL" conversionTo)+    "Parser"+    (do it+          "Basic range of syntax"+          (shouldBe+             (Parsec.parse partsParser "" "foo $bar3*123 zot '$$12.4' $wibble")+             (Right+                [ SqlPart "foo "+                , ParamName "bar3"+                , SqlPart "*123 zot '"+                , SqlPart "$"+                , SqlPart "12.4' "+                , ParamName "wibble"+                ]))+        it+          "Incomplete parameter"+          (shouldBe+             (first (const ()) (Parsec.parse partsParser "" "foo$"))+             (Left ()))+        it+          "Invalid parameter character"+          (shouldBe+             (first (const ()) (Parsec.parse partsParser "" "foo$."))+             (Left ())))  regressions :: Spec regressions = do@@ -110,7 +140,8 @@         roundtrip @Int "minBound(Int16)" "Int" "smallint" (fromIntegral (minBound :: Int16))         roundtrip @Word8 "minBound(Word8)" "Word8" "tinyint" minBound)   quickCheckRoundtrip @Day "Day" "date"-  quickCheckRoundtrip @LocalTime "LocalTime" "datetime2"+  quickCheckRoundtrip @Datetime2 "LocalTime" "datetime2"+  quickCheckRoundtrip @Smalldatetime "LocalTime" "datetime2"   quickCheckRoundtrip @TestDateTime "TestDateTime" "datetime"   quickCheckOneway @TimeOfDay "TimeOfDay" "time"   quickCheckRoundtrip @TestTimeOfDay "TimeOfDay" "time"@@ -128,6 +159,7 @@   quickCheckRoundtrip @ByteString "ByteString" ("varchar(" <>  (show maxStringLen) <> ")")   quickCheckRoundtrip @TestBinary "ByteString" ("binary(" <>  (show maxStringLen) <> ")")   quickCheckRoundtrip @Binary "ByteString" ("varbinary(" <>  (show maxStringLen) <> ")")+  quickCheckRoundtrip @TestGUID "GUID" "uniqueidentifier"  connectivity :: Spec connectivity = do@@ -493,6 +525,17 @@          (SQLServer.Binary             (S.take maxStringLen (bytes <> S.replicate maxStringLen 0)))) +newtype TestGUID = TestGUID Binary+  deriving (Show, Eq, Ord, SQLServer.ToSql, FromValue)++instance Arbitrary TestGUID where+  arbitrary = do+    bytes <- arbitrary+    pure+      (TestGUID+         (SQLServer.Binary+            (S.take 16 (bytes <> S.replicate maxStringLen 0))))+ -- | The maximum total number of decimal digits that will be stored, -- both to the left and to the right of the decimal point. The -- precision must be a value from 1 through the maximum precision of@@ -567,7 +610,7 @@           (timeToTimeOfDay              (secondsToDiffTime seconds + (fromRational (fractional % 10000000)))) -newtype TestDateTime = TestDateTime LocalTime+newtype TestDateTime = TestDateTime Datetime2   deriving (Eq, Ord, Show, SQLServer.ToSql, FromValue)  newtype TestTimeOfDay = TestTimeOfDay TimeOfDay@@ -579,7 +622,7 @@     pure (TestTimeOfDay (timeToTimeOfDay (secondsToDiffTime seconds)))  instance Arbitrary TestDateTime where-  arbitrary = fmap TestDateTime (LocalTime <$> arbitrary <*> arbitraryLimited)+  arbitrary = fmap (TestDateTime . Datetime2) (LocalTime <$> arbitrary <*> arbitraryLimited)     where       arbitraryLimited = do         fractional <- elements [993, 003, 497, 007, 000, 127] :: Gen Integer@@ -589,3 +632,6 @@         pure           (timeToTimeOfDay              (secondsToDiffTime seconds + (fromRational (fractional % 1000))))++deriving instance Arbitrary Datetime2+deriving instance Arbitrary Smalldatetime