module Database.Persist.Sql.Raw where

import Control.Exception (throwIO)
import Control.Monad (liftM, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (logDebugNS, runLoggingT)
import Control.Monad.Reader (MonadReader, ReaderT, ask)
import Control.Monad.Trans.Resource (MonadResource, release)
import Data.Acquire (Acquire, allocateAcquire, mkAcquire, with)
import Data.Conduit
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Int (Int64)
import Data.Text (Text, pack)
import qualified Data.Text as T

import Database.Persist
import Database.Persist.Sql.Class
import Database.Persist.Sql.Types
import Database.Persist.Sql.Types.Internal
import Database.Persist.SqlBackend.Internal.StatementCache

rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
         => Text
         -> [PersistValue]
         -> ConduitM () [PersistValue] m ()
rawQuery :: forall (m :: * -> *) env.
(MonadResource m, MonadReader env m,
 BackendCompatible SqlBackend env) =>
Text -> [PersistValue] -> ConduitM () [PersistValue] m ()
rawQuery Text
sql [PersistValue]
vals = do
    Acquire (ConduitM () [PersistValue] m ())
srcRes <- forall (m :: * -> *) backend b.
(MonadIO m, MonadReader backend m) =>
ReaderT backend IO b -> m b
liftPersist forall a b. (a -> b) -> a -> b
$ forall (m1 :: * -> *) (m2 :: * -> *) env.
(MonadIO m1, MonadIO m2, BackendCompatible SqlBackend env) =>
Text
-> [PersistValue]
-> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
rawQueryRes Text
sql [PersistValue]
vals
    (ReleaseKey
releaseKey, ConduitM () [PersistValue] m ()
src) <- forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire Acquire (ConduitM () [PersistValue] m ())
srcRes
    ConduitM () [PersistValue] m ()
src
    forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
releaseKey

rawQueryRes
    :: (MonadIO m1, MonadIO m2, BackendCompatible SqlBackend env)
    => Text
    -> [PersistValue]
    -> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
rawQueryRes :: forall (m1 :: * -> *) (m2 :: * -> *) env.
(MonadIO m1, MonadIO m2, BackendCompatible SqlBackend env) =>
Text
-> [PersistValue]
-> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
rawQueryRes Text
sql [PersistValue]
vals = do
    SqlBackend
conn <- forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
    let make :: IO Statement
make = do
            forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebugNS ([Char] -> Text
pack [Char]
"SQL") forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
sql forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"; " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
vals)
                (SqlBackend -> Loc -> Text -> LogLevel -> LogStr -> IO ()
connLogFunc SqlBackend
conn)
            SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
conn Text
sql
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        Statement
stmt <- forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO Statement
make Statement -> IO ()
stmtReset
        Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt [PersistValue]
vals

-- | Execute a raw SQL statement
rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend)
           => Text            -- ^ SQL statement, possibly with placeholders.
           -> [PersistValue]  -- ^ Values to fill the placeholders.
           -> ReaderT backend m ()
rawExecute :: forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
x [PersistValue]
y = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m Int64
rawExecuteCount Text
x [PersistValue]
y

-- | Execute a raw SQL statement and return the number of
-- rows it has modified.
rawExecuteCount :: (MonadIO m, BackendCompatible SqlBackend backend)
                => Text            -- ^ SQL statement, possibly with placeholders.
                -> [PersistValue]  -- ^ Values to fill the placeholders.
                -> ReaderT backend m Int64
rawExecuteCount :: forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m Int64
rawExecuteCount Text
sql [PersistValue]
vals = do
    SqlBackend
conn <- forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebugNS ([Char] -> Text
pack [Char]
"SQL") forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
sql forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"; " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
vals)
        (SqlBackend -> Loc -> Text -> LogLevel -> LogStr -> IO ()
connLogFunc SqlBackend
conn)
    Statement
stmt <- forall (m :: * -> *) backend.
(MonadIO m, MonadReader backend m,
 BackendCompatible SqlBackend backend) =>
