diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,13 @@ # Changelog +# Changelog + +## 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. +- Fixed enum decoding for both query results and scalar-function inputs by honouring the logical type’s underlying storage width (uint8/uint16/uint32). +- Ensured decimal vectors read accurate width/scale metadata when materializing results or invoking UDFs. +- Added unsigned `ToField` bindings that route through DuckDB’s native uint creators and exposed `FromField Word`. +- Expanded the test suite with regressions covering unsigned round-trips, huge integers, intervals, decimals, and timezone-aware values. + ## 0.1.0.0 - Initial release 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.1 +version: 0.1.1.2 license: MPL-2.0 license-file: LICENSE author: Matthias Pall Gissurarson 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 @@ -77,6 +77,7 @@ 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.Int (Int16, Int32, Int64, Int8) import Data.Maybe (isJust, isNothing) import Data.Text (Text) @@ -84,42 +85,55 @@ import qualified Data.Text.Foreign as TextForeign import qualified Data.Text.Encoding as TextEncoding import Data.Time.Calendar (Day, fromGregorian) -import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.LocalTime + ( LocalTime (..) + , TimeOfDay (..) + , minutesToTimeZone + , utcToLocalTime + , utc + ) import Data.Word (Word16, Word32, Word64, Word8) import Data.Ratio ((%)) import Database.DuckDB.FFI -import Database.DuckDB.Simple.FromField ( - Field (..), - FieldValue (..), - FieldParser, - FromField (..), - ResultError (..), - ) -import Database.DuckDB.Simple.FromRow ( - FromRow (..), - RowParser, - field, - fieldWith, - numFieldsRemaining, - parseRow, - rowErrorsToSqlError +import Database.DuckDB.Simple.FromField + ( BigNum (..) + , BitString (..) + , DecimalValue (..) + , Field (..) + , FieldValue (..) + , FieldParser + , FromField (..) + , ResultError (..) + , IntervalValue (..) + , TimeWithZone (..) ) +import Database.DuckDB.Simple.FromRow + ( FromRow (..) + , RowParser + , field + , fieldWith + , numFieldsRemaining + , parseRow + , rowErrorsToSqlError + ) import Database.DuckDB.Simple.Function (Function, createFunction, deleteFunction) -import Database.DuckDB.Simple.Internal ( - Connection (..), - ConnectionState (..), - Query (..), - SQLError (..), - Statement (..), - StatementState (..), - StatementStream (..), - StatementStreamChunk (..), - StatementStreamChunkVector (..), - StatementStreamColumn (..), - StatementStreamState (..), - withConnectionHandle, - withQueryCString, - withStatementHandle +import Database.DuckDB.Simple.Internal + ( Connection (..) + , ConnectionState (..) + , Query (..) + , SQLError (..) + , Statement (..) + , StatementState (..) + , StatementStream (..) + , StatementStreamChunk (..) + , StatementStreamChunkVector (..) + , StatementStreamColumn (..) + , StatementStreamState (..) + , withConnectionHandle + , withQueryCString + , withStatementHandle ) import Database.DuckDB.Simple.ToField (FieldBinding, NamedParam (..), ToField (..), bindFieldBinding, renderFieldBinding) import Database.DuckDB.Simple.ToRow (ToRow (..)) @@ -862,6 +876,12 @@ destroyPrepared stmt = alloca \ptr -> poke ptr stmt >> c_duckdb_destroy_prepare ptr +destroyLogicalType :: DuckDBLogicalType -> IO () +destroyLogicalType logicalType = + alloca \ptr -> do + poke ptr logicalType + c_duckdb_destroy_logical_type ptr + fetchPrepareError :: DuckDBPreparedStatement -> IO Text fetchPrepareError stmt = do msgPtr <- c_duckdb_prepare_error stmt @@ -1057,10 +1077,11 @@ zipWithM (buildMaterializedField rowIdx) columns vectors buildMaterializedField :: Int -> StatementStreamColumn -> StatementStreamChunkVector -> IO Field -buildMaterializedField rowIdx column StatementStreamChunkVector{statementStreamChunkVectorData, statementStreamChunkVectorValidity} = do +buildMaterializedField rowIdx column StatementStreamChunkVector{statementStreamChunkVectorHandle, statementStreamChunkVectorData, statementStreamChunkVectorValidity} = do value <- materializedValueFromPointers (statementStreamColumnType column) + statementStreamChunkVectorHandle statementStreamChunkVectorData statementStreamChunkVectorValidity rowIdx @@ -1077,7 +1098,7 @@ 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 dataPtr validity localRow + materializedValueFromPointers dtype vector dataPtr validity localRow withChunkForRow :: Ptr DuckDBResult -> Int -> (DuckDBDataChunk -> Int -> IO a) -> IO a withChunkForRow resPtr targetRow action = do @@ -1106,70 +1127,138 @@ seek (chunkIdx + 1) (remaining - rowCount) seek 0 targetRow -materializedValueFromPointers :: DuckDBType -> Ptr () -> Ptr Word64 -> Int -> IO FieldValue -materializedValueFromPointers dtype dataPtr validity rowIdx = do +materializedValueFromPointers :: DuckDBType -> DuckDBVector -> Ptr () -> Ptr Word64 -> Int -> IO FieldValue +materializedValueFromPointers dtype vector dataPtr validity rowIdx = do let duckIdx = fromIntegral rowIdx :: DuckDBIdx valid <- chunkIsRowValid validity duckIdx if not valid then pure FieldNull - else case dtype of - DuckDBTypeBoolean -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx - pure (FieldBool (raw /= 0)) - DuckDBTypeTinyInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Int8) rowIdx - pure (FieldInt8 raw) - DuckDBTypeSmallInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx - pure (FieldInt16 raw) - DuckDBTypeInteger -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx - pure (FieldInt32 raw) - DuckDBTypeBigInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx - pure (FieldInt64 raw) - DuckDBTypeUTinyInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx - pure (FieldWord8 raw) - DuckDBTypeUSmallInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx - pure (FieldWord16 raw) - DuckDBTypeUInteger -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx - pure (FieldWord32 raw) - DuckDBTypeUBigInt -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Word64) rowIdx - pure (FieldWord64 raw) - DuckDBTypeFloat -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Float) rowIdx - pure (FieldFloat raw) - DuckDBTypeDouble -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Double) rowIdx - pure (FieldDouble raw) - DuckDBTypeVarchar -> FieldText <$> chunkDecodeText dataPtr duckIdx - DuckDBTypeUUID -> FieldText <$> chunkDecodeText dataPtr duckIdx - DuckDBTypeBlob -> FieldBlob <$> chunkDecodeBlob dataPtr duckIdx - DuckDBTypeDate -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx - FieldDate <$> decodeDuckDBDate (DuckDBDate raw) - DuckDBTypeTime -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTime) rowIdx - FieldTime <$> decodeDuckDBTime raw - DuckDBTypeTimestamp -> do - raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx - FieldTimestamp <$> decodeDuckDBTimestamp raw - DuckDBTypeDecimal -> do - decimal <- peekElemOff (castPtr dataPtr :: Ptr DuckDBDecimal) rowIdx - alloca \ptr -> do - poke ptr decimal - CDouble value <- c_duckdb_decimal_to_double ptr - pure (FieldDouble (realToFrac value)) - DuckDBTypeHugeInt -> - error "duckdb-simple: HugeInt type not supported" - DuckDBTypeUHugeInt -> - error "duckdb-simple: UHugeInt type not supported" - other -> - error ("duckdb-simple: unsupported DuckDB type in eager result: " <> show other) + 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 + pure (FieldBool (raw /= 0)) + DuckDBTypeTinyInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Int8) rowIdx + pure (FieldInt8 raw) + DuckDBTypeSmallInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx + pure (FieldInt16 raw) + DuckDBTypeInteger -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx + pure (FieldInt32 raw) + DuckDBTypeBigInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx + pure (FieldInt64 raw) + DuckDBTypeUTinyInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx + pure (FieldWord8 raw) + DuckDBTypeUSmallInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx + pure (FieldWord16 raw) + DuckDBTypeUInteger -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx + pure (FieldWord32 raw) + DuckDBTypeUBigInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Word64) rowIdx + pure (FieldWord64 raw) + DuckDBTypeFloat -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Float) rowIdx + pure (FieldFloat raw) + DuckDBTypeDouble -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Double) rowIdx + pure (FieldDouble raw) + DuckDBTypeVarchar -> FieldText <$> chunkDecodeText dataPtr duckIdx + DuckDBTypeUUID -> FieldText <$> chunkDecodeText dataPtr duckIdx + DuckDBTypeBlob -> FieldBlob <$> chunkDecodeBlob dataPtr duckIdx + DuckDBTypeDate -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx + FieldDate <$> decodeDuckDBDate (DuckDBDate raw) + DuckDBTypeTime -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTime) rowIdx + FieldTime <$> decodeDuckDBTime raw + DuckDBTypeTimeNs -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeNs) rowIdx + pure (FieldTime (decodeDuckDBTimeNs raw)) + DuckDBTypeTimeTz -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeTz) rowIdx + FieldTimeTZ <$> decodeDuckDBTimeTz raw + DuckDBTypeTimestamp -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx + FieldTimestamp <$> decodeDuckDBTimestamp raw + DuckDBTypeTimestampS -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampS) rowIdx + FieldTimestamp <$> decodeDuckDBTimestampSeconds raw + DuckDBTypeTimestampMs -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampMs) rowIdx + FieldTimestamp <$> decodeDuckDBTimestampMilliseconds raw + DuckDBTypeTimestampNs -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampNs) rowIdx + FieldTimestamp <$> decodeDuckDBTimestampNanoseconds raw + DuckDBTypeTimestampTz -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx + FieldTimestampTZ <$> decodeDuckDBTimestampUTCTime raw + DuckDBTypeInterval -> do + 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" + DuckDBTypeHugeInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx + pure (FieldHugeInt (duckDBHugeIntToInteger raw)) + DuckDBTypeUHugeInt -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx + pure (FieldUHugeInt (duckDBUHugeIntToInteger raw)) + DuckDBTypeBit -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBit) rowIdx + FieldBit <$> decodeDuckDBBit raw + DuckDBTypeBigNum -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBignum) rowIdx + FieldBigNum <$> decodeDuckDBBigNum raw + 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" + DuckDBTypeSQLNull -> + pure FieldNull + DuckDBTypeStringLiteral -> FieldText <$> chunkDecodeText dataPtr duckIdx + DuckDBTypeIntegerLiteral -> do + raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx + pure (FieldInt64 raw) + other -> + error ("duckdb-simple: unsupported DuckDB type in eager result: " <> show other) decodeDuckDBDate :: DuckDBDate -> IO Day decodeDuckDBDate raw = @@ -1210,6 +1299,94 @@ (fromIntegral duckDBTimeStructHour) (fromIntegral duckDBTimeStructMinute) totalSeconds + +decodeDuckDBTimeNs :: DuckDBTimeNs -> TimeOfDay +decodeDuckDBTimeNs (DuckDBTimeNs nanos) = + let (hours, remainderHours) = nanos `divMod` (60 * 60 * 1000000000) + (minutes, remainderMinutes) = remainderHours `divMod` (60 * 1000000000) + (seconds, fractionalNanos) = remainderMinutes `divMod` 1000000000 + fractional = fromRational (toInteger fractionalNanos % 1000000000) + totalSeconds = fromIntegral seconds + fractional + in TimeOfDay + (fromIntegral hours) + (fromIntegral minutes) + totalSeconds + +decodeDuckDBTimeTz :: DuckDBTimeTz -> IO TimeWithZone +decodeDuckDBTimeTz raw = + alloca \ptr -> do + c_duckdb_from_time_tz raw ptr + DuckDBTimeTzStruct{duckDBTimeTzStructTime = timeStruct, duckDBTimeTzStructOffset = offset} <- peek ptr + let timeOfDay = timeStructToTimeOfDay timeStruct + minutes = fromIntegral offset `div` 60 + zone = minutesToTimeZone minutes + pure TimeWithZone{timeWithZoneTime = timeOfDay, timeWithZoneZone = zone} + +decodeDuckDBTimestampSeconds :: DuckDBTimestampS -> IO LocalTime +decodeDuckDBTimestampSeconds (DuckDBTimestampS seconds) = + decodeDuckDBTimestamp (DuckDBTimestamp (seconds * 1000000)) + +decodeDuckDBTimestampMilliseconds :: DuckDBTimestampMs -> IO LocalTime +decodeDuckDBTimestampMilliseconds (DuckDBTimestampMs millis) = + decodeDuckDBTimestamp (DuckDBTimestamp (millis * 1000)) + +decodeDuckDBTimestampNanoseconds :: DuckDBTimestampNs -> IO LocalTime +decodeDuckDBTimestampNanoseconds (DuckDBTimestampNs nanos) = do + let utcTime = posixSecondsToUTCTime (fromRational (toInteger nanos % 1000000000)) + pure (utcToLocalTime utc utcTime) + +decodeDuckDBTimestampUTCTime :: DuckDBTimestamp -> IO UTCTime +decodeDuckDBTimestampUTCTime (DuckDBTimestamp micros) = + pure (posixSecondsToUTCTime (fromRational (toInteger micros % 1000000))) + +intervalValueFromDuckDB :: DuckDBInterval -> IntervalValue +intervalValueFromDuckDB DuckDBInterval{duckDBIntervalMonths, duckDBIntervalDays, duckDBIntervalMicros} = + IntervalValue + { intervalMonths = duckDBIntervalMonths + , intervalDays = duckDBIntervalDays + , 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} = + (fromIntegral duckDBHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBHugeIntLower + +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 @@ -14,6 +14,11 @@ module Database.DuckDB.Simple.FromField ( Field (..), FieldValue (..), + BitString (..), + BigNum (..), + DecimalValue (..), + IntervalValue (..), + TimeWithZone (..), ResultError (..), FieldParser, FromField (..), @@ -28,7 +33,14 @@ import qualified Data.Text.Encoding as TextEncoding import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime (..)) -import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), localTimeToUTC, utc) +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 @@ -53,12 +65,50 @@ | FieldDate Day | FieldTime TimeOfDay | FieldTimestamp LocalTime - -- TODO: HugeInt and UHugeInt support + | FieldInterval IntervalValue + | FieldHugeInt Integer + | FieldUHugeInt Integer + | FieldDecimal DecimalValue + | FieldTimestampTZ UTCTime + | FieldTimeTZ TimeWithZone + | FieldBit BitString + | FieldBigNum BigNum + | FieldEnum Word32 + deriving (Eq, Show) - deriving (-- | FieldInteger Integer - -- | FieldNatural Natural - Eq, Show) +data DecimalValue = DecimalValue + { decimalWidth :: !Word8 + , decimalScale :: !Word8 + , decimalInteger :: !Integer + , decimalApproximate :: !Double + } + deriving (Eq, Show) +data IntervalValue = IntervalValue + { intervalMonths :: !Int32 + , intervalDays :: !Int32 + , intervalMicros :: !Int64 + } + 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) + +data TimeWithZone = TimeWithZone + { timeWithZoneTime :: !TimeOfDay + , timeWithZoneZone :: !TimeZone + } + deriving (Eq, Show) + -- | Pattern synonym to make it easier to match on any integral type. pattern FieldInt :: Int -> FieldValue pattern FieldInt i <- (fieldValueToInt -> Just i) @@ -152,6 +202,9 @@ fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> Ok (fromIntegral i) + FieldHugeInt value -> boundedFromInteger f value + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -159,6 +212,9 @@ fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> Ok (fromIntegral i) + FieldHugeInt value -> boundedFromInteger f value + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> Ok (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -166,6 +222,9 @@ fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> boundedIntegral f i + FieldHugeInt value -> boundedFromInteger f value + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -173,6 +232,9 @@ fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> boundedIntegral f i + FieldHugeInt value -> boundedFromInteger f value + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -180,9 +242,22 @@ fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> boundedIntegral f i + FieldHugeInt value -> boundedFromInteger f value + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" +instance FromField Integer where + fromField f@Field{fieldValue} = + case fieldValue of + FieldInt i -> Ok (fromIntegral i) + FieldWord w -> Ok (fromIntegral w) + FieldHugeInt value -> Ok value + FieldUHugeInt value -> Ok value + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField Word64 where fromField f@Field{fieldValue} = case fieldValue of @@ -191,6 +266,12 @@ | otherwise -> returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) + FieldHugeInt value + | value >= 0 -> boundedFromInteger f value + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> Ok (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -202,6 +283,12 @@ | otherwise -> returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) + FieldHugeInt value + | value >= 0 -> boundedFromInteger f value + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> Ok value FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -213,6 +300,12 @@ | otherwise -> returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) + FieldHugeInt value + | value >= 0 -> boundedFromInteger f value + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -224,14 +317,38 @@ | otherwise -> returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) + FieldHugeInt value + | value >= 0 -> boundedFromInteger f value + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" +instance FromField Word where + fromField f@Field{fieldValue} = + case fieldValue of + FieldInt i + | i >= 0 -> boundedFromInteger f (fromIntegral i) + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + FieldWord w -> Ok w + FieldHugeInt value + | value >= 0 -> boundedFromInteger f value + | otherwise -> + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" + FieldUHugeInt value -> boundedFromInteger f value + FieldEnum value -> boundedFromInteger f (fromIntegral value) + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField Double where fromField f@Field{fieldValue} = case fieldValue of FieldDouble d -> Ok d FieldInt i -> Ok (fromIntegral i) + FieldDecimal DecimalValue{decimalApproximate} -> Ok decimalApproximate FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" @@ -259,9 +376,31 @@ case fieldValue of FieldBlob bs -> Ok bs FieldText t -> Ok (TextEncoding.encodeUtf8 t) + FieldBit bit -> Ok (bitStringBytes bit) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" +instance FromField BitString where + fromField f@Field{fieldValue} = + case fieldValue of + FieldBit bit -> Ok bit + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + +instance FromField BigNum where + fromField f@Field{fieldValue} = + case fieldValue of + FieldBigNum big -> Ok big + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + +instance FromField DecimalValue where + fromField f@Field{fieldValue} = + case fieldValue of + FieldDecimal dec -> Ok dec + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField Day where fromField f@Field{fieldValue} = case fieldValue of @@ -278,21 +417,41 @@ FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" +instance FromField TimeWithZone where + fromField f@Field{fieldValue} = + case fieldValue of + FieldTimeTZ tz -> Ok tz + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField LocalTime where fromField f@Field{ fieldValue} = case fieldValue of FieldTimestamp ts -> Ok ts FieldDate day -> Ok (LocalTime day midnight) + FieldTimestampTZ utcTime -> Ok (utcToLocalTime utc utcTime) FieldNull -> returnError UnexpectedNull f "" _ -> returnError Incompatible f "" where midnight = TimeOfDay 0 0 0 +instance FromField IntervalValue where + fromField f@Field{fieldValue} = + case fieldValue of + FieldInterval interval -> Ok interval + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + instance FromField UTCTime where - fromField field = - case fromField field of - Ok (timestamp :: LocalTime) -> Ok (localTimeToUTC utc timestamp) - Errors errs -> Errors errs + fromField f@Field{fieldValue} = + case fieldValue of + FieldTimestamp ts -> Ok (localTimeToUTC utc ts) + FieldTimestampTZ utcTime -> Ok utcTime + FieldDate day -> Ok (localTimeToUTC utc (LocalTime day midnight)) + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" + where + midnight = TimeOfDay 0 0 0 instance (FromField a) => FromField (Maybe a) where fromField Field{fieldValue = FieldNull} = Ok Nothing @@ -307,6 +466,14 @@ returnError ConversionFailed f "integer value out of bounds" | otherwise = Ok (fromIntegral i) +boundedFromInteger :: forall a. (Integral a, Bounded a, Typeable a) => Field -> Integer -> Ok a +boundedFromInteger f@Field{} value + | value < toInteger (minBound :: a) = + returnError ConversionFailed f "integer value out of bounds" + | value > toInteger (maxBound :: a) = + 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 returnError :: forall b. (Typeable b) => (Text -> Text -> Text -> Text -> ResultError) -> Field -> Text -> Ok b @@ -336,7 +503,12 @@ FieldDate{} -> "DATE" FieldTime{} -> "TIME" FieldTimestamp{} -> "TIMESTAMP" - --- TODO: Not supported yet --- FieldInteger{} -> "HUGEINT" --- FieldNatural{} -> "UHUGEINT" + FieldInterval{} -> "INTERVAL" + FieldHugeInt{} -> "HUGEINT" + FieldUHugeInt{} -> "UHUGEINT" + FieldDecimal{} -> "DECIMAL" + FieldTimestampTZ{} -> "TIMESTAMP_TZ" + FieldTimeTZ{} -> "TIME_TZ" + FieldBit{} -> "BIT" + FieldBigNum{} -> "BIGNUM" + FieldEnum{} -> "ENUM" 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 @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,32 +32,49 @@ ) import Control.Monad (forM, forM_, when) 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.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 Database.DuckDB.FFI -import Database.DuckDB.Simple.FromField ( - Field (..), - FieldValue (..), - FromField (..), - ) -import Database.DuckDB.Simple.Internal ( - Connection, - Query (..), - SQLError (..), - withConnectionHandle, - withQueryCString, - ) +import Database.DuckDB.Simple.FromField + ( BigNum (..) + , BitString (..) + , DecimalValue (..) + , Field (..) + , FieldValue (..) + , FromField (..) + , IntervalValue (..) + , TimeWithZone (..) + ) +import Database.DuckDB.Simple.Internal + ( Connection + , Query (..) + , SQLError (..) + , withConnectionHandle + , withQueryCString + ) import Foreign.C.String (peekCString) -import Foreign.C.Types (CBool (..)) +import Foreign.C.Types (CBool (..), CDouble (..)) 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 (peekElemOff, poke, pokeElemOff) +import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff) import Database.DuckDB.Simple.Ok (Ok(..)) -- | Tag DuckDB logical types we support for scalar return values. @@ -362,6 +380,17 @@ vector <- c_duckdb_data_chunk_get_vector chunk (fromIntegral columnIndex) logical <- c_duckdb_vector_get_column_type vector dtype <- c_duckdb_get_type_id logical + decimalInfo <- + if dtype == DuckDBTypeDecimal + then do + width <- c_duckdb_decimal_width logical + scale <- c_duckdb_decimal_scale logical + pure (Just (width, scale)) + else pure Nothing + enumInternal <- + if dtype == DuckDBTypeEnum + then Just <$> c_duckdb_enum_internal_type logical + else pure Nothing destroyLogicalType logical dataPtr <- c_duckdb_vector_get_data vector validity <- c_duckdb_vector_get_validity vector @@ -370,7 +399,7 @@ valid <- isRowValid validity rowIdx value <- if valid - then fetchValue dtype dataPtr rowIdx + then fetchValue dtype decimalInfo enumInternal dataPtr rowIdx else pure FieldNull pure Field @@ -386,51 +415,126 @@ CBool flag <- c_duckdb_validity_row_is_valid validity rowIdx pure (flag /= 0) -fetchValue :: DuckDBType -> Ptr () -> DuckDBIdx -> IO FieldValue -fetchValue dtype dataPtr rowIdx - | dtype == DuckDBTypeBoolean = do - value <- peekElemOff (castPtr dataPtr :: Ptr Word8) (fromIntegral rowIdx) - pure (FieldBool (value /= 0)) - | dtype == DuckDBTypeTinyInt = do - value <- peekElemOff (castPtr dataPtr :: Ptr Int8) (fromIntegral rowIdx) - pure (FieldInt8 (fromIntegral value)) - | dtype == DuckDBTypeSmallInt = do - value <- peekElemOff (castPtr dataPtr :: Ptr Int16) (fromIntegral rowIdx) - pure (FieldInt16 (fromIntegral value)) - | dtype == DuckDBTypeInteger = do - value <- peekElemOff (castPtr dataPtr :: Ptr Int32) (fromIntegral rowIdx) - pure (FieldInt32 (fromIntegral value)) - | dtype == DuckDBTypeBigInt || dtype == DuckDBTypeHugeInt = do - value <- peekElemOff (castPtr dataPtr :: Ptr Int64) (fromIntegral rowIdx) - pure (FieldInt64 value) - | dtype == DuckDBTypeUTinyInt = do - value <- peekElemOff (castPtr dataPtr :: Ptr Word8) (fromIntegral rowIdx) - pure (FieldWord8 (fromIntegral value)) - | dtype == DuckDBTypeUSmallInt = do - value <- peekElemOff (castPtr dataPtr :: Ptr Word16) (fromIntegral rowIdx) - pure (FieldWord16 (fromIntegral value)) - | dtype == DuckDBTypeUInteger = do - value <- peekElemOff (castPtr dataPtr :: Ptr Word32) (fromIntegral rowIdx) - pure (FieldWord32 (fromIntegral value)) - | dtype == DuckDBTypeUBigInt || dtype == DuckDBTypeUHugeInt = do - value <- peekElemOff (castPtr dataPtr :: Ptr Word64) (fromIntegral rowIdx) - pure (FieldWord64 (fromIntegral value)) - | dtype == DuckDBTypeFloat = do - value <- peekElemOff (castPtr dataPtr :: Ptr Float) (fromIntegral rowIdx) - pure (FieldDouble (realToFrac value)) - | dtype == DuckDBTypeDouble = do - value <- peekElemOff (castPtr dataPtr :: Ptr Double) (fromIntegral rowIdx) - pure (FieldDouble value) - | dtype == DuckDBTypeVarchar = do - textValue <- decodeDuckText dataPtr rowIdx - pure (FieldText textValue) - | otherwise = - throwIO $ - functionInvocationError $ - Text.concat - [ Text.pack "duckdb-simple: unsupported argument type " - , Text.pack (show dtype) - ] +fetchValue :: DuckDBType -> Maybe (Word8, Word8) -> Maybe DuckDBType -> Ptr () -> DuckDBIdx -> IO FieldValue +fetchValue dtype decimalInfo enumInternal dataPtr rowIdx = + let idx = fromIntegral rowIdx + in case dtype of + DuckDBTypeBoolean -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word8) idx + pure (FieldBool (value /= 0)) + DuckDBTypeTinyInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Int8) idx + pure (FieldInt8 value) + DuckDBTypeSmallInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Int16) idx + pure (FieldInt16 value) + DuckDBTypeInteger -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Int32) idx + pure (FieldInt32 value) + DuckDBTypeBigInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Int64) idx + pure (FieldInt64 value) + DuckDBTypeHugeInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) idx + pure (FieldHugeInt (duckDBHugeIntToInteger value)) + DuckDBTypeUTinyInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word8) idx + pure (FieldWord8 value) + DuckDBTypeUSmallInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word16) idx + pure (FieldWord16 value) + DuckDBTypeUInteger -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word32) idx + pure (FieldWord32 value) + DuckDBTypeUBigInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word64) idx + pure (FieldWord64 value) + DuckDBTypeUHugeInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) idx + pure (FieldUHugeInt (duckDBUHugeIntToInteger value)) + DuckDBTypeFloat -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Float) idx + pure (FieldFloat value) + DuckDBTypeDouble -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Double) idx + pure (FieldDouble value) + DuckDBTypeVarchar -> FieldText <$> decodeDuckText dataPtr rowIdx + DuckDBTypeUUID -> FieldText <$> decodeDuckText dataPtr rowIdx + DuckDBTypeBlob -> FieldBlob <$> decodeDuckBlob dataPtr rowIdx + DuckDBTypeDate -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBDate) idx + FieldDate <$> decodeDuckDBDate value + DuckDBTypeTime -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTime) idx + FieldTime <$> decodeDuckDBTime value + DuckDBTypeTimeNs -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeNs) idx + pure (FieldTime (decodeDuckDBTimeNs value)) + DuckDBTypeTimeTz -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeTz) idx + FieldTimeTZ <$> decodeDuckDBTimeTz value + DuckDBTypeTimestamp -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) idx + FieldTimestamp <$> decodeDuckDBTimestamp value + DuckDBTypeTimestampS -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampS) idx + FieldTimestamp <$> decodeDuckDBTimestampSeconds value + DuckDBTypeTimestampMs -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampMs) idx + FieldTimestamp <$> decodeDuckDBTimestampMilliseconds value + DuckDBTypeTimestampNs -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampNs) idx + FieldTimestamp <$> decodeDuckDBTimestampNanoseconds value + DuckDBTypeTimestampTz -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) idx + FieldTimestampTZ <$> decodeDuckDBTimestampUTCTime value + DuckDBTypeInterval -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBInterval) idx + pure (FieldInterval (intervalValueFromDuckDB value)) + DuckDBTypeDecimal -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBDecimal) idx + case decimalInfo of + Just (width, scale) -> do + decimal <- decimalValueFromDuckDB width scale value + pure (FieldDecimal decimal) + Nothing -> + throwIO $ + functionInvocationError $ + Text.pack "duckdb-simple: missing decimal metadata for scalar function argument" + DuckDBTypeBit -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBit) idx + FieldBit <$> decodeDuckDBBit value + DuckDBTypeBigNum -> do + value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBBignum) idx + FieldBigNum <$> decodeDuckDBBigNum value + DuckDBTypeEnum -> do + case enumInternal of + Just DuckDBTypeUTinyInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word8) idx + pure (FieldEnum (fromIntegral value)) + Just DuckDBTypeUSmallInt -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word16) idx + pure (FieldEnum (fromIntegral value)) + Just DuckDBTypeUInteger -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Word32) idx + pure (FieldEnum value) + _ -> + throwIO $ + functionInvocationError $ + Text.pack "duckdb-simple: unsupported enum internal storage type for scalar function argument" + DuckDBTypeSQLNull -> + pure FieldNull + DuckDBTypeStringLiteral -> FieldText <$> decodeDuckText dataPtr rowIdx + DuckDBTypeIntegerLiteral -> do + value <- peekElemOff (castPtr dataPtr :: Ptr Int64) idx + pure (FieldInt64 value) + other -> + throwIO $ + functionInvocationError $ + Text.concat + [ Text.pack "duckdb-simple: unsupported argument type " + , Text.pack (show other) + ] decodeDuckText :: Ptr () -> DuckDBIdx -> IO Text decodeDuckText dataPtr rowIdx = do @@ -445,8 +549,148 @@ bytes <- BS.packCStringLen (cstr, fromIntegral len) pure (TE.decodeUtf8 bytes) +decodeDuckBlob :: Ptr () -> DuckDBIdx -> IO BS.ByteString +decodeDuckBlob dataPtr rowIdx = do + let bytePtr = castPtr dataPtr :: Ptr Word8 + offset = fromIntegral rowIdx * duckdbStringTSize + stringPtr = castPtr (bytePtr `plusPtr` offset) :: Ptr DuckDBStringT + len <- c_duckdb_string_t_length stringPtr + if len == 0 + then pure BS.empty + else do + ptr <- c_duckdb_string_t_data stringPtr + BS.packCStringLen (ptr, fromIntegral len) + duckdbStringTSize :: Int duckdbStringTSize = 16 + +decodeDuckDBDate :: DuckDBDate -> IO Day +decodeDuckDBDate raw = + alloca \ptr -> do + c_duckdb_from_date raw ptr + dateStruct <- peek ptr + pure (dateStructToDay dateStruct) + +decodeDuckDBTime :: DuckDBTime -> IO TimeOfDay +decodeDuckDBTime raw = + alloca \ptr -> do + c_duckdb_from_time raw ptr + timeStruct <- peek ptr + pure (timeStructToTimeOfDay timeStruct) + +decodeDuckDBTimestamp :: DuckDBTimestamp -> IO LocalTime +decodeDuckDBTimestamp raw = + alloca \ptr -> do + c_duckdb_from_timestamp raw ptr + DuckDBTimestampStruct{duckDBTimestampStructDate = dateStruct, duckDBTimestampStructTime = timeStruct} <- peek ptr + pure + LocalTime + { localDay = dateStructToDay dateStruct + , localTimeOfDay = timeStructToTimeOfDay timeStruct + } + +dateStructToDay :: DuckDBDateStruct -> Day +dateStructToDay DuckDBDateStruct{duckDBDateStructYear, duckDBDateStructMonth, duckDBDateStructDay} = + fromGregorian (fromIntegral duckDBDateStructYear) (fromIntegral duckDBDateStructMonth) (fromIntegral duckDBDateStructDay) + +timeStructToTimeOfDay :: DuckDBTimeStruct -> TimeOfDay +timeStructToTimeOfDay DuckDBTimeStruct{duckDBTimeStructHour, duckDBTimeStructMinute, duckDBTimeStructSecond, duckDBTimeStructMicros} = + let secondsInt = fromIntegral duckDBTimeStructSecond :: Integer + micros = fromIntegral duckDBTimeStructMicros :: Integer + fractional = fromRational (micros % 1000000) + totalSeconds = fromInteger secondsInt + fractional + in TimeOfDay + (fromIntegral duckDBTimeStructHour) + (fromIntegral duckDBTimeStructMinute) + totalSeconds + +decodeDuckDBTimeNs :: DuckDBTimeNs -> TimeOfDay +decodeDuckDBTimeNs (DuckDBTimeNs nanos) = + let (hours, remainderHours) = nanos `divMod` (60 * 60 * 1000000000) + (minutes, remainderMinutes) = remainderHours `divMod` (60 * 1000000000) + (seconds, fractionalNanos) = remainderMinutes `divMod` 1000000000 + fractional = fromRational (toInteger fractionalNanos % 1000000000) + totalSeconds = fromIntegral seconds + fractional + in TimeOfDay + (fromIntegral hours) + (fromIntegral minutes) + totalSeconds + +decodeDuckDBTimeTz :: DuckDBTimeTz -> IO TimeWithZone +decodeDuckDBTimeTz raw = + alloca \ptr -> do + c_duckdb_from_time_tz raw ptr + DuckDBTimeTzStruct{duckDBTimeTzStructTime = timeStruct, duckDBTimeTzStructOffset = offset} <- peek ptr + let timeOfDay = timeStructToTimeOfDay timeStruct + minutes = fromIntegral offset `div` 60 + zone = minutesToTimeZone minutes + pure TimeWithZone{timeWithZoneTime = timeOfDay, timeWithZoneZone = zone} + +decodeDuckDBTimestampSeconds :: DuckDBTimestampS -> IO LocalTime +decodeDuckDBTimestampSeconds (DuckDBTimestampS seconds) = + decodeDuckDBTimestamp (DuckDBTimestamp (seconds * 1000000)) + +decodeDuckDBTimestampMilliseconds :: DuckDBTimestampMs -> IO LocalTime +decodeDuckDBTimestampMilliseconds (DuckDBTimestampMs millis) = + decodeDuckDBTimestamp (DuckDBTimestamp (millis * 1000)) + +decodeDuckDBTimestampNanoseconds :: DuckDBTimestampNs -> IO LocalTime +decodeDuckDBTimestampNanoseconds (DuckDBTimestampNs nanos) = do + let utcTime = posixSecondsToUTCTime (fromRational (toInteger nanos % 1000000000)) + pure (utcToLocalTime utc utcTime) + +decodeDuckDBTimestampUTCTime :: DuckDBTimestamp -> IO UTCTime +decodeDuckDBTimestampUTCTime (DuckDBTimestamp micros) = + pure (posixSecondsToUTCTime (fromRational (toInteger micros % 1000000))) + +intervalValueFromDuckDB :: DuckDBInterval -> IntervalValue +intervalValueFromDuckDB DuckDBInterval{duckDBIntervalMonths, duckDBIntervalDays, duckDBIntervalMicros} = + IntervalValue + { intervalMonths = duckDBIntervalMonths + , intervalDays = duckDBIntervalDays + , 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} = + (fromIntegral duckDBHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBHugeIntLower + +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/ToField.hs b/src/Database/DuckDB/Simple/ToField.hs --- a/src/Database/DuckDB/Simple/ToField.hs +++ b/src/Database/DuckDB/Simple/ToField.hs @@ -95,21 +95,20 @@ toField = intBinding instance ToField Word where - toField value = intBinding (fromIntegral value :: Int64) + toField value = uint64Binding (fromIntegral value) instance ToField Word16 where - toField value = intBinding (fromIntegral value :: Int64) + toField value = uint16Binding value instance ToField Word32 where - toField value = intBinding (fromIntegral value :: Int64) + toField value = uint32Binding value instance ToField Word64 where - toField value = - mkFieldBinding - (show value) - \stmt idx -> - bindDuckValue stmt idx (c_duckdb_create_int64 (fromIntegral value)) + toField value = uint64Binding value +instance ToField Word8 where + toField value = uint8Binding value + instance ToField Double where toField value = mkFieldBinding @@ -205,6 +204,34 @@ (show value) \stmt idx -> bindDuckValue stmt idx (c_duckdb_create_int64 value) + +uint64Binding :: Word64 -> FieldBinding +uint64Binding value = + mkFieldBinding + (show value) + \stmt idx -> + bindDuckValue stmt idx (c_duckdb_create_uint64 value) + +uint32Binding :: Word32 -> FieldBinding +uint32Binding value = + mkFieldBinding + (show value) + \stmt idx -> + bindDuckValue stmt idx (c_duckdb_create_uint32 value) + +uint16Binding :: Word16 -> FieldBinding +uint16Binding value = + mkFieldBinding + (show value) + \stmt idx -> + bindDuckValue stmt idx (c_duckdb_create_uint16 value) + +uint8Binding :: Word8 -> FieldBinding +uint8Binding value = + mkFieldBinding + (show value) + \stmt idx -> + bindDuckValue stmt idx (c_duckdb_create_uint8 value) encodeDay :: Day -> IO DuckDBDate encodeDay day = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -18,10 +18,23 @@ import Data.Int (Int64) import qualified Data.Text as Text import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime) -import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), localTimeToUTC, utc) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.LocalTime ( + LocalTime (..), + TimeOfDay (..), + localTimeToUTC, + minutesToTimeZone, + timeOfDayToTime, + utc, + ) +import Data.Word (Word16, Word32, Word64, Word8) import Database.DuckDB.Simple -import Database.DuckDB.Simple.FromField (Field (..), returnError) +import Database.DuckDB.Simple.FromField ( + Field (..), + IntervalValue (..), + TimeWithZone (..), + returnError, + ) import GHC.Generics (Generic) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit @@ -332,6 +345,60 @@ _ <- execute conn "INSERT INTO blobs VALUES (?)" (Only payload) [Only blobOut] <- query_ conn "SELECT payload FROM blobs" assertEqual "blob round-trip" payload blobOut + , testCase "round-trips unsigned integers" $ + withConnection ":memory:" \conn -> do + _ <- execute_ conn "CREATE TABLE unsigneds (u8 UTINYINT, u16 USMALLINT, u32 UINTEGER, u64 UBIGINT)" + let w8 = 200 :: Word8 + w16 = 60000 :: Word16 + w32 = 4000000000 :: Word32 + w64 = maxBound :: Word64 + _ <- execute conn "INSERT INTO unsigneds VALUES (?, ?, ?, ?)" (w8, w16, w32, w64) + [(r8, r16, r32, r64)] <- query_ conn "SELECT u8, u16, u32, u64 FROM unsigneds" + assertEqual "Word8 round-trip" w8 r8 + assertEqual "Word16 round-trip" w16 r16 + assertEqual "Word32 round-trip" w32 r32 + assertEqual "Word64 round-trip" w64 r64 + [Only (asWord :: Word)] <- query_ conn "SELECT u64 FROM unsigneds" + assertEqual "Word from UBIGINT" (fromIntegral w64) asWord + , testCase "decodes huge integers as Integer" $ + withConnection ":memory:" \conn -> do + let hugeValue = 170141183460469231731687303715884105727 :: Integer + [Only (hugeOut :: Integer)] <- + query_ conn "SELECT 170141183460469231731687303715884105727::HUGEINT" + assertEqual "hugeint" hugeValue hugeOut + , testCase "decodes interval components" $ + withConnection ":memory:" \conn -> do + [Only intervalVal] <- + query_ conn "SELECT INTERVAL '2 months 3 days 04:05:06.007008'" + let IntervalValue{intervalMonths, intervalDays, intervalMicros} = intervalVal + expectedMicros = + (((4 * 60 + 5) * 60) + 6) * 1000000 + 7008 + assertEqual "interval months" 2 intervalMonths + assertEqual "interval days" 3 intervalDays + assertEqual "interval micros" expectedMicros intervalMicros + , testCase "decodes decimals via Double conversion" $ + withConnection ":memory:" \conn -> do + [Only decimalAsDouble] <- + (query_ conn "SELECT CAST(12345.6789 AS DECIMAL(18,4))" :: IO [Only Double]) + assertBool + "decimal as double" + (abs (decimalAsDouble - 12345.6789) < 1e-6) + , testCase "decodes time with time zone" $ + withConnection ":memory:" \conn -> do + [Only tzVal] <- query_ conn "SELECT TIMETZ '14:30:15+02:30'" + let expectedTime = TimeOfDay 14 30 15 + expectedZone = minutesToTimeZone 150 + assertEqual "timetz time" expectedTime (timeWithZoneTime tzVal) + assertEqual "timetz zone" expectedZone (timeWithZoneZone tzVal) + , testCase "decodes timestamp with time zone as UTC" $ + withConnection ":memory:" \conn -> do + [Only utcVal] <- + (query_ conn "SELECT TIMESTAMPTZ '2024-10-12 14:30:15+02:30'" :: IO [Only UTCTime]) + let expected = + UTCTime + (fromGregorian 2024 10 12) + (timeOfDayToTime (TimeOfDay 12 0 15)) + assertEqual "timestamptz utc" expected utcVal , testCase "custom FieldParser enforces invariants" $ withConnection ":memory:" \conn -> do _ <- execute_ conn "CREATE TABLE nonempty (name TEXT)"