diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ # Changelog -# Changelog +## 0.1.2.0 +- Added LIST/MAP coverage note: LIST columns decode into Haskell lists and MAP columns into strict `Map k v`, with matching parameter bindings via `ToField`. +- Taught `FromField` to interpret `FieldBigNum` as `Integer`/`Natural` and added matching `ToField` instances for `BigNum`, `Integer`, and `Natural` so BIGNUM parameters round-trip without truncation. +- Added `duckdbColumnType` helper and `DuckDBColumnType` class, exposing the DuckDB column type associated with each `ToField` instance. +- Fixed UUID decoding by undoing DuckDB’s upper-word bias and added a UUID round-trip regression test. +- Fixed BIT encoding and decoding ## 0.1.1.2 - Broadened `FieldValue` and `FromField` coverage to handle all DuckDB scalar types, including intervals, HUGEINT/UHUGEINT, decimals (with metadata), time/timestamp with additional precisions, timezone-aware values, bit strings, bignums, and enums. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,8 +3,10 @@ `duckdb-simple` provides a high-level Haskell interface to DuckDB inspired by the ergonomics of [`sqlite-simple`](https://hackage.haskell.org/package/sqlite-simple). It builds on the low-level bindings exposed by [`duckdb-ffi`](../duckdb-ffi) and -provides a small, focused API for opening connections, running queries, binding -parameters, and decoding typed results. +provides a focused API for opening connections, running queries, binding +parameters, and decoding typed results—including the full set of DuckDB scalar +types (signed/unsigned integers, decimals, hugeints, intervals, precise and +timezone-aware temporals, blobs, enums, bit strings, and bignums). ## Getting Started @@ -25,14 +27,14 @@ ### Key Modules -- `Database.DuckDB.Simple` – primary API: connections, statements, execution, - queries, and error handling. -- `Database.DuckDB.Simple.ToField` / `ToRow` – typeclasses for preparing - parameters that can be passed to `execute`/`query`. +- `Database.DuckDB.Simple` – connections, prepared statements, execution, + queries, metadata, and error handling. +- `Database.DuckDB.Simple.ToField` / `ToRow` – typeclasses and helpers for + preparing positional or named parameters. - `Database.DuckDB.Simple.FromField` / `FromRow` – typeclasses for decoding - query results returned by `query`/`query_`. -- `Database.DuckDB.Simple.Types` – common utility types (`Query`, `Null`, - `Only`, `(:.)`, `SQLError`). + query results, with generic deriving support for product types. +- `Database.DuckDB.Simple.Types` – shared types (`Query`, `Null`, `Only`, + `(:.)`, `SQLError`). - `Database.DuckDB.Simple.Function` – register scalar Haskell functions that can be invoked directly from SQL. @@ -70,10 +72,10 @@ ["$kind" := ("metric" :: String), "$payload" := ("ok" :: String)] ``` -DuckDB currently does not allow mixing positional and named placeholders within -the same SQL statement; the library preserves DuckDB’s error message in that -situation. Savepoints are also unavailable in DuckDB at the moment, so -`withSavepoint` throws an `SQLError` detailing the limitation. +DuckDB does not allow mixing positional and named placeholders within the same +SQL statement; the library preserves DuckDB’s error message in that situation. +Savepoints are currently rejected by DuckDB, so `withSavepoint` raises an +`SQLError` describing the limitation. If the number of supplied parameters does not match the statement’s declared placeholders—or if you attempt to bind named arguments to a positional-only @@ -140,32 +142,19 @@ For manual cursor-style iteration, use `nextRow`/`nextRowWith` on an open `Statement` to pull rows one at a time and decide when to stop. -### Temporal & Binary Types - -`duckdb-simple` now maps DuckDB temporal columns directly onto familiar -`Data.Time` types (`DATE` → `Day`, `TIME` → `TimeOfDay`, `TIMESTAMP` → -`LocalTime`/`UTCTime`). Binary blobs surface as strict `ByteString` values. Casting -logic plugs into the existing `ToField`/`FromField` classes, so round-tripping values -through prepared statements works just like the numeric and text helpers shown earlier. - -### Feature Coverage & Roadmap - -Included today: +### Feature Coverage - Connections, prepared statements, positional/named parameter binding. - High-level execution (`execute*`) and eager queries (`query*`, `queryNamed`). -- Streaming/folding helpers (`fold`, `foldNamed`, `fold_`, `nextRow`). -- Temporal (`Day`, `TimeOfDay`, `LocalTime`, `UTCTime`) and blob (`ByteString`) - round-trips via `FromField`/`ToField` instances. -- Row decoding via `FromField`/`FromRow`, including generic deriving support. -- Basic transaction helpers (`withTransaction`, `withSavepoint` fallback). -- Metadata helpers: `columnCount`, `columnName`, and connection-level - `rowsChanged`. - -Planned for a future release: - -- Broader type coverage for structured/list/decimal families, including UUID-friendly APIs. -- Native savepoints once DuckDB exposes the required support. +- Streaming helpers (`fold`, `foldNamed`, `fold_`, `nextRow`) for constant-space + result processing. +- Comprehensive scalar type support: signed/unsigned integers, HUGEINT/UHUGEINT, + decimals (with width/scale), intervals, precise and timezone-aware temporals, + enums, bit strings, blobs, and bignums. +- Row decoding via `FromField`/`FromRow`, with generic deriving for product types. +- User-defined scalar functions backed by Haskell functions. +- Transaction helpers (`withTransaction`, `withSavepoint` fallback) and metadata + accessors (`columnCount`, `columnName`, `rowsChanged`). ## User-Defined Functions @@ -190,10 +179,9 @@ Exceptions raised while the function executes are propagated back to DuckDB as `SQLError` values, and `deleteFunction` issues a `DROP FUNCTION IF EXISTS` -statement to remove the registration. Current DuckDB releases mark C API -registrations as internal, so the drop operation reports an error instead of -removing the function; duckdb-simple surfaces that limitation as an -`SQLError`. +statement to remove the registration. DuckDB registers C API scalar functions +as internal entries; attempting to drop them this way will yield an error, which +the library surfaces as an `SQLError`. ## Tests diff --git a/duckdb-simple.cabal b/duckdb-simple.cabal --- a/duckdb-simple.cabal +++ b/duckdb-simple.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: duckdb-simple -version: 0.1.1.2 +version: 0.1.2.0 license: MPL-2.0 license-file: LICENSE author: Matthias Pall Gissurarson @@ -42,9 +42,11 @@ build-depends: base >=4.14 && <5 , bytestring >= 0.11 && <0.12 - , duckdb-ffi >= 1.4 && <1.5 + , containers >= 0.6 && <0.7 + , duckdb-ffi >= 1.4.1.2 && <1.5 , text >= 2.0 && <2.1 , transformers >= 0.6 && <0.7 + , uuid >=1.3 && <1.4 , time >= 1.12 && <1.13 test-suite duckdb-simple-test @@ -56,7 +58,12 @@ base >=4.14 && <5 , duckdb-simple , bytestring + , containers >= 0.6 && <0.7 , text , tasty >=1.4 && <1.6 , tasty-hunit >=0.10 && <0.12 + , tasty-quickcheck >=0.10 && <0.11 + , tasty-expected-failure >=0.12 && <0.13 + , QuickCheck >=2.14 && <2.15 + , uuid >=1.3 && <1.4 , time diff --git a/src/Database/DuckDB/Simple.hs b/src/Database/DuckDB/Simple.hs --- a/src/Database/DuckDB/Simple.hs +++ b/src/Database/DuckDB/Simple.hs @@ -63,6 +63,8 @@ ToRow (..), FieldBinding, NamedParam (..), + DuckDBColumnType (..), + duckdbColumnType, Null (..), Only (..), (:.) (..), @@ -73,11 +75,11 @@ deleteFunction, ) where -import Control.Monad (forM, foldM, join, void, when, zipWithM, zipWithM_) +import Control.Monad (forM, join, void, when, zipWithM, zipWithM_) import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef) import Control.Exception (SomeException, bracket, finally, mask, onException, throwIO, try) import qualified Data.ByteString as BS -import Data.Bits ((.|.), shiftL) +import Data.Bits ((.|.), shiftL, Bits (..)) import Data.Int (Int16, Int32, Int64, Int8) import Data.Maybe (isJust, isNothing) import Data.Text (Text) @@ -105,9 +107,10 @@ , FieldValue (..) , FieldParser , FromField (..) - , ResultError (..) , IntervalValue (..) + , ResultError (..) , TimeWithZone (..) + , fromBigNumBytes ) import Database.DuckDB.Simple.FromRow ( FromRow (..) @@ -135,15 +138,16 @@ , withQueryCString , withStatementHandle ) -import Database.DuckDB.Simple.ToField (FieldBinding, NamedParam (..), ToField (..), bindFieldBinding, renderFieldBinding) +import Database.DuckDB.Simple.ToField (DuckDBColumnType (..), FieldBinding, NamedParam (..), ToField (..), bindFieldBinding, duckdbColumnType, renderFieldBinding) import Database.DuckDB.Simple.ToRow (ToRow (..)) import Database.DuckDB.Simple.Types (FormatError (..), Null (..), Only (..), (:.) (..)) import Foreign.C.String (CString, peekCString, withCString) -import Foreign.C.Types (CBool (..), CDouble (..)) +import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Alloc (alloca, free, malloc) import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) -import Foreign.Storable (peek, peekElemOff, poke) +import Foreign.Storable (Storable (..), peekElemOff, peekByteOff, pokeByteOff) import Database.DuckDB.Simple.Ok (Ok(..)) +import qualified Data.UUID as UUID -- | Open a DuckDB database located at the supplied path. open :: FilePath -> IO Connection @@ -537,7 +541,7 @@ withStatementHandle stmt \handle -> do columns <- collectStreamColumns handle resultPtr <- malloc - rc <- c_duckdb_execute_prepared_streaming handle resultPtr + rc <- c_duckdb_execute_prepared handle resultPtr if rc /= DuckDBSuccess then do (errMsg, errType) <- fetchResultError resultPtr @@ -582,7 +586,7 @@ fetchChunk :: StatementStream -> IO StatementStream fetchChunk stream@StatementStream{statementStreamResult} = do - chunk <- c_duckdb_stream_fetch_chunk statementStreamResult + chunk <- c_duckdb_fetch_chunk statementStreamResult if chunk == nullPtr then pure stream else do @@ -638,7 +642,7 @@ zipWithM (buildField queryText rowIdx) columns vectors buildField :: Query -> Int -> StatementStreamColumn -> StatementStreamChunkVector -> IO Field -buildField queryText rowIdx column StatementStreamChunkVector{statementStreamChunkVectorData, statementStreamChunkVectorValidity} = do +buildField queryText rowIdx column StatementStreamChunkVector{statementStreamChunkVectorHandle, statementStreamChunkVectorData, statementStreamChunkVectorValidity} = do let duckIdx = fromIntegral rowIdx dtype = statementStreamColumnType column valid <- chunkIsRowValid statementStreamChunkVectorValidity duckIdx @@ -695,8 +699,16 @@ raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Double) rowIdx pure (FieldDouble raw) DuckDBTypeVarchar -> FieldText <$> chunkDecodeText statementStreamChunkVectorData duckIdx - DuckDBTypeHugeInt -> error "duckdb-simple: HUGEINT is not supported" - DuckDBTypeUHugeInt -> error "duckdb-simple: HUGEINT is not supported" + DuckDBTypeList -> FieldList <$> decodeListElements statementStreamChunkVectorHandle statementStreamChunkVectorData rowIdx + DuckDBTypeMap -> FieldMap <$> decodeMapPairs statementStreamChunkVectorHandle statementStreamChunkVectorData rowIdx + DuckDBTypeStruct -> error "duckdb-simple: STRUCT columns are not supported" + DuckDBTypeUnion -> error "duckdb-simple: UNION columns are not supported" + DuckDBTypeHugeInt -> do + raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr DuckDBHugeInt) rowIdx + pure (FieldHugeInt (duckDBHugeIntToInteger raw)) + DuckDBTypeUHugeInt -> do + raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr DuckDBUHugeInt) rowIdx + pure (FieldUHugeInt (duckDBUHugeIntToInteger raw)) _ -> throwIO (streamingUnsupportedTypeError queryText column) pure @@ -1014,20 +1026,33 @@ collectRows :: Ptr DuckDBResult -> IO [[Field]] collectRows resPtr = do columns <- collectResultColumns resPtr - chunkCount <- (fromIntegral <$> c_duckdb_result_chunk_count resPtr) :: IO Int - if null columns || chunkCount <= 0 - then pure [] - else do - (_, chunks) <- - foldM - (\(rowBase, acc) chunkIdx -> do - (nextBase, chunkRows) <- collectChunkRows resPtr columns chunkIdx rowBase - pure (nextBase, chunkRows : acc) - ) - (0, []) - [0 .. chunkCount - 1] - pure (concat (reverse chunks)) + collectChunks columns [] + where + collectChunks columns acc = do + chunk <- c_duckdb_fetch_chunk resPtr + if chunk == nullPtr + then pure (concat (reverse acc)) + else do + rows <- + finally + (decodeChunk columns chunk) + (destroyDataChunk chunk) + let acc' = maybe acc (: acc) rows + collectChunks columns acc' + decodeChunk columns chunk = do + rawSize <- c_duckdb_data_chunk_get_size chunk + let rowCount = fromIntegral rawSize :: Int + if rowCount <= 0 + then pure Nothing + else + if null columns + then pure (Just (replicate rowCount [])) + else do + vectors <- prepareChunkVectors chunk columns + rows <- mapM (buildMaterializedRow columns vectors) [0 .. rowCount - 1] + pure (Just rows) + collectResultColumns :: Ptr DuckDBResult -> IO [StatementStreamColumn] collectResultColumns resPtr = do rawCount <- c_duckdb_column_count resPtr @@ -1046,32 +1071,6 @@ , statementStreamColumnType = dtype } -collectChunkRows :: Ptr DuckDBResult -> [StatementStreamColumn] -> Int -> Int -> IO (Int, [[Field]]) -collectChunkRows resPtr columns chunkIndex rowBase = do - chunk <- c_duckdb_result_get_chunk resPtr (fromIntegral chunkIndex) - if chunk == nullPtr - then pure (rowBase, []) - else - finally - (do - rawSize <- c_duckdb_data_chunk_get_size chunk - let rowCount = fromIntegral rawSize :: Int - when (rowCount > 0 && not (null columns)) $ - void $ - fetchFieldValue - resPtr - (statementStreamColumnType (head columns)) - (statementStreamColumnIndex (head columns)) - rowBase - if rowCount <= 0 - then pure (rowBase, []) - else do - vectors <- prepareChunkVectors chunk columns - rows <- mapM (buildMaterializedRow columns vectors) [0 .. rowCount - 1] - pure (rowBase + rowCount, rows) - ) - (destroyDataChunk chunk) - buildMaterializedRow :: [StatementStreamColumn] -> [StatementStreamChunkVector] -> Int -> IO [Field] buildMaterializedRow columns vectors rowIdx = zipWithM (buildMaterializedField rowIdx) columns vectors @@ -1092,41 +1091,87 @@ , fieldValue = value } -fetchFieldValue :: Ptr DuckDBResult -> DuckDBType -> Int -> Int -> IO FieldValue -fetchFieldValue resPtr dtype columnIndex rowIndex = - withChunkForRow resPtr rowIndex \chunk localRow -> do - vector <- c_duckdb_data_chunk_get_vector chunk (fromIntegral columnIndex) - dataPtr <- c_duckdb_vector_get_data vector - validity <- c_duckdb_vector_get_validity vector - materializedValueFromPointers dtype vector dataPtr validity localRow +data DuckDBListEntry = DuckDBListEntry + { duckDBListEntryOffset :: !Word64 + , duckDBListEntryLength :: !Word64 + } + deriving (Eq, Show) -withChunkForRow :: Ptr DuckDBResult -> Int -> (DuckDBDataChunk -> Int -> IO a) -> IO a -withChunkForRow resPtr targetRow action = do - chunkCount <- (fromIntegral <$> c_duckdb_result_chunk_count resPtr) :: IO Int - let seek chunkIdx remaining - | chunkIdx >= chunkCount = - throwIO (userError "duckdb-simple: row index out of bounds while materialising result") - | otherwise = do - chunk <- c_duckdb_result_get_chunk resPtr (fromIntegral chunkIdx) - if chunk == nullPtr - then seek (chunkIdx + 1) remaining - else do - rawSize <- c_duckdb_data_chunk_get_size chunk - let rowCount = fromIntegral rawSize :: Int - if rowCount <= 0 - then do - destroyDataChunk chunk - seek (chunkIdx + 1) remaining - else if remaining < rowCount - then - finally - (action chunk remaining) - (destroyDataChunk chunk) - else do - destroyDataChunk chunk - seek (chunkIdx + 1) (remaining - rowCount) - seek 0 targetRow +instance Storable DuckDBListEntry where + sizeOf _ = listEntryWordSize * 2 + alignment _ = alignment (0 :: Word64) + peek ptr = do + offset <- peekByteOff ptr 0 + len <- peekByteOff ptr listEntryWordSize + pure DuckDBListEntry{duckDBListEntryOffset = offset, duckDBListEntryLength = len} + poke ptr DuckDBListEntry{duckDBListEntryOffset, duckDBListEntryLength} = do + pokeByteOff ptr 0 duckDBListEntryOffset + pokeByteOff ptr listEntryWordSize duckDBListEntryLength +listEntryWordSize :: Int +listEntryWordSize = sizeOf (0 :: Word64) + +decodeListElements :: DuckDBVector -> Ptr () -> Int -> IO [FieldValue] +decodeListElements vector dataPtr rowIdx = do + entry <- peekElemOff (castPtr dataPtr :: Ptr DuckDBListEntry) rowIdx + (baseIdx, len) <- listEntryBounds (Text.pack "list") entry + childVec <- c_duckdb_list_vector_get_child vector + when (childVec == nullPtr) $ + throwIO (userError "duckdb-simple: list child vector is null") + childType <- vectorElementType childVec + childData <- c_duckdb_vector_get_data childVec + childValidity <- c_duckdb_vector_get_validity childVec + forM [0 .. len - 1] \delta -> + materializedValueFromPointers childType childVec childData childValidity (baseIdx + delta) + +decodeMapPairs :: DuckDBVector -> Ptr () -> Int -> IO [(FieldValue, FieldValue)] +decodeMapPairs vector dataPtr rowIdx = do + entry <- peekElemOff (castPtr dataPtr :: Ptr DuckDBListEntry) rowIdx + (baseIdx, len) <- listEntryBounds (Text.pack "map") entry + structVec <- c_duckdb_list_vector_get_child vector + when (structVec == nullPtr) $ + throwIO (userError "duckdb-simple: map struct vector is null") + keyVec <- c_duckdb_struct_vector_get_child structVec 0 + valueVec <- c_duckdb_struct_vector_get_child structVec 1 + when (keyVec == nullPtr || valueVec == nullPtr) $ + throwIO (userError "duckdb-simple: map child vectors are null") + keyType <- vectorElementType keyVec + valueType <- vectorElementType valueVec + keyData <- c_duckdb_vector_get_data keyVec + valueData <- c_duckdb_vector_get_data valueVec + keyValidity <- c_duckdb_vector_get_validity keyVec + valueValidity <- c_duckdb_vector_get_validity valueVec + forM [0 .. len - 1] \delta -> do + let childIdx = baseIdx + delta + keyValue <- materializedValueFromPointers keyType keyVec keyData keyValidity childIdx + valueValue <- materializedValueFromPointers valueType valueVec valueData valueValidity childIdx + pure (keyValue, valueValue) + +vectorElementType :: DuckDBVector -> IO DuckDBType +vectorElementType vec = do + logical <- c_duckdb_vector_get_column_type vec + dtype <- c_duckdb_get_type_id logical + destroyLogicalType logical + pure dtype + +listEntryBounds :: Text -> DuckDBListEntry -> IO (Int, Int) +listEntryBounds context DuckDBListEntry{duckDBListEntryOffset, duckDBListEntryLength} = do + base <- ensureWithinIntRange (context <> Text.pack " offset") duckDBListEntryOffset + len <- ensureWithinIntRange (context <> Text.pack " length") duckDBListEntryLength + let maxInt = toInteger (maxBound :: Int) + upperBound = toInteger base + toInteger len - 1 + when (len > 0 && upperBound > maxInt) $ + throwIO (userError ("duckdb-simple: " <> Text.unpack context <> " bounds exceed Int range")) + pure (base, len) + +ensureWithinIntRange :: Text -> Word64 -> IO Int +ensureWithinIntRange context value = + let actual = toInteger value + limit = toInteger (maxBound :: Int) + in if actual <= limit + then pure (fromInteger actual) + else throwIO (userError ("duckdb-simple: " <> Text.unpack context <> " exceeds Int range")) + materializedValueFromPointers :: DuckDBType -> DuckDBVector -> Ptr () -> Ptr Word64 -> Int -> IO FieldValue materializedValueFromPointers dtype vector dataPtr validity rowIdx = do let duckIdx = fromIntegral rowIdx :: DuckDBIdx @@ -1134,23 +1179,6 @@ if not valid then pure FieldNull else do - (decimalInfo, enumInternal) <- - if dtype == DuckDBTypeDecimal || dtype == DuckDBTypeEnum - then do - logical <- c_duckdb_vector_get_column_type vector - info <- - case dtype of - DuckDBTypeDecimal -> do - width <- c_duckdb_decimal_width logical - scale <- c_duckdb_decimal_scale logical - pure (Just (width, scale), Nothing) - DuckDBTypeEnum -> do - internal <- c_duckdb_enum_internal_type logical - pure (Nothing, Just internal) - _ -> pure (Nothing, Nothing) - destroyLogicalType logical - pure info - else pure (Nothing, Nothing) case dtype of DuckDBTypeBoolean -> do raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx @@ -1186,7 +1214,11 @@ raw <- peekElemOff (castPtr dataPtr :: Ptr Double) rowIdx pure (FieldDouble raw) DuckDBTypeVarchar -> FieldText <$> chunkDecodeText dataPtr duckIdx - DuckDBTypeUUID -> FieldText <$> chunkDecodeText dataPtr duckIdx + DuckDBTypeUUID -> do + DuckDBUHugeInt lower upper_biased <- + peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx + let upper = upper_biased `xor` (0x8000000000000000 :: Word64) + return $ FieldUUID $ UUID.fromWords64 (fromIntegral upper) lower DuckDBTypeBlob -> FieldBlob <$> chunkDecodeBlob dataPtr duckIdx DuckDBTypeDate -> do raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx @@ -1219,13 +1251,24 @@ raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBInterval) rowIdx pure (FieldInterval (intervalValueFromDuckDB raw)) DuckDBTypeDecimal -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBDecimal) rowIdx - case decimalInfo of - Just (width, scale) -> do - decimal <- decimalValueFromDuckDB width scale raw - pure (FieldDecimal decimal) - Nothing -> - error "duckdb-simple: missing decimal metadata for result vector" + bracket (c_duckdb_vector_get_column_type vector) + (\lty -> alloca $ \ptr -> poke ptr lty >> c_duckdb_destroy_logical_type ptr) $ + \logical -> do + width <- c_duckdb_decimal_width logical + scale <- c_duckdb_decimal_scale logical + internal_ty <- c_duckdb_decimal_internal_type logical + raw <- case internal_ty of + DuckDBTypeSmallInt -> + toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx + DuckDBTypeInteger -> + toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx + DuckDBTypeBigInt -> + toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx + DuckDBTypeHugeInt -> + toInteger . duckDBHugeIntToInteger <$> + peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx + _ -> error "duckdb-simple: unsupported decimal internal storage type" + pure (FieldDecimal (DecimalValue width scale raw)) DuckDBTypeHugeInt -> do raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx pure (FieldHugeInt (duckDBHugeIntToInteger raw)) @@ -1233,24 +1276,52 @@ raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx pure (FieldUHugeInt (duckDBUHugeIntToInteger raw)) DuckDBTypeBit -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBit) rowIdx - FieldBit <$> decodeDuckDBBit raw + -- Same deal as with bignum, we need to manually decode the string_t + let base = castPtr dataPtr :: Ptr Word8 + -- luckily, the underlying data has only one field, which is a string_t + offset = fromIntegral rowIdx * duckdbStringTSize + stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT + len <- c_duckdb_string_t_length stringPtr + ptr <- c_duckdb_string_t_data stringPtr + bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len) + case bs of + [] -> return $ FieldBit (BitString 0 BS.empty) + [padding] -> return $ FieldBit (BitString padding BS.empty) + (padding:b:bits) -> do + let tc = [(8-fromIntegral padding)..7] + cleared = foldl clearBit b tc + return $ FieldBit $ BitString padding (BS.pack (cleared:bits)) DuckDBTypeBigNum -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBignum) rowIdx - FieldBigNum <$> decodeDuckDBBigNum raw + -- Here we have to get messy, because DuckDB returns a pointer + -- to a bignum_t and not a duckdb_bignum. + let base = castPtr dataPtr :: Ptr Word8 + -- luckily, the underlying data has only one field, which is a string_t + offset = fromIntegral rowIdx * duckdbStringTSize + stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT + len <- c_duckdb_string_t_length stringPtr + if len < 3 + then return $ FieldBigNum (BigNum 0) + else do ptr <- c_duckdb_string_t_data stringPtr + bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len) + return $ FieldBigNum $ BigNum (fromBigNumBytes bs) + DuckDBTypeList -> FieldList <$> decodeListElements vector dataPtr rowIdx + DuckDBTypeMap -> FieldMap <$> decodeMapPairs vector dataPtr rowIdx + DuckDBTypeStruct -> error "duckdb-simple: STRUCT columns are not supported" + DuckDBTypeUnion -> error "duckdb-simple: UNION columns are not supported" DuckDBTypeEnum -> do - case enumInternal of - Just DuckDBTypeUTinyInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx - pure (FieldEnum (fromIntegral raw)) - Just DuckDBTypeUSmallInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx - pure (FieldEnum (fromIntegral raw)) - Just DuckDBTypeUInteger -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx - pure (FieldEnum raw) - _ -> - error "duckdb-simple: unsupported enum internal storage type" + bracket (c_duckdb_vector_get_column_type vector) + (\lty -> alloca $ \ptr -> poke ptr lty >> c_duckdb_destroy_logical_type ptr) $ + \logical -> do + enumInternal <- c_duckdb_enum_internal_type logical + FieldEnum <$> + case enumInternal of + DuckDBTypeUTinyInt -> do + fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx + DuckDBTypeUSmallInt -> do + fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx + DuckDBTypeUInteger -> do + fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx + _ -> error "duckdb-simple: unsupported enum internal storage type" DuckDBTypeSQLNull -> pure FieldNull DuckDBTypeStringLiteral -> FieldText <$> chunkDecodeText dataPtr duckIdx @@ -1347,19 +1418,6 @@ , intervalMicros = duckDBIntervalMicros } -decimalValueFromDuckDB :: Word8 -> Word8 -> DuckDBDecimal -> IO DecimalValue -decimalValueFromDuckDB width scale rawDecimal = - alloca \ptr -> do - let decimal = rawDecimal{duckDBDecimalWidth = width, duckDBDecimalScale = scale} - poke ptr decimal - CDouble approx <- c_duckdb_decimal_to_double ptr - pure - DecimalValue - { decimalWidth = width - , decimalScale = scale - , decimalInteger = duckDBHugeIntToInteger (duckDBDecimalValue decimal) - , decimalApproximate = realToFrac approx - } duckDBHugeIntToInteger :: DuckDBHugeInt -> Integer duckDBHugeIntToInteger DuckDBHugeInt{duckDBHugeIntLower, duckDBHugeIntUpper} = @@ -1368,25 +1426,6 @@ duckDBUHugeIntToInteger :: DuckDBUHugeInt -> Integer duckDBUHugeIntToInteger DuckDBUHugeInt{duckDBUHugeIntLower, duckDBUHugeIntUpper} = (fromIntegral duckDBUHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBUHugeIntLower - -decodeDuckDBBit :: DuckDBBit -> IO BitString -decodeDuckDBBit DuckDBBit{duckDBBitData, duckDBBitSize} - | duckDBBitData == nullPtr || duckDBBitSize == 0 = - pure BitString{bitStringLength = 0, bitStringBytes = BS.empty} - | otherwise = do - let bitLength = duckDBBitSize - byteLength = fromIntegral ((bitLength + 7) `div` 8) :: Int - bytes <- BS.packCStringLen (castPtr duckDBBitData, byteLength) - pure BitString{bitStringLength = bitLength, bitStringBytes = bytes} - -decodeDuckDBBigNum :: DuckDBBignum -> IO BigNum -decodeDuckDBBigNum DuckDBBignum{duckDBBignumData, duckDBBignumSize, duckDBBignumIsNegative} - | duckDBBignumData == nullPtr || duckDBBignumSize == 0 = - pure BigNum{bigNumIsNegative = duckDBBignumIsNegative /= 0, bigNumMagnitude = BS.empty} - | otherwise = do - let byteLength = fromIntegral duckDBBignumSize :: Int - bytes <- BS.packCStringLen (castPtr duckDBBignumData, byteLength) - pure BigNum{bigNumIsNegative = duckDBBignumIsNegative /= 0, bigNumMagnitude = bytes} peekError :: Ptr CString -> IO Text peekError ptr = do diff --git a/src/Database/DuckDB/Simple/FromField.hs b/src/Database/DuckDB/Simple/FromField.hs --- a/src/Database/DuckDB/Simple/FromField.hs +++ b/src/Database/DuckDB/Simple/FromField.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Database.DuckDB.Simple.FromField @@ -14,37 +16,47 @@ module Database.DuckDB.Simple.FromField ( Field (..), FieldValue (..), - BitString (..), + BitString(..), + bsFromBool, BigNum (..), + fromBigNumBytes, + toBigNumBytes, DecimalValue (..), IntervalValue (..), TimeWithZone (..), ResultError (..), FieldParser, FromField (..), - returnError + returnError, ) where import Control.Exception (Exception, SomeException (..)) +import Data.Bits (Bits (..), finiteBitSize) import qualified Data.ByteString as BS +import Data.Data (Typeable, typeRep) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as TextEncoding import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime (..)) -import Data.Time.LocalTime - ( LocalTime (..) - , TimeOfDay (..) - , TimeZone (..) - , localTimeToUTC - , utc - , utcToLocalTime - ) +import Data.Time.LocalTime ( + LocalTime (..), + TimeOfDay (..), + TimeZone (..), + localTimeToUTC, + utc, + utcToLocalTime, + ) import Data.Word (Word16, Word32, Word64, Word8) -import Database.DuckDB.Simple.Types (Null (..)) import Database.DuckDB.Simple.Ok -import Data.Data (Typeable, Proxy (..), typeRep) +import Database.DuckDB.Simple.Types (Null (..)) +import GHC.Num.Integer (integerFromWordList) +import Numeric.Natural (Natural) +import qualified Data.UUID as UUID -- | Internal representation of a column value. data FieldValue @@ -57,6 +69,7 @@ | FieldWord16 Word16 | FieldWord32 Word32 | FieldWord64 Word64 + | FieldUUID UUID.UUID | FieldFloat Float | FieldDouble Double | FieldText Text @@ -74,13 +87,14 @@ | FieldBit BitString | FieldBigNum BigNum | FieldEnum Word32 + | FieldList [FieldValue] + | FieldMap [(FieldValue, FieldValue)] deriving (Eq, Show) data DecimalValue = DecimalValue { decimalWidth :: !Word8 , decimalScale :: !Word8 , decimalInteger :: !Integer - , decimalApproximate :: !Double } deriving (Eq, Show) @@ -91,18 +105,92 @@ } deriving (Eq, Show) -data BitString = BitString - { bitStringLength :: !Word64 - , bitStringBytes :: !BS.ByteString - } - deriving (Eq, Show) -data BigNum = BigNum - { bigNumIsNegative :: !Bool - , bigNumMagnitude :: !BS.ByteString - } - deriving (Eq, Show) +newtype BigNum = BigNum Integer + deriving stock (Eq, Show) + deriving (Num) via Integer +{- | Decode DuckDB’s BIGNUM blob (3-byte header + big-endian payload where negative magnitudes are +bitwise complemented) back into a Haskell 'Integer'. We undo the complement when needed, then chunk +the remaining bytes into machine-word limbs (MSB chunk first) for 'integerFromWordList'. +-} +fromBigNumBytes :: [Word8] -> Integer +fromBigNumBytes bytes = + let header = take 3 bytes + payloadRaw = drop 3 bytes + isNeg = head header .&. 0x80 == 0 + payload = if isNeg then map complement payloadRaw else payloadRaw + bytesPerWord = finiteBitSize (0 :: Word) `div` 8 -- 8 on 64-bit, 4 on 32-bit + len = length payload + (firstChunk, rest) = splitAt (len `mod` bytesPerWord) payload + + chunkWords [] = [] + chunkWords xs = + let (chunk, remainder) = splitAt bytesPerWord xs + in chunk : chunkWords remainder + + toWord = foldl (\acc b -> (acc `shiftL` 8) .|. fromIntegral b) 0 + limbs = (if null firstChunk then id else (firstChunk :)) (chunkWords rest) + in integerFromWordList isNeg (map toWord limbs) + +{- | Encode an 'Integer' into DuckDB’s BIGNUM blob layout: emit the 3-byte header + (sign bit plus payload length) followed by the magnitude bytes in the same + big-endian / complemented-on-negative form that DuckDB stores internally. +-} +toBigNumBytes :: Integer -> [Word8] +toBigNumBytes value = + let isNeg = value < 0 + magnitude = if isNeg then negate value else value + payloadBE + | magnitude == 0 = [0] + | otherwise = go magnitude [] + where + go 0 acc = acc + go n acc = + let (q, r) = quotRem n 256 + in go q (fromIntegral r : acc) + + headerBase :: Word32 + headerBase = (fromIntegral (length payloadBE) .|. 0x00800000) + headerVal :: Word32 + headerVal = if isNeg then complement headerBase else headerBase + headerMasked = headerVal .&. 0x00FFFFFF + headerBytes = + [ fromIntegral ((headerMasked `shiftR` 16) .&. 0xFF) + , fromIntegral ((headerMasked `shiftR` 8) .&. 0xFF) + , fromIntegral (headerMasked .&. 0xFF) + ] + payloadBytes = if isNeg then map complement payloadBE else payloadBE + in headerBytes <> payloadBytes + +data BitString = BitString { padding :: !Word8 + , bits :: !BS.ByteString} + deriving stock (Eq) + +instance Show BitString where + show (BitString padding bits) = + drop (fromIntegral padding) $ concatMap word8ToString $ BS.unpack bits + where + word8ToString :: Word8 -> String + word8ToString w = map (\n -> if testBit w n then '1' else '0') [7, 6 .. 0] + +-- | Construct a 'BitString' from a list of 'Bool's, where the first element +bsFromBool :: [Bool] -> BitString +bsFromBool bits = + let totalBits = length bits + padding = (8 - (totalBits `mod` 8)) `mod` 8 + paddedBits = replicate padding False ++ bits + byteChunks = chunk 8 paddedBits + byteValues = map bitsToWord8 byteChunks + in BitString (fromIntegral padding) (BS.pack byteValues) + where + chunk _ [] = [] + chunk n xs = take n xs : chunk n (drop n xs) + + bitsToWord8 :: [Bool] -> Word8 + bitsToWord8 bs = foldl (\acc (b, i) -> if b then setBit acc i else acc) 0 (zip bs [7, 6 .. 0]) + + data TimeWithZone = TimeWithZone { timeWithZoneTime :: !TimeOfDay , timeWithZoneZone :: !TimeZone @@ -143,38 +231,45 @@ } deriving (Eq, Show) --- | Exception thrown if conversion from a SQL value to a Haskell --- value fails. -data ResultError = Incompatible { errSQLType :: Text - , errSQLField :: Text - , errHaskellType :: Text - , errMessage :: Text } - -- ^ The SQL and Haskell types are not compatible. - | UnexpectedNull { errSQLType :: Text - , errSQLField :: Text - , errHaskellType :: Text - , errMessage :: Text } - -- ^ A SQL @NULL@ was encountered when the Haskell - -- type did not permit it. - | ConversionFailed { errSQLType :: Text - , errSQLField :: Text - , errHaskellType :: Text - , errMessage :: Text } - -- ^ The SQL value could not be parsed, or could not - -- be represented as a valid Haskell value, or an - -- unexpected low-level error occurred (e.g. mismatch - -- between metadata and actual data in a row). - deriving (Eq, Show, Typeable) +{- | Exception thrown if conversion from a SQL value to a Haskell +value fails. +-} +data ResultError + = -- | The SQL and Haskell types are not compatible. + Incompatible + { errSQLType :: Text + , errSQLField :: Text + , errHaskellType :: Text + , errMessage :: Text + } + | -- | A SQL @NULL@ was encountered when the Haskell + -- type did not permit it. + UnexpectedNull + { errSQLType :: Text + , errSQLField :: Text + , errHaskellType :: Text + , errMessage :: Text + } + | -- | The SQL value could not be parsed, or could not + -- be represented as a valid Haskell value, or an + -- unexpected low-level error occurred (e.g. mismatch + -- between metadata and actual data in a row). + ConversionFailed + { errSQLType :: Text + , errSQLField :: Text + , errHaskellType :: Text + , errMessage :: Text + } + deriving (Eq, Show, Typeable) instance Exception ResultError - - --- | Parser used by 'FromField' instances and utilities such as --- 'Database.DuckDB.Simple.FromRow.fieldWith'. The supplied 'Field' contains --- column metadata and an already-decoded 'FieldValue'; callers should return --- 'Ok' on success or 'Errors' (typically wrapping a 'ResultError') when the --- conversion fails. +{- | Parser used by 'FromField' instances and utilities such as +'Database.DuckDB.Simple.FromRow.fieldWith'. The supplied 'Field' contains +column metadata and an already-decoded 'FieldValue'; callers should return +'Ok' on success or 'Errors' (typically wrapping a 'ResultError') when the +conversion fails. +-} type FieldParser a = Field -> Ok a -- | Types that can be constructed from a DuckDB column. @@ -188,8 +283,19 @@ fromField f@Field{fieldValue} = case fieldValue of FieldNull -> Ok Null - _ -> returnError Incompatible f "expected NULL" + _ -> returnError Incompatible f "expected NULL" +instance FromField UUID.UUID where + fromField f@Field{fieldValue} = + case fieldValue of + FieldText t -> + case UUID.fromText t of + Just uuid -> Ok uuid + Nothing -> returnError ConversionFailed f "invalid UUID format" + FieldUUID uuid -> Ok uuid + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField Bool where fromField f@Field{fieldValue} = case fieldValue of @@ -253,18 +359,40 @@ case fieldValue of FieldInt i -> Ok (fromIntegral i) FieldWord w -> Ok (fromIntegral w) + FieldBigNum (BigNum big) -> Ok big FieldHugeInt value -> Ok value FieldUHugeInt value -> Ok value FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" +instance FromField Natural where + fromField f@Field{fieldValue} = + case fieldValue of + FieldInt i + | i >= 0 -> Ok (fromIntegral i) + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to Natural" + FieldWord w -> Ok (fromIntegral w) + FieldHugeInt value + | value >= 0 -> Ok (fromIntegral value) + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to Natural" + FieldUHugeInt value -> Ok (fromIntegral value) + FieldBigNum (BigNum big) -> + if big >= 0 + then Ok $ fromIntegral big + else returnError ConversionFailed f "negative value cannot be converted to Natural" + FieldEnum value -> Ok (fromIntegral value) + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField Word64 where fromField f@Field{fieldValue} = case fieldValue of FieldInt i | i >= 0 -> Ok (fromIntegral i) | otherwise -> - returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) FieldHugeInt value | value >= 0 -> boundedFromInteger f value @@ -348,7 +476,8 @@ case fieldValue of FieldDouble d -> Ok d FieldInt i -> Ok (fromIntegral i) - FieldDecimal DecimalValue{decimalApproximate} -> Ok decimalApproximate + FieldDecimal DecimalValue{decimalInteger, decimalScale} -> + Ok (realToFrac decimalInteger / 10 ^ decimalScale) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -376,14 +505,14 @@ case fieldValue of FieldBlob bs -> Ok bs FieldText t -> Ok (TextEncoding.encodeUtf8 t) - FieldBit bit -> Ok (bitStringBytes bit) + FieldBit (BitString _ bits) -> Ok bits FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" instance FromField BitString where fromField f@Field{fieldValue} = case fieldValue of - FieldBit bit -> Ok bit + FieldBit b -> Ok b FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -394,6 +523,53 @@ FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" +instance {-# OVERLAPPABLE #-} (Typeable a, FromField a) => FromField [a] where + fromField f@Field{fieldValue} = + case fieldValue of + FieldList entries -> + traverse (uncurry parseElement) (zip [0 :: Int ..] entries) + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + where + parseElement idx value = + fromField + Field + { fieldName = fieldNameWithIndex idx + , fieldIndex = fieldIndex f + , fieldValue = value + } + fieldNameWithIndex idx = + let base = fieldName f + idxText = Text.pack (show idx) + in base <> Text.pack "[" <> idxText <> Text.pack "]" + +instance (Ord k, Typeable k, Typeable v, FromField k, FromField v) => FromField (Map k v) where + fromField f@Field{fieldValue} = + case fieldValue of + FieldMap pairs -> Map.fromList <$> traverse (uncurry parsePair) (zip [0 :: Int ..] pairs) + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + where + parsePair idx (keyValue, valValue) = do + key <- + fromField + Field + { fieldName = fieldName f <> suffix idx ".key" + , fieldIndex = fieldIndex f + , fieldValue = keyValue + } + value <- + fromField + Field + { fieldName = fieldName f <> suffix idx ".value" + , fieldIndex = fieldIndex f + , fieldValue = valValue + } + pure (key, value) + suffix idx label = + let idxText = Text.pack (show idx) + in Text.pack "[" <> idxText <> Text.pack "]" <> Text.pack label + instance FromField DecimalValue where fromField f@Field{fieldValue} = case fieldValue of @@ -425,7 +601,7 @@ _ -> returnError Incompatible f "" instance FromField LocalTime where - fromField f@Field{ fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldTimestamp ts -> Ok ts FieldDate day -> Ok (LocalTime day midnight) @@ -474,15 +650,19 @@ returnError ConversionFailed f "integer value out of bounds" | otherwise = Ok (fromInteger value) --- | Helper to construct a ResultError with field context. --- based on postgresql-simple's implementation +{- | Helper to construct a ResultError with field context. +based on postgresql-simple's implementation +-} returnError :: forall b. (Typeable b) => (Text -> Text -> Text -> Text -> ResultError) -> Field -> Text -> Ok b returnError mkError Field{fieldValue, fieldName} msg = - Errors [SomeException $ mkError (fieldValueTypeName fieldValue) - fieldName - (Text.pack $ show (typeRep (Proxy :: Proxy b))) - msg] - + Errors + [ SomeException $ + mkError + (fieldValueTypeName fieldValue) + fieldName + (Text.pack $ show (typeRep (Proxy :: Proxy b))) + msg + ] fieldValueTypeName :: FieldValue -> Text fieldValueTypeName = \case @@ -512,3 +692,6 @@ FieldBit{} -> "BIT" FieldBigNum{} -> "BIGNUM" FieldEnum{} -> "ENUM" + FieldList{} -> "LIST" + FieldMap{} -> "MAP" + FieldUUID{} -> "UUID" diff --git a/src/Database/DuckDB/Simple/FromRow.hs b/src/Database/DuckDB/Simple/FromRow.hs --- a/src/Database/DuckDB/Simple/FromRow.hs +++ b/src/Database/DuckDB/Simple/FromRow.hs @@ -5,8 +5,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} {- | Module : Database.DuckDB.Simple.FromRow @@ -122,7 +122,7 @@ Ok (value, (columnCount, _)) | columnCount == length fields -> Ok value | otherwise -> Errors [SomeException $ ColumnOutOfBounds (columnCount + 1)] - Errors errs -> Errors errs + Errors errs -> Errors errs instance FromRow () where fromRow = pure () @@ -255,26 +255,26 @@ renderError :: ResultError -> Text renderError = \case Incompatible{errSQLType, errSQLField, errHaskellType, errMessage} -> - Text.concat - [ "duckdb-simple: column " - , errSQLField - , " has type " - , errSQLType - , " but expected " - , errHaskellType - , if Text.null errMessage - then "" - else ": " <> errMessage - ] + Text.concat + [ "duckdb-simple: column " + , errSQLField + , " has type " + , errSQLType + , " but expected " + , errHaskellType + , if Text.null errMessage + then "" + else ": " <> errMessage + ] UnexpectedNull{errHaskellType, errSQLField, errMessage} -> - Text.concat - [ "duckdb-simple: column " - , errSQLField - , " is NULL but expected " - , errHaskellType - , if Text.null errMessage - then "" - else ": " <> errMessage - ] + Text.concat + [ "duckdb-simple: column " + , errSQLField + , " is NULL but expected " + , errHaskellType + , if Text.null errMessage + then "" + else ": " <> errMessage + ] ConversionFailed{errMessage} -> errMessage diff --git a/src/Database/DuckDB/Simple/Function.hs b/src/Database/DuckDB/Simple/Function.hs --- a/src/Database/DuckDB/Simple/Function.hs +++ b/src/Database/DuckDB/Simple/Function.hs @@ -31,51 +31,52 @@ try, ) import Control.Monad (forM, forM_, when) +import Data.Bits (shiftL, (.|.), clearBit) import qualified Data.ByteString as BS -import Data.Bits ((.|.), shiftL) import Data.Int (Int16, Int32, Int64, Int8) -import Data.Ratio ((%)) import Data.Proxy (Proxy (..)) +import Data.Ratio ((%)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as TE import qualified Data.Text.Foreign as TextForeign -import Data.Word (Word16, Word32, Word64, Word8) import Data.Time.Calendar (Day, fromGregorian) import Data.Time.Clock (UTCTime (..)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Time.LocalTime - ( LocalTime (..) - , TimeOfDay (..) - , minutesToTimeZone - , utc - , utcToLocalTime - ) +import Data.Time.LocalTime ( + LocalTime (..), + TimeOfDay (..), + minutesToTimeZone, + utc, + utcToLocalTime, + ) +import Data.Word (Word16, Word32, Word64, Word8) import Database.DuckDB.FFI -import Database.DuckDB.Simple.FromField - ( BigNum (..) - , BitString (..) - , DecimalValue (..) - , Field (..) - , FieldValue (..) - , FromField (..) - , IntervalValue (..) - , TimeWithZone (..) - ) -import Database.DuckDB.Simple.Internal - ( Connection - , Query (..) - , SQLError (..) - , withConnectionHandle - , withQueryCString - ) +import Database.DuckDB.Simple.FromField ( + BigNum (..), + BitString (..), + DecimalValue (..), + Field (..), + FieldValue (..), + FromField (..), + IntervalValue (..), + TimeWithZone (..), + fromBigNumBytes, + ) +import Database.DuckDB.Simple.Internal ( + Connection, + Query (..), + SQLError (..), + withConnectionHandle, + withQueryCString, + ) +import Database.DuckDB.Simple.Ok (Ok (..)) import Foreign.C.String (peekCString) -import Foreign.C.Types (CBool (..), CDouble (..)) +import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr, plusPtr) import Foreign.StablePtr (StablePtr, castPtrToStablePtr, castStablePtrToPtr, deRefStablePtr, freeStablePtr, newStablePtr) import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff) -import Database.DuckDB.Simple.Ok (Ok(..)) -- | Tag DuckDB logical types we support for scalar return values. data ScalarType @@ -502,11 +503,32 @@ functionInvocationError $ Text.pack "duckdb-simple: missing decimal metadata for scalar function argument" DuckDBTypeBit -> do - value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBit) idx - FieldBit <$> decodeDuckDBBit value + -- Same deal as with bignum, we need to manually decode the string_t + let base = castPtr dataPtr :: Ptr Word8 + -- luckily, the underlying data has only one field, which is a string_t + offset = fromIntegral rowIdx * duckdbStringTSize + stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT + len <- c_duckdb_string_t_length stringPtr + ptr <- c_duckdb_string_t_data stringPtr + bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len) + case bs of + [] -> return $ FieldBit (BitString 0 BS.empty) + [padding] -> return $ FieldBit (BitString padding BS.empty) + (padding:b:bits) -> + let cleared = foldl clearBit b [0..fromIntegral padding -1] + in return $ FieldBit $ BitString padding (BS.pack (cleared:bits)) DuckDBTypeBigNum -> do - value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBignum) idx - FieldBigNum <$> decodeDuckDBBigNum value + let base = castPtr dataPtr :: Ptr Word8 + -- luckily, the underlying data has only one field, which is a string_t + offset = fromIntegral rowIdx * duckdbStringTSize + stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT + len <- c_duckdb_string_t_length stringPtr + if len < 3 + then return $ FieldBigNum (BigNum 0) + else do + ptr <- c_duckdb_string_t_data stringPtr + bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len) + return $ FieldBigNum $ BigNum (fromBigNumBytes bs) DuckDBTypeEnum -> do case enumInternal of Just DuckDBTypeUTinyInt -> do @@ -652,18 +674,14 @@ } decimalValueFromDuckDB :: Word8 -> Word8 -> DuckDBDecimal -> IO DecimalValue -decimalValueFromDuckDB width scale rawDecimal = - alloca \ptr -> do - let decimal = rawDecimal{duckDBDecimalWidth = width, duckDBDecimalScale = scale} - poke ptr decimal - CDouble approx <- c_duckdb_decimal_to_double ptr - pure - DecimalValue - { decimalWidth = width - , decimalScale = scale - , decimalInteger = duckDBHugeIntToInteger (duckDBDecimalValue decimal) - , decimalApproximate = realToFrac approx - } +decimalValueFromDuckDB width scale rawDecimal = do + let decimal = rawDecimal{duckDBDecimalWidth = width, duckDBDecimalScale = scale} + pure + DecimalValue + { decimalWidth = width + , decimalScale = scale + , decimalInteger = duckDBHugeIntToInteger (duckDBDecimalValue decimal) + } duckDBHugeIntToInteger :: DuckDBHugeInt -> Integer duckDBHugeIntToInteger DuckDBHugeInt{duckDBHugeIntLower, duckDBHugeIntUpper} = @@ -672,25 +690,6 @@ duckDBUHugeIntToInteger :: DuckDBUHugeInt -> Integer duckDBUHugeIntToInteger DuckDBUHugeInt{duckDBUHugeIntLower, duckDBUHugeIntUpper} = (fromIntegral duckDBUHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBUHugeIntLower - -decodeDuckDBBit :: DuckDBBit -> IO BitString -decodeDuckDBBit DuckDBBit{duckDBBitData, duckDBBitSize} - | duckDBBitData == nullPtr || duckDBBitSize == 0 = - pure BitString{bitStringLength = 0, bitStringBytes = BS.empty} - | otherwise = do - let bitLength = duckDBBitSize - byteLength = fromIntegral ((bitLength + 7) `div` 8) :: Int - bytes <- BS.packCStringLen (castPtr duckDBBitData, byteLength) - pure BitString{bitStringLength = bitLength, bitStringBytes = bytes} - -decodeDuckDBBigNum :: DuckDBBignum -> IO BigNum -decodeDuckDBBigNum DuckDBBignum{duckDBBignumData, duckDBBignumSize, duckDBBignumIsNegative} - | duckDBBignumData == nullPtr || duckDBBignumSize == 0 = - pure BigNum{bigNumIsNegative = duckDBBignumIsNegative /= 0, bigNumMagnitude = BS.empty} - | otherwise = do - let byteLength = fromIntegral duckDBBignumSize :: Int - bytes <- BS.packCStringLen (castPtr duckDBBignumData, byteLength) - pure BigNum{bigNumIsNegative = duckDBBignumIsNegative /= 0, bigNumMagnitude = bytes} writeResults :: ScalarType -> [ScalarValue] -> DuckDBVector -> IO () writeResults resultType values outVec = do diff --git a/src/Database/DuckDB/Simple/Internal.hs b/src/Database/DuckDB/Simple/Internal.hs --- a/src/Database/DuckDB/Simple/Internal.hs +++ b/src/Database/DuckDB/Simple/Internal.hs @@ -41,8 +41,8 @@ import qualified Data.Text.Foreign as TextForeign import Data.Word (Word64) import Database.DuckDB.FFI ( - DuckDBDataChunk, DuckDBConnection, + DuckDBDataChunk, DuckDBDatabase, DuckDBErrorType, DuckDBPreparedStatement, @@ -67,7 +67,7 @@ fromString = Query . Text.pack -- | Tracks the lifetime of a DuckDB database and connection pair. -newtype Connection = Connection { connectionState :: IORef ConnectionState } +newtype Connection = Connection {connectionState :: IORef ConnectionState} -- | Internal connection lifecycle state. data ConnectionState @@ -136,12 +136,13 @@ instance Exception SQLError -toSQLError :: Exception e => e -> SQLError -toSQLError ex = SQLError - { sqlErrorMessage = Text.pack (show ex) - , sqlErrorType = Nothing - , sqlErrorQuery = Nothing - } +toSQLError :: (Exception e) => e -> SQLError +toSQLError ex = + SQLError + { sqlErrorMessage = Text.pack (show ex) + , sqlErrorType = Nothing + , sqlErrorQuery = Nothing + } -- | Shared error value used when an operation targets a closed connection. connectionClosedError :: SQLError diff --git a/src/Database/DuckDB/Simple/ToField.hs b/src/Database/DuckDB/Simple/ToField.hs --- a/src/Database/DuckDB/Simple/ToField.hs +++ b/src/Database/DuckDB/Simple/ToField.hs @@ -1,8 +1,10 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Database.DuckDB.Simple.ToField @@ -14,15 +16,19 @@ module Database.DuckDB.Simple.ToField ( FieldBinding, ToField (..), + DuckDBColumnType (..), NamedParam (..), + duckdbColumnType, bindFieldBinding, renderFieldBinding, ) where import Control.Exception (bracket, throwIO) import Control.Monad (when) +import Data.Bits (complement) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) +import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Foreign as TextForeign @@ -31,6 +37,7 @@ import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), timeOfDayToTime, utc, utcToLocalTime) import Data.Word (Word16, Word32, Word64, Word8) import Database.DuckDB.FFI +import Database.DuckDB.Simple.FromField (BigNum (..), toBigNumBytes, BitString(..)) import Database.DuckDB.Simple.Internal ( SQLError (..), Statement (..), @@ -39,9 +46,12 @@ import Database.DuckDB.Simple.Types (Null (..)) import Foreign.C.String (peekCString) import Foreign.C.Types (CDouble (..)) +import Foreign.Marshal (fromBool) import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr, castPtr, nullPtr) import Foreign.Storable (poke) +import Numeric.Natural (Natural) +import qualified Data.UUID as UUID -- | Represents a named parameter binding using the @:=@ operator. data NamedParam where @@ -55,6 +65,14 @@ , fieldBindingDisplay :: !String } +-- | Types that map to a concrete DuckDB column type when used with 'ToField'. +class DuckDBColumnType a where + duckdbColumnTypeFor :: Proxy a -> Text + +-- | Report the DuckDB column type that best matches a given 'ToField' instance. +duckdbColumnType :: forall a. (DuckDBColumnType a) => Proxy a -> Text +duckdbColumnType = duckdbColumnTypeFor + -- | Apply a 'FieldBinding' to the given statement/index. bindFieldBinding :: Statement -> DuckDBIdx -> FieldBinding -> IO () bindFieldBinding stmt idx FieldBinding{fieldBindingAction} = fieldBindingAction stmt idx @@ -71,12 +89,13 @@ } -- | Types that can be used as positional parameters. -class ToField a where +class (DuckDBColumnType a) => ToField a where toField :: a -> FieldBinding instance ToField Null where toField Null = nullBinding "NULL" + instance ToField Bool where toField value = mkFieldBinding (show value) $ \stmt idx -> @@ -94,20 +113,33 @@ instance ToField Int64 where toField = intBinding +instance ToField BigNum where + toField = bignumBinding + +instance ToField UUID.UUID where + toField = uuidBinding + +instance ToField Integer where + toField :: Integer -> FieldBinding + toField = toField . BigNum + +instance ToField Natural where + toField = toField . BigNum . toInteger + instance ToField Word where toField value = uint64Binding (fromIntegral value) instance ToField Word16 where - toField value = uint16Binding value + toField = uint16Binding instance ToField Word32 where - toField value = uint32Binding value + toField = uint32Binding instance ToField Word64 where - toField value = uint64Binding value + toField = uint64Binding instance ToField Word8 where - toField value = uint8Binding value + toField = uint8Binding instance ToField Double where toField value = @@ -139,6 +171,12 @@ TextForeign.withCString (Text.pack str) $ \cstr -> bindDuckValue stmt idx (c_duckdb_create_varchar cstr) +instance DuckDBColumnType BitString where + duckdbColumnTypeFor _ = "BIT" + +instance ToField BitString where + toField = bitBinding + instance ToField BS.ByteString where toField bs = mkFieldBinding @@ -190,6 +228,81 @@ { fieldBindingDisplay = "Just " <> renderFieldBinding binding } +instance DuckDBColumnType Null where + duckdbColumnTypeFor _ = "NULL" + +instance DuckDBColumnType Bool where + duckdbColumnTypeFor _ = "BOOLEAN" + +instance DuckDBColumnType Int where + duckdbColumnTypeFor _ = "BIGINT" + +instance DuckDBColumnType Int16 where + duckdbColumnTypeFor _ = "SMALLINT" + +instance DuckDBColumnType Int32 where + duckdbColumnTypeFor _ = "INTEGER" + +instance DuckDBColumnType Int64 where + duckdbColumnTypeFor _ = "BIGINT" + +instance DuckDBColumnType BigNum where + duckdbColumnTypeFor _ = "BIGNUM" + +instance DuckDBColumnType UUID.UUID where + duckdbColumnTypeFor _ = "UUID" + +instance DuckDBColumnType Integer where + duckdbColumnTypeFor _ = "BIGNUM" + +instance DuckDBColumnType Natural where + duckdbColumnTypeFor _ = "BIGNUM" + +instance DuckDBColumnType Word where + duckdbColumnTypeFor _ = "UBIGINT" + +instance DuckDBColumnType Word8 where + duckdbColumnTypeFor _ = "UTINYINT" + +instance DuckDBColumnType Word16 where + duckdbColumnTypeFor _ = "USMALLINT" + +instance DuckDBColumnType Word32 where + duckdbColumnTypeFor _ = "UINTEGER" + +instance DuckDBColumnType Word64 where + duckdbColumnTypeFor _ = "UBIGINT" + +instance DuckDBColumnType Double where + duckdbColumnTypeFor _ = "DOUBLE" + +instance DuckDBColumnType Float where + duckdbColumnTypeFor _ = "FLOAT" + +instance DuckDBColumnType Text where + duckdbColumnTypeFor _ = "TEXT" + +instance DuckDBColumnType String where + duckdbColumnTypeFor _ = "TEXT" + +instance DuckDBColumnType BS.ByteString where + duckdbColumnTypeFor _ = "BLOB" + +instance DuckDBColumnType Day where + duckdbColumnTypeFor _ = "DATE" + +instance DuckDBColumnType TimeOfDay where + duckdbColumnTypeFor _ = "TIME" + +instance DuckDBColumnType LocalTime where + duckdbColumnTypeFor _ = "TIMESTAMP" + +instance DuckDBColumnType UTCTime where + duckdbColumnTypeFor _ = "TIMESTAMPTZ" + +instance (DuckDBColumnType a) => DuckDBColumnType (Maybe a) where + duckdbColumnTypeFor _ = duckdbColumnTypeFor (Proxy :: Proxy a) + -- | Helper for binding 'Null' values. nullBinding :: String -> FieldBinding nullBinding repr = @@ -232,6 +345,80 @@ (show value) \stmt idx -> bindDuckValue stmt idx (c_duckdb_create_uint8 value) + +uuidBinding :: UUID.UUID -> FieldBinding +uuidBinding uuid = + mkFieldBinding + (show uuid) + \stmt idx -> + bindDuckValue stmt idx $ + alloca $ \ptr -> do + let (upper, lower) = UUID.toWords64 uuid + poke ptr DuckDBUHugeInt + { duckDBUHugeIntLower = lower + , duckDBUHugeIntUpper = upper + } + c_duckdb_create_uuid ptr + +bitBinding :: BitString -> FieldBinding +bitBinding (BitString padding bits) = + mkFieldBinding + (show (BitString padding bits)) + \stmt idx -> + let w_padding = (fromIntegral padding :: Word8):BS.unpack bits + in bindDuckValue stmt idx $ + if BS.null bits + then alloca \ptr -> do + poke + ptr + DuckDBBit + { duckDBBitData = nullPtr + , duckDBBitSize = 0 + } + c_duckdb_create_bit ptr + else + BS.useAsCStringLen (BS.pack w_padding) \(rawPtr, len) -> + alloca \ptr -> do + poke + ptr + DuckDBBit + { duckDBBitData = castPtr rawPtr + , duckDBBitSize = fromIntegral len + } + c_duckdb_create_bit ptr + +bignumBinding :: BigNum -> FieldBinding +bignumBinding (BigNum big) = + mkFieldBinding + (show big) + \stmt idx -> + bindDuckValue stmt idx $ + let neg = fromBool (big < 0) + big_num_bytes = + BS.pack $ + if big < 0 + then map complement (drop 3 $ toBigNumBytes big) + else drop 3 $ toBigNumBytes big + in if BS.null big_num_bytes + then alloca \ptr -> do + poke + ptr + DuckDBBignum + { duckDBBignumData = nullPtr + , duckDBBignumSize = 0 + , duckDBBignumIsNegative = neg + } + c_duckdb_create_bignum ptr + else BS.useAsCStringLen big_num_bytes \(rawPtr, len) -> + alloca \ptr -> do + poke + ptr + DuckDBBignum + { duckDBBignumData = castPtr rawPtr + , duckDBBignumSize = fromIntegral len + , duckDBBignumIsNegative = neg + } + c_duckdb_create_bignum ptr encodeDay :: Day -> IO DuckDBDate encodeDay day = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,14 +11,18 @@ module Main (main) where import Control.Applicative ((<|>)) -import Control.Exception (ErrorCall, Exception, try) +import Control.Exception (ErrorCall, Exception, SomeException, displayException, fromException, try) import Control.Monad (replicateM_) import qualified Data.ByteString as BS import Data.IORef (atomicModifyIORef', newIORef) -import Data.Int (Int64) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.String (fromString) import qualified Data.Text as Text import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime (..)) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) import Data.Time.LocalTime ( LocalTime (..), TimeOfDay (..), @@ -28,17 +32,30 @@ utc, ) import Data.Word (Word16, Word32, Word64, Word8) +import Data.Ratio ((%)) import Database.DuckDB.Simple import Database.DuckDB.Simple.FromField ( + BigNum (..), + BitString (..), + bsFromBool, + DecimalValue (..), Field (..), + FieldValue (..), IntervalValue (..), TimeWithZone (..), + fromBigNumBytes, returnError, + toBigNumBytes, ) +import Database.DuckDB.Simple.Ok (Ok (..)) import GHC.Generics (Generic) +import Numeric.Natural (Natural) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit -import Database.DuckDB.Simple.Ok (Ok(..)) +import Test.Tasty.QuickCheck (testProperty, (===)) +import Test.Tasty.ExpectedFailure (expectFailBecause) +import qualified Data.UUID as UUID +import Data.Maybe (fromJust) data Person = Person { personId :: Int @@ -73,18 +90,18 @@ let normalized = Text.toLower txt in if normalized == expected then Ok () - else returnError ConversionFailed fld "failed to match exact string" + else returnError ConversionFailed fld "failed to match exact string" newtype NonEmptyText = NonEmptyText Text.Text deriving (Eq, Show) nonEmptyTextParser :: FieldParser NonEmptyText nonEmptyTextParser f@Field{} = - case fromField f of + case fromField f of Errors err -> Errors err Ok txt | Text.null txt -> - returnError ConversionFailed f "NonEmptyText requires a non-empty string" + returnError ConversionFailed f "NonEmptyText requires a non-empty string" | otherwise -> Ok (NonEmptyText txt) instance FromField NonEmptyText where @@ -321,11 +338,255 @@ assertEqual "yes/no parsing" [YesNo False, YesNo True] rows ] +data DuckDBExpectation + = ExpectEquals FieldValue + | ExpectSatisfies (FieldValue -> Assertion) + | ExpectException (SomeException -> Assertion) + +data DuckDBExpression + = CastExpression Text.Text Text.Text + | DirectExpression Text.Text + +data DuckDBCastCase = DuckDBCastCase + { castLabel :: String + , castExpression :: DuckDBExpression + , castExpectation :: DuckDBExpectation + , castExpectFailureReason :: Maybe String + } + +duckdbTypeCastTests :: TestTree +duckdbTypeCastTests = + testGroup + "duckdb type casts" + (map buildCase duckdbCastCases) + where + buildCase DuckDBCastCase{castLabel, castExpression, castExpectation, castExpectFailureReason} = + let base = + testCase castLabel $ + withConnection ":memory:" \conn -> do + let sql = + Query + (case castExpression of + CastExpression expressionValue expressionType -> + Text.concat ["SELECT CAST(", expressionValue, " AS ", expressionType, ")"] + DirectExpression expressionSQL -> + Text.concat ["SELECT ", expressionSQL] + ) + result <- try (query_ conn sql) :: IO (Either SomeException [Only FieldValue]) + runExpectation castLabel castExpectation result + maybe (pure ()) assertFailure castExpectFailureReason + in maybe base (\reason -> expectFailBecause reason base) castExpectFailureReason + +runExpectation :: String -> DuckDBExpectation -> Either SomeException [Only FieldValue] -> Assertion +runExpectation label expectation outcome = + case expectation of + ExpectEquals expected -> + case outcome of + Right [Only fieldValue] -> + assertEqual (label <> " result mismatch") expected fieldValue + Right other -> + assertFailure (label <> " expected single row, got " <> show other) + Left err -> + assertFailure (label <> " expected success, but query failed: " <> displayException err) + ExpectSatisfies predicate -> + case outcome of + Right [Only fieldValue] -> + predicate fieldValue + Right other -> + assertFailure (label <> " expected single row, got " <> show other) + Left err -> + assertFailure (label <> " expected success, but query failed: " <> displayException err) + ExpectException predicate -> + case outcome of + Left err -> + predicate err + Right rows -> + assertFailure (label <> " expected failure, but query succeeded with " <> show rows) + +duckdbCastCases :: [DuckDBCastCase] +duckdbCastCases = + [ successCase "BOOLEAN" (quoted "true") "BOOLEAN" (ExpectEquals (FieldBool True)) + , successCase "TINYINT" (quotedValue tinyIntValue) "TINYINT" (ExpectEquals (FieldInt8 tinyIntValue)) + , successCase "SMALLINT" (quotedValue smallIntValue) "SMALLINT" (ExpectEquals (FieldInt16 smallIntValue)) + , successCase "INTEGER" (quotedValue intValue) "INTEGER" (ExpectEquals (FieldInt32 intValue)) + , successCase "BIGINT" (quotedValue bigIntValue) "BIGINT" (ExpectEquals (FieldInt64 bigIntValue)) + , successCase "UTINYINT" (quotedValue uTinyValue) "UTINYINT" (ExpectEquals (FieldWord8 uTinyValue)) + , successCase "USMALLINT" (quotedValue uSmallValue) "USMALLINT" (ExpectEquals (FieldWord16 uSmallValue)) + , successCase "UINTEGER" (quotedValue uIntValue) "UINTEGER" (ExpectEquals (FieldWord32 uIntValue)) + , successCase "UBIGINT" (quotedValue uBigValue) "UBIGINT" (ExpectEquals (FieldWord64 uBigValue)) + , successCase "FLOAT" (quoted "3.25") "FLOAT" (ExpectEquals (FieldFloat floatValue)) + , successCase "DOUBLE" (quoted "2.5") "DOUBLE" (ExpectEquals (FieldDouble doubleValue)) + , successCase "TIMESTAMP" (quoted "2024-01-02 03:04:05.123456") "TIMESTAMP" (ExpectEquals (FieldTimestamp timestampLocalTimeMicros)) + , successCase "DATE" (quoted "2024-10-12") "DATE" (ExpectEquals (FieldDate dateValue)) + , successCase "TIME" (quoted "14:30:15.123456") "TIME" (ExpectEquals (FieldTime timeValue)) + , successCase "INTERVAL" (quoted "1 day") "INTERVAL" (ExpectEquals (FieldInterval intervalValue)) + , successCase "HUGEINT" (quotedValue hugeIntLiteral) "HUGEINT" (ExpectEquals (FieldHugeInt hugeIntLiteral)) + , successCase "UHUGEINT" (quotedValue uHugeIntLiteral) "UHUGEINT" (ExpectEquals (FieldUHugeInt uHugeIntLiteral)) + , successCase "VARCHAR" (quoted varcharText) "VARCHAR" (ExpectEquals (FieldText varcharText)) + , successCase "BLOB" (quoted "duckdb") "BLOB" (ExpectEquals (FieldBlob blobValue)) + , successCase "DECIMAL" (quoted "12345.6789") "DECIMAL(18,4)" (ExpectEquals (FieldDecimal decimalValue)) + , successCase "TIMESTAMP_S" (quoted "2024-01-02 03:04:05") "TIMESTAMP_S" (ExpectEquals (FieldTimestamp timestampLocalTimeSeconds)) + , successCase "TIMESTAMP_MS" (quoted "2024-01-02 03:04:05.123") "TIMESTAMP_MS" (ExpectEquals (FieldTimestamp timestampLocalTimeMillis)) + , successCase "TIMESTAMP_NS" (quoted "2024-01-02 03:04:05.123456789") "TIMESTAMP_NS" (ExpectEquals (FieldTimestamp timestampLocalTimeNanos)) + , successCase "ENUM" (quoted "beta") "ENUM('alpha','beta')" (ExpectEquals (FieldEnum 1)) + , successCase "LIST" (quoted "[1,2,3]") "INTEGER[]" (ExpectEquals (FieldList listElements)) + , successDirect "MAP" "MAP(['a','b'], [1,2])" (expectMapEntries mapPairs) + , successCase "TIMETZ" (quoted "03:04:05+02:30") "TIME WITH TIME ZONE" (ExpectEquals (FieldTimeTZ timeWithZoneValue)) + , successCase "TIMESTAMPTZ" (quoted "2024-01-02 03:04:05+02:30") "TIMESTAMP WITH TIME ZONE" (ExpectEquals (FieldTimestampTZ timestampTzUtc)) + , successCase "BIGNUM" (quoted bigNumLiteralText) "BIGNUM" (ExpectEquals (FieldBigNum (BigNum bigNumLiteral))) + , successCase "UUID" (quoted $ UUID.toText uuid) "UUID" (ExpectEquals (FieldUUID uuid)) + , successCase "BIT" (quoted $ Text.pack $ show bits) "BIT" (ExpectEquals (FieldBit bits)) + -- This one is broken upstream, instead of a DuckDBTypeTimeNs, we get a DuckDBType 0 + , failCaseWith "TIME_NS" (quoted "03:04:05.123456789") "TIME_NS" "TIME_NS decoding unsupported" (expectErrorCallContaining "unsupported DuckDB type") + -- not implemented yet + , failCaseWith "STRUCT" (quoted "{\"a\":1,\"b\":2}") "STRUCT(a INTEGER, b INTEGER)" "STRUCT decoding unsupported" (expectErrorCallContaining "STRUCT columns are not supported") + , failCaseWith "ARRAY" (quoted "[1,2,3]") "INTEGER[3]" "ARRAY decoding unsupported" (expectErrorCallContaining "unsupported DuckDB type") + , failCaseWith "UNION" (quoted "1") "UNION(\"value\" INTEGER)" "UNION casts unsupported" (expectSQLErrorContaining "UNION") + -- These can never surface from a query, only internally. + , failCaseOK "ANY" (quoted "1") "ANY" (expectSQLErrorContaining "ANY") + , failCaseOK "STRING_LITERAL" (quoted literalText) "STRING_LITERAL" (expectSQLErrorContaining "STRING_LITERAL") + , failCaseOK "INTEGER_LITERAL" (quoted "123") "INTEGER_LITERAL" (expectSQLErrorContaining "INTEGER_LITERAL") + , failCaseOK "INVALID" "0" "INVALID" (expectSQLErrorContaining "INVALID") + , failCaseOK "SQLNULL" "NULL" "SQLNULL" (expectSQLErrorContaining "SQLNULL") + ] + where + bits = BitString 7 $ BS.pack [1, 255] + quoted t = Text.concat ["'", t, "'"] + quotedValue v = quoted (valueText v) + valueText :: (Show a) => a -> Text.Text + valueText = Text.pack . show + successCase label value ty expectation = + DuckDBCastCase + { castLabel = label + , castExpression = CastExpression value ty + , castExpectation = expectation + , castExpectFailureReason = Nothing + } + successDirect label expr expectation = + DuckDBCastCase + { castLabel = label + , castExpression = DirectExpression expr + , castExpectation = expectation + , castExpectFailureReason = Nothing + } + failCaseWith label value ty reason expectation = + DuckDBCastCase + { castLabel = label + , castExpression = CastExpression value ty + , castExpectation = expectation + , castExpectFailureReason = Just reason + } + failCaseOK label value ty expectation = + DuckDBCastCase + { castLabel = label + , castExpression = CastExpression value ty + , castExpectation = expectation + , castExpectFailureReason = Nothing + } + expectMapEntries expectedPairs = + ExpectSatisfies $ \fieldValue -> + case fieldValue of + FieldMap actualPairs -> + let normalize pairs = sortOn (mapKey . fst) pairs + mapKey (FieldText txt) = txt + mapKey other = Text.pack (show other) + in assertEqual "map entries" (normalize expectedPairs) (normalize actualPairs) + other -> + assertFailure ("expected FieldMap, but saw " <> show other) + expectSQLErrorContaining :: Text.Text -> DuckDBExpectation + expectSQLErrorContaining needle = + ExpectException $ \err -> + case fromException err :: Maybe SQLError of + Just sqlErr -> + let message = sqlErrorMessage sqlErr + in assertBool + ("expected SQLError containing " <> Text.unpack needle <> ", but saw: " <> Text.unpack message) + (Text.isInfixOf needle message) + Nothing -> + assertFailure ("expected SQLError, but saw " <> displayException err) + expectErrorCallContaining :: Text.Text -> DuckDBExpectation + expectErrorCallContaining needle = + ExpectException $ \err -> + case fromException err :: Maybe ErrorCall of + Just callErr -> + let message = Text.pack (displayException callErr) + in assertBool + ("expected ErrorCall containing " <> Text.unpack needle <> ", but saw: " <> Text.unpack message) + (Text.isInfixOf needle message) + Nothing -> + assertFailure ("expected ErrorCall, but saw " <> displayException err) + bsFromString :: String -> BS.ByteString + bsFromString = BS.pack . map (fromIntegral . fromEnum) + secondsWithFraction :: Integer -> Integer -> Integer -> Rational + secondsWithFraction whole numerator denominator = + fromIntegral whole + numerator % denominator + tinyIntValue :: Int8 + tinyIntValue = 42 + smallIntValue :: Int16 + smallIntValue = 32000 + intValue :: Int32 + intValue = 2147483647 + bigIntValue :: Int64 + bigIntValue = 9223372036854775807 + uTinyValue :: Word8 + uTinyValue = 200 + uSmallValue :: Word16 + uSmallValue = 60000 + uIntValue :: Word32 + uIntValue = maxBound + uBigValue :: Word64 + uBigValue = maxBound + floatValue :: Float + floatValue = 3.25 + doubleValue :: Double + doubleValue = 2.5 + timestampDay = fromGregorian 2024 1 2 + timestampLocalTimeMicros = + LocalTime timestampDay (TimeOfDay 3 4 (fromRational (secondsWithFraction 5 123456 1000000))) + timestampLocalTimeSeconds = + LocalTime timestampDay (TimeOfDay 3 4 5) + timestampLocalTimeMillis = + LocalTime timestampDay (TimeOfDay 3 4 (fromRational (secondsWithFraction 5 123 1000))) + timestampLocalTimeNanos = + LocalTime timestampDay (TimeOfDay 3 4 (fromRational (secondsWithFraction 5 123456789 1000000000))) + dateValue = fromGregorian 2024 10 12 + timeValue = + TimeOfDay 14 30 (fromRational (secondsWithFraction 15 123456 1000000)) + intervalValue = + IntervalValue{intervalMonths = 0, intervalDays = 1, intervalMicros = 0} + decimalValue = + DecimalValue{decimalWidth = 18, decimalScale = 4, decimalInteger = 123456789} + listElements = + [FieldInt32 1, FieldInt32 2, FieldInt32 3] + mapPairs = + [ (FieldText (Text.pack "a"), FieldInt32 1) + , (FieldText (Text.pack "b"), FieldInt32 2) + ] + uuid :: UUID.UUID + uuid = fromJust $ UUID.fromText "123e4567-e89b-12d3-a456-426614174000" + timeWithZoneValue = + TimeWithZone{timeWithZoneTime = TimeOfDay 3 4 5, timeWithZoneZone = minutesToTimeZone 150} + timestampTzUtc = + UTCTime timestampDay (secondsToDiffTime 2045) + bigNumLiteral :: Integer + bigNumLiteral = 1234567890123456789012345678901234567890 + bigNumLiteralText = valueText bigNumLiteral + varcharText :: Text.Text + varcharText = "Hello, DuckDB" + blobValue = bsFromString "duckdb" + hugeIntLiteral :: Integer + hugeIntLiteral = (2 ^ (120 :: Int)) + 123456789 + uHugeIntLiteral :: Integer + uHugeIntLiteral = (2 ^ (128 :: Int)) - 1 + literalText :: Text.Text + literalText = "literal" + typeTests :: TestTree typeTests = testGroup "types" - [ testCase "round-trips date/time/timestamp" $ + [ duckdbTypeCastTests + , testCase "round-trips date/time/timestamp" $ withConnection ":memory:" \conn -> do _ <- execute_ conn "CREATE TABLE temporals (d DATE, t TIME, ts TIMESTAMP)" let dayVal = fromGregorian 2024 10 12 @@ -366,6 +627,79 @@ [Only (hugeOut :: Integer)] <- query_ conn "SELECT 170141183460469231731687303715884105727::HUGEINT" assertEqual "hugeint" hugeValue hugeOut + , testCase "decodes huge integers as Natural" $ + withConnection ":memory:" \conn -> do + let hugeValue = 170141183460469231731687303715884105727 :: Natural + [Only (naturalOut :: Natural)] <- + query_ conn "SELECT 170141183460469231731687303715884105727::HUGEINT" + assertEqual "hugeint natural" hugeValue naturalOut + , testCase "decodes unsigned huge integers as Natural" $ + withConnection ":memory:" \conn -> do + let uhValue = 170141183460469231731687303715884105727 :: Natural + [Only (naturalOut :: Natural)] <- + query_ conn "SELECT 170141183460469231731687303715884105727::UHUGEINT" + assertEqual "uhugeint natural" uhValue naturalOut + , testCase "FromField Integer consumes FieldBigNum" $ do + let original = 1234567899876543210123456789 :: Integer + bigField = + Field + { fieldName = "big" + , fieldIndex = 0 + , fieldValue = FieldBigNum (BigNum original) + } + case (fromField bigField :: Ok Integer) of + Ok result -> assertEqual "FieldBigNum Integer" original result + Errors err -> assertFailure ("unexpected parse failure: " <> show err) + , testCase "FromField Natural rejects negative FieldBigNum" $ do + let bigValue = BigNum (-5) + bigField = + Field + { fieldName = "big" + , fieldIndex = 0 + , fieldValue = FieldBigNum bigValue + } + case (fromField bigField :: Ok Natural) of + Errors _ -> pure () + Ok result -> assertFailure ("expected failure, got " <> show result) + , testCase "BigNum conversions round-trip Integer" $ do + let original = (2 ^ (200 :: Int)) + 8675309 :: Integer + converted = toBigNumBytes original + assertEqual "round-trip Integer" original (fromBigNumBytes converted) + , testProperty "fromBigNumBytes . toBigNumBytes is identity" \(n :: Integer) -> + fromBigNumBytes (toBigNumBytes n) === n + , testCase "selects BIGNUM values as BigNum" $ + withConnection ":memory:" \conn -> do + _ <- execute_ conn "CREATE TABLE bignums (val BIGNUM)" + let bigValues :: [Integer] + bigValues = + [ (2 ^ (200 :: Int)) + 8675309 + , 0 + , negate ((2 ^ (180 :: Int)) + 12345) + ] + rows <- concat <$> mapM (\bv -> query_ conn $ fromString $ "SELECT CAST('" <> show bv <> "' AS BIGNUM)") bigValues + -- query_ conn "SELECT val FROM bignums ORDER BY rowid" :: IO [Only BigNum] + assertEqual "BIGNUM results" (fmap (Only . BigNum) bigValues) rows + , testCase "round-trips BIGNUM values through the database" $ + withConnection ":memory:" \conn -> do + _ <- execute_ conn "CREATE TABLE bignum_roundtrip (val BIGNUM)" + let ints = + [ (2 ^ (200 :: Int)) + 8675309 + , 0 + , negate ((2 ^ (180 :: Int)) + 12345) + ] + _ <- executeMany conn "INSERT INTO bignum_roundtrip VALUES (?)" (fmap (Only . BigNum) ints) + rows <- query_ conn "SELECT val FROM bignum_roundtrip ORDER BY rowid" :: IO [Only Integer] + assertEqual "BIGNUM round-trip" (fmap Only ints) rows + , testCase "duckdbColumnType reports BIGNUM for Integer" $ + assertEqual + "duckdbColumnType Integer" + (Text.pack "BIGNUM") + (duckdbColumnType (Proxy :: Proxy Integer)) + , testCase "duckdbColumnType preserves Maybe parameter" $ + assertEqual + "duckdbColumnType Maybe Word16" + (Text.pack "USMALLINT") + (duckdbColumnType (Proxy :: Proxy (Maybe Word16))) , testCase "decodes interval components" $ withConnection ":memory:" \conn -> do [Only intervalVal] <- @@ -380,9 +714,10 @@ withConnection ":memory:" \conn -> do [Only decimalAsDouble] <- (query_ conn "SELECT CAST(12345.6789 AS DECIMAL(18,4))" :: IO [Only Double]) + let diff = abs (decimalAsDouble - 12345.6789) assertBool - "decimal as double" - (abs (decimalAsDouble - 12345.6789) < 1e-6) + ("decimal as double: " <> show diff) + (diff < 1e-4) , testCase "decodes time with time zone" $ withConnection ":memory:" \conn -> do [Only tzVal] <- query_ conn "SELECT TIMETZ '14:30:15+02:30'" @@ -390,6 +725,17 @@ expectedZone = minutesToTimeZone 150 assertEqual "timetz time" expectedTime (timeWithZoneTime tzVal) assertEqual "timetz zone" expectedZone (timeWithZoneZone tzVal) + , testCase "decodes list columns into Haskell lists" $ + withConnection ":memory:" \conn -> do + [Only (listOut :: [Int])] <- + query_ conn "SELECT LIST_VALUE(1, 2, 3)::INTEGER[]" + assertEqual "list decode" [1, 2, 3] listOut + , testCase "decodes map columns into strict Map" $ + withConnection ":memory:" \conn -> do + [Only (mapOut :: Map.Map Text.Text Int)] <- + query_ conn "SELECT MAP(['a', 'b']::TEXT[], [1, 2]::INTEGER[])" + let expected = Map.fromList [(Text.pack "a", 1), (Text.pack "b", 2)] + assertEqual "map decode" expected mapOut , testCase "decodes timestamp with time zone as UTC" $ withConnection ":memory:" \conn -> do [Only utcVal] <- @@ -409,6 +755,34 @@ assertThrows (query_ conn "SELECT name FROM nonempty" :: IO [Only NonEmptyText]) (Text.isInfixOf "NonEmptyText requires a non-empty string" . sqlErrorMessage) + , testCase "round-trips uuid payloads" $ + withConnection ":memory:" \conn -> do + _ <- execute_ conn "CREATE TABLE uuids (uuid UUID)" + let uuidTexts = + [ "123e4567-e89b-12d3-a456-426614174000" + , "923e4567-e89b-12d3-a456-426614174000" + , "ffffffff-ffff-ffff-ffff-ffffffffffff" + ] + maybeUUIDs = traverse UUID.fromText uuidTexts + uuids <- + case maybeUUIDs of + Nothing -> assertFailure "invalid UUID literal in test data" >> pure [] + Just parsed -> pure parsed + _ <- executeMany conn "INSERT INTO uuids VALUES (?)" (fmap Only uuids) + rows <- query_ conn "SELECT uuid FROM uuids ORDER BY rowid" :: IO [Only UUID.UUID] + assertEqual "uuid round-trip" (fmap Only uuids) rows + , testCase "round-trips bitstring payloads" $ + withConnection ":memory:" \conn -> do + _ <- execute_ conn "CREATE TABLE bits (bit BIT)" + let bitValues = + [ bsFromBool [True] + , bsFromBool [False, False, False, True, True, True, False, True, False] + , bsFromBool [False, False, False, False, True, True, True, False, True, False] + , bsFromBool [True, False, False, False, True, True, True, False, True, False] + ] + _ <- executeMany conn "INSERT INTO bits VALUES (?)" (fmap Only bitValues) + rows <- query_ conn "SELECT bit FROM bits ORDER BY rowid" :: IO [Only BitString] + assertEqual "bit round-trip" (fmap Only bitValues) rows ] streamingTests :: TestTree