-- |
-- An API of low-level IO operations.
module Hasql.IO where

import Database.PostgreSQL.LibPQ qualified as LibPQ
import Hasql.Commands qualified as Commands
import Hasql.Decoders.Result qualified as ResultDecoders
import Hasql.Decoders.Results qualified as ResultsDecoders
import Hasql.Encoders.Params qualified as ParamsEncoders
import Hasql.Errors
import Hasql.Prelude
import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry

{-# INLINE acquireConnection #-}
acquireConnection :: ByteString -> IO LibPQ.Connection
acquireConnection :: ByteString -> IO Connection
acquireConnection =
  ByteString -> IO Connection
LibPQ.connectdb

{-# INLINE acquirePreparedStatementRegistry #-}
acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry
acquirePreparedStatementRegistry :: IO PreparedStatementRegistry
acquirePreparedStatementRegistry =
  IO PreparedStatementRegistry
PreparedStatementRegistry.new

{-# INLINE releaseConnection #-}
releaseConnection :: LibPQ.Connection -> IO ()
releaseConnection :: Connection -> IO ()
releaseConnection Connection
connection =
  Connection -> IO ()
LibPQ.finish Connection
connection

{-# INLINE checkConnectionStatus #-}
checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))
checkConnectionStatus :: Connection -> IO (Maybe (Maybe ByteString))
checkConnectionStatus Connection
c =
  do
    ConnStatus
s <- Connection -> IO ConnStatus
LibPQ.status Connection
c
    case ConnStatus
s of
      ConnStatus
LibPQ.ConnectionOk -> Maybe (Maybe ByteString) -> IO (Maybe (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe ByteString)
forall a. Maybe a
Nothing
      ConnStatus
_ -> (Maybe ByteString -> Maybe (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe (Maybe ByteString))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ByteString -> Maybe (Maybe ByteString)
forall a. a -> Maybe a
Just (Connection -> IO (Maybe ByteString)
LibPQ.errorMessage Connection
c)

{-# INLINE checkServerVersion #-}
checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)
checkServerVersion :: Connection -> IO (Maybe Int)
checkServerVersion Connection
c =
  (Int -> Maybe Int) -> IO Int -> IO (Maybe Int)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Bool) -> Maybe Int -> Maybe Int
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
80200) (Maybe Int -> Maybe Int) -> (Int -> Maybe Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Maybe Int
forall a. a -> Maybe a
Just) (Connection -> IO Int
LibPQ.serverVersion Connection
c)

{-# INLINE getIntegerDatetimes #-}
getIntegerDatetimes :: LibPQ.Connection -> IO Bool
getIntegerDatetimes :: Connection -> IO Bool
getIntegerDatetimes Connection
c =
  (Maybe ByteString -> Bool) -> IO (Maybe ByteString) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ByteString -> Bool
forall {a}. (Eq a, IsString a) => Maybe a -> Bool
decodeValue (IO (Maybe ByteString) -> IO Bool)
-> IO (Maybe ByteString) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO (Maybe ByteString)
LibPQ.parameterStatus Connection
c ByteString
"integer_datetimes"
  where
    decodeValue :: Maybe a -> Bool
decodeValue =
      \case
        Just a
"on" -> Bool
True
        Maybe a
_ -> Bool
False

{-# INLINE initConnection #-}
initConnection :: LibPQ.Connection -> IO ()
initConnection :: Connection -> IO ()
initConnection Connection
c =
  IO (Maybe Result) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Result) -> IO ()) -> IO (Maybe Result) -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO (Maybe Result)
LibPQ.exec Connection
c (Commands -> ByteString
Commands.asBytes (Commands
Commands.setEncodersToUTF8 Commands -> Commands -> Commands
forall a. Semigroup a => a -> a -> a
<> Commands
Commands.setMinClientMessagesToWarning))

{-# INLINE getResults #-}
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)
getResults :: forall a.
Connection -> Bool -> Results a -> IO (Either CommandError a)
getResults Connection
connection Bool
integerDatetimes Results a
decoder =
  {-# SCC "getResults" #-}
  Either CommandError a
-> Either CommandError () -> Either CommandError a
forall a b.
Either CommandError a
-> Either CommandError b -> Either CommandError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
(<*) (Either CommandError a
 -> Either CommandError () -> Either CommandError a)
-> IO (Either CommandError a)
-> IO (Either CommandError () -> Either CommandError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either CommandError a)
get IO (Either CommandError () -> Either CommandError a)
-> IO (Either CommandError ()) -> IO (Either CommandError a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Either CommandError ())
dropRemainders
  where
    get :: IO (Either CommandError a)
get =
      Results a -> (Bool, Connection) -> IO (Either CommandError a)
forall a.
Results a -> (Bool, Connection) -> IO (Either CommandError a)
ResultsDecoders.run Results a
decoder (Bool
integerDatetimes, Connection
connection)
    dropRemainders :: IO (Either CommandError ())
dropRemainders =
      Results () -> (Bool, Connection) -> IO (Either CommandError ())
forall a.
Results a -> (Bool, Connection) -> IO (Either CommandError a)
ResultsDecoders.run Results ()
ResultsDecoders.dropRemainders (Bool
integerDatetimes, Connection
connection)

{-# INLINE getPreparedStatementKey #-}
getPreparedStatementKey ::
  LibPQ.Connection ->
  PreparedStatementRegistry.PreparedStatementRegistry ->
  ByteString ->
  [LibPQ.Oid] ->
  IO (Either CommandError ByteString)
getPreparedStatementKey :: Connection
-> PreparedStatementRegistry
-> ByteString
-> [Oid]
-> IO (Either CommandError ByteString)
getPreparedStatementKey Connection
connection PreparedStatementRegistry
registry ByteString
template [Oid]
oidList =
  {-# SCC "getPreparedStatementKey" #-}
  LocalKey
-> (ByteString -> IO (Bool, Either CommandError ByteString))
-> (ByteString -> IO (Either CommandError ByteString))
-> PreparedStatementRegistry
-> IO (Either CommandError ByteString)
forall a.
LocalKey
-> (ByteString -> IO (Bool, a))
-> (ByteString -> IO a)
-> PreparedStatementRegistry
-> IO a
PreparedStatementRegistry.update LocalKey
localKey ByteString -> IO (Bool, Either CommandError ByteString)
onNewRemoteKey ByteString -> IO (Either CommandError ByteString)
forall {f :: * -> *} {f :: * -> *} {a}.
(Applicative f, Applicative f) =>
a -> f (f a)
onOldRemoteKey PreparedStatementRegistry
registry
  where
    localKey :: LocalKey
localKey =
      ByteString -> [Word32] -> LocalKey
PreparedStatementRegistry.LocalKey ByteString
template [Word32]
wordOIDList
      where
        wordOIDList :: [Word32]
wordOIDList =
          (Oid -> Word32) -> [Oid] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (\(LibPQ.Oid CUInt
x) -> CUInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
x) [Oid]
oidList
    onNewRemoteKey :: ByteString -> IO (Bool, Either CommandError ByteString)
onNewRemoteKey ByteString
key =
      do
        Bool
sent <- Connection -> ByteString -> ByteString -> Maybe [Oid] -> IO Bool
LibPQ.sendPrepare Connection
connection ByteString
key ByteString
template (([Oid] -> Bool) -> Maybe [Oid] -> Maybe [Oid]
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not (Bool -> Bool) -> ([Oid] -> Bool) -> [Oid] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Oid] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([Oid] -> Maybe [Oid]
forall a. a -> Maybe a
Just [Oid]
oidList))
        let resultsDecoder :: Results ()
resultsDecoder =
              if Bool
sent
                then Result () -> Results ()
forall a. Result a -> Results a
ResultsDecoders.single Result ()
ResultDecoders.noResult
                else Results ()
forall a. Results a
ResultsDecoders.clientError
        (Either CommandError () -> (Bool, Either CommandError ByteString))
-> IO (Either CommandError ())
-> IO (Bool, Either CommandError ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either CommandError () -> (Bool, Either CommandError ByteString)
resultsMapping (IO (Either CommandError ())
 -> IO (Bool, Either CommandError ByteString))
-> IO (Either CommandError ())
-> IO (Bool, Either CommandError ByteString)
forall a b. (a -> b) -> a -> b
$ Connection -> Bool -> Results () -> IO (Either CommandError ())
forall a.
Connection -> Bool -> Results a -> IO (Either CommandError a)
getResults Connection
connection Bool
forall a. HasCallStack => a
undefined Results ()
resultsDecoder
      where
        resultsMapping :: Either CommandError () -> (Bool, Either CommandError ByteString)
resultsMapping =
          \case
            Left CommandError
x -> (Bool
False, CommandError -> Either CommandError ByteString
forall a b. a -> Either a b
Left CommandError
x)
            Right ()
_ -> (Bool
True, ByteString -> Either CommandError ByteString
forall a b. b -> Either a b
Right ByteString
key)
    onOldRemoteKey :: a -> f (f a)
onOldRemoteKey a
key =
      f a -> f (f a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
key)

{-# INLINE checkedSend #-}
checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ())
checkedSend :: Connection -> IO Bool -> IO (Either CommandError ())
checkedSend Connection
connection IO Bool
send =
  IO Bool
send IO Bool
-> (Bool -> IO (Either CommandError ()))
-> IO (Either CommandError ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> (Maybe ByteString -> Either CommandError ())
-> IO (Maybe ByteString) -> IO (Either CommandError ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CommandError -> Either CommandError ()
forall a b. a -> Either a b
Left (CommandError -> Either CommandError ())
-> (Maybe ByteString -> CommandError)
-> Maybe ByteString
-> Either CommandError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe ByteString -> CommandError
ClientError) (IO (Maybe ByteString) -> IO (Either CommandError ()))
-> IO (Maybe ByteString) -> IO (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ Connection -> IO (Maybe ByteString)
LibPQ.errorMessage Connection
connection
    Bool
True -> Either CommandError () -> IO (Either CommandError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either CommandError ()
forall a b. b -> Either a b
Right ())

{-# INLINE sendPreparedParametricStatement #-}
sendPreparedParametricStatement ::
  LibPQ.Connection ->
  PreparedStatementRegistry.PreparedStatementRegistry ->
  Bool ->
  ByteString ->
  ParamsEncoders.Params a ->
  a ->
  IO (Either CommandError ())
sendPreparedParametricStatement :: forall a.
Connection
-> PreparedStatementRegistry
-> Bool
-> ByteString
-> Params a
-> a
-> IO (Either CommandError ())
sendPreparedParametricStatement Connection
connection PreparedStatementRegistry
registry Bool
integerDatetimes ByteString
template (ParamsEncoders.Params (Op a -> DList (Oid, Format, Bool -> Maybe ByteString, Text)
encoderOp)) a
input =
  let ([Oid]
oidList, [Maybe (ByteString, Format)]
valueAndFormatList) =
        let step :: (Oid, Format, Bool -> Maybe ByteString, Text)
-> ([Oid], [Maybe (ByteString, Format)])
-> ([Oid], [Maybe (ByteString, Format)])
step (Oid
oid, Format
format, Bool -> Maybe ByteString
encoder, Text
_) ~([Oid]
oidList, [Maybe (ByteString, Format)]
bytesAndFormatList) =
              (,)
                (Oid
oid Oid -> [Oid] -> [Oid]
forall a. a -> [a] -> [a]
: [Oid]
oidList)
                ((ByteString -> (ByteString, Format))
-> Maybe ByteString -> Maybe (ByteString, Format)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
bytes -> (ByteString
bytes, Format
format)) (Bool -> Maybe ByteString
encoder Bool
integerDatetimes) Maybe (ByteString, Format)
-> [Maybe (ByteString, Format)] -> [Maybe (ByteString, Format)]
forall a. a -> [a] -> [a]
: [Maybe (ByteString, Format)]
bytesAndFormatList)
         in ((Oid, Format, Bool -> Maybe ByteString, Text)
 -> ([Oid], [Maybe (ByteString, Format)])
 -> ([Oid], [Maybe (ByteString, Format)]))
-> ([Oid], [Maybe (ByteString, Format)])
-> DList (Oid, Format, Bool -> Maybe ByteString, Text)
-> ([Oid], [Maybe (ByteString, Format)])
forall a b. (a -> b -> b) -> b -> DList a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Oid, Format, Bool -> Maybe ByteString, Text)
-> ([Oid], [Maybe (ByteString, Format)])
-> ([Oid], [Maybe (ByteString, Format)])
step ([], []) (a -> DList (Oid, Format, Bool -> Maybe ByteString, Text)
encoderOp a
input)
   in ExceptT CommandError IO () -> IO (Either CommandError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CommandError IO () -> IO (Either CommandError ()))
-> ExceptT CommandError IO () -> IO (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ do
        ByteString
key <- IO (Either CommandError ByteString)
-> ExceptT CommandError IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either CommandError ByteString)
 -> ExceptT CommandError IO ByteString)
-> IO (Either CommandError ByteString)
-> ExceptT CommandError IO ByteString
forall a b. (a -> b) -> a -> b
$ Connection
-> PreparedStatementRegistry
-> ByteString
-> [Oid]
-> IO (Either CommandError ByteString)
getPreparedStatementKey Connection
connection PreparedStatementRegistry
registry ByteString
template [Oid]
oidList
        IO (Either CommandError ()) -> ExceptT CommandError IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either CommandError ()) -> ExceptT CommandError IO ())
-> IO (Either CommandError ()) -> ExceptT CommandError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> IO Bool -> IO (Either CommandError ())
checkedSend Connection
connection (IO Bool -> IO (Either CommandError ()))
-> IO Bool -> IO (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ Connection
-> ByteString -> [Maybe (ByteString, Format)] -> Format -> IO Bool
LibPQ.sendQueryPrepared Connection
connection ByteString
key [Maybe (ByteString, Format)]
valueAndFormatList Format
LibPQ.Binary

{-# INLINE sendUnpreparedParametricStatement #-}
sendUnpreparedParametricStatement ::
  LibPQ.Connection ->
  Bool ->
  ByteString ->
  ParamsEncoders.Params a ->
  a ->
  IO (Either CommandError ())
sendUnpreparedParametricStatement :: forall a.
Connection
-> Bool
-> ByteString
-> Params a
-> a
-> IO (Either CommandError ())
sendUnpreparedParametricStatement Connection
connection Bool
integerDatetimes ByteString
template (ParamsEncoders.Params (Op a -> DList (Oid, Format, Bool -> Maybe ByteString, Text)
encoderOp)) a
input =
  let params :: [Maybe (Oid, ByteString, Format)]
params =
        let step :: (Oid, Format, Bool -> Maybe ByteString, Text)
-> [Maybe (Oid, ByteString, Format)]
-> [Maybe (Oid, ByteString, Format)]
step (Oid
oid, Format
format, Bool -> Maybe ByteString
encoder, Text
_) [Maybe (Oid, ByteString, Format)]
acc =
              ((,,) (Oid -> ByteString -> Format -> (Oid, ByteString, Format))
-> Maybe Oid
-> Maybe (ByteString -> Format -> (Oid, ByteString, Format))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oid -> Maybe Oid
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Oid
oid Maybe (ByteString -> Format -> (Oid, ByteString, Format))
-> Maybe ByteString -> Maybe (Format -> (Oid, ByteString, Format))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Maybe ByteString
encoder Bool
integerDatetimes Maybe (Format -> (Oid, ByteString, Format))
-> Maybe Format -> Maybe (Oid, ByteString, Format)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Format -> Maybe Format
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
format) Maybe (Oid, ByteString, Format)
-> [Maybe (Oid, ByteString, Format)]
-> [Maybe (Oid, ByteString, Format)]
forall a. a -> [a] -> [a]
: [Maybe (Oid, ByteString, Format)]
acc
         in ((Oid, Format, Bool -> Maybe ByteString, Text)
 -> [Maybe (Oid, ByteString, Format)]
 -> [Maybe (Oid, ByteString, Format)])
-> [Maybe (Oid, ByteString, Format)]
-> DList (Oid, Format, Bool -> Maybe ByteString, Text)
-> [Maybe (Oid, ByteString, Format)]
forall a b. (a -> b -> b) -> b -> DList a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Oid, Format, Bool -> Maybe ByteString, Text)
-> [Maybe (Oid, ByteString, Format)]
-> [Maybe (Oid, ByteString, Format)]
step [] (a -> DList (Oid, Format, Bool -> Maybe ByteString, Text)
encoderOp a
input)
   in Connection -> IO Bool -> IO (Either CommandError ())
checkedSend Connection
connection (IO Bool -> IO (Either CommandError ()))
-> IO Bool -> IO (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ Connection
-> ByteString
-> [Maybe (Oid, ByteString, Format)]
-> Format
-> IO Bool
LibPQ.sendQueryParams Connection
connection ByteString
template [Maybe (Oid, ByteString, Format)]
params Format
LibPQ.Binary

{-# INLINE sendParametricStatement #-}
sendParametricStatement ::
  LibPQ.Connection ->
  Bool ->
  PreparedStatementRegistry.PreparedStatementRegistry ->
  ByteString ->
  ParamsEncoders.Params a ->
  Bool ->
  a ->
  IO (Either CommandError ())
sendParametricStatement :: forall a.
Connection
-> Bool
-> PreparedStatementRegistry
-> ByteString
-> Params a
-> Bool
-> a
-> IO (Either CommandError ())
sendParametricStatement Connection
connection Bool
integerDatetimes PreparedStatementRegistry
registry ByteString
template Params a
encoder Bool
prepared a
params =
  {-# SCC "sendParametricStatement" #-}
  if Bool
prepared
    then Connection
-> PreparedStatementRegistry
-> Bool
-> ByteString
-> Params a
-> a
-> IO (Either CommandError ())
forall a.
Connection
-> PreparedStatementRegistry
-> Bool
-> ByteString
-> Params a
-> a
-> IO (Either CommandError ())
sendPreparedParametricStatement Connection
connection PreparedStatementRegistry
registry Bool
integerDatetimes ByteString
template Params a
encoder a
params
    else Connection
-> Bool
-> ByteString
-> Params a
-> a
-> IO (Either CommandError ())
forall a.
Connection
-> Bool
-> ByteString
-> Params a
-> a
-> IO (Either CommandError ())
sendUnpreparedParametricStatement Connection
connection Bool
integerDatetimes ByteString
template Params a
encoder a
params

{-# INLINE sendNonparametricStatement #-}
sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ())
sendNonparametricStatement :: Connection -> ByteString -> IO (Either CommandError ())
sendNonparametricStatement Connection
connection ByteString
sql =
  Connection -> IO Bool -> IO (Either CommandError ())
checkedSend Connection
connection (IO Bool -> IO (Either CommandError ()))
-> IO Bool -> IO (Either CommandError ())
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO Bool
LibPQ.sendQuery Connection
connection ByteString
sql