module Hasql.Comms.Roundtrip
  ( Roundtrip,
    toPipelineIO,
    toSerialIO,

    -- * Constructors
    prepare,
    queryPrepared,
    queryParams,
    query,
    script,

    -- * Errors
    Error (..),
  )
where

import Hasql.Comms.Recv qualified as Recv
import Hasql.Comms.ResultDecoder qualified as ResultDecoder
import Hasql.Comms.Send qualified as Send
import Hasql.Platform.Prelude
import Hasql.Pq qualified as Pq

data Roundtrip context a
  = Roundtrip (Send.Send context) (Recv.Recv context a)
  deriving stock ((forall a b.
 (a -> b) -> Roundtrip context a -> Roundtrip context b)
-> (forall a b. a -> Roundtrip context b -> Roundtrip context a)
-> Functor (Roundtrip context)
forall a b. a -> Roundtrip context b -> Roundtrip context a
forall a b. (a -> b) -> Roundtrip context a -> Roundtrip context b
forall context a b. a -> Roundtrip context b -> Roundtrip context a
forall context a b.
(a -> b) -> Roundtrip context a -> Roundtrip context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall context a b.
(a -> b) -> Roundtrip context a -> Roundtrip context b
fmap :: forall a b. (a -> b) -> Roundtrip context a -> Roundtrip context b
$c<$ :: forall context a b. a -> Roundtrip context b -> Roundtrip context a
<$ :: forall a b. a -> Roundtrip context b -> Roundtrip context a
Functor)

