{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Database.Selda.Backend.Internal
( StmtID, BackendID (..)
, QueryRunner, SeldaBackend (..), SeldaConnection (..), SeldaStmt (..)
, MonadSelda (..), SeldaT (..), SeldaM
, SeldaError (..)
, Param (..), Lit (..), ColAttr (..)
, SqlType (..), SqlValue (..), SqlTypeRep (..)
, PPConfig (..), defPPConfig
, sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat
, freshStmtId
, invalidate
, newConnection, allStmts
, runSeldaT, seldaBackend
) where
import Database.Selda.Caching (invalidate)
import Database.Selda.SQL (Param (..))
import Database.Selda.SqlType
import Database.Selda.Table (Table, ColAttr (..), tableName)
import Database.Selda.SQL.Print.Config
import Database.Selda.Types (TableName)
import Control.Concurrent
import Control.Exception (throw)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.State
import Data.Dynamic
import Data.Hashable
import qualified Data.HashMap.Strict as M
import Data.IORef
import Data.Text (Text)
import System.IO.Unsafe (unsafePerformIO)
data BackendID = SQLite | PostgreSQL | Other Text
deriving (Show, Eq, Ord)
data SeldaError
= DbError String
| SqlError String
deriving (Show, Eq, Typeable)
instance Exception SeldaError
newtype StmtID = StmtID Int
deriving (Show, Eq, Ord, Hashable)
newtype ConnID = ConnID Int
deriving (Show, Eq, Ord)
{-# NOINLINE nextStmtId #-}
nextStmtId :: IORef Int
nextStmtId = unsafePerformIO $ newIORef 1
freshStmtId :: MonadIO m => m StmtID
freshStmtId = liftIO $ atomicModifyIORef' nextStmtId $ \n -> (n+1, StmtID n)
type QueryRunner a = Text -> [Param] -> IO a
data SeldaStmt = SeldaStmt
{
stmtHandle :: !Dynamic
, stmtText :: !Text
, stmtParams :: ![Either Int Param]
, stmtTables :: ![TableName]
}
data SeldaConnection = SeldaConnection
{
connBackend :: !SeldaBackend
, connDbId :: Text
, connStmts :: !(IORef (M.HashMap StmtID SeldaStmt))
, connClosed :: !(IORef Bool)
, connLock :: !(MVar ())
}
newConnection :: MonadIO m => SeldaBackend -> Text -> m SeldaConnection
newConnection back dbid =
liftIO $ SeldaConnection back dbid <$> newIORef M.empty
<*> newIORef False
<*> newMVar ()
allStmts :: SeldaConnection -> IO [(StmtID, Dynamic)]
allStmts =
fmap (map (\(k, v) -> (k, stmtHandle v)) . M.toList) . readIORef . connStmts
data SeldaBackend = SeldaBackend
{
runStmt :: Text -> [Param] -> IO (Int, [[SqlValue]])
, runStmtWithPK :: Text -> [Param] -> IO Int
, prepareStmt :: StmtID -> [SqlTypeRep] -> Text -> IO Dynamic
, runPrepared :: Dynamic -> [Param] -> IO (Int, [[SqlValue]])
, ppConfig :: PPConfig
, closeConnection :: SeldaConnection -> IO ()
, backendId :: BackendID
}
data SeldaState = SeldaState
{
stConnection :: !SeldaConnection
, stTouchedTables :: !(Maybe [TableName])
}
class MonadIO m => MonadSelda m where
seldaConnection :: m SeldaConnection
invalidateTable :: Table a -> m ()
wrapTransaction :: m ()
-> m ()
-> m a
-> m a
seldaBackend :: MonadSelda m => m SeldaBackend
seldaBackend = connBackend <$> seldaConnection
newtype SeldaT m a = S {unS :: StateT SeldaState m a}
deriving ( Functor, Applicative, Monad, MonadIO
, MonadThrow, MonadCatch, MonadMask, MonadTrans
)
instance (MonadIO m, MonadMask m) => MonadSelda (SeldaT m) where
seldaConnection = S $ fmap stConnection get
invalidateTable tbl = S $ do
st <- get
case stTouchedTables st of
Nothing -> liftIO $ invalidate [tableName tbl]
Just ts -> put $ st {stTouchedTables = Just (tableName tbl : ts)}
wrapTransaction commit rollback m = mask $ \restore -> do
S $ modify' $ \st ->
case stTouchedTables st of
Nothing -> st {stTouchedTables = Just []}
Just _ -> throw $ SqlError "attempted to nest transactions"
x <- restore m `onException` rollback
commit
st <- S get
maybe (return ()) (liftIO . invalidate) (stTouchedTables st)
S $ put $ st {stTouchedTables = Nothing}
return x
type SeldaM = SeldaT IO
runSeldaT :: (MonadIO m, MonadMask m) => SeldaT m a -> SeldaConnection -> m a
runSeldaT m c =
bracket (liftIO $ takeMVar (connLock c))
(const $ liftIO $ putMVar (connLock c) ())
(const go)
where
go = do
closed <- liftIO $ readIORef (connClosed c)
when closed $ do
liftIO $ throwM $ DbError "runSeldaT called with a closed connection"
fst <$> runStateT (unS m) (SeldaState c Nothing)