Text -> m Statement
getStmt Text
sql
    Int64
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt [PersistValue]
vals
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Statement -> IO ()
stmtReset Statement
stmt
    forall (m :: * -> *) a. Monad m => a -> m a
return Int64
res

getStmt
  :: (MonadIO m, MonadReader backend m, BackendCompatible SqlBackend backend)
  => Text -> m Statement
getStmt :: forall (m :: * -> *) backend.
(MonadIO m, MonadReader backend m,
 BackendCompatible SqlBackend backend) =>
Text -> m Statement
getStmt Text
sql = do
    SqlBackend
conn <- forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
conn Text
sql

getStmtConn :: SqlBackend -> Text -> IO Statement
getStmtConn :: SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
conn Text
sql = do
    let cacheK :: StatementCacheKey
cacheK = Text -> StatementCacheKey
mkCacheKeyFromQuery Text
sql
    Maybe Statement
mstmt <- StatementCache -> StatementCacheKey -> IO (Maybe Statement)
statementCacheLookup (SqlBackend -> StatementCache
connStmtMap SqlBackend
conn) StatementCacheKey
cacheK
    Statement
stmt <- case Maybe Statement
mstmt of
        Just Statement
stmt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Statement
stmt
        Maybe Statement
Nothing -> do
            Statement
stmt' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SqlBackend -> Text -> IO Statement
connPrepare SqlBackend
conn Text
sql
            IORef Bool
iactive <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Bool
True
            let stmt :: Statement
stmt = Statement
                    { stmtFinalize :: IO ()
stmtFinalize = do
                        Bool
active <- forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
active forall a b. (a -> b) -> a -> b
$ do Statement -> IO ()
stmtFinalize Statement
stmt'
                                         forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
iactive Bool
False
                    , stmtReset :: IO ()
stmtReset = do
                        Bool
active <- forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
active forall a b. (a -> b) -> a -> b
$ Statement -> IO ()
stmtReset Statement
stmt'
                    , stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = \[PersistValue]
x -> do
                        Bool
active <- forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        if Bool
active
                            then Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt' [PersistValue]
x
                            else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PersistentSqlException
StatementAlreadyFinalized Text
sql
                    , stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = \[PersistValue]
x -> do
                        Bool
active <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        if Bool
active
                            then Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt' [PersistValue]
x
                            else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PersistentSqlException
StatementAlreadyFinalized Text
sql
                    }

            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ StatementCache -> StatementCacheKey -> Statement -> IO ()
statementCacheInsert (SqlBackend -> StatementCache
connStmtMap SqlBackend
conn) StatementCacheKey
cacheK Statement
stmt
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Statement
stmt
    (SqlBackendHooks -> SqlBackend -> Text -> Statement -> IO Statement
hookGetStatement forall a b. (a -> b) -> a -> b
$ SqlBackend -> SqlBackendHooks
connHooks SqlBackend
conn) SqlBackend
conn Text
sql Statement
stmt

