diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/odbc.cabal b/odbc.cabal --- a/odbc.cabal +++ b/odbc.cabal @@ -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 diff --git a/src/Database/ODBC/Internal.hs b/src/Database/ODBC/Internal.hs --- a/src/Database/ODBC/Internal.hs +++ b/src/Database/ODBC/Internal.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 diff --git a/src/Database/ODBC/SQLServer.hs b/src/Database/ODBC/SQLServer.hs --- a/src/Database/ODBC/SQLServer.hs +++ b/src/Database/ODBC/SQLServer.hs @@ -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. +-- +-- +-- +-- 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@. +-- +-- +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 diff --git a/src/Database/ODBC/TH.hs b/src/Database/ODBC/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/ODBC/TH.hs @@ -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 "" + , 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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