{-# LANGUAGE UndecidableInstances #-} module Mensam.Server.Application.SeldaPool where import Mensam.Server.Application.Configured.Class import Mensam.Server.Application.SeldaPool.Class import Mensam.Server.Configuration import Mensam.Server.Configuration.SQLite import Mensam.Server.Database.Migration import Control.Monad.Catch import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.Trans import Control.Monad.Trans.Compose import Control.Monad.Trans.Compose.Transparent import Control.Monad.Trans.Control import Control.Monad.Trans.Control.Identity import Control.Monad.Trans.Reader import Data.Kind import Data.Pool qualified as P import Data.Text qualified as T import Database.Selda import Database.Selda.Backend import Database.Selda.SQLite import System.Posix.Files type SeldaPoolT :: (Type -> Type) -> Type -> Type newtype SeldaPoolT m a = SeldaPoolT {forall (m :: * -> *) a. SeldaPoolT m a -> ReaderT SeldaPoolContext m a unSeldaPoolT :: ReaderT SeldaPoolContext m a} deriving newtype (Functor (SeldaPoolT m) Functor (SeldaPoolT m) => (forall a. a -> SeldaPoolT m a) -> (forall a b. SeldaPoolT m (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b) -> (forall a b c. (a -> b -> c) -> SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m c) -> (forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b) -> (forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m a) -> Applicative (SeldaPoolT m) forall a. a -> SeldaPoolT m a forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m a forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b forall a b. SeldaPoolT m (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b forall a b c. (a -> b -> c) -> SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m c forall (f :: * -> *). Functor f => (forall a. a -> f a) -> (forall a b. f (a -> b) -> f a -> f b) -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c) -> (forall a b. f a -> f b -> f b) -> (forall a b. f a -> f b -> f a) -> Applicative f forall (m :: * -> *). Applicative m => Functor (SeldaPoolT m) forall (m :: * -> *) a. Applicative m => a -> SeldaPoolT m a forall (m :: * -> *) a b. Applicative m => SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m a forall (m :: * -> *) a b. Applicative m => SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b forall (m :: * -> *) a b. Applicative m => SeldaPoolT m (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b forall (m :: * -> *) a b c. Applicative m => (a -> b -> c) -> SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m c $cpure :: forall (m :: * -> *) a. Applicative m => a -> SeldaPoolT m a pure :: forall a. a -> SeldaPoolT m a $c<*> :: forall (m :: * -> *) a b. Applicative m => SeldaPoolT m (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b <*> :: forall a b. SeldaPoolT m (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b $cliftA2 :: forall (m :: * -> *) a b c. Applicative m => (a -> b -> c) -> SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m c liftA2 :: forall a b c. (a -> b -> c) -> SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m c $c*> :: forall (m :: * -> *) a b. Applicative m => SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b *> :: forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b $c<* :: forall (m :: * -> *) a b. Applicative m => SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m a <* :: forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m a Applicative, (forall a b. (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b) -> (forall a b. a -> SeldaPoolT m b -> SeldaPoolT m a) -> Functor (SeldaPoolT m) forall a b. a -> SeldaPoolT m b -> SeldaPoolT m a forall a b. (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b forall (m :: * -> *) a b. Functor m => a -> SeldaPoolT m b -> SeldaPoolT m a forall (m :: * -> *) a b. Functor m => (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f $cfmap :: forall (m :: * -> *) a b. Functor m => (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b fmap :: forall a b. (a -> b) -> SeldaPoolT m a -> SeldaPoolT m b $c<$ :: forall (m :: * -> *) a b. Functor m => a -> SeldaPoolT m b -> SeldaPoolT m a <$ :: forall a b. a -> SeldaPoolT m b -> SeldaPoolT m a Functor, Applicative (SeldaPoolT m) Applicative (SeldaPoolT m) => (forall a b. SeldaPoolT m a -> (a -> SeldaPoolT m b) -> SeldaPoolT m b) -> (forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b) -> (forall a. a -> SeldaPoolT m a) -> Monad (SeldaPoolT m) forall a. a -> SeldaPoolT m a forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b forall a b. SeldaPoolT m a -> (a -> SeldaPoolT m b) -> SeldaPoolT m b forall (m :: * -> *). Monad m => Applicative (SeldaPoolT m) forall (m :: * -> *) a. Monad m => a -> SeldaPoolT m a forall (m :: * -> *) a b. Monad m => SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b forall (m :: * -> *) a b. Monad m => SeldaPoolT m a -> (a -> SeldaPoolT m b) -> SeldaPoolT m b forall (m :: * -> *). Applicative m => (forall a b. m a -> (a -> m b) -> m b) -> (forall a b. m a -> m b -> m b) -> (forall a. a -> m a) -> Monad m $c>>= :: forall (m :: * -> *) a b. Monad m => SeldaPoolT m a -> (a -> SeldaPoolT m b) -> SeldaPoolT m b >>= :: forall a b. SeldaPoolT m a -> (a -> SeldaPoolT m b) -> SeldaPoolT m b $c>> :: forall (m :: * -> *) a b. Monad m => SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b >> :: forall a b. SeldaPoolT m a -> SeldaPoolT m b -> SeldaPoolT m b $creturn :: forall (m :: * -> *) a. Monad m => a -> SeldaPoolT m a return :: forall a. a -> SeldaPoolT m a Monad) deriving newtype ((forall (m :: * -> *). Monad m => Monad (SeldaPoolT m)) => (forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a) -> MonadTrans SeldaPoolT forall (m :: * -> *). Monad m => Monad (SeldaPoolT m) forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *). (forall (m :: * -> *). Monad m => Monad (t m)) => (forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t $clift :: forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a lift :: forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a MonadTrans, MonadTrans SeldaPoolT MonadTrans SeldaPoolT => (forall (m :: * -> *) a. Monad m => (Run SeldaPoolT -> m a) -> SeldaPoolT m a) -> (forall (m :: * -> *) a. Monad m => m (StT SeldaPoolT a) -> SeldaPoolT m a) -> MonadTransControl SeldaPoolT forall (m :: * -> *) a. Monad m => m (StT SeldaPoolT a) -> SeldaPoolT m a forall (m :: * -> *) a. Monad m => (Run SeldaPoolT -> m a) -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *). MonadTrans t => (forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a) -> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a) -> MonadTransControl t $cliftWith :: forall (m :: * -> *) a. Monad m => (Run SeldaPoolT -> m a) -> SeldaPoolT m a liftWith :: forall (m :: * -> *) a. Monad m => (Run SeldaPoolT -> m a) -> SeldaPoolT m a $crestoreT :: forall (m :: * -> *) a. Monad m => m (StT SeldaPoolT a) -> SeldaPoolT m a restoreT :: forall (m :: * -> *) a. Monad m => m (StT SeldaPoolT a) -> SeldaPoolT m a MonadTransControl, MonadTransControl SeldaPoolT MonadTransControl SeldaPoolT => (forall (m :: * -> *) a. Monad m => ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a) -> MonadTransControlIdentity SeldaPoolT forall (m :: * -> *) a. Monad m => ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *). MonadTransControl t => (forall (m :: * -> *) a. Monad m => ((forall x. t m x -> m x) -> m a) -> t m a) -> MonadTransControlIdentity t $cliftWithIdentity :: forall (m :: * -> *) a. Monad m => ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a liftWithIdentity :: forall (m :: * -> *) a. Monad m => ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a MonadTransControlIdentity) deriving newtype (Monad (SeldaPoolT m) Monad (SeldaPoolT m) => (forall a. IO a -> SeldaPoolT m a) -> MonadIO (SeldaPoolT m) forall a. IO a -> SeldaPoolT m a forall (m :: * -> *). Monad m => (forall a. IO a -> m a) -> MonadIO m forall (m :: * -> *). MonadIO m => Monad (SeldaPoolT m) forall (m :: * -> *) a. MonadIO m => IO a -> SeldaPoolT m a $cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SeldaPoolT m a liftIO :: forall a. IO a -> SeldaPoolT m a MonadIO) deriving newtype (Monad (SeldaPoolT m) Monad (SeldaPoolT m) => (forall e a. (HasCallStack, Exception e) => e -> SeldaPoolT m a) -> MonadThrow (SeldaPoolT m) forall e a. (HasCallStack, Exception e) => e -> SeldaPoolT m a forall (m :: * -> *). Monad m => (forall e a. (HasCallStack, Exception e) => e -> m a) -> MonadThrow m forall (m :: * -> *). MonadThrow m => Monad (SeldaPoolT m) forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> SeldaPoolT m a $cthrowM :: forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> SeldaPoolT m a throwM :: forall e a. (HasCallStack, Exception e) => e -> SeldaPoolT m a MonadThrow, MonadThrow (SeldaPoolT m) MonadThrow (SeldaPoolT m) => (forall e a. (HasCallStack, Exception e) => SeldaPoolT m a -> (e -> SeldaPoolT m a) -> SeldaPoolT m a) -> MonadCatch (SeldaPoolT m) forall e a. (HasCallStack, Exception e) => SeldaPoolT m a -> (e -> SeldaPoolT m a) -> SeldaPoolT m a forall (m :: * -> *). MonadThrow m => (forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a) -> MonadCatch m forall (m :: * -> *). MonadCatch m => MonadThrow (SeldaPoolT m) forall (m :: * -> *) e a. (MonadCatch m, HasCallStack, Exception e) => SeldaPoolT m a -> (e -> SeldaPoolT m a) -> SeldaPoolT m a $ccatch :: forall (m :: * -> *) e a. (MonadCatch m, HasCallStack, Exception e) => SeldaPoolT m a -> (e -> SeldaPoolT m a) -> SeldaPoolT m a catch :: forall e a. (HasCallStack, Exception e) => SeldaPoolT m a -> (e -> SeldaPoolT m a) -> SeldaPoolT m a MonadCatch, MonadCatch (SeldaPoolT m) MonadCatch (SeldaPoolT m) => (forall b. HasCallStack => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b) -> (forall b. HasCallStack => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b) -> (forall a b c. HasCallStack => SeldaPoolT m a -> (a -> ExitCase b -> SeldaPoolT m c) -> (a -> SeldaPoolT m b) -> SeldaPoolT m (b, c)) -> MonadMask (SeldaPoolT m) forall b. HasCallStack => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b forall a b c. HasCallStack => SeldaPoolT m a -> (a -> ExitCase b -> SeldaPoolT m c) -> (a -> SeldaPoolT m b) -> SeldaPoolT m (b, c) forall (m :: * -> *). MonadMask m => MonadCatch (SeldaPoolT m) forall (m :: * -> *) b. (MonadMask m, HasCallStack) => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b forall (m :: * -> *) a b c. (MonadMask m, HasCallStack) => SeldaPoolT m a -> (a -> ExitCase b -> SeldaPoolT m c) -> (a -> SeldaPoolT m b) -> SeldaPoolT m (b, c) forall (m :: * -> *). MonadCatch m => (forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b) -> (forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b) -> (forall a b c. HasCallStack => m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)) -> MonadMask m $cmask :: forall (m :: * -> *) b. (MonadMask m, HasCallStack) => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b mask :: forall b. HasCallStack => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b $cuninterruptibleMask :: forall (m :: * -> *) b. (MonadMask m, HasCallStack) => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b uninterruptibleMask :: forall b. HasCallStack => ((forall a. SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m b) -> SeldaPoolT m b $cgeneralBracket :: forall (m :: * -> *) a b c. (MonadMask m, HasCallStack) => SeldaPoolT m a -> (a -> ExitCase b -> SeldaPoolT m c) -> (a -> SeldaPoolT m b) -> SeldaPoolT m (b, c) generalBracket :: forall a b c. HasCallStack => SeldaPoolT m a -> (a -> ExitCase b -> SeldaPoolT m c) -> (a -> SeldaPoolT m b) -> SeldaPoolT m (b, c) MonadMask) instance (MonadLogger m, MonadMask m, MonadUnliftIO m) => MonadSeldaPool (SeldaPoolT m) where runSeldaTransactionT :: forall a. SeldaTransactionT (SeldaPoolT m) a -> SeldaPoolT m (SeldaResult a) runSeldaTransactionT SeldaTransactionT (SeldaPoolT m) a tma = do Bool alreadyInTransaction <- SeldaPoolContext -> Bool seldaAlreadyInTransaction (SeldaPoolContext -> Bool) -> SeldaPoolT m SeldaPoolContext -> SeldaPoolT m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ReaderT SeldaPoolContext m SeldaPoolContext -> SeldaPoolT m SeldaPoolContext forall (m :: * -> *) a. ReaderT SeldaPoolContext m a -> SeldaPoolT m a SeldaPoolT ReaderT SeldaPoolContext m SeldaPoolContext forall (m :: * -> *) r. Monad m => ReaderT r m r ask if Bool alreadyInTransaction then do let Text msg :: Text = Text "Tried to start nested SQLite transaction. Nested transactions are not allowed to prevent deadlocks." m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logError Text msg SeldaError -> SeldaPoolT m (SeldaResult a) forall e a. (HasCallStack, Exception e) => e -> SeldaPoolT m a forall (m :: * -> *) e a. (MonadThrow m, HasCallStack, Exception e) => e -> m a throwM (SeldaError -> SeldaPoolT m (SeldaResult a)) -> SeldaError -> SeldaPoolT m (SeldaResult a) forall a b. (a -> b) -> a -> b $ String -> SeldaError SqlError (String -> SeldaError) -> String -> SeldaError forall a b. (a -> b) -> a -> b $ Text -> String forall a. Show a => a -> String show Text msg else do Pool (SeldaConnection SQLite) pool <- SeldaPoolContext -> Pool (SeldaConnection SQLite) seldaConnectionPool (SeldaPoolContext -> Pool (SeldaConnection SQLite)) -> SeldaPoolT m SeldaPoolContext -> SeldaPoolT m (Pool (SeldaConnection SQLite)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ReaderT SeldaPoolContext m SeldaPoolContext -> SeldaPoolT m SeldaPoolContext forall (m :: * -> *) a. ReaderT SeldaPoolContext m a -> SeldaPoolT m a SeldaPoolT ReaderT SeldaPoolContext m SeldaPoolContext forall (m :: * -> *) r. Monad m => ReaderT r m r ask let transactionComputation :: SeldaPoolT m (SeldaResult a) transactionComputation = ((forall x. SeldaPoolT m x -> m x) -> m (SeldaResult a)) -> SeldaPoolT m (SeldaResult a) forall (m :: * -> *) a. Monad m => ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTransControlIdentity t, Monad m) => ((forall x. t m x -> m x) -> m a) -> t m a liftWithIdentity (((forall x. SeldaPoolT m x -> m x) -> m (SeldaResult a)) -> SeldaPoolT m (SeldaResult a)) -> ((forall x. SeldaPoolT m x -> m x) -> m (SeldaResult a)) -> SeldaPoolT m (SeldaResult a) forall a b. (a -> b) -> a -> b $ \forall x. SeldaPoolT m x -> m x runT -> ((forall a. m a -> IO a) -> IO (SeldaResult a)) -> m (SeldaResult a) forall b. ((forall a. m a -> IO a) -> IO b) -> m b forall (m :: * -> *) b. MonadUnliftIO m => ((forall a. m a -> IO a) -> IO b) -> m b withRunInIO (((forall a. m a -> IO a) -> IO (SeldaResult a)) -> m (SeldaResult a)) -> ((forall a. m a -> IO a) -> IO (SeldaResult a)) -> m (SeldaResult a) forall a b. (a -> b) -> a -> b $ \forall a. m a -> IO a runInIO -> Pool (SeldaConnection SQLite) -> (SeldaConnection SQLite -> IO (SeldaResult a)) -> IO (SeldaResult a) forall a r. Pool a -> (a -> IO r) -> IO r P.withResource Pool (SeldaConnection SQLite) pool ((SeldaConnection SQLite -> IO (SeldaResult a)) -> IO (SeldaResult a)) -> (SeldaConnection SQLite -> IO (SeldaResult a)) -> IO (SeldaResult a) forall a b. (a -> b) -> a -> b $ \SeldaConnection SQLite connection -> (SeldaT SQLite IO (SeldaResult a) -> SeldaConnection SQLite -> IO (SeldaResult a) forall (m :: * -> *) b a. (MonadIO m, MonadMask m) => SeldaT b m a -> SeldaConnection b -> m a `runSeldaT` SeldaConnection SQLite connection) (SeldaT SQLite IO (SeldaResult a) -> IO (SeldaResult a)) -> SeldaT SQLite IO (SeldaResult a) -> IO (SeldaResult a) forall a b. (a -> b) -> a -> b $ do IO () -> SeldaT SQLite IO () forall (m :: * -> *) a. Monad m => m a -> SeldaT SQLite m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (IO () -> SeldaT SQLite IO ()) -> IO () -> SeldaT SQLite IO () forall a b. (a -> b) -> a -> b $ m () -> IO () forall a. m a -> IO a runInIO (m () -> IO ()) -> m () -> IO () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "Starting SQLite transaction." a result <- SeldaT SQLite IO a -> SeldaT SQLite IO a forall (m :: * -> *) a. (MonadSelda m, MonadMask m) => m a -> m a transaction (SeldaT SQLite IO a -> SeldaT SQLite IO a) -> SeldaT SQLite IO a -> SeldaT SQLite IO a forall a b. (a -> b) -> a -> b $ SeldaTransactionT IO a -> SeldaT SQLite IO a forall (m :: * -> *) a. SeldaTransactionT m a -> SeldaT SQLite m a unSeldaTransactionT (SeldaTransactionT IO a -> SeldaT SQLite IO a) -> SeldaTransactionT IO a -> SeldaT SQLite IO a forall a b. (a -> b) -> a -> b $ (SeldaPoolT m a -> IO a) -> SeldaTransactionT (SeldaPoolT m) a -> SeldaTransactionT IO a forall (m :: * -> *) a (n :: * -> *) b. (m a -> n b) -> SeldaTransactionT m a -> SeldaTransactionT n b mapSeldaTransactionT (m a -> IO a forall a. m a -> IO a runInIO (m a -> IO a) -> (SeldaPoolT m a -> m a) -> SeldaPoolT m a -> IO a forall b c a. (b -> c) -> (a -> b) -> a -> c . SeldaPoolT m a -> m a forall x. SeldaPoolT m x -> m x runT (SeldaPoolT m a -> m a) -> (SeldaPoolT m a -> SeldaPoolT m a) -> SeldaPoolT m a -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . SeldaPoolT m a -> SeldaPoolT m a forall a. SeldaPoolT m a -> SeldaPoolT m a localSetAlreadyInTransaction) SeldaTransactionT (SeldaPoolT m) a tma IO () -> SeldaT SQLite IO () forall (m :: * -> *) a. Monad m => m a -> SeldaT SQLite m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (IO () -> SeldaT SQLite IO ()) -> IO () -> SeldaT SQLite IO () forall a b. (a -> b) -> a -> b $ m () -> IO () forall a. m a -> IO a runInIO (m () -> IO ()) -> m () -> IO () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo Text "Committed SQLite transaction." SeldaResult a -> SeldaT SQLite IO (SeldaResult a) forall a. a -> SeldaT SQLite IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (SeldaResult a -> SeldaT SQLite IO (SeldaResult a)) -> SeldaResult a -> SeldaT SQLite IO (SeldaResult a) forall a b. (a -> b) -> a -> b $ a -> SeldaResult a forall a. a -> SeldaResult a SeldaSuccess a result SeldaPoolT m (SeldaResult a) -> (SomeException -> SeldaPoolT m (SeldaResult a)) -> SeldaPoolT m (SeldaResult a) forall e a. (HasCallStack, Exception e) => SeldaPoolT m a -> (e -> SeldaPoolT m a) -> SeldaPoolT m a forall (m :: * -> *) e a. (MonadCatch m, HasCallStack, Exception e) => m a -> (e -> m a) -> m a catch SeldaPoolT m (SeldaResult a) transactionComputation ((SomeException -> SeldaPoolT m (SeldaResult a)) -> SeldaPoolT m (SeldaResult a)) -> (SomeException -> SeldaPoolT m (SeldaResult a)) -> SeldaPoolT m (SeldaResult a) forall a b. (a -> b) -> a -> b $ \case (SomeException err :: SomeException) -> do m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo (Text -> m ()) -> Text -> m () forall a b. (a -> b) -> a -> b $ Text "SQLite transaction failed and the database was rolled back: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text T.pack (SomeException -> String forall a. Show a => a -> String show SomeException err) SeldaResult a -> SeldaPoolT m (SeldaResult a) forall a. a -> SeldaPoolT m a forall (f :: * -> *) a. Applicative f => a -> f a pure (SeldaResult a -> SeldaPoolT m (SeldaResult a)) -> SeldaResult a -> SeldaPoolT m (SeldaResult a) forall a b. (a -> b) -> a -> b $ SomeException -> SeldaResult a forall a. SomeException -> SeldaResult a SeldaFailure SomeException err where localSetAlreadyInTransaction :: SeldaPoolT m a -> SeldaPoolT m a localSetAlreadyInTransaction :: forall a. SeldaPoolT m a -> SeldaPoolT m a localSetAlreadyInTransaction = ReaderT SeldaPoolContext m a -> SeldaPoolT m a forall (m :: * -> *) a. ReaderT SeldaPoolContext m a -> SeldaPoolT m a SeldaPoolT (ReaderT SeldaPoolContext m a -> SeldaPoolT m a) -> (SeldaPoolT m a -> ReaderT SeldaPoolContext m a) -> SeldaPoolT m a -> SeldaPoolT m a forall b c a. (b -> c) -> (a -> b) -> a -> c . (SeldaPoolContext -> SeldaPoolContext) -> ReaderT SeldaPoolContext m a -> ReaderT SeldaPoolContext m a forall r (m :: * -> *) a. (r -> r) -> ReaderT r m a -> ReaderT r m a local (\SeldaPoolContext context -> SeldaPoolContext context {seldaAlreadyInTransaction = True}) (ReaderT SeldaPoolContext m a -> ReaderT SeldaPoolContext m a) -> (SeldaPoolT m a -> ReaderT SeldaPoolContext m a) -> SeldaPoolT m a -> ReaderT SeldaPoolContext m a forall b c a. (b -> c) -> (a -> b) -> a -> c . SeldaPoolT m a -> ReaderT SeldaPoolContext m a forall (m :: * -> *) a. SeldaPoolT m a -> ReaderT SeldaPoolContext m a unSeldaPoolT deriving via SeldaPoolT ((t2 :: (Type -> Type) -> Type -> Type) m) instance (MonadLogger (t2 m), MonadMask (t2 m), MonadUnliftIO (t2 m), MonadIO (ComposeT SeldaPoolT t2 m)) => MonadSeldaPool (ComposeT SeldaPoolT t2 m) runSeldaPoolT :: (MonadConfigured m, MonadLogger m, MonadMask m, MonadUnliftIO m) => SeldaPoolT m a -> m a runSeldaPoolT :: forall (m :: * -> *) a. (MonadConfigured m, MonadLogger m, MonadMask m, MonadUnliftIO m) => SeldaPoolT m a -> m a runSeldaPoolT SeldaPoolT m a tma = do Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "Initializing SQLite connection pool for Selda." SQLiteConfig config <- Configuration -> SQLiteConfig configSqlite (Configuration -> SQLiteConfig) -> m Configuration -> m SQLiteConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m Configuration forall (m :: * -> *). MonadConfigured m => m Configuration configuration Pool (SeldaConnection SQLite) pool <- ((forall a. m a -> IO a) -> IO (Pool (SeldaConnection SQLite))) -> m (Pool (SeldaConnection SQLite)) forall b. ((forall a. m a -> IO a) -> IO b) -> m b forall (m :: * -> *) b. MonadUnliftIO m => ((forall a. m a -> IO a) -> IO b) -> m b withRunInIO (((forall a. m a -> IO a) -> IO (Pool (SeldaConnection SQLite))) -> m (Pool (SeldaConnection SQLite))) -> ((forall a. m a -> IO a) -> IO (Pool (SeldaConnection SQLite))) -> m (Pool (SeldaConnection SQLite)) forall a b. (a -> b) -> a -> b $ \forall a. m a -> IO a runInIO -> do let openConnection :: IO (SeldaConnection SQLite) openConnection :: IO (SeldaConnection SQLite) openConnection = m (SeldaConnection SQLite) -> IO (SeldaConnection SQLite) forall a. m a -> IO a runInIO (m (SeldaConnection SQLite) -> IO (SeldaConnection SQLite)) -> m (SeldaConnection SQLite) -> IO (SeldaConnection SQLite) forall a b. (a -> b) -> a -> b $ do Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "Opening SQLite connection." SeldaConnection SQLite connection <- IO (SeldaConnection SQLite) -> m (SeldaConnection SQLite) forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (SeldaConnection SQLite) -> m (SeldaConnection SQLite)) -> IO (SeldaConnection SQLite) -> m (SeldaConnection SQLite) forall a b. (a -> b) -> a -> b $ String -> IO (SeldaConnection SQLite) forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m (SeldaConnection SQLite) sqliteOpen (String -> IO (SeldaConnection SQLite)) -> String -> IO (SeldaConnection SQLite) forall a b. (a -> b) -> a -> b $ SQLiteConfig -> String sqliteFilepath SQLiteConfig config Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo Text "Opened SQLite connection successfully." SeldaConnection SQLite -> m (SeldaConnection SQLite) forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure SeldaConnection SQLite connection closeConnection :: SeldaConnection SQLite -> IO () closeConnection :: SeldaConnection SQLite -> IO () closeConnection SeldaConnection SQLite connection = m () -> IO () forall a. m a -> IO a runInIO (m () -> IO ()) -> m () -> IO () forall a b. (a -> b) -> a -> b $ do Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "Closing SQLite connection." IO () -> m () forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ SeldaConnection SQLite -> IO () forall (m :: * -> *) b. MonadIO m => SeldaConnection b -> m () seldaClose SeldaConnection SQLite connection Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo Text "Closed SQLite connection successfully." poolConfig :: PoolConfig (SeldaConnection SQLite) poolConfig = IO (SeldaConnection SQLite) -> (SeldaConnection SQLite -> IO ()) -> Double -> Int -> PoolConfig (SeldaConnection SQLite) forall a. IO a -> (a -> IO ()) -> Double -> Int -> PoolConfig a P.defaultPoolConfig IO (SeldaConnection SQLite) openConnection SeldaConnection SQLite -> IO () closeConnection (SQLiteConfig -> Double sqliteConnectionPoolTimeoutSeconds SQLiteConfig config) (SQLiteConfig -> Int sqliteConnectionPoolMaxNumberOfConnections SQLiteConfig config) PoolConfig (SeldaConnection SQLite) -> IO (Pool (SeldaConnection SQLite)) forall a. PoolConfig a -> IO (Pool a) P.newPool PoolConfig (SeldaConnection SQLite) poolConfig Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo Text "Initialized SQLite connection pool for Selda successfully." let context :: SeldaPoolContext context = MkSeldaPoolContext { seldaConnectionPool :: Pool (SeldaConnection SQLite) seldaConnectionPool = Pool (SeldaConnection SQLite) pool , seldaAlreadyInTransaction :: Bool seldaAlreadyInTransaction = Bool False } (ReaderT SeldaPoolContext m a -> SeldaPoolContext -> m a forall r (m :: * -> *) a. ReaderT r m a -> r -> m a `runReaderT` SeldaPoolContext context) (ReaderT SeldaPoolContext m a -> m a) -> ReaderT SeldaPoolContext m a -> m a forall a b. (a -> b) -> a -> b $ SeldaPoolT m a -> ReaderT SeldaPoolContext m a forall (m :: * -> *) a. SeldaPoolT m a -> ReaderT SeldaPoolContext m a unSeldaPoolT (SeldaPoolT m a -> ReaderT SeldaPoolContext m a) -> SeldaPoolT m a -> ReaderT SeldaPoolContext m a forall a b. (a -> b) -> a -> b $ do m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "Checking SQLite file." Bool sqliteExists <- IO Bool -> SeldaPoolT m Bool forall a. IO a -> SeldaPoolT m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO Bool -> SeldaPoolT m Bool) -> IO Bool -> SeldaPoolT m Bool forall a b. (a -> b) -> a -> b $ String -> IO Bool fileExist (String -> IO Bool) -> String -> IO Bool forall a b. (a -> b) -> a -> b $ SQLiteConfig -> String sqliteFilepath SQLiteConfig config if Bool sqliteExists then m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "SQLite file exists." else do m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "SQLite file doesn't exist." m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo Text "Creating new SQLite database file." ComposeT SeldaPoolT TransparentT m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => ComposeT SeldaPoolT TransparentT m a -> SeldaPoolT m a runComposableSeldaPoolT ComposeT SeldaPoolT TransparentT m () forall (m :: * -> *). (MonadSeldaPool m, MonadLogger m) => m () createDatabase m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => m a -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> SeldaPoolT m ()) -> m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logDebug Text "Updating database by migrating to the expected schema." ComposeT SeldaPoolT TransparentT m () -> SeldaPoolT m () forall (m :: * -> *) a. Monad m => ComposeT SeldaPoolT TransparentT m a -> SeldaPoolT m a runComposableSeldaPoolT (ComposeT SeldaPoolT TransparentT m () -> SeldaPoolT m ()) -> ComposeT SeldaPoolT TransparentT m () -> SeldaPoolT m () forall a b. (a -> b) -> a -> b $ SeldaTransactionT (ComposeT SeldaPoolT TransparentT m) () -> ComposeT SeldaPoolT TransparentT m (SeldaResult ()) forall a. SeldaTransactionT (ComposeT SeldaPoolT TransparentT m) a -> ComposeT SeldaPoolT TransparentT m (SeldaResult a) forall (m :: * -> *) a. MonadSeldaPool m => SeldaTransactionT m a -> m (SeldaResult a) runSeldaTransactionT SeldaTransactionT (ComposeT SeldaPoolT TransparentT m) () forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadSeldaPool m) => SeldaTransactionT m () migrateDatabase ComposeT SeldaPoolT TransparentT m (SeldaResult ()) -> (SeldaResult () -> ComposeT SeldaPoolT TransparentT m ()) -> ComposeT SeldaPoolT TransparentT m () forall a b. ComposeT SeldaPoolT TransparentT m a -> (a -> ComposeT SeldaPoolT TransparentT m b) -> ComposeT SeldaPoolT TransparentT m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case SeldaFailure SomeException err -> do Text -> ComposeT SeldaPoolT TransparentT m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logError (Text -> ComposeT SeldaPoolT TransparentT m ()) -> Text -> ComposeT SeldaPoolT TransparentT m () forall a b. (a -> b) -> a -> b $ Text "Failed database migration: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text T.pack (SomeException -> String forall a. Show a => a -> String show SomeException err) String -> ComposeT SeldaPoolT TransparentT m () forall a. HasCallStack => String -> a error String "Outdated database." SeldaSuccess () -> do Text -> ComposeT SeldaPoolT TransparentT m () forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m () logInfo Text "Database migration was successful." SeldaPoolT m a tma where runComposableSeldaPoolT :: Monad m => ComposeT SeldaPoolT TransparentT m a -> SeldaPoolT m a runComposableSeldaPoolT :: forall (m :: * -> *) a. Monad m => ComposeT SeldaPoolT TransparentT m a -> SeldaPoolT m a runComposableSeldaPoolT ComposeT SeldaPoolT TransparentT m a ctma = ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a forall (m :: * -> *) a. Monad m => ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTransControlIdentity t, Monad m) => ((forall x. t m x -> m x) -> m a) -> t m a liftWithIdentity (((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a) -> ((forall x. SeldaPoolT m x -> m x) -> m a) -> SeldaPoolT m a forall a b. (a -> b) -> a -> b $ \forall x. SeldaPoolT m x -> m x runT -> TransparentT m a -> m a forall (m :: * -> *) a. TransparentT m a -> m a runTransparentT (TransparentT m a -> m a) -> (SeldaPoolT (Elevator NoT m) a -> TransparentT m a) -> SeldaPoolT (Elevator NoT m) a -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . m a -> TransparentT m a forall (m :: * -> *) a. Monad m => m a -> Elevator NoT m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m a -> TransparentT m a) -> (SeldaPoolT (Elevator NoT m) a -> m a) -> SeldaPoolT (Elevator NoT m) a -> TransparentT m a forall b c a. (b -> c) -> (a -> b) -> a -> c . SeldaPoolT m a -> m a forall x. SeldaPoolT m x -> m x runT (SeldaPoolT m a -> m a) -> (SeldaPoolT (Elevator NoT m) a -> SeldaPoolT m a) -> SeldaPoolT (Elevator NoT m) a -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . (TransparentT m a -> m a) -> SeldaPoolT (Elevator NoT m) a -> SeldaPoolT m a forall (m :: * -> *) a (n :: * -> *) b. (m a -> n b) -> SeldaPoolT m a -> SeldaPoolT n b mapSeldaPoolT TransparentT m a -> m a forall (m :: * -> *) a. TransparentT m a -> m a runTransparentT (SeldaPoolT (Elevator NoT m) a -> m a) -> SeldaPoolT (Elevator NoT m) a -> m a forall a b. (a -> b) -> a -> b $ ComposeT SeldaPoolT TransparentT m a -> SeldaPoolT (Elevator NoT m) a forall (t1 :: (* -> *) -> * -> *) (t2 :: (* -> *) -> * -> *) (m :: * -> *) a. ComposeT t1 t2 m a -> t1 (t2 m) a deComposeT ComposeT SeldaPoolT TransparentT m a ctma where mapSeldaPoolT :: (m a -> n b) -> SeldaPoolT m a -> SeldaPoolT n b mapSeldaPoolT :: forall (m :: * -> *) a (n :: * -> *) b. (m a -> n b) -> SeldaPoolT m a -> SeldaPoolT n b mapSeldaPoolT m a -> n b f = ReaderT SeldaPoolContext n b -> SeldaPoolT n b forall (m :: * -> *) a. ReaderT SeldaPoolContext m a -> SeldaPoolT m a SeldaPoolT (ReaderT SeldaPoolContext n b -> SeldaPoolT n b) -> (SeldaPoolT m a -> ReaderT SeldaPoolContext n b) -> SeldaPoolT m a -> SeldaPoolT n b forall b c a. (b -> c) -> (a -> b) -> a -> c . (m a -> n b) -> ReaderT SeldaPoolContext m a -> ReaderT SeldaPoolContext n b forall (m :: * -> *) a (n :: * -> *) b r. (m a -> n b) -> ReaderT r m a -> ReaderT r n b mapReaderT m a -> n b f (ReaderT SeldaPoolContext m a -> ReaderT SeldaPoolContext n b) -> (SeldaPoolT m a -> ReaderT SeldaPoolContext m a) -> SeldaPoolT m a -> ReaderT SeldaPoolContext n b forall b c a. (b -> c) -> (a -> b) -> a -> c . SeldaPoolT m a -> ReaderT SeldaPoolContext m a forall (m :: * -> *) a. SeldaPoolT m a -> ReaderT SeldaPoolContext m a unSeldaPoolT type SeldaPoolContext :: Type data SeldaPoolContext = MkSeldaPoolContext { SeldaPoolContext -> Pool (SeldaConnection SQLite) seldaConnectionPool :: P.Pool (SeldaConnection SQLite) , SeldaPoolContext -> Bool seldaAlreadyInTransaction :: Bool }