module Database.Persist.Sql.Raw where

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

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

rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
         => Text
         -> [PersistValue]
         -> ConduitM () [PersistValue] m ()
rawQuery :: Text -> [PersistValue] -> ConduitM () [PersistValue] m ()
rawQuery Text
sql [PersistValue]
vals = do
    Acquire (ConduitM () [PersistValue] m ())
srcRes <- ReaderT env IO (Acquire (ConduitM () [PersistValue] m ()))
-> ConduitT
     () [PersistValue] m (Acquire (ConduitM () [PersistValue] m ()))
forall (m :: * -> *) backend b.
(MonadIO m, MonadReader backend m) =>
ReaderT backend IO b -> m b
liftPersist (ReaderT env IO (Acquire (ConduitM () [PersistValue] m ()))
 -> ConduitT
      () [PersistValue] m (Acquire (ConduitM () [PersistValue] m ())))
-> ReaderT env IO (Acquire (ConduitM () [PersistValue] m ()))
-> ConduitT
     () [PersistValue] m (Acquire (ConduitM () [PersistValue] m ()))
forall a b. (a -> b) -> a -> b
$ Text
-> [PersistValue]
-> ReaderT env IO (Acquire (ConduitM () [PersistValue] m ()))
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) <- Acquire (ConduitM () [PersistValue] m ())
-> ConduitT
     () [PersistValue] m (ReleaseKey, ConduitM () [PersistValue] m ())
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire Acquire (ConduitM () [PersistValue] m ())
srcRes
    ConduitM () [PersistValue] m ()
src
    ReleaseKey -> ConduitM () [PersistValue] m ()
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 :: Text
-> [PersistValue]
-> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
rawQueryRes Text
sql [PersistValue]
vals = do
    SqlBackend
conn <- env -> SqlBackend
forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend (env -> SqlBackend)
-> ReaderT env m1 env -> ReaderT env m1 SqlBackend
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ReaderT env m1 env
forall r (m :: * -> *). MonadReader r m => m r
ask
    let make :: IO Statement
make = do
            LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (Text -> Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebugNS (String -> Text
pack String
"SQL") (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
sql (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
vals)
                (SqlBackend -> Loc -> Text -> LogLevel -> LogStr -> IO ()
connLogFunc SqlBackend
conn)
            SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
conn Text
sql
    Acquire (ConduitM () [PersistValue] m2 ())
-> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire (ConduitM () [PersistValue] m2 ())
 -> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ())))
-> Acquire (ConduitM () [PersistValue] m2 ())
-> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ()))
forall a b. (a -> b) -> a -> b
$ do
        Statement
stmt <- IO Statement -> (Statement -> IO ()) -> Acquire Statement
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO Statement
make Statement -> IO ()
stmtReset
        Statement
-> [PersistValue] -> Acquire (ConduitM () [PersistValue] m2 ())
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 :: Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
x [PersistValue]
y = (Int64 -> ()) -> ReaderT backend m Int64 -> ReaderT backend m ()
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (() -> Int64 -> ()
forall a b. a -> b -> a
const ()) (ReaderT backend m Int64 -> ReaderT backend m ())
-> ReaderT backend m Int64 -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ Text -> [PersistValue] -> ReaderT backend m Int64
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 :: Text -> [PersistValue] -> ReaderT backend m Int64
rawExecuteCount Text
sql [PersistValue]
vals = do
    SqlBackend
conn <- backend -> SqlBackend
forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend (backend -> SqlBackend)
-> ReaderT backend m backend -> ReaderT backend m SqlBackend
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ReaderT backend m backend
forall r (m :: * -> *). MonadReader r m => m r
ask
    LoggingT (ReaderT backend m) ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ReaderT backend m ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (Text -> Text -> LoggingT (ReaderT backend m) ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebugNS (String -> Text
pack String
"SQL") (Text -> LoggingT (ReaderT backend m) ())
-> Text -> LoggingT (ReaderT backend m) ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
sql (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
vals)
        (SqlBackend -> Loc -> Text -> LogLevel -> LogStr -> IO ()
connLogFunc SqlBackend
conn)
    Statement
stmt <- Text -> ReaderT backend m Statement
forall (m :: * -> *) backend.
(MonadIO m, MonadReader backend m,
 BackendCompatible SqlBackend backend) =>
Text -> m Statement
getStmt Text
sql
    Int64
res <- IO Int64 -> ReaderT backend m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> ReaderT backend m Int64)
-> IO Int64 -> ReaderT backend m Int64
forall a b. (a -> b) -> a -> b
$ Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt [PersistValue]
vals
    IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO ()
stmtReset Statement
stmt
    Int64 -> ReaderT backend m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
res

getStmt
  :: (MonadIO m, MonadReader backend m, BackendCompatible SqlBackend backend)
  => Text -> m Statement
getStmt :: Text -> m Statement
getStmt Text
sql = do
    SqlBackend
