diff --git a/Example.hs b/Example.hs index 2e2d5dc..9c8aeff 100644 --- a/Example.hs +++ b/Example.hs @@ -36,5 +36,20 @@ main = artistID userID +main = + do + H.withPool $ \pool -> do + H.txIO pool (H.NoACID) $ do + H.noResultTx $ + [H.q| INSERT INTO users (name, birth_date, gender) VALUES (?, ?, ?) |] + "Nikita Volkov" + "1358-10-12" + (H.Enum Male) + + H.txIO pool (H.Write H.Serialized) $ do + artistID <- + H.streamWithCursorTx $ + [H.q| SELECT id FROM artists WHERE name = ? |] + ("Metallica") diff --git a/high-sql.cabal b/high-sql.cabal index 3b47f03..89991f1 100644 --- a/high-sql.cabal +++ b/high-sql.cabal @@ -41,6 +41,7 @@ library HighSQL.Prelude HighSQL.QQ.Parser HighSQL.RowParser + HighSQL.Transaction HighSQL.API exposed-modules: HighSQL.Backend diff --git a/library/HighSQL/Backend.hs b/library/HighSQL/Backend.hs index 83bcef7..f40fdbe 100644 --- a/library/HighSQL/Backend.hs +++ b/library/HighSQL/Backend.hs @@ -2,11 +2,11 @@ -- An open API for implementation of specific backend drivers. module HighSQL.Backend where -import HighSQL.Prelude +import HighSQL.Prelude hiding (Error) import qualified Language.Haskell.TH as TH -data BackendError = +data Error = -- -- | -- -- The transaction failed and should be retried. -- TransactionConflict | @@ -15,7 +15,7 @@ data BackendError = ConnectionLost Text deriving (Show, Typeable) -instance Exception BackendError +instance Exception Error -- | diff --git a/library/HighSQL/Transaction.hs b/library/HighSQL/Transaction.hs new file mode 100644 index 0000000..4075c5b --- /dev/null +++ b/library/HighSQL/Transaction.hs @@ -0,0 +1,189 @@ +module HighSQL.Transaction where + +import HighSQL.Prelude hiding (Read, Write, Error) +import qualified HighSQL.Backend as Backend +import qualified HighSQL.RowParser as RowParser +import qualified ListT + + +-- | +-- A transaction with a level @l@, +-- running on an anonymous state-thread @s@ +-- and gaining a result @r@. +newtype Transaction b l s r = + Transaction (ReaderT (Backend.Connection b) IO r) + deriving (Functor, Applicative, Monad) + + +class Level l where + run :: Backend b => Backend.Connection b -> l -> (forall s. Transaction b l s r) -> IO r + +instance Level NoLocking where + run c NoLocking (Transaction r) = + handle backendHandler $ runReaderT r c + +instance Level Read where + run c (Read isolation) (Transaction r) = + handle backendHandler $ Backend.inTransaction (isolation, False) (runReaderT r c) c + +instance Level Write where + run c (Write isolation) (Transaction r) = + handle backendHandler $ Backend.inTransaction (isolation, True) (runReaderT r c) c + + +backendHandler :: Backend.Error -> IO a +backendHandler = + \case + Backend.ConnectionLost t -> throwIO $ ConnectionLost t + + +-- * Locking Levels +------------------------- + +-- | +-- A level requiring no locking by the transaction +-- and hence providing no ACID guarantees. +-- Essentially this means that there will be no +-- traditional transaction established on the backend. +data NoLocking = + NoLocking + +-- | +-- A level requiring minimal locking from the database, +-- however it only allows to execute the \"SELECT\" statements. +data Read = + Read (Backend.IsolationLevel) + +-- | +-- A level, which allows to perform any kind of statements, +-- including \"SELECT\", \"UPDATE\", \"INSERT\", \"DELETE\", +-- \"CREATE\", \"DROP\" and \"ALTER\". +-- +-- However, compared to 'Read', +-- it requires the database to choose +-- a more resource-demanding locking strategy. +data Write = + Write (Backend.IsolationLevel) + + +-- * Privileges +------------------------- + +class CursorsPrivilege l + +instance CursorsPrivilege Read +instance CursorsPrivilege Write + +class ModificationPrivilege l + +instance ModificationPrivilege Write +instance ModificationPrivilege NoLocking + + +-- * Results Stream +------------------------- + +type ResultsStream b l s r = + TransactionListT s (Transaction b l s) r + +-- | +-- A select of results, +-- which fetches only those that you reach. +-- +-- It is implemented as a wrapper around 'ListT.ListT', +-- hence all the utility functions of the list transformer API +-- are applicable to this type. +-- +-- It uses the same trick as 'ST' to become impossible to be +-- executed outside of its transaction. +-- Hence you can only access it while remaining in a transaction, +-- and, when the transaction finishes, +-- all the acquired resources get automatically released. +newtype TransactionListT s m r = + TransactionListT (ListT.ListT m r) + deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus, + Monoid, ListT.ListMonad) + +instance ListT.ListTrans (TransactionListT s) where + uncons = + unsafeCoerce + (ListT.uncons :: ListT.ListT m r -> m (Maybe (r, ListT.ListT m r))) + + +-- * Error +------------------------- + +-- | +-- The only exception type that this API can raise. +data Error = + -- | + -- Cannot connect to a server + -- or the connection got interrupted. + ConnectionLost Text | + -- | + -- Attempt to parse a statement execution result into an incompatible type. + -- Indicates either a mismatching schema or an incorrect query. + ResultParsingError ByteString TypeRep + deriving (Show, Typeable) + +instance Exception Error + + +-- * Transactions +------------------------- + +type Backend = + Backend.Backend + +type RowParser = + RowParser.RowParser + +-- | +-- Execute a modification statement producing no result. +modify :: + Backend b => ModificationPrivilege l => + Backend.Statement b -> Transaction b l s () +modify s = + Transaction $ ReaderT $ Backend.execute s + +-- | +-- Execute a statement, which generates an auto-increment value. +modifyAndGenerate :: + Backend b => Backend.Mapping b Integer => ModificationPrivilege l => + Backend.Statement b -> Transaction b l s (Maybe Integer) +modifyAndGenerate s = + select s >>= ListT.head + +modifyAndCount :: + Backend b => Backend.Mapping b Integer => ModificationPrivilege l => + Backend.Statement b -> Transaction b l s Integer +modifyAndCount s = + Transaction $ ReaderT $ Backend.executeAndCountEffects s + +select :: + forall b l s r. + Backend b => RowParser b r => Typeable r => + Backend.Statement b -> Transaction b l s (ResultsStream b l s r) +select s = + Transaction $ ReaderT $ \c -> do + (w, s) <- Backend.executeAndStream s c + return $ TransactionListT $ hoist (Transaction . lift) $ do + row <- replicateM w s + maybe (lift $ throwIO parsingError) return $ RowParser.parse row + where + parsingError = + ResultParsingError (fst s) (typeOf (undefined :: r)) + +selectWithCursor :: + forall b l s r. + Backend b => RowParser b r => Typeable r => CursorsPrivilege l => + Backend.Statement b -> Transaction b l s (ResultsStream b l s r) +selectWithCursor s = + Transaction $ ReaderT $ \c -> do + (w, s) <- Backend.executeAndStreamWithCursor s c + return $ TransactionListT $ hoist (Transaction . lift) $ do + row <- replicateM w s + maybe (lift $ throwIO parsingError) return $ RowParser.parse row + where + parsingError = + ResultParsingError (fst s) (typeOf (undefined :: r))