module Database.Dpi.Field(
DataField(..)
, FromDataFields(..)
, FromDataField(..)
, ToDataField(..)
, isNullable
, getName
, fromByteString
, toByteString
, toDataFieldMap
, readDataField
, DataFieldMap
) where
import Database.Dpi.Internal
import Database.Dpi.Prelude
import Database.Dpi.Util
import Control.Exception (throw)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Unsafe as B
import Data.Int (Int64)
import Data.List (intercalate)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Scientific
import Data.Time
import Data.Time.Clock.POSIX
data DataField = DataField
{ info :: !Data_QueryInfo
, value :: !DataValue
} deriving (Show)
class FromDataField a where
fromDataField :: DataField -> IO (Maybe a)
{-# INLINE isNullable #-}
isNullable :: DataField -> Bool
isNullable DataField{..} = let Data_QueryInfo{..} = info in nullOk
{-# INLINE getName #-}
getName :: DataField -> IO ByteString
getName DataField{..} = let Data_QueryInfo{..} = info in tsLen name
type DataFieldMap = [(ByteString, DataField)]
toDataFieldMap :: [DataField] -> IO DataFieldMap
toDataFieldMap = mapM go
where
go f = (,f) <$> getName f
readDataField :: FromDataField a => DataFieldMap -> ByteString -> IO (Maybe a)
readDataField dfm name = case lookup name dfm of
Nothing -> return Nothing
Just v -> fromDataField v
instance FromDataField ByteString where
fromDataField DataField{..} = let Data_QueryInfo{..} = info in go name typeInfo value
where
go _ _ (DataNull _) = return Nothing
go _ _ (DataChar v) = Just <$> toByteString v
go _ _ (DataLongRaw v) = Just <$> toByteString v
go _ _ (DataLongVarchar v) = Just <$> toByteString v
go _ _ (DataNVarchar v) = Just <$> toByteString v
go _ _ (DataRaw v) = Just <$> toByteString v
go _ _ (DataVarchar v) = Just <$> toByteString v
go _ _ (DataNChar v) = Just <$> toByteString v
go n _ _ = singleError' n
instance FromDataField Integer where
fromDataField = fmap (fmap (round :: Scientific -> Integer)) . fromDataField
instance FromDataField Int where
fromDataField = fmap (fmap fromInteger) . fromDataField
instance FromDataField Int64 where
fromDataField = fmap (fmap fromInteger) . fromDataField
instance FromDataField Word where
fromDataField = fmap (fmap fromInteger) . fromDataField
instance FromDataField Word64 where
fromDataField = fmap (fmap fromInteger) . fromDataField
instance FromDataField Double where
fromDataField = fmap (fmap (realToFrac :: Scientific -> Double)) . fromDataField
instance FromDataField Float where
fromDataField = fmap (fmap (realToFrac :: Scientific -> Float)) . fromDataField
instance FromDataField Scientific where
fromDataField DataField{..} = let Data_QueryInfo{..} = info in go name typeInfo value
where
go _ _ (DataNull _) = return Nothing
go _ _ (DataInt v) = return . Just $ realToFrac v
go _ _ (DataUint v) = return . Just $ realToFrac v
go _ _ (DataNumInt v) = return . Just $ realToFrac v
go _ _ (DataNumUint v) = return . Just $ realToFrac v
go _ _ (DataFloat v) = return . Just $ realToFrac v
go _ _ (DataNumDouble v) = return . Just $ realToFrac v
go _ _ (DataDouble v) = return . Just $ realToFrac v
go _ _ (DataNumBytes Data_Bytes{..}) = (Just . read . BC.unpack) <$> tsLen bytes
go n _ _ = singleError' n
instance FromDataField Bool where
fromDataField DataField{..} = let Data_QueryInfo{..} = info in go name typeInfo value
where
go _ _ (DataNull _) = return Nothing
go _ _ (DataBoolean v) = return $ Just v
go n _ _ = singleError' n
instance FromDataField UTCTime where
fromDataField DataField{..} = let Data_QueryInfo{..} = info in go name typeInfo value
where
go _ _ (DataNull _) = return Nothing
go _ _ (DataDate v) = return . Just $ toUTCTime v
go _ _ (DataTimestamp v) = return . Just $ toUTCTime v
go _ _ (DataTimestampLtz v) = return . Just $ toUTCTimeL v
go _ _ (DataTimestampTz v) = return . Just $ toUTCTime v
go _ _ (DataTimestampD v) = return . Just $ toUTCTimeD v
go _ _ (DataTimestampLtzD v) = return . Just $ toUTCTimeD v
go _ _ (DataTimestampTzD v) = return . Just $ toUTCTimeD v
go n _ _ = singleError' n
instance FromDataField ZonedTime where
fromDataField DataField{..} = let Data_QueryInfo{..} = info in go name typeInfo value
where
go _ _ (DataNull _) = return Nothing
go _ _ (DataDate v) = return . Just $ toZonedTime False v
go _ _ (DataTimestamp v) = return . Just $ toZonedTime False v
go _ _ (DataTimestampLtz v) = return . Just $ toZonedTime True v
go _ _ (DataTimestampTz v) = return . Just $ toZonedTime False v
go _ _ (DataTimestampD v) = return . Just $ utcToZonedTime utc $ toUTCTimeD v
go _ _ (DataTimestampLtzD v) = return . Just $ utcToZonedTime utc $ toUTCTimeD v
go _ _ (DataTimestampTzD v) = return . Just $ utcToZonedTime utc $ toUTCTimeD v
go n _ _ = singleError' n
instance FromDataField LocalTime where
fromDataField = fmap (fmap go) . fromDataField
where
go ZonedTime{..} = zonedTimeToLocalTime
instance FromDataField DiffTime where
fromDataField DataField{..} = let Data_QueryInfo{..} = info in go name typeInfo value
where
go _ _ (DataNull _) = return Nothing
go _ _ (DataIntervalDs v) = return . Just $ toDiffTime v
go _ _ (DataIntervalYm v) = return . Just $ toDiffTime' v
go n _ _ = singleError' n
class ToDataField a where
toDataField :: a -> NativeTypeNum -> OracleTypeNum -> IO DataValue
instance ToDataField ByteString where
toDataField v NativeTypeBytes OracleTypeChar = DataChar <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeLongRaw = DataLongRaw <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeLongVarchar = DataLongVarchar <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeNchar = DataNChar <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeNumber = DataNumBytes <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeNvarchar = DataNVarchar <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeRaw = DataRaw <$> fromByteString v
toDataField v NativeTypeBytes OracleTypeVarchar = DataVarchar <$> fromByteString v
toDataField _ _ _ = singleError "Text"
instance ToDataField Bool where
toDataField v NativeTypeBoolean OracleTypeBoolean = return $ DataBoolean v
toDataField _ _ _ = singleError "Bool"
instance ToDataField Integer where
toDataField v NativeTypeDouble OracleTypeNativeDouble = return $ DataDouble $ realToFrac v
toDataField v NativeTypeDouble OracleTypeNumber = return $ DataNumDouble $ realToFrac v
toDataField v NativeTypeFloat OracleTypeNativeFloat = return $ DataFloat $ realToFrac v
toDataField v NativeTypeInt64 OracleTypeNativeInt = return $ DataInt $ fromIntegral v
toDataField v NativeTypeInt64 OracleTypeNumber = return $ DataNumInt $ fromIntegral v
toDataField v NativeTypeUint64 OracleTypeNativeUint = return $ DataUint $ fromIntegral v
toDataField v NativeTypeUint64 OracleTypeNumber = return $ DataNumUint $ fromIntegral v
toDataField _ _ _ = singleError "Integer"
instance ToDataField Int where
toDataField v = toDataField (toInteger v)
instance ToDataField Int64 where
toDataField v = toDataField (toInteger v)
instance ToDataField Word where
toDataField v = toDataField (toInteger v)
instance ToDataField Word64 where
toDataField v = toDataField (toInteger v)
instance ToDataField Scientific where
toDataField v NativeTypeDouble OracleTypeNativeDouble = return $ DataDouble $ realToFrac v
toDataField v NativeTypeDouble OracleTypeNumber = return $ DataNumDouble $ realToFrac v
toDataField v NativeTypeFloat OracleTypeNativeFloat = return $ DataFloat $ realToFrac v
toDataField v NativeTypeInt64 OracleTypeNativeInt = return $ DataInt $ round v
toDataField v NativeTypeInt64 OracleTypeNumber = return $ DataNumInt $ round v
toDataField v NativeTypeUint64 OracleTypeNativeUint = return $ DataUint $ round v
toDataField v NativeTypeUint64 OracleTypeNumber = return $ DataNumUint $ round v
toDataField _ _ _ = singleError "Decimal"
instance ToDataField Double where
toDataField v NativeTypeDouble OracleTypeNativeDouble = return $ DataDouble $ realToFrac v
toDataField v NativeTypeDouble OracleTypeNumber = return $ DataNumDouble $ realToFrac v
toDataField v NativeTypeFloat OracleTypeNativeFloat = return $ DataFloat $ realToFrac v
toDataField v NativeTypeInt64 OracleTypeNativeInt = return $ DataInt $ round v
toDataField v NativeTypeInt64 OracleTypeNumber = return $ DataNumInt $ round v
toDataField v NativeTypeUint64 OracleTypeNativeUint = return $ DataUint $ round v
toDataField v NativeTypeUint64 OracleTypeNumber = return $ DataNumUint $ round v
toDataField _ _ _ = singleError "Double"
instance ToDataField Float where
toDataField v = toDataField (realToFrac v :: Double)
instance ToDataField UTCTime where
toDataField v NativeTypeTimestamp OracleTypeDate = return $ DataDate $ fromUTCTime v
toDataField v NativeTypeDouble OracleTypeTimestamp = return $ DataTimestampD $ fromUTCTimeD v
toDataField v NativeTypeDouble OracleTypeTimestampLtz = return $ DataTimestampLtzD $ fromUTCTimeD v
toDataField v NativeTypeDouble OracleTypeTimestampTz = return $ DataTimestampTzD $ fromUTCTimeD v
toDataField v NativeTypeTimestamp OracleTypeTimestamp = return $ DataTimestamp $ fromUTCTime v
toDataField v NativeTypeTimestamp OracleTypeTimestampLtz = return $ DataTimestampLtz $ fromUTCTime v
toDataField v NativeTypeTimestamp OracleTypeTimestampTz = return $ DataTimestampTz $ fromUTCTime v
toDataField _ _ _ = singleError "UTCTime"
instance ToDataField ZonedTime where
toDataField v NativeTypeTimestamp OracleTypeDate = return $ DataDate $ fromZonedTime v
toDataField v NativeTypeTimestamp OracleTypeTimestamp = return $ DataTimestamp $ fromZonedTime v
toDataField v NativeTypeTimestamp OracleTypeTimestampLtz = return $ DataTimestampLtz $ fromZonedTime v
toDataField v NativeTypeTimestamp OracleTypeTimestampTz = return $ DataTimestampTz $ fromZonedTime v
toDataField _ _ _ = singleError "ZonedTime"
instance ToDataField DiffTime where
toDataField v NativeTypeIntervalDs OracleTypeIntervalDs = return $ DataIntervalDs $ fromDiffTime v
toDataField v NativeTypeIntervalYm OracleTypeIntervalYm = return $ DataIntervalYm $ fromDiffTime' v
toDataField _ _ _ = singleError "DiffTime"
fromByteString :: ByteString -> IO Data_Bytes
fromByteString bs = B.unsafeUseAsCStringLen bs $ \bytes -> let encoding ="utf-8" in return Data_Bytes{..}
toByteString :: Data_Bytes -> IO ByteString
toByteString Data_Bytes{..} = B.packCStringLen bytes
{-# INLINE fromDiffTime #-}
fromDiffTime :: DiffTime -> Data_IntervalDS
fromDiffTime dt =
let dts = diffTimeToPicoseconds dt
(r1,fseconds) = dts `divMod` pico
(r2,seconds) = r1 `divMod` 60
(r3,minutes) = r2 `divMod` 60
(days,hours) = r3 `divMod` 24
in Data_IntervalDS (fromInteger days) (fromInteger hours) (fromInteger minutes) (fromInteger seconds) (fromInteger fseconds)
pico :: Integer
pico = (10 :: Integer) ^ (12 :: Integer)
{-# INLINE fromDiffTime' #-}
fromDiffTime' :: DiffTime -> Data_IntervalYM
fromDiffTime' dt =
let dts = diffTimeToPicoseconds dt `div` (30 * 86400 * pico)
(y,m) = dts `divMod` 12
in Data_IntervalYM (fromInteger y) (fromInteger m)
{-# INLINE toDiffTime #-}
toDiffTime :: Data_IntervalDS -> DiffTime
toDiffTime Data_IntervalDS{..} = picosecondsToDiffTime $ toInteger fseconds + pico * (toInteger seconds + 60 * (toInteger minutes + 60 * (toInteger hours + 24 * toInteger days)))
{-# INLINE toDiffTime' #-}
toDiffTime' :: Data_IntervalYM -> DiffTime
toDiffTime' Data_IntervalYM{..} = secondsToDiffTime $ 30 * 86400 * pico * (toInteger years * 12 + toInteger months)
{-# INLINE fromUTCTime #-}
fromUTCTime :: UTCTime -> Data_Timestamp
fromUTCTime UTCTime{..} =
let (year,month,day) = toGregorian utctDay
Data_IntervalDS{..} = fromDiffTime utctDayTime
in Data_Timestamp (fromInteger year) (fe month) (fe day) (fe hours) (fe minutes) (fe seconds) (fe fseconds) 0 0
{-# INLINE toUTCTime #-}
toUTCTime :: Data_Timestamp -> UTCTime
toUTCTime = zonedTimeToUTC . toZonedTime False
{-# INLINE toUTCTimeL #-}
toUTCTimeL :: Data_Timestamp -> UTCTime
toUTCTimeL = zonedTimeToUTC . toZonedTime True
{-# INLINE fromZonedTime #-}
fromZonedTime :: ZonedTime -> Data_Timestamp
fromZonedTime ZonedTime{..} =
let timestamp = fromUTCTime (localTimeToUTC utc zonedTimeToLocalTime)
TimeZone{..} = zonedTimeZone
(h,m) = timeZoneMinutes `divMod` 60
in timestamp { tzHourOffset = fe h, tzMinuteOffset = fe m }
{-# INLINE toZonedTime #-}
toZonedTime :: Bool -> Data_Timestamp -> ZonedTime
toZonedTime isLocal Data_Timestamp{..} =
let utctDay = fromGregorian (fe year) (fe month) (fe day)
days = 0
hours = fe hour
minutes = fe minute
seconds = fe second
fseconds = fe fsecond
utctDayTime = toDiffTime Data_IntervalDS{..}
offset = toInteger tzHourOffset * 60 + toInteger tzMinuteOffset
timezone = minutesToTimeZone $ fromInteger offset
in if isLocal
then utcToZonedTime timezone $ addUTCTime (fromInteger $ 60 * negate offset) UTCTime{..}
else utcToZonedTime timezone $ addUTCTime (fromInteger $ 60 * negate offset) UTCTime{..}
{-# INLINE fromUTCTimeD #-}
fromUTCTimeD :: UTCTime -> CDouble
fromUTCTimeD = realToFrac . utcTimeToPOSIXSeconds
{-# INLINE toUTCTimeD #-}
toUTCTimeD :: CDouble -> UTCTime
toUTCTimeD = posixSecondsToUTCTime . realToFrac
{-# INLINE singleError #-}
singleError :: String -> IO a
singleError name = throw $ DpiException $ "type mismatch " <> name
{-# INLINE singleError' #-}
singleError' :: CStringLen -> IO a
singleError' name = B.packCStringLen name >>= singleError . BC.unpack
class FromDataFields a where
fromDataFields' :: [DataField] -> IO a
fromDataFields' dfs = toDataFieldMap dfs >>= fromDataFields
fromDataFields :: DataFieldMap -> IO a
fromDataFields dfm = fromDataFields' $ fmap snd dfm
{-# MINIMAL fromDataFields | fromDataFields' #-}
instance FromDataFields [DataField] where
fromDataFields' = return
instance FromDataFields String where
fromDataFields' dfs = intercalate "," <$> sequence (fmap go dfs)
where
go f@DataField{..} = go2 f value
go3 f = (fromMaybe "" . fmap show) <$> f
go2 v (DataBoolean _) = go3 (fromDataField v :: IO (Maybe Bool) )
go2 v (DataInt _) = go3 (fromDataField v :: IO (Maybe Integer) )
go2 v (DataNumInt _) = go3 (fromDataField v :: IO (Maybe Integer) )
go2 v (DataNumUint _) = go3 (fromDataField v :: IO (Maybe Integer) )
go2 v (DataUint _) = go3 (fromDataField v :: IO (Maybe Integer) )
go2 v (DataDouble _) = go3 (fromDataField v :: IO (Maybe Double) )
go2 v (DataNumDouble _) = go3 (fromDataField v :: IO (Maybe Double) )
go2 v (DataNumBytes _) = go3 (fromDataField v :: IO (Maybe Double) )
go2 v (DataFloat _) = go3 (fromDataField v :: IO (Maybe Float) )
go2 v (DataChar _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataLongRaw _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataLongVarchar _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataNChar _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataNVarchar _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataRaw _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataVarchar _) = go3 (fromDataField v :: IO (Maybe ByteString) )
go2 v (DataIntervalDs _) = go3 (fromDataField v :: IO (Maybe DiffTime) )
go2 v (DataIntervalYm _) = go3 (fromDataField v :: IO (Maybe DiffTime) )
go2 v (DataTimestampD _) = go3 (fromDataField v :: IO (Maybe UTCTime) )
go2 v (DataTimestampLtzD _) = go3 (fromDataField v :: IO (Maybe ZonedTime) )
go2 v (DataTimestampTzD _) = go3 (fromDataField v :: IO (Maybe ZonedTime) )
go2 v (DataDate _) = go3 (fromDataField v :: IO (Maybe UTCTime) )
go2 v (DataTimestamp _) = go3 (fromDataField v :: IO (Maybe UTCTime) )
go2 v (DataTimestampLtz _) = go3 (fromDataField v :: IO (Maybe ZonedTime) )
go2 v (DataTimestampTz _) = go3 (fromDataField v :: IO (Maybe ZonedTime) )
go2 _ _ = return ""