module Hasql.Private.Session.UnliftIO where

-- mtl
import Control.Monad.Reader.Class (ask)
import Control.Monad.Error.Class (throwError)

-- unliftio-core
import Control.Monad.IO.Unlift

-- safe-exceptions
import Control.Exception.Safe

--hasql
import Hasql.Session

instance MonadUnliftIO Session where
  withRunInIO :: forall b. ((forall a. Session a -> IO a) -> IO b) -> Session b
withRunInIO (forall a. Session a -> IO a) -> IO b
inner = do
    Connection
conn <- Session Connection
forall r (m :: * -> *). MonadReader r m => m r
ask
    Either QueryError b
res <- IO (Either QueryError b) -> Session (Either QueryError b)
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QueryError b) -> Session (Either QueryError b))
-> IO (Either QueryError b) -> Session (Either QueryError b)
forall a b. (a -> b) -> a -> b
$ IO b -> IO (Either QueryError b)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO b -> IO (Either QueryError b))
-> IO b -> IO (Either QueryError b)
forall a b. (a -> b) -> a -> b
$ (forall a. Session a -> IO a) -> IO b
inner ((forall a. Session a -> IO a) -> IO b)
-> (forall a. Session a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ \Session a
sess -> do
      Session a -> Connection -> IO (Either QueryError a)
forall a. Session a -> Connection -> IO (Either QueryError a)
run Session a
sess Connection
conn IO (Either QueryError a) -> (Either QueryError a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QueryError -> IO a) -> (a -> IO a) -> Either QueryError a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QueryError -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    case Either QueryError b
res of
      Left QueryError
e -> QueryError -> Session b
forall a. QueryError -> Session a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError QueryError
e
      Right b
a -> b -> Session b
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a