1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE RankNTypes #-}
4module Database.Persist.Sql.Types.Internal
5    ( HasPersistBackend (..)
6    , IsPersistBackend (..)
7    , SqlReadBackend (..)
8    , SqlWriteBackend (..)
9    , readToUnknown
10    , readToWrite
11    , writeToUnknown
12    , LogFunc
13    , InsertSqlResult (..)
14    , Statement (..)
15    , IsolationLevel (..)
16    , makeIsolationLevelStatement
17    , SqlBackend (..)
18    , SqlBackendCanRead
19    , SqlBackendCanWrite
20    , SqlReadT
21    , SqlWriteT
22    , IsSqlBackend
23    ) where
24
25import Data.List.NonEmpty (NonEmpty(..))
26import Control.Monad.IO.Class (MonadIO (..))
27import Control.Monad.Logger (LogSource, LogLevel)
28import Control.Monad.Trans.Class (lift)
29import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
30import Data.Acquire (Acquire)
31import Data.Conduit (ConduitM)
32import Data.Int (Int64)
33import Data.IORef (IORef)
34import Data.Map (Map)
35import Data.Monoid ((<>))
36import Data.String (IsString)
37import Data.Text (Text)
38import Data.Typeable (Typeable)
39import Language.Haskell.TH.Syntax (Loc)
40import System.Log.FastLogger (LogStr)
41
42import Database.Persist.Class
43  ( HasPersistBackend (..)
44  , PersistQueryRead, PersistQueryWrite
45  , PersistStoreRead, PersistStoreWrite
46  , PersistUniqueRead, PersistUniqueWrite
47  , BackendCompatible(..)
48  )
49import Database.Persist.Class.PersistStore (IsPersistBackend (..))
50import Database.Persist.Types
51
52type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
53
54data InsertSqlResult = ISRSingle Text
55                     | ISRInsertGet Text Text
56                     | ISRManyKeys Text [PersistValue]
57
58data Statement = Statement
59    { stmtFinalize :: IO ()
60    , stmtReset :: IO ()
61    , stmtExecute :: [PersistValue] -> IO Int64
62    , stmtQuery :: forall m. MonadIO m
63                => [PersistValue]
64                -> Acquire (ConduitM () [PersistValue] m ())
65    }
66
67-- | Please refer to the documentation for the database in question for a full
68-- overview of the semantics of the varying isloation levels
69data IsolationLevel = ReadUncommitted
70                    | ReadCommitted
71                    | RepeatableRead
72                    | Serializable
73                    deriving (Show, Eq, Enum, Ord, Bounded)
74
75makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s
76makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of
77    ReadUncommitted -> "READ UNCOMMITTED"
78    ReadCommitted -> "READ COMMITTED"
79    RepeatableRead -> "REPEATABLE READ"
80    Serializable -> "SERIALIZABLE"
81
82data SqlBackend = SqlBackend
83    { connPrepare :: Text -> IO Statement
84    -- | table name, column names, id name, either 1 or 2 statements to run
85    , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
86    , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult)
87    -- ^ SQL for inserting many rows and returning their primary keys, for
88    -- backends that support this functioanlity. If 'Nothing', rows will be
89    -- inserted one-at-a-time using 'connInsertSql'.
90    , connUpsertSql :: Maybe (EntityDef -> NonEmpty UniqueDef -> Text -> Text)
91    -- ^ Some databases support performing UPSERT _and_ RETURN entity
92    -- in a single call.
93    --
94    -- This field when set will be used to generate the UPSERT+RETURN sql given
95    -- * an entity definition
96    -- * updates to be run on unique key(s) collision
97    --
98    -- When left as 'Nothing', we find the unique key from entity def before
99    -- * trying to fetch an entity by said key
100    -- * perform an update when result found, else issue an insert
101    -- * return new entity from db
102    --
103    -- @since 2.6
104    , connPutManySql :: Maybe (EntityDef -> Int -> Text)
105    -- ^ Some databases support performing bulk UPSERT, specifically
106    -- "insert or replace many records" in a single call.
107    --
108    -- This field when set, given
109    -- * an entity definition
110    -- * number of records to be inserted
111    -- should produce a PUT MANY sql with placeholders for records
112    --
113    -- When left as 'Nothing', we default to using 'defaultPutMany'.
114    --
115    -- @since 2.8.1
116    , connStmtMap :: IORef (Map Text Statement)
117    , connClose :: IO ()
118    , connMigrateSql
119        :: [EntityDef]
120        -> (Text -> IO Statement)
121        -> EntityDef
122        -> IO (Either [Text] [(Bool, Text)])
123    , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
124    , connCommit :: (Text -> IO Statement) -> IO ()
125    , connRollback :: (Text -> IO Statement) -> IO ()
126    , connEscapeName :: DBName -> Text
127    , connNoLimit :: Text
128    , connRDBMS :: Text
129    , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text
130    , connLogFunc :: LogFunc
131    , connMaxParams :: Maybe Int
132    -- ^ Some databases (probably only Sqlite) have a limit on how
133    -- many question-mark parameters may be used in a statement
134    --
135    -- @since 2.6.1
136    , connRepsertManySql :: Maybe (EntityDef -> Int -> Text)
137    -- ^ Some databases support performing bulk an atomic+bulk INSERT where
138    -- constraint conflicting entities can replace existing entities.
139    --
140    -- This field when set, given
141    -- * an entity definition
142    -- * number of records to be inserted
143    -- should produce a INSERT sql with placeholders for primary+record fields
144    --
145    -- When left as 'Nothing', we default to using 'defaultRepsertMany'.
146    --
147    -- @since 2.9.0
148    }
149    deriving Typeable
150instance HasPersistBackend SqlBackend where
151    type BaseBackend SqlBackend = SqlBackend
152    persistBackend = id
153instance IsPersistBackend SqlBackend where
154    mkPersistBackend = id
155
156-- | An SQL backend which can only handle read queries
157--
158-- The constructor was exposed in 2.10.0.
159newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } deriving Typeable
160instance HasPersistBackend SqlReadBackend where
161    type BaseBackend SqlReadBackend = SqlBackend
162    persistBackend = unSqlReadBackend
163instance IsPersistBackend SqlReadBackend where
164    mkPersistBackend = SqlReadBackend
165
166-- | An SQL backend which can handle read or write queries
167--
168-- The constructor was exposed in 2.10.0
169newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } deriving Typeable
170instance HasPersistBackend SqlWriteBackend where
171    type BaseBackend SqlWriteBackend = SqlBackend
172    persistBackend = unSqlWriteBackend
173instance IsPersistBackend SqlWriteBackend where
174    mkPersistBackend = SqlWriteBackend
175
176-- | Useful for running a write query against an untagged backend with unknown capabilities.
177writeToUnknown :: Monad m => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a
178writeToUnknown ma = do
179  unknown <- ask
180  lift . runReaderT ma $ SqlWriteBackend unknown
181
182-- | Useful for running a read query against a backend with read and write capabilities.
183readToWrite :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlWriteBackend m a
184readToWrite ma = do
185  write <- ask
186  lift . runReaderT ma . SqlReadBackend $ unSqlWriteBackend write
187
188-- | Useful for running a read query against a backend with unknown capabilities.
189readToUnknown :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlBackend m a
190readToUnknown ma = do
191  unknown <- ask
192  lift . runReaderT ma $ SqlReadBackend unknown
193
194-- | A constraint synonym which witnesses that a backend is SQL and can run read queries.
195type SqlBackendCanRead backend =
196  ( BackendCompatible SqlBackend backend
197  , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend
198  )
199-- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries.
200type SqlBackendCanWrite backend =
201  ( SqlBackendCanRead backend
202  , PersistQueryWrite backend, PersistStoreWrite backend, PersistUniqueWrite backend
203  )
204-- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read queries.
205type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backend m a
206-- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read and write queries.
207type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a
208-- | A backend which is a wrapper around @SqlBackend@.
209type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
210