-- | Execute a raw SQL statement and return its results as a
-- list. If you do not expect a return value, use of
-- `rawExecute` is recommended.
--
-- If you're using 'Entity'@s@ (which is quite likely), then you
-- /must/ use entity selection placeholders (double question
-- mark, @??@).  These @??@ placeholders are then replaced for
-- the names of the columns that we need for your entities.
-- You'll receive an error if you don't use the placeholders.
-- Please see the 'Entity'@s@ documentation for more details.
--
-- You may put value placeholders (question marks, @?@) in your
-- SQL query.  These placeholders are then replaced by the values
-- you pass on the second parameter, already correctly escaped.
-- You may want to use 'toPersistValue' to help you constructing
-- the placeholder values.
--
-- Since you're giving a raw SQL statement, you don't get any
-- guarantees regarding safety.  If 'rawSql' is not able to parse
-- the results of your query back, then an exception is raised.
-- However, most common problems are mitigated by using the
-- entity selection placeholder @??@, and you shouldn't see any
-- error at all if you're not using 'Single'.
--
-- Some example of 'rawSql' based on this schema:
--
-- @
-- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- Person
--     name String
--     age Int Maybe
--     deriving Show
-- BlogPost
--     title String
--     authorId PersonId
--     deriving Show
-- |]
-- @
--
-- Examples based on the above schema:
--
-- @
-- getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person]
-- getPerson = rawSql "select ?? from person where name=?" [PersistText "john"]
--
-- getAge :: MonadIO m => ReaderT SqlBackend m [Single Int]
-- getAge = rawSql "select person.age from person where name=?" [PersistText "john"]
--
-- getAgeName :: MonadIO m => ReaderT SqlBackend m [(Single Int, Single Text)]
-- getAgeName = rawSql "select person.age, person.name from person where name=?" [PersistText "john"]
--
-- getPersonBlog :: MonadIO m => ReaderT SqlBackend m [(Entity Person, Entity BlogPost)]
-- getPersonBlog = rawSql "select ??,?? from person,blog_post where person.id = blog_post.author_id" []
-- @
--
-- Minimal working program for PostgreSQL backend based on the above concepts:
--
-- > {-# LANGUAGE EmptyDataDecls             #-}
-- > {-# LANGUAGE FlexibleContexts           #-}
-- > {-# LANGUAGE GADTs                      #-}
-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- > {-# LANGUAGE MultiParamTypeClasses      #-}
-- > {-# LANGUAGE OverloadedStrings          #-}
-- > {-# LANGUAGE QuasiQuotes                #-}
-- > {-# LANGUAGE TemplateHaskell            #-}
-- > {-# LANGUAGE TypeFamilies               #-}
-- >
-- > import           Control.Monad.IO.Class  (liftIO)
-- > import           Control.Monad.Logger    (runStderrLoggingT)
-- > import           Database.Persist
-- > import           Control.Monad.Reader
-- > import           Data.Text
-- > import           Database.Persist.Sql
-- > import           Database.Persist.Postgresql
-- > import           Database.Persist.TH
-- >
-- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- > Person
-- >     name String
-- >     age Int Maybe
-- >     deriving Show
-- > |]
-- >
-- > conn = "host=localhost dbname=new_db user=postgres password=postgres port=5432"
-- >
-- > getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person]
-- > getPerson = rawSql "select ?? from person where name=?" [PersistText "sibi"]
-- >
-- > liftSqlPersistMPool y x = liftIO (runSqlPersistMPool y x)
-- >
-- > main :: IO ()
-- > main = runStderrLoggingT $ withPostgresqlPool conn 10 $ liftSqlPersistMPool $ do
-- >          runMigration migrateAll
-- >          xs <- getPerson
-- >          liftIO (print xs)
-- >

rawSql :: (RawSql a, MonadIO m, BackendCompatible SqlBackend backend)
       => Text             -- ^ SQL statement, possibly with placeholders.
       -> [PersistValue]   -- ^ Values to fill the placeholders.
       -> ReaderT backend m [a]
rawSql :: forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
stmt = [PersistValue] -> ReaderT backend m [a]
run
    where
      getType :: (x -> m [a]) -> a
      getType :: forall x (m :: * -> *) a. (x -> m [a]) -> a
getType = forall a. HasCallStack => [Char] -> a
error [Char]
"rawSql.getType"

      x :: a
x = forall x (m :: * -> *) a. (x -> m [a]) -> a
getType [PersistValue] -> ReaderT backend m [a]
run
      process :: [PersistValue] -> Either Text a
process = forall a. RawSql a => [PersistValue] -> Either Text a
rawSqlProcessRow

      withStmt' :: [Text]
-> [PersistValue]
-> ConduitT [PersistValue] Void IO [a]
-> ReaderT backend m [a]
withStmt' [Text]
colSubsts [PersistValue]
params ConduitT [PersistValue] Void IO [a]
sink = do
            Acquire (ConduitM () [PersistValue] IO ())
srcRes <- forall (m1 :: * -> *) (m2 :: * -> *) env.
(MonadIO m1, MonadIO m2, BackendCompatible SqlBackend env) =>
Text
-> [PersistValue]
-> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
rawQueryRes Text
sql [PersistValue]
params
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with Acquire (ConduitM () [PersistValue] IO ())
srcRes (\ConduitM () [PersistValue] IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT [PersistValue] Void IO [a]
sink)
          where
            sql :: Text
sql = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [Text]
makeSubsts [Text]
colSubsts forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
placeholder Text
stmt
            placeholder :: Text
placeholder = Text
"??"
            makeSubsts :: [Text] -> [Text] -> [Text]
makeSubsts (Text
s:[Text]
ss) (Text
t:[Text]
ts) = Text
t forall a. a -> [a] -> [a]
: Text
s forall a. a -> [a] -> [a]
: [Text] -> [Text] -> [Text]
makeSubsts [Text]
ss [Text]
ts
            makeSubsts []     []     = []
            makeSubsts []     [Text]
ts     = [Text -> [Text] -> Text
T.intercalate Text
placeholder [Text]
ts]
            makeSubsts [Text]
ss     []     = forall a. HasCallStack => [Char] -> a
error (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
err)
                where
                  err :: [[Char]]
err = [ [Char]
"rawsql: there are still ", forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ss)
                        , [Char]
"'??' placeholder substitutions to be made "
                        , [Char]
"but all '??' placeholders have already been "
                        , [Char]
"consumed.  Please read 'rawSql's documentation "
                        , [Char]
"on how '??' placeholders work."
                        ]

      run :: [PersistValue] -> ReaderT backend m [a]
run [PersistValue]
params = do
        SqlBackend
conn <- forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
        let (Int
colCount, [Text]
colSubsts) = forall a. RawSql a => (Text -> Text) -> a -> (Int, [Text])
rawSqlCols (SqlBackend -> Text -> Text
connEscapeRawName SqlBackend
conn) a
x
        [Text]
-> [PersistValue]
-> ConduitT [PersistValue] Void IO [a]
-> ReaderT backend m [a]
withStmt' [Text]
colSubsts [PersistValue]
params forall a b. (a -> b) -> a -> b
$ Int -> ConduitT [PersistValue] Void IO [a]
firstRow Int
colCount

      firstRow :: Int -> ConduitT [PersistValue] Void IO [a]
firstRow Int
colCount = do
        Maybe [PersistValue]
mrow <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
        case Maybe [PersistValue]
mrow of
          Maybe [PersistValue]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
          Just [PersistValue]
row
              | Int
colCount forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [PersistValue]
row -> Maybe [PersistValue] -> ConduitT [PersistValue] Void IO [a]
getter Maybe [PersistValue]
mrow
              | Bool
otherwise              -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  [ [Char]
"rawSql: wrong number of columns, got "
                  , forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PersistValue]
row), [Char]
" but expected ", forall a. Show a => a -> [Char]
show Int
colCount
                  , [Char]
" (", forall a. RawSql a => a -> [Char]
rawSqlColCountReason a
x, [Char]
")." ]

      getter :: Maybe [PersistValue] -> ConduitT [PersistValue] Void IO [a]
getter = ([a] -> [a])
-> Maybe [PersistValue] -> ConduitT [PersistValue] Void IO [a]
go forall a. a -> a
id
          where
            go :: ([a] -> [a])
-> Maybe [PersistValue] -> ConduitT [PersistValue] Void IO [a]
go [a] -> [a]
acc Maybe [PersistValue]
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
acc [])
            go [a] -> [a]
acc (Just [PersistValue]
row) =
              case [PersistValue] -> Either Text a
process [PersistValue]
row of
                Left Text
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (Text -> [Char]
T.unpack Text
err)
                Right a
r  -> forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([a] -> [a])
-> Maybe [PersistValue] -> ConduitT [PersistValue] Void IO [a]
go ([a] -> [a]
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
rforall a. a -> [a] -> [a]
:))