conn <- backend -> SqlBackend
forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend (backend -> SqlBackend) -> m backend -> m SqlBackend
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m backend
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Statement -> m Statement
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Statement -> m Statement) -> IO Statement -> m Statement
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
    Map Text Statement
smap <- IO (Map Text Statement) -> IO (Map Text Statement)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text Statement) -> IO (Map Text Statement))
-> IO (Map Text Statement) -> IO (Map Text Statement)
forall a b. (a -> b) -> a -> b
$ IORef (Map Text Statement) -> IO (Map Text Statement)
forall a. IORef a -> IO a
readIORef (IORef (Map Text Statement) -> IO (Map Text Statement))
-> IORef (Map Text Statement) -> IO (Map Text Statement)
forall a b. (a -> b) -> a -> b
$ SqlBackend -> IORef (Map Text Statement)
connStmtMap SqlBackend
conn
    case Text -> Map Text Statement -> Maybe Statement
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
sql Map Text Statement
smap of
        Just Statement
stmt -> Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
stmt
        Maybe Statement
Nothing -> do
            Statement
stmt' <- IO Statement -> IO Statement
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Statement -> IO Statement) -> IO Statement -> IO Statement
forall a b. (a -> b) -> a -> b
$ SqlBackend -> Text -> IO Statement
connPrepare SqlBackend
conn Text
sql
            IORef Bool
iactive <- IO (IORef Bool) -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> IO (IORef Bool))
-> IO (IORef Bool) -> IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
            let stmt :: Statement
stmt = Statement :: IO ()
-> IO ()
-> ([PersistValue] -> IO Int64)
-> (forall (m :: * -> *).
    MonadIO m =>
    [PersistValue] -> Acquire (ConduitM () [PersistValue] m ()))
-> Statement
Statement
                    { stmtFinalize :: IO ()
stmtFinalize = do
                        Bool
active <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
active (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Statement -> IO ()
stmtFinalize Statement
stmt'
                                         IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
iactive Bool
False
                    , stmtReset :: IO ()
stmtReset = do
                        Bool
active <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
active (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO ()
stmtReset Statement
stmt'
                    , stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = \[PersistValue]
x -> do
                        Bool
active <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        if Bool
active
                            then Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt' [PersistValue]
x
                            else PersistentSqlException -> IO Int64
forall e a. Exception e => e -> IO a
throwIO (PersistentSqlException -> IO Int64)
-> PersistentSqlException -> IO Int64
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 <- IO Bool -> Acquire Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Acquire Bool) -> IO Bool -> Acquire Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
iactive
                        if Bool
active
                            then Statement
-> [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt' [PersistValue]
x
                            else IO (ConduitM () [PersistValue] m ())
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ConduitM () [PersistValue] m ())
 -> Acquire (ConduitM () [PersistValue] m ()))
-> IO (ConduitM () [PersistValue] m ())
-> Acquire (ConduitM () [PersistValue] m ())
forall a b. (a -> b) -> a -> b
$ PersistentSqlException -> IO (ConduitM () [PersistValue] m ())
forall e a. Exception e => e -> IO a
throwIO (PersistentSqlException -> IO (ConduitM () [PersistValue] m ()))
-> PersistentSqlException -> IO (ConduitM () [PersistValue] m ())
forall a b. (a -> b) -> a -> b
$ Text -> PersistentSqlException
StatementAlreadyFinalized Text
sql
                    }
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Map Text Statement) -> Map Text Statement -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (SqlBackend -> IORef (Map Text Statement)
connStmtMap SqlBackend
conn) (Map Text Statement -> IO ()) -> Map Text Statement -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Statement -> Map Text Statement -> Map Text Statement
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
sql Statement
stmt Map Text Statement
smap
            Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
stmt = [PersistValue] -> ReaderT backend m [a]
run
    where
      getType :: (x -> m [a]) -> a
      getType :: (x -> m [a]) -> a
getType = String -> (x -> m [a]) -> a
forall a. HasCallStack => String -> a
error String
"rawSql.getType"

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

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

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

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

      getter :: Maybe [PersistValue] -> ConduitM [PersistValue] Void IO [a]
getter = ([a] -> [a])
-> Maybe [PersistValue] -> ConduitM [PersistValue] Void IO [a]
go [a] -> [a]
forall a. a -> a
id
          where
            go :: ([a] -> [a])
-> Maybe [PersistValue] -> ConduitM [PersistValue] Void IO [a]
go [a] -> [a]
acc Maybe [PersistValue]
Nothing = [a] -> ConduitM [PersistValue] Void IO [a]
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 -> String -> ConduitM [PersistValue] Void IO [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Text -> String
T.unpack Text
err)
                Right a
r  -> ConduitT [PersistValue] Void IO (Maybe [PersistValue])
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT [PersistValue] Void IO (Maybe [PersistValue])
-> (Maybe [PersistValue] -> ConduitM [PersistValue] Void IO [a])
-> ConduitM [PersistValue] Void IO [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([a] -> [a])
-> Maybe [PersistValue] -> ConduitM [PersistValue] Void IO [a]
go ([a] -> [a]
acc ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:))