diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,17 @@ +0.2.0: + * Drop Maybes, use NullValue. + +0.1.1: + * Fix Smalldatetime ToSql instance to set seconds to 0. + * Add support for numeric. + +0.1.0: + * Removed instance of ToSql for LocalTime, added two new + newtypes: Datetime2 and Smalldatetime. + +0.0.4: + * Improved non-Unicode field support: varchar/text treated as + actual binary, not "characters" in the SQL server sense. + +0.0.3: + * Handle multiple statements in exec call. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -45,11 +45,12 @@ putStr "> " catch (fmap Just T.getLine) (\(_ :: IOException) -> pure Nothing) output count row = do - putStrLn (intercalate ", " (map (maybe "NULL" showColumn) row)) + putStrLn (intercalate ", " (map showColumn row)) pure (ODBC.Continue (count + 1)) where showColumn = \case + ODBC.NullValue -> "NULL" ODBC.TextValue t -> show t ODBC.ByteStringValue bs -> show bs ODBC.BinaryValue bs -> show bs diff --git a/odbc.cabal b/odbc.cabal --- a/odbc.cabal +++ b/odbc.cabal @@ -5,11 +5,11 @@ suite runs on OS X, Windows and Linux. copyright: FP Complete 2018 maintainer: chrisdone@fpcomplete.com -version: 0.1.1 +version: 0.2.0 license: BSD3 license-file: LICENSE build-type: Simple -extra-source-files: README.md doc/style.css doc/patch.sh doc/init.js doc/highlight.pack.js +extra-source-files: README.md CHANGELOG doc/style.css doc/patch.sh doc/init.js doc/highlight.pack.js cabal-version: >=1.10 homepage: https://github.com/fpco/odbc diff --git a/src/Database/ODBC/Conversion.hs b/src/Database/ODBC/Conversion.hs --- a/src/Database/ODBC/Conversion.hs +++ b/src/Database/ODBC/Conversion.hs @@ -24,116 +24,95 @@ -- | Convert from a 'Value' to a regular Haskell value. class FromValue a where - fromValue :: Maybe Value -> Either String a + fromValue :: Value -> Either String a -- ^ The 'String' is used for a helpful error message. --- | Expect a value to be non-null. -withNonNull :: - (Value -> Either String a) -> Maybe Value -> Either String a -withNonNull f = - \case - Nothing -> Left "Unexpected NULL for value" - Just v -> f v - instance FromValue a => FromValue (Maybe a) where fromValue = \case - Nothing -> pure Nothing - Just v -> fmap Just (fromValue (Just v)) + NullValue -> pure Nothing + v -> fmap Just (fromValue v) instance FromValue Value where - fromValue = withNonNull pure + fromValue = pure instance FromValue Text where fromValue = - withNonNull - (\case - TextValue x -> pure (id x) - v -> Left ("Expected Text, but got: " ++ show v)) + (\case + TextValue x -> pure (id x) + v -> Left ("Expected Text, but got: " ++ show v)) instance FromValue LT.Text where fromValue = - withNonNull - (\case - TextValue x -> pure (LT.fromStrict x) - v -> Left ("Expected Text, but got: " ++ show v)) + (\case + TextValue x -> pure (LT.fromStrict x) + v -> Left ("Expected Text, but got: " ++ show v)) instance FromValue ByteString where fromValue = - withNonNull - (\case - ByteStringValue x -> pure (id x) - v -> Left ("Expected ByteString, but got: " ++ show v)) + (\case + ByteStringValue x -> pure (id x) + v -> Left ("Expected ByteString, but got: " ++ show v)) instance FromValue Binary where fromValue = - withNonNull - (\case - BinaryValue x -> pure (id x) - v -> Left ("Expected Binary, but got: " ++ show v)) + (\case + BinaryValue x -> pure (id x) + v -> Left ("Expected Binary, but got: " ++ show v)) instance FromValue L.ByteString where fromValue = - withNonNull - (\case - ByteStringValue x -> pure (L.fromStrict x) - v -> Left ("Expected ByteString, but got: " ++ show v)) + (\case + ByteStringValue x -> pure (L.fromStrict x) + v -> Left ("Expected ByteString, but got: " ++ show v)) instance FromValue Int where fromValue = - withNonNull - (\case - IntValue x -> pure (id x) - v -> Left ("Expected Int, but got: " ++ show v)) + (\case + IntValue x -> pure (id x) + v -> Left ("Expected Int, but got: " ++ show v)) instance FromValue Double where fromValue = - withNonNull - (\case - DoubleValue x -> pure (id x) - v -> Left ("Expected Double, but got: " ++ show v)) + (\case + DoubleValue x -> pure (id x) + v -> Left ("Expected Double, but got: " ++ show v)) instance FromValue Float where fromValue = - withNonNull - (\case - FloatValue x -> pure (realToFrac x) - v -> Left ("Expected Float, but got: " ++ show v)) + (\case + FloatValue x -> pure (realToFrac x) + v -> Left ("Expected Float, but got: " ++ show v)) instance FromValue Word8 where fromValue = - withNonNull - (\case - ByteValue x -> pure x - v -> Left ("Expected Byte, but got: " ++ show v)) + (\case + ByteValue x -> pure x + v -> Left ("Expected Byte, but got: " ++ show v)) instance FromValue Bool where fromValue = - withNonNull - (\case - BoolValue x -> pure (id x) - v -> Left ("Expected Bool, but got: " ++ show v)) + (\case + BoolValue x -> pure (id x) + v -> Left ("Expected Bool, but got: " ++ show v)) instance FromValue Day where fromValue = - withNonNull - (\case - DayValue x -> pure (id x) - v -> Left ("Expected Day, but got: " ++ show v)) + (\case + DayValue x -> pure (id x) + v -> Left ("Expected Day, but got: " ++ show v)) instance FromValue TimeOfDay where fromValue = - withNonNull - (\case - TimeOfDayValue x -> pure (id x) - v -> Left ("Expected TimeOfDay, but got: " ++ show v)) + (\case + TimeOfDayValue x -> pure (id x) + v -> Left ("Expected TimeOfDay, but got: " ++ show v)) instance FromValue LocalTime where fromValue = - withNonNull - (\case - LocalTimeValue x -> pure (id x) - v -> Left ("Expected LocalTime, but got: " ++ show v)) + (\case + LocalTimeValue x -> pure (id x) + v -> Left ("Expected LocalTime, but got: " ++ show v)) -------------------------------------------------------------------------------- -- Producing rows @@ -144,9 +123,10 @@ -- e.g. @[Maybe Value]@ if you don't know what you're dealing with, or -- a tuple e.g. @(Text, Int, Bool)@. class FromRow r where - fromRow :: [Maybe Value] -> Either String r + fromRow :: [Value] -> Either String r instance FromValue v => FromRow (Maybe v) where + fromRow [NullValue] = Right Nothing fromRow [v] = fromValue v fromRow _ = Left "Unexpected number of fields in row" @@ -154,7 +134,7 @@ fromRow [v] = fmap Identity (fromValue v) fromRow _ = Left "Unexpected number of fields in row" -instance FromRow [Maybe Value] where +instance FromRow [Value] where fromRow = pure instance FromRow Value where 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 @@ -123,6 +123,8 @@ -- ^ Time of day (hh, mm, ss + fractional) values. | LocalTimeValue !LocalTime -- ^ Local date and time. + | NullValue + -- ^ SQL null value. deriving (Eq, Show, Typeable, Ord, Generic, Data) instance NFData Value @@ -238,7 +240,7 @@ MonadIO m => Connection -- ^ A connection to the database. -> Text -- ^ SQL query. - -> m [[Maybe Value]] + -> m [[Value]] -- ^ A strict list of rows. This list is not lazy, so if you are -- retrieving a large data set, be aware that all of it will be -- loaded into memory. @@ -254,7 +256,7 @@ (MonadIO m, MonadUnliftIO m) => Connection -- ^ A connection to the database. -> Text -- ^ SQL query. - -> (state -> [Maybe Value] -> m (Step state)) + -> (state -> [Value] -> m (Step state)) -- ^ A stepping function that gets as input the current @state@ and -- a row, returning either a new @state@ or a final @result@. -> state @@ -329,7 +331,7 @@ fetchIterator :: Ptr EnvAndDbc -> UnliftIO m - -> (state -> [Maybe Value] -> m (Step state)) + -> (state -> [Value] -> m (Step state)) -> state -> SQLHSTMT s -> IO state @@ -382,7 +384,7 @@ (fetchAllResults dbc stmt) -- | Fetch all rows from a statement. -fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[Maybe Value]] +fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[Value]] fetchStatementRows dbc stmt = do SQLSMALLINT cols <- withMalloc @@ -457,7 +459,7 @@ })))))))) -- | Pull data for the given column. -getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO (Maybe Value) +getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO Value getData dbc stmt i col = if | colType == sql_longvarchar -> getBytesData dbc stmt i | colType == sql_varchar -> getBytesData dbc stmt i @@ -471,9 +473,9 @@ (\bitPtr -> do mlen <- getTypedData dbc stmt sql_c_bit i (coerce bitPtr) (SQLLEN 1) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> - fmap (Just . BoolValue . (/= (0 :: Word8))) (peek bitPtr)) + fmap (BoolValue . (/= (0 :: Word8))) (peek bitPtr)) | colType == sql_double -> withMalloc (\doublePtr -> do @@ -481,10 +483,10 @@ getTypedData dbc stmt sql_c_double i (coerce doublePtr) (SQLLEN 8) -- float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> do !d <- fmap DoubleValue (peek doublePtr) - pure (Just d)) + pure d) | colType == sql_float -> withMalloc (\floatPtr -> do @@ -493,10 +495,10 @@ -- SQLFLOAT is covered by SQL_C_DOUBLE: https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> do !d <- fmap DoubleValue (peek floatPtr) - pure (Just d)) + pure d) | colType == sql_real -> withMalloc (\floatPtr -> do @@ -505,13 +507,13 @@ -- SQLFLOAT is covered by SQL_C_DOUBLE: https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> do !d <- fmap (FloatValue . (realToFrac :: Double -> Float)) (peek floatPtr) - pure (Just d)) + pure d) | colType == sql_numeric || colType == sql_decimal -> withMalloc (\floatPtr -> do @@ -520,20 +522,20 @@ -- NUMERIC/DECIMAL can be read as FLOAT -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> do !d <- fmap DoubleValue (peek floatPtr) - pure (Just d)) + pure d) | colType == sql_integer -> withMalloc (\intPtr -> do mlen <- getTypedData dbc stmt sql_c_long i (coerce intPtr) (SQLLEN 4) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> fmap - (Just . IntValue . fromIntegral) + (IntValue . fromIntegral) (peek (intPtr :: Ptr Int32))) | colType == sql_bigint -> withMalloc @@ -541,10 +543,10 @@ mlen <- getTypedData dbc stmt sql_c_bigint i (coerce intPtr) (SQLLEN 8) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> fmap - (Just . IntValue . fromIntegral) + (IntValue . fromIntegral) (peek (intPtr :: Ptr Int64))) | colType == sql_smallint -> withMalloc @@ -552,10 +554,10 @@ mlen <- getTypedData dbc stmt sql_c_short i (coerce intPtr) (SQLLEN 2) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> fmap - (Just . IntValue . fromIntegral) + (IntValue . fromIntegral) (peek (intPtr :: Ptr Int16))) | colType == sql_tinyint -> withMalloc @@ -563,8 +565,8 @@ mlen <- getTypedData dbc stmt sql_c_short i (coerce intPtr) (SQLLEN 1) case mlen of - Nothing -> pure Nothing - Just {} -> fmap (Just . ByteValue) (peek (intPtr :: Ptr Word8))) + Nothing -> pure NullValue + Just {} -> fmap ByteValue (peek (intPtr :: Ptr Word8))) | colType == sql_type_date -> withMallocBytes 3 @@ -572,10 +574,10 @@ mlen <- getTypedData dbc stmt sql_c_date i (coerce datePtr) (SQLLEN 3) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> fmap - (Just . DayValue) + DayValue (fromGregorian <$> (fmap fromIntegral (odbc_DATE_STRUCT_year datePtr)) <*> (fmap fromIntegral (odbc_DATE_STRUCT_month datePtr)) <*> @@ -594,10 +596,10 @@ (coerce datePtr) (SQLLEN 12) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> fmap - (Just . TimeOfDayValue) + TimeOfDayValue (TimeOfDay <$> (fmap fromIntegral (odbc_TIME_STRUCT_hour datePtr)) <*> (fmap fromIntegral (odbc_TIME_STRUCT_minute datePtr)) <*> @@ -615,10 +617,10 @@ (coerce timestampPtr) (SQLLEN 16) case mlen of - Nothing -> pure Nothing + Nothing -> pure NullValue Just {} -> fmap - (Just . LocalTimeValue) + LocalTimeValue (LocalTime <$> (fromGregorian <$> (fmap fromIntegral (odbc_TIMESTAMP_STRUCT_year timestampPtr)) <*> @@ -649,8 +651,8 @@ colType = columnType col -- | Get a GUID as a binary value. -getGuid :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value) -getGuid dbc stmt column = +getGuid :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value +getGuid dbc stmt column = do uninterruptibleMask_ (do bufferp <- callocBytes odbcGuidBytes void @@ -662,14 +664,14 @@ (coerce bufferp) (SQLLEN odbcGuidBytes)) !bs <- S.unsafePackMallocCStringLen (bufferp, odbcGuidBytes) - evaluate (Just (BinaryValue (Binary bs)))) + evaluate (BinaryValue (Binary bs))) -- | Get the column's data as a vector of CHAR. -getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value) +getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value getBytesData dbc stmt column = do mavailableBytes <- getSize dbc stmt sql_c_binary column case mavailableBytes of - Just 0 -> pure (Just (ByteStringValue mempty)) + Just 0 -> pure (ByteStringValue mempty) Just availableBytes -> uninterruptibleMask_ (do let allocBytes = availableBytes + 1 @@ -685,15 +687,15 @@ bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBytes) - evaluate (Just (ByteStringValue bs))) - Nothing -> pure Nothing + evaluate (ByteStringValue bs)) + Nothing -> pure NullValue -- | Get the column's data as raw binary. -getBinaryData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value) +getBinaryData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value getBinaryData dbc stmt column = do mavailableBinary <- getSize dbc stmt sql_c_binary column case mavailableBinary of - Just 0 -> pure (Just (BinaryValue (Binary mempty))) + Just 0 -> pure (BinaryValue (Binary mempty)) Just availableBinary -> uninterruptibleMask_ (do let allocBinary = availableBinary @@ -709,16 +711,16 @@ bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBinary) - evaluate (Just (BinaryValue (Binary bs)))) - Nothing -> pure Nothing + evaluate (BinaryValue (Binary bs))) + Nothing -> pure NullValue -- | Get the column's data as a text string. -getTextData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value) +getTextData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value getTextData dbc stmt column = do mavailableChars <- getSize dbc stmt sql_c_wchar column case mavailableChars of - Just 0 -> pure (Just (TextValue mempty)) - Nothing -> pure Nothing + Just 0 -> pure (TextValue mempty) + Nothing -> pure NullValue Just availableBytes -> do let allocBytes = availableBytes + 2 withMallocBytes @@ -734,7 +736,7 @@ (SQLLEN (fromIntegral allocBytes))) t <- T.fromPtr bufferp (fromIntegral (div availableBytes 2)) let !v = TextValue t - pure (Just v)) + pure v) -- | Get some data into the given pointer. getTypedData :: 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 @@ -106,7 +106,7 @@ -- exec conn "DROP TABLE IF EXISTS example" -- exec conn "CREATE TABLE example (id int, name ntext, likes_tacos bit)" -- exec conn "INSERT INTO example VALUES (1, \'Chris\', 0), (2, \'Mary\', 1)" --- rows <- query conn "SELECT * FROM example" :: IO [[Maybe Value]] +-- rows <- query conn "SELECT * FROM example" :: IO [[Value]] -- print rows -- rows2 <- query conn "SELECT * FROM example" :: IO [(Int,Text,Bool)] -- print rows2 @@ -123,7 +123,7 @@ -- The output of this program for @rows@: -- -- @ --- [[Just (IntValue 1),Just (TextValue \"Chris\"),Just (BoolValue False)],[Just (IntValue 2),Just (TextValue \"Mary\"),Just (BoolValue True)]] +-- [[IntValue 1, TextValue \"Chris\", BoolValue False],[ IntValue 2, TextValue \"Mary\", BoolValue True]] -- @ -- -- The output for @rows2@: @@ -186,16 +186,12 @@ -- stream -- conn -- \"SELECT * FROM example\" --- (\\longest mtext -> +-- (\\longest text -> -- pure -- (Continue --- (maybe --- longest --- (\\text -> --- if T.length text > T.length longest --- then text --- else longest) --- mtext))) +-- (if T.length text > T.length longest +-- then text +-- else longest))) -- \"\" -- print longest) -- @ @@ -272,6 +268,9 @@ class ToSql a where toSql :: a -> Query +instance ToSql a => ToSql (Maybe a) where + toSql = maybe (Query (Seq.fromList [ValuePart NullValue])) toSql + -- | Converts whatever the 'Value' is to SQL. instance ToSql Value where toSql = Query . Seq.fromList . pure . ValuePart @@ -444,6 +443,7 @@ renderValue :: Value -> Text renderValue = \case + NullValue -> "NULL" TextValue t -> "(N'" <> T.concatMap escapeChar t <> "')" BinaryValue (Internal.Binary bytes) -> "0x" <> diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} @@ -160,7 +163,7 @@ quickCheckRoundtrip @ByteString "ByteString" ("varchar(" <> (show maxStringLen) <> ")") quickCheckRoundtrip @TestBinary "ByteString" ("binary(" <> (show maxStringLen) <> ")") quickCheckRoundtrip @Binary "ByteString" ("varbinary(" <> (show maxStringLen) <> ")") - quickCheckRoundtrip @TestGUID "GUID" "uniqueidentifier" + quickCheckRoundtripEx @TestGUID False "GUID" "uniqueidentifier" connectivity :: Spec connectivity = do @@ -201,19 +204,19 @@ Internal.close c shouldBe rows - [ [ Just (IntValue 123) - , Just (ByteStringValue "abc") - , Just (BoolValue True) - , Just (TextValue "wib") - , Just (DoubleValue 2.415) + [ [ (IntValue 123) + , (ByteStringValue "abc") + , (BoolValue True) + , (TextValue "wib") + , (DoubleValue 2.415) ] - , [ Just (IntValue 456) - , Just (ByteStringValue "def") - , Just (BoolValue False) - , Just (TextValue "wibble") - , Just (DoubleValue 0.9999999999999) + , [ (IntValue 456) + , (ByteStringValue "def") + , (BoolValue False) + , (TextValue "wibble") + , (DoubleValue 0.9999999999999) ] - , [Nothing, Nothing, Nothing, Nothing, Nothing] + , [NullValue, NullValue, NullValue, NullValue, NullValue] ]) it "Querying commands with no results" @@ -301,11 +304,20 @@ shouldBe result input) quickCheckRoundtrip :: - forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t) + forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t, ToSql (Maybe t)) => String -> String -> Spec -quickCheckRoundtrip l typ = +quickCheckRoundtrip = quickCheckRoundtripEx @t True + +quickCheckRoundtripEx :: + forall t. + (Arbitrary t, Eq t, Show t, ToSql t, FromValue t, ToSql (Maybe t)) + => Bool + -> String + -> String + -> Spec +quickCheckRoundtripEx testMaybes l typ = beforeAll (do c <- connectWithString SQLServer.exec c "DROP TABLE IF EXISTS test" @@ -313,44 +325,66 @@ pure c) (afterAll SQLServer.close - (it - ("QuickCheck roundtrip: HS=" <> l <> ", SQL=" <> typ) - (\c -> - property - (\input -> - monadicIO - (do SQLServer.exec c "TRUNCATE TABLE test" - let q = - "INSERT INTO test VALUES (" <> toSql (input :: t) <> - ")" - liftIO - (catch - (SQLServer.exec c q) - (\e -> do - print (e :: SomeException) - T.putStrLn (SQLServer.renderQuery q) - SQLServer.close c - throwIO e)) - [Identity result] <- - SQLServer.query c "SELECT f FROM test" - when - (result /= input) - (liftIO - (putStr - (unlines - [ "Expected: " ++ show input - , "Actual: " ++ show result - , "Query was: " ++ show q - ]))) - monitor - (counterexample - (unlines - [ "Expected: " ++ show input - , "Actual: " ++ show result - , "Query was: " ++ - T.unpack (SQLServer.renderQuery q) - ])) - assert (result == input)))))) + (let makeIt :: + forall t'. + ( Arbitrary t' + , Show t' + , ToSql t' + , FromValue t' + , Eq t' + , ToSql (Maybe t') + ) + => String + -> String + -> (t -> t') + -> SpecWith Connection + makeIt l' typ' f = + it + ("QuickCheck roundtrip: HS=" <> l' <> ", SQL=" <> typ') + (\c -> + property + (\(f -> input) -> + monadicIO + (do SQLServer.exec c "TRUNCATE TABLE test" + let q = + "INSERT INTO test VALUES (" <> toSql input <> + ")" + liftIO + (catch + (SQLServer.exec c q) + (\e -> do + print (e :: SomeException) + T.putStrLn (SQLServer.renderQuery q) + SQLServer.close c + throwIO e)) + [Identity result] <- + SQLServer.query c "SELECT f FROM test" + when + (result /= input) + (liftIO + (putStr + (unlines + [ "Expected: " ++ show input + , "Actual: " ++ show result + , "Query was: " ++ show q + ]))) + monitor + (counterexample + (unlines + [ "Expected: " ++ show input + , "Actual: " ++ show result + , "Query was: " ++ + T.unpack (SQLServer.renderQuery q) + ])) + assert (result == input)))) + in do makeIt l typ id + when + testMaybes + (do makeIt ("Maybe " ++ l) typ Just + makeIt + ("Maybe " ++ l) + (typ ++ " (NULL)") + (const Nothing :: a -> Maybe a)))) quickCheckOneway :: forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t) @@ -434,7 +468,7 @@ result :: Either String t result = case rows of - Right [[Just x]] -> + Right [[x]] -> case unpack x of Nothing -> Left "Couldn't unpack value." Just v -> pure v