postgresql-pure-0.2.3.0: src/Database/HDBC/PostgreSQL/Pure.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- |
-- This is a compatible interface with @HDBC-postgresql@'s @Database.HDBC.PostgreSQL@ except 'Config'.
--
-- Prepared statements are closed when some requests come once 'Statement's are GCed, because HDBC doesn't have "close" interface.
module Database.HDBC.PostgreSQL.Pure
( -- * Connection
Config (..)
, Connection (config)
, Pure.Address (..)
, withConnection
, connect
-- * Transaction
, begin
) where
import qualified Database.PostgreSQL.Pure.Internal.Connection as Pure
import qualified Database.PostgreSQL.Pure.Internal.Data as Pure
import qualified Database.PostgreSQL.Pure.Internal.Exception as Pure
import qualified Database.PostgreSQL.Pure.Internal.MonadFail as MonadFail
import qualified Database.PostgreSQL.Pure.Internal.Parser as Pure
import qualified Database.PostgreSQL.Pure.List as Pure
import qualified Database.PostgreSQL.Pure.Oid as Oid
import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TimeParser
import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TimeBuilder
import Paths_postgresql_pure (version)
import Database.HDBC (IConnection (clone, commit, dbServerVer, dbTransactionSupport, describeTable, disconnect, getTables, hdbcClientVer, hdbcDriverName, prepare, proxiedClientName, proxiedClientVer, rollback, run, runRaw),
SqlColDesc (SqlColDesc, colDecDigits, colNullable, colOctetLength, colSize, colType),
SqlError (SqlError, seErrorMsg, seNativeError, seState),
SqlTypeId, throwSqlError)
import Database.HDBC.ColTypes (SqlInterval (SqlIntervalSecondT), SqlTypeId (SqlBigIntT, SqlBitT, SqlCharT, SqlDateT, SqlDecimalT, SqlDoubleT, SqlFloatT, SqlIntervalT, SqlTimeT, SqlTimeWithZoneT, SqlTimestampT, SqlTimestampWithZoneT, SqlUnknownT, SqlVarBinaryT, SqlVarCharT))
import Database.HDBC.Statement (SqlValue (SqlBool, SqlByteString, SqlChar, SqlDiffTime, SqlDouble, SqlInt32, SqlInt64, SqlInteger, SqlLocalDate, SqlLocalTime, SqlLocalTimeOfDay, SqlNull, SqlPOSIXTime, SqlRational, SqlString, SqlUTCTime, SqlWord32, SqlWord64, SqlZonedLocalTimeOfDay, SqlZonedTime),
Statement (Statement, describeResult, execute, executeMany, executeRaw, fetchRow, finish, getColumnNames, originalQuery))
import Control.Concurrent (MVar, modifyMVar_, newMVar)
import Control.Exception.Safe (Exception (displayException, fromException, toException),
impureThrow, try)
import Control.Monad (unless, void, (<=<))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Builder.Prim as BSBP
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as BSS
import qualified Data.ByteString.UTF8 as BSU
import Data.Convertible (Convertible (safeConvert), convert)
import Data.Default.Class (Default (def))
import Data.Foldable (for_)
import Data.Int (Int32, Int64)
import Data.IORef (IORef, mkWeakIORef, newIORef, readIORef, writeIORef)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Scientific (FPFormat (Exponent), Scientific, formatScientific,
fromRationalRepetend)
import Data.String (IsString (fromString))
import Data.Time (DiffTime, NominalDiffTime, TimeOfDay, TimeZone, utc,
zonedTimeToUTC)
import Data.Traversable (for)
import Data.Tuple.Only (Only (Only))
import Data.Typeable (Typeable, cast)
import Data.Version (showVersion)
import Data.Word (Word32, Word64)
import Database.PostgreSQL.Placeholder.Convert (convertQuestionMarkStyleToDollarSignStyle,
splitQueries)
import GHC.Records (HasField (getField))
import qualified PostgreSQL.Binary.Decoding as BD
import qualified PostgreSQL.Binary.Encoding as BE
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
-- | A configuration of a connection.
--
-- Default configuration is 'def', which is following.
--
-- >>> address def
-- AddressResolved 127.0.0.1:5432
-- >>> user def
-- "postgres"
-- >>> password def
-- ""
-- >>> database def
-- ""
-- >>> sendingBufferSize def
-- 4096
-- >>> receptionBufferSize def
-- 4096
--
-- @
-- encodeString def = \\code -> case code of \"UTF8\" -> 'pure' . 'BSU.fromString'; _ -> 'const' $ 'fail' $ "unexpected character code: " <> 'show' code
-- decodeString def = \\code -> case code of \"UTF8\" -> 'pure' . 'BSU.toString'; _ -> 'const' $ 'fail' $ "unexpected character code: " <> 'show' code
-- @
data Config =
Config
{ address :: Pure.Address
, user :: String
, password :: String
, database :: String
, sendingBufferSize :: Int -- ^ in byte
, receptionBufferSize :: Int -- ^ in byte
, encodeString :: BSS.ShortByteString -> Pure.StringEncoder
, decodeString :: BSS.ShortByteString -> Pure.StringDecoder
}
instance Show Config where
show Config { address, user, password, database, sendingBufferSize, receptionBufferSize } =
mconcat
[ "Config { address = "
, show address
, ", user = "
, show user
, ", password = "
, show password
, ", database = "
, show database
, ", sendingBufferSize = "
, show sendingBufferSize
, ", receptionBufferSize = "
, show receptionBufferSize
, ", encodeString = <function>, decodeString = <function> }"
]
instance Default Config where
def =
let Pure.Config { address, user, password, database, sendingBufferSize, receptionBufferSize } = def
in
Config
{ address
, user
, password
, database
, sendingBufferSize
, receptionBufferSize
, encodeString = \code -> case code of "UTF8" -> pure . BSU.fromString; _ -> const $ fail $ "unexpected character code: " <> show code
, decodeString = \code -> case code of "UTF8" -> pure . BSU.toString; _ -> const $ fail $ "unexpected character code: " <> show code
}
-- | PostgreSQL connection.
data Connection =
Connection
{ connection :: Pure.Connection
, statementCounter :: IORef Word
, unnecessaryPreparedStatements :: MVar [Pure.PreparedStatement] -- To accumulate unnecessary prepared statements
-- to dispose them when some requests come,
-- because HDBC doesn't have a interface to close statements.
, config :: Config
}
-- | Bracket function for a connection.
withConnection :: Config -> (Connection -> IO a) -> IO a
withConnection config@Config { address, user, password, database, sendingBufferSize, receptionBufferSize } f =
Pure.withConnection Pure.Config { address, user, password, database, sendingBufferSize, receptionBufferSize } $ \c -> do
void $ Pure.sync c Pure.begin
conn <- Connection c <$> newIORef 0 <*> newMVar [] <*> pure config
f conn
-- | To connect to the server.
connect :: Config -> IO Connection
connect config@Config { address, user, password, database, sendingBufferSize, receptionBufferSize } = do
c <- Pure.connect Pure.Config { address, user, password, database, sendingBufferSize, receptionBufferSize }
void $ Pure.sync c Pure.begin
Connection c <$> newIORef 0 <*> newMVar [] <*> pure config
instance IConnection Connection where
disconnect = Pure.disconnect . connection
commit hc@Connection { connection } =
convertException $ do
closeUnnecessaryPreparedStatements hc
void $ Pure.sync connection (Pure.commit, Pure.begin)
rollback hc@Connection { connection } =
convertException $ do
closeUnnecessaryPreparedStatements hc
void $ Pure.sync connection (Pure.rollback, Pure.begin)
run hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } query values =
convertException $ do
closeUnnecessaryPreparedStatements hc
charCode <- lookupClientEncoding parameters
let
encode = encodeString charCode
decode = decodeString charCode
queryQS :: BS.ByteString
queryQS = fromString query
queryDS =
case convertQuestionMarkStyleToDollarSignStyle queryQS of
Right q -> Pure.Query q
Left err -> impureThrow $ RequestBuildingFailed $ "conversion from question mark style to dollar sign style: " <> err
ps <- Pure.flush connection $ Pure.parse "" queryDS (Left (0, 0)) -- footnote [1]
let
pProc = forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode values ps
eProc = Pure.execute @_ @() 0 decode pProc
(_, _, e, _) <- Pure.flush connection eProc
pure $ resultCount $ Pure.result e
runRaw hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } query =
convertException $ do
closeUnnecessaryPreparedStatements hc
charCode <- lookupClientEncoding parameters
let
encode = encodeString charCode
decode = decodeString charCode
queries = splitQueries $ fromString query
for_ queries $ \q -> do
ps <- Pure.flush connection $ Pure.parse "" (Pure.Query q) (Left (0, 0)) -- footnote [1]
Pure.flush connection $ Pure.execute @_ @() 0 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode ([] :: [SqlValue]) ps
prepare hc@Connection { connection = connection@Pure.Connection { parameters }, statementCounter, unnecessaryPreparedStatements, config = Config { encodeString, decodeString } } query =
convertException $ do
closeUnnecessaryPreparedStatements hc
count <- incrementCounter statementCounter
portalCounter <- newIORef 0
charCode <- lookupClientEncoding parameters
let
encode = encodeString charCode
decode = decodeString charCode
encodeIO = MonadFail.fromEither . encode :: String -> IO BS.ByteString
decodeIO = MonadFail.fromEither . decode :: BS.ByteString -> IO String
queryBS <- encodeIO query
let
queryDS =
case convertQuestionMarkStyleToDollarSignStyle queryBS of
Right q -> Pure.Query q
Left err -> impureThrow $ RequestBuildingFailed $ "conversion from question mark style to dollar sign style: " <> err
countBS <- encodeIO $ show count
let
psName = Pure.PreparedStatementName $ countBS <> ": " <> queryBS
(preparedStatement, _) <- Pure.sync connection $ Pure.parse psName queryDS (Left (0, 0)) -- footnote [1]
portalsRef <- newIORef [] :: IO (IORef [(Maybe [SqlValue], Pure.Portal)])
alive <- newIORef () -- see the document of 'keepPreparedStatementAlive'
let
execute :: [SqlValue] -> IO Integer
execute values =
convertException $ do
closeUnnecessaryPreparedStatements hc
finish'
count <- incrementCounter portalCounter
countBS <- encodeIO $ show count
let
pName =
case psName of
Pure.PreparedStatementName n -> Pure.PortalName $ countBS <> ": " <> n
((_, p, e, _), _) <- Pure.sync connection $ Pure.execute 1 decode $ forceBind $ Pure.bind pName Pure.TextFormat Pure.TextFormat parameters encode values preparedStatement
keepPreparedStatementAlive
writeIORef portalsRef $
case Pure.result e of
Pure.ExecuteSuspended -> [(Just $ head $ Pure.records e, p)]
_ -> []
pure $ resultCount $ Pure.result e
executeRaw :: IO ()
executeRaw = void $ execute []
executeMany :: [[SqlValue]] -> IO ()
executeMany valuess =
convertException $ do
closeUnnecessaryPreparedStatements hc
finish'
eProcs <-
for valuess $ \values -> do
count <- incrementCounter portalCounter
countBS <- encodeIO $ show count
let
pName =
case psName of
Pure.PreparedStatementName n -> Pure.PortalName $ countBS <> ": " <> n
pure $ Pure.execute 1 decode $ forceBind $ Pure.bind pName Pure.TextFormat Pure.TextFormat parameters encode values preparedStatement
(rs, _) <- Pure.sync connection eProcs
keepPreparedStatementAlive
writeIORef portalsRef $
mconcat $
(<$> rs) $ \(_, p, e, _) ->
case Pure.result e of
Pure.ExecuteSuspended -> [(Just $ head $ Pure.records e, p)]
_ -> mempty
finish :: IO ()
finish =
convertException $ do
closeUnnecessaryPreparedStatements hc
finish'
keepPreparedStatementAlive
writeIORef portalsRef []
finish' :: IO ()
finish' = do
ps <- readIORef portalsRef
unless (null ps) $ void $ Pure.sync connection $ Pure.close . snd <$> ps
fetchRow :: IO (Maybe [SqlValue])
fetchRow =
convertException $ do
closeUnnecessaryPreparedStatements hc
ps <- readIORef portalsRef
case ps of
(Just r, p):ps -> do
writeIORef portalsRef ((Nothing, p):ps)
pure $ Just r
(Nothing, p):ps -> do
((_, _, e, _), _) <- Pure.sync connection $ Pure.execute 1 decode p
keepPreparedStatementAlive
case Pure.result e of
Pure.ExecuteSuspended ->
pure $ Just $ head $ Pure.records e
_ -> do
void $ Pure.sync connection $ Pure.close p
keepPreparedStatementAlive
writeIORef portalsRef ps
pure Nothing
[] -> pure Nothing
getColumnNames :: IO [String]
getColumnNames =
convertException $ do
closeUnnecessaryPreparedStatements hc
sequence $ decodeIO . getField @"name" <$> Pure.resultInfos preparedStatement
originalQuery :: String
originalQuery = query
describeResult :: IO [(String, SqlColDesc)]
describeResult =
convertException $ do
closeUnnecessaryPreparedStatements hc
let
columnInfos = Pure.resultInfos preparedStatement
psProc = Pure.parse "attr" "SELECT attnotnull FROM pg_attribute WHERE attrelid = $1 AND attnum = $2" (Right ([Oid.oid, Oid.int2], [Oid.bool]))
(ps, _) <- Pure.sync connection psProc
results <-
for columnInfos $ \Pure.ColumnInfo { name, tableOid, attributeNumber, typeOid, typeLength, typeModifier } -> do
((_, _, e, _), _) <- Pure.sync connection $ Pure.execute 1 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode (tableOid, attributeNumber) ps
let
(Only attnotnull) = head $ Pure.records e
(colSize, colDecDigits) = columnSize typeOid typeLength typeModifier
nameStr <- decodeIO name
pure
( nameStr
, SqlColDesc
{ colType = convert typeOid
, colSize
, colOctetLength = Nothing
, colDecDigits
, colNullable = Just $ not attnotnull
}
)
void $ Pure.sync connection $ Pure.close ps
keepPreparedStatementAlive
pure results
-- The GHC optimiser make 'Statement's be GCed in advance of exiting those scopes.
-- To prevent it, insert 'readIORef's at the end of actions.
-- Finalisers of 'IORef's are set, instead of ones of 'Statement's.
-- See: https://github.com/snoyberg/http-client/pull/352
keepPreparedStatementAlive :: IO ()
keepPreparedStatementAlive = void $ readIORef alive
statement =
Statement
{ execute
, executeRaw
, executeMany
, finish
, fetchRow
, getColumnNames
, originalQuery
, describeResult
}
-- set up a finaliser
void $ mkWeakIORef alive $ modifyMVar_ unnecessaryPreparedStatements $ pure . (preparedStatement:)
pure statement
clone hc@Connection { config } =
convertException $ do
closeUnnecessaryPreparedStatements hc
connect config
hdbcDriverName _ = "postgresql"
hdbcClientVer _ = showVersion version
proxiedClientName = hdbcDriverName
proxiedClientVer = hdbcClientVer
dbServerVer Connection { connection = Pure.Connection { parameters }, config = Config { decodeString } } =
fromMaybe "" $ do
serverVersion <- M.lookup "server_version" parameters
decode <- decodeString <$> lookupClientEncoding parameters
MonadFail.fromEither $ decode $ BSS.fromShort serverVersion
dbTransactionSupport _ = True
getTables hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } =
convertException $ do
closeUnnecessaryPreparedStatements hc
charCode <- lookupClientEncoding parameters
let
encode = encodeString charCode
decode = decodeString charCode
decodeIO = MonadFail.fromEither . decode :: BS.ByteString -> IO String
q :: Pure.Query
q = "SELECT table_name FROM information_schema.tables WHERE table_schema != 'pg_catalog' AND table_schema != 'information_schema'"
((_, _, e, _), _) <- Pure.sync connection $ Pure.execute 0 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode () $ Pure.parse "" q (Right ([], [Oid.sqlIdentifier]))
sequence $ decodeIO . (\(Only (Pure.SqlIdentifier str)) -> str) <$> Pure.records e
describeTable hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } tableName =
convertException $ do
closeUnnecessaryPreparedStatements hc
charCode <- lookupClientEncoding parameters
let
encode = encodeString charCode
decode = decodeString charCode
decodeIO = MonadFail.fromEither . decode :: BS.ByteString -> IO String
q :: Pure.Query
q = "SELECT attname, atttypid, attlen, atttypmod, attnotnull FROM pg_attribute, pg_class, pg_namespace WHERE attnum > 0 AND attisdropped IS FALSE AND attrelid = pg_class.oid AND relnamespace = pg_namespace.oid AND relname = $1 ORDER BY attnum"
((_, _, e, _), _) <-
Pure.sync connection $ Pure.execute 0 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode (Only tableName) $ Pure.parse "" q (Right ([Oid.name], [Oid.name, Oid.oid, Oid.int2, Oid.int4, Oid.bool]))
for (Pure.records e) $ \(attname, atttypid, attlen, atttypmod, attnotnull) -> do
let
typeLength = case attlen of { (-1) -> Pure.VariableLength ; _ -> Pure.FixedLength attlen }
(colSize, colDecDigits) = columnSize atttypid typeLength atttypmod
attnameBS <- decodeIO attname
pure
( attnameBS
, SqlColDesc
{ colType = convert atttypid
, colSize
, colOctetLength = Nothing
, colDecDigits
, colNullable = Just $ not attnotnull
}
)
-- | To send @BEGIN@ SQL statement.
begin :: Connection -> IO ()
begin hc@Connection { connection } =
convertException $ do
closeUnnecessaryPreparedStatements hc
void $ Pure.sync connection Pure.begin
columnSize :: Pure.Oid -> Pure.TypeLength -> Pure.TypeModifier -> (Maybe Int, Maybe Int)
columnSize typeOid Pure.VariableLength typeModifier
| typeOid `elem` [Oid.bpchar, Oid.varchar] = (Just $ fromIntegral typeModifier - 4, Nothing) -- minus header size
| typeOid == Oid.numeric = let (p, q) = (fromIntegral typeModifier - 4) `divMod` (2 ^ (16 :: Int) :: Int) in (Just p, Just q)
| otherwise = (Nothing, Nothing)
columnSize _ (Pure.FixedLength l) _ = (Just $ fromIntegral l, Nothing)
forceBind :: Either String Pure.PortalProcedure -> Pure.PortalProcedure
forceBind (Right a) = a
forceBind (Left err) = impureThrow $ RequestBuildingFailed err
incrementCounter :: IORef Word -> IO Word
incrementCounter ref = do
n <- readIORef ref
writeIORef ref (n + 1)
pure n
closeUnnecessaryPreparedStatements :: Connection -> IO ()
closeUnnecessaryPreparedStatements Connection { connection, unnecessaryPreparedStatements } =
modifyMVar_ unnecessaryPreparedStatements $ \pss -> do
unless (null pss) $ void $ Pure.sync connection $ Pure.close <$> pss
pure []
convertException :: IO a -> IO a
convertException a = do
r <- try a
case r of
Right v -> pure v
Left e -> throwSqlError $ SqlError { seState = "", seNativeError = -1, seErrorMsg = displayException (e :: Pure.Exception) }
newtype RequestBuildingFailed = RequestBuildingFailed { message :: String } deriving (Show, Read, Eq, Typeable)
instance Exception RequestBuildingFailed where
toException = toException . Pure.Exception
fromException = (\(Pure.Exception e) -> cast e) <=< fromException
instance Pure.FromField SqlValue where
fromField _ _ Nothing = pure SqlNull
fromField decode info@Pure.ColumnInfo { typeOid } v
| typeOid == Oid.char
= SqlChar <$> Pure.fromField decode info v
| typeOid `elem` [Oid.bpchar, Oid.varchar, Oid.text, Oid.name]
= SqlByteString <$> Pure.fromField decode info v
| typeOid `elem` [Oid.int2, Oid.int4]
= SqlInt32 <$> Pure.fromField decode info v
| typeOid == Oid.int8
= SqlInt64 <$> Pure.fromField decode info v
| typeOid == Oid.bool
= SqlBool <$> Pure.fromField decode info v
| typeOid `elem` [Oid.float4, Oid.float8]
= SqlDouble <$> Pure.fromField decode info v
| typeOid == Oid.numeric
= SqlRational . toRational @Scientific <$> Pure.fromField decode info v
| typeOid == Oid.date
= SqlLocalDate <$> Pure.fromField decode info v
| typeOid == Oid.time
= SqlLocalTimeOfDay <$> Pure.fromField decode info v
| typeOid == Oid.timetz
= uncurry SqlZonedLocalTimeOfDay <$> Pure.fromField decode info v
| typeOid == Oid.timestamp
= SqlLocalTime <$> Pure.fromField decode info v
| typeOid == Oid.timestamptz
= SqlUTCTime <$> Pure.fromField decode info v
| typeOid == Oid.interval
= SqlDiffTime . fromRational . toRational @DiffTime <$> Pure.fromField decode info v
| typeOid == Oid.oid
= SqlInt32 . (\(Oid.Oid n) -> n) <$> Pure.fromField decode info v
| otherwise = fail $ "unsupported type: " <> show typeOid
instance Pure.ToField SqlValue where
toField backendParams encode oid format (SqlString v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlByteString v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlWord32 v) = Pure.toField backendParams encode oid format $ fromIntegral @Word32 @Int32 v -- may get overflow
toField backendParams encode oid format (SqlWord64 v) = Pure.toField backendParams encode oid format $ fromIntegral @Word64 @Int64 v -- may get overflow
toField backendParams encode oid format (SqlInt32 v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlInt64 v)
| fromIntegral (minBound :: Int32) <= v && v <= fromIntegral (maxBound :: Int32) = Pure.toField backendParams encode oid format (fromIntegral v :: Int32)
| otherwise = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlInteger v) = Pure.toField backendParams encode oid format $ fromInteger @Scientific v
toField backendParams encode oid format (SqlChar v) = Pure.toField backendParams encode oid format [v]
toField backendParams encode oid format (SqlBool v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlDouble v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlRational v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlLocalDate v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlLocalTimeOfDay v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlZonedLocalTimeOfDay t tz) = Pure.toField backendParams encode oid format (t, tz)
toField backendParams encode oid format (SqlLocalTime v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlZonedTime v) = Pure.toField backendParams encode oid format $ zonedTimeToUTC v
toField backendParams encode oid format (SqlUTCTime v) = Pure.toField backendParams encode oid format v
toField backendParams encode oid format (SqlDiffTime v) = Pure.toField backendParams encode oid format $ fromRational @DiffTime $ toRational @NominalDiffTime v
toField backendParams encode oid format (SqlPOSIXTime v) = Pure.toField backendParams encode oid format v
toField _ _ _ Pure.TextFormat SqlNull = pure Nothing
toField _ _ _ _ _ = fail "unsupported" -- SqlEpochTime and SqlTimeDiff are deprecated
-- | Security risk of DoS attack.
--
-- You should convert 'Rational' to 'Scientific' with 'fromRationalRepetend' in the user side.
-- If the rational value is computed to repeating decimals like 1/3 = 0.3333., this consumes a lot of memories.
-- This is provided because of the HDBC compatibility.
instance Pure.ToField Rational where
toField _ encode Nothing format v =
let
s =
case fromRationalRepetend Nothing v of
Left (s, _) -> s
Right (s, _) -> s
in
case format of
Pure.TextFormat -> Just <$> MonadFail.fromEither (encode $ formatScientific Exponent Nothing s)
Pure.BinaryFormat -> pure $ Just $ BE.encodingBytes $ BE.numeric s
toField backendParams encode (Just o) f v | o == Oid.numeric = Pure.toField backendParams encode Nothing f v
| otherwise = fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Rational"
resultCount :: Pure.ExecuteResult -> Integer
resultCount e =
toInteger $
case e of
Pure.ExecuteComplete tag ->
case tag of
Pure.InsertTag _ n -> n
Pure.DeleteTag n -> n
Pure.UpdateTag n -> n
Pure.SelectTag _ -> 0
Pure.MoveTag n -> n
Pure.FetchTag n -> n
Pure.CopyTag n -> n
Pure.CreateTableTag -> 0
Pure.DropTableTag -> 0
Pure.BeginTag -> 0
Pure.CommitTag -> 0
Pure.RollbackTag -> 0
Pure.SetTag -> 0
Pure.ExecuteEmptyQuery -> 0
Pure.ExecuteSuspended -> 0
instance Convertible Pure.Oid SqlTypeId where
safeConvert oid | oid `elem` [Oid.int2, Oid.int4, Oid.int8] = pure SqlBigIntT
| oid == Oid.numeric = pure SqlDecimalT
| oid == Oid.float4 = pure SqlFloatT
| oid == Oid.float8 = pure SqlDoubleT
| oid `elem` [Oid.char, Oid.bpchar] = pure SqlCharT
| oid `elem` [Oid.varchar, Oid.text] = pure SqlVarCharT
| oid == Oid.bytea = pure SqlVarBinaryT
| oid == Oid.timestamp = pure SqlTimestampT
| oid == Oid.timestamptz = pure SqlTimestampWithZoneT
| oid == Oid.date = pure SqlDateT
| oid == Oid.time = pure SqlTimeT
| oid == Oid.timetz = pure SqlTimeWithZoneT
| oid == Oid.interval = pure $ SqlIntervalT SqlIntervalSecondT
| oid == Oid.bool = pure SqlBitT
| otherwise = pure $ SqlUnknownT $ show oid
lookupClientEncoding :: MonadFail m => Pure.BackendParameters -> m BSS.ShortByteString
lookupClientEncoding params =
case M.lookup "client_encoding" params of
Nothing -> fail "\"client_encoding\" backend parameter not found"
Just code -> pure code
instance Pure.FromField (TimeOfDay, TimeZone) where
fromField _ Pure.ColumnInfo { typeOid, Pure.formatCode } (Just v)
| typeOid == Oid.timetz
= case formatCode of
Pure.TextFormat -> Pure.attoparsecParser ((,) <$> TimeParser.timeOfDay <*> (fromMaybe utc <$> TimeParser.timeZone)) v
Pure.BinaryFormat -> Pure.valueParser BD.timetz_int v
fromField _ Pure.ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: (TimeOfDay, TimeZone)"
instance Pure.ToField (TimeOfDay, TimeZone) where
toField _ _ Nothing Pure.TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSBP.primBounded (TimeBuilder.timeOfDay BSBP.>*< TimeBuilder.timeZone)
toField backendParams _ Nothing Pure.BinaryFormat =
case M.lookup "integer_datetimes" backendParams of
Nothing -> const $ fail "not found \"integer_datetimes\" backend parameter"
Just "on" -> pure . Just . BE.encodingBytes . BE.timetz_int
Just "off" -> pure . Just . BE.encodingBytes . BE.timetz_float
Just v -> const $ fail $ "\"integer_datetimes\" has unrecognized value: " <> show v
toField backendParams encode (Just o) f | o == Oid.timetz = Pure.toField backendParams encode Nothing f
| otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: (TimeOfDay, TimeZone))"
-- Footnote
-- [1] Dirty hack: The numbers 0 and 0 are not used, when the prepared statement procedure is not given to "bind".