instance Applicative (Roundtrip context) where
  {-# INLINE pure #-}
  pure :: forall a. a -> Roundtrip context a
pure a
x = Send context -> Recv context a -> Roundtrip context a
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip Send context
forall a. Monoid a => a
mempty (a -> Recv context a
forall a. a -> Recv context a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  {-# INLINE (<*>) #-}
  Roundtrip Send context
send1 Recv context (a -> b)
recv1 <*> :: forall a b.
Roundtrip context (a -> b)
-> Roundtrip context a -> Roundtrip context b
<*> Roundtrip Send context
send2 Recv context a
recv2 =
    Send context -> Recv context b -> Roundtrip context b
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip (Send context
send1 Send context -> Send context -> Send context
forall a. Semigroup a => a -> a -> a
<> Send context
send2) (Recv context (a -> b)
recv1 Recv context (a -> b) -> Recv context a -> Recv context b
forall a b.
Recv context (a -> b) -> Recv context a -> Recv context b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Recv context a
recv2)

instance Bifunctor Roundtrip where
  {-# INLINE bimap #-}
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> Roundtrip a c -> Roundtrip b d
bimap a -> b
f c -> d
g (Roundtrip Send a
send Recv a c
recv) =
    Send b -> Recv b d -> Roundtrip b d
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
      ((a -> b) -> Send a -> Send b
forall a b. (a -> b) -> Send a -> Send b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Send a
send)
      ((a -> b) -> (c -> d) -> Recv a c -> Recv b d
forall a b c d. (a -> b) -> (c -> d) -> Recv a c -> Recv b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g Recv a c
recv)

toPipelineIO :: Roundtrip context a -> context -> Pq.Connection -> IO (Either (Error context) a)
toPipelineIO :: forall context a.
Roundtrip context a
-> context -> Connection -> IO (Either (Error context) a)
toPipelineIO Roundtrip context a
sendAndRecv context
context Connection
connection = ((forall a. IO a -> IO a) -> IO (Either (Error context) a))
-> IO (Either (Error context) a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask \forall a. IO a -> IO a
restore -> do
  Result context
sendResult <- Send context -> Connection -> IO (Result context)
forall context. Send context -> Connection -> IO (Result context)
Send.toHandler (context -> Send context
forall context. context -> Send context
Send.enterPipelineMode context
context Send context -> Send context -> Send context
forall a. Semigroup a => a -> a -> a
<> Send context
send) Connection
connection
  case Result context
sendResult of
    Send.Error context
context Maybe ByteString
details -> Either (Error context) a -> IO (Either (Error context) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error context -> Either (Error context) a
forall a b. a -> Either a b
Left (context -> Maybe ByteString -> Error context
forall context. context -> Maybe ByteString -> Error context
ClientError context
context Maybe ByteString
details))
    Result context
Send.Ok -> do
      Either (Error context) a
recvResult <- (Error context -> Error context)
-> Either (Error context) a -> Either (Error context) a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error context -> Error context
forall context. Error context -> Error context
ServerError (Either (Error context) a -> Either (Error context) a)
-> IO (Either (Error context) a) -> IO (Either (Error context) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either (Error context) a) -> IO (Either (Error context) a)
forall a. IO a -> IO a
restore (Recv context a -> Connection -> IO (Either (Error context) a)
forall context a.
Recv context a -> Connection -> IO (Either (Error context) a)
Recv.toHandler Recv context a
recv Connection
connection)
      Either (Error context) ()
exitResult <- do
        Result context
result <- Send context -> Connection -> IO (Result context)
forall context. Send context -> Connection -> IO (Result context)
Send.toHandler (context -> Send context
forall context. context -> Send context
Send.exitPipelineMode context
context) Connection
connection
        case Result context
result of
          Send.Error context
context Maybe ByteString
details -> Either (Error context) () -> IO (Either (Error context) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error context -> Either (Error context) ()
forall a b. a -> Either a b
Left (context -> Maybe ByteString -> Error context
forall context. context -> Maybe ByteString -> Error context
ClientError context
context Maybe ByteString
details))
          Result context
Send.Ok -> Either (Error context) () -> IO (Either (Error context) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either (Error context) ()
forall a b. b -> Either a b
Right ())
      pure (Either (Error context) a
recvResult Either (Error context) a
-> Either (Error context) () -> Either (Error context) a
forall a b.
Either (Error context) a
-> Either (Error context) b -> Either (Error context) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Either (Error context) ()
exitResult)
  where
    Roundtrip Send context
send Recv context a
recv = Roundtrip context a
sendAndRecv Roundtrip context a -> Roundtrip context () -> Roundtrip context a
forall a b.
Roundtrip context a -> Roundtrip context b -> Roundtrip context a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* context -> Roundtrip context ()
forall context. context -> Roundtrip context ()
pipelineSync context
context

toSerialIO :: Roundtrip context a -> Pq.Connection -> IO (Either (Error context) a)
toSerialIO :: forall context a.
Roundtrip context a -> Connection -> IO (Either (Error context) a)
toSerialIO (Roundtrip Send context
send Recv context a
recv) Connection
connection = do
  Result context
sendResult <- Send context -> Connection -> IO (Result context)
forall context. Send context -> Connection -> IO (Result context)
Send.toHandler Send context
send Connection
connection
  case Result context
sendResult of
    Send.Error context
context Maybe ByteString
details -> Either (Error context) a -> IO (Either (Error context) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error context -> Either (Error context) a
forall a b. a -> Either a b
Left (context -> Maybe ByteString -> Error context
forall context. context -> Maybe ByteString -> Error context
ClientError context
context Maybe ByteString
details))
    Result context
Send.Ok -> do
      Either (Error context) a
recvResult <- Recv context a -> Connection -> IO (Either (Error context) a)
forall context a.
Recv context a -> Connection -> IO (Either (Error context) a)
Recv.toHandler Recv context a
recv Connection
connection
      pure ((Error context -> Error context)
-> Either (Error context) a -> Either (Error context) a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error context -> Error context
forall context. Error context -> Error context
ServerError Either (Error context) a
recvResult)

pipelineSync :: context -> Roundtrip context ()
pipelineSync :: forall context. context -> Roundtrip context ()
pipelineSync context
context =
  Send context -> Recv context () -> Roundtrip context ()
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
    (context -> Send context
forall context. context -> Send context
Send.pipelineSync context
context)
    (context -> ResultDecoder () -> Recv context ()
forall context a. context -> ResultDecoder a -> Recv context a
Recv.singleResult context
context ResultDecoder ()
ResultDecoder.pipelineSync)

prepare :: context -> ByteString -> ByteString -> [Pq.Oid] -> Roundtrip context ()
prepare :: forall context.
context
-> ByteString -> ByteString -> [Oid] -> Roundtrip context ()
prepare context
context ByteString
statementName ByteString
sql [Oid]
oidList =
  Send context -> Recv context () -> Roundtrip context ()
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
    (context -> ByteString -> ByteString -> Maybe [Oid] -> Send context
forall context.
context -> ByteString -> ByteString -> Maybe [Oid] -> Send context
Send.prepare context
context ByteString
statementName ByteString
sql ([Oid] -> Maybe [Oid]
forall a. a -> Maybe a
Just [Oid]
oidList))
    (context -> ResultDecoder () -> Recv context ()
forall context a. context -> ResultDecoder a -> Recv context a
Recv.singleResult context
context ResultDecoder ()
ResultDecoder.ok)

queryPrepared ::
  context ->
  -- | Prepared statement name.
  ByteString ->
  -- | Parameters.
  [Maybe (ByteString, Pq.Format)] ->
  -- | Result format.
  Pq.Format ->
  -- | Result decoder.
  ResultDecoder.ResultDecoder a ->
  Roundtrip context a
queryPrepared :: forall context a.
context
-> ByteString
-> [Maybe (ByteString, Format)]
-> Format
-> ResultDecoder a
-> Roundtrip context a
queryPrepared context
context ByteString
statementName [Maybe (ByteString, Format)]
params Format
resultFormat ResultDecoder a
resultDecoder =
  Send context -> Recv context a -> Roundtrip context a
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
    (context
-> ByteString
-> [Maybe (ByteString, Format)]
-> Format
-> Send context
forall context.
context
-> ByteString
-> [Maybe (ByteString, Format)]
-> Format
-> Send context
Send.queryPrepared context
context ByteString
statementName [Maybe (ByteString, Format)]
params Format
resultFormat)
    (context -> ResultDecoder a -> Recv context a
forall context a. context -> ResultDecoder a -> Recv context a
Recv.singleResult context
context ResultDecoder a
resultDecoder)

queryParams ::
  context ->
  -- | SQL.
  ByteString ->
  -- | Parameters.
  [Maybe (Pq.Oid, ByteString, Pq.Format)] ->
  -- | Result format.
  Pq.Format ->
  -- | Result decoder.
  ResultDecoder.ResultDecoder a ->
  Roundtrip context a
queryParams :: forall context a.
context
-> ByteString
-> [Maybe (Oid, ByteString, Format)]
-> Format
-> ResultDecoder a
-> Roundtrip context a
queryParams context
context ByteString
sql [Maybe (Oid, ByteString, Format)]
params Format
resultFormat ResultDecoder a
resultDecoder =
  Send context -> Recv context a -> Roundtrip context a
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
    (context
-> ByteString
-> [Maybe (Oid, ByteString, Format)]
-> Format
-> Send context
forall context.
context
-> ByteString
-> [Maybe (Oid, ByteString, Format)]
-> Format
-> Send context
Send.queryParams context
context ByteString
sql [Maybe (Oid, ByteString, Format)]
params Format
resultFormat)
    (context -> ResultDecoder a -> Recv context a
forall context a. context -> ResultDecoder a -> Recv context a
Recv.singleResult context
context ResultDecoder a
resultDecoder)

query :: context -> ByteString -> Roundtrip context ()
query :: forall context. context -> ByteString -> Roundtrip context ()
query context
context ByteString
sql =
  Send context -> Recv context () -> Roundtrip context ()
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
    (context -> ByteString -> Send context
forall context. context -> ByteString -> Send context
Send.query context
context ByteString
sql)
    (context -> ResultDecoder () -> Recv context ()
forall context a. context -> ResultDecoder a -> Recv context a
Recv.singleResult context
context ResultDecoder ()
ResultDecoder.ok)

-- | Execute a script (multi-statement SQL).
-- Unlike 'query', this consumes all results from the execution,
-- which is necessary for scripts containing multiple statements.
script :: context -> ByteString -> Roundtrip context ()
script :: forall context. context -> ByteString -> Roundtrip context ()
script context
context ByteString
sql =
  Send context -> Recv context () -> Roundtrip context ()
forall context a.
Send context -> Recv context a -> Roundtrip context a
Roundtrip
    (context -> ByteString -> Send context
forall context. context -> ByteString -> Send context
Send.query context
context ByteString
sql)
    (context -> ResultDecoder () -> Recv context ()
forall context a. context -> ResultDecoder a -> Recv context ()
Recv.allResults context
context ResultDecoder ()
ResultDecoder.ok)

data Error context
  = ClientError context (Maybe ByteString)
  | ServerError (Recv.Error context)
  deriving stock (Int -> Error context -> ShowS
[Error context] -> ShowS
Error context -> String
(Int -> Error context -> ShowS)
-> (Error context -> String)
-> ([Error context] -> ShowS)
-> Show (Error context)
forall context. Show context => Int -> Error context -> ShowS
forall context. Show context => [Error context] -> ShowS
forall context. Show context => Error context -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall context. Show context => Int -> Error context -> ShowS
showsPrec :: Int -> Error context -> ShowS
$cshow :: forall context. Show context => Error context -> String
show :: Error context -> String
$cshowList :: forall context. Show context => [Error context] -> ShowS
showList :: [Error context] -> ShowS
Show, Error context -> Error context -> Bool
(Error context -> Error context -> Bool)
-> (Error context -> Error context -> Bool) -> Eq (Error context)
forall context.
Eq context =>
Error context -> Error context -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall context.
Eq context =>
Error context -> Error context -> Bool
== :: Error context -> Error context -> Bool
$c/= :: forall context.
Eq context =>
Error context -> Error context -> Bool
/= :: Error context -> Error context -> Bool
Eq)