{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Selda.Prepared (Preparable, Prepare, prepared) where
import Database.Selda.Backend.Internal
( Lit(LCustom),
SqlType(sqlType),
SqlTypeRep,
Param(..),
MonadSelda(Backend, withConnection),
SeldaBackend(ppConfig, runPrepared, backendId, prepareStmt),
SeldaConnection(connBackend, connStmts),
SeldaStmt(SeldaStmt, stmtHandle, stmtParams, stmtText),
StmtID(..),
BackendID,
freshStmtId,
withBackend )
import Database.Selda.Column ( Exp(Lit), Col(..) )
import Database.Selda.Compile
( Result, Res, compileWith, buildResult )
import Database.Selda.Query.Type ( Query )
import Database.Selda.SQL (param, paramType)
import Control.Exception ( Exception, try, throw, mask )
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import qualified Data.IntMap as M
import Data.IORef
( IORef, atomicModifyIORef', newIORef, readIORef, writeIORef )
import Data.Proxy ( Proxy(..) )
import Data.Text (Text)
import Data.Typeable ( Typeable )
import System.IO.Unsafe ( unsafePerformIO )
data Placeholder = Placeholder Int
deriving Int -> Placeholder -> ShowS
[Placeholder] -> ShowS
Placeholder -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Placeholder] -> ShowS
$cshowList :: [Placeholder] -> ShowS
show :: Placeholder -> String
$cshow :: Placeholder -> String
showsPrec :: Int -> Placeholder -> ShowS
$cshowsPrec :: Int -> Placeholder -> ShowS
Show
instance Exception Placeholder
firstParamIx :: Int
firstParamIx :: Int
firstParamIx = Int
0
type family ResultT f where
ResultT (a -> b) = ResultT b
ResultT (m a) = a
type family Equiv q f where
Equiv (Col s a -> q) (a -> f) = Equiv q f
Equiv (Query s a) (m [b]) = (Res a ~ b, Backend m ~ s)
type CompResult = (Text, [Either Int Param], [SqlTypeRep])
class Preparable q where
mkQuery :: MonadSelda m
=> Int
-> q
-> [SqlTypeRep]
-> m CompResult
class Prepare q f where
mkFun :: Preparable q
=> IORef (Maybe (BackendID, CompResult))
-> StmtID
-> q
-> [Param]
-> f
instance (SqlType a, Prepare q b) => Prepare q (a -> b) where
mkFun :: Preparable q =>
IORef (Maybe (BackendID, CompResult))
-> StmtID -> q -> [Param] -> a -> b
mkFun IORef (Maybe (BackendID, CompResult))
ref StmtID
sid q
qry [Param]
ps a
x = forall q f.
(Prepare q f, Preparable q) =>
IORef (Maybe (BackendID, CompResult))
-> StmtID -> q -> [Param] -> f
mkFun IORef (Maybe (BackendID, CompResult))
ref StmtID
sid q
qry (forall a. SqlType a => a -> Param
param a
x forall a. a -> [a] -> [a]
: [Param]
ps)
instance (Typeable a, MonadSelda m, a ~ Res (ResultT q), Result (ResultT q)) =>
Prepare q (m [a]) where
mkFun :: Preparable q =>
IORef (Maybe (BackendID, CompResult))
-> StmtID -> q -> [Param] -> m [a]
mkFun IORef (Maybe (BackendID, CompResult))
ref (StmtID Int
sid) q
qry [Param]
arguments = forall (m :: * -> *) a.
MonadSelda m =>
(SeldaConnection (Backend m) -> m a) -> m a
withConnection forall a b. (a -> b) -> a -> b
$ \SeldaConnection (Backend m)
conn -> do
let backend :: SeldaBackend (Backend m)
backend = forall b. SeldaConnection b -> SeldaBackend b
connBackend SeldaConnection (Backend m)
conn
args :: [Param]
args = forall a. [a] -> [a]
reverse [Param]
arguments
IntMap SeldaStmt
stmts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (forall b. SeldaConnection b -> IORef (IntMap SeldaStmt)
connStmts SeldaConnection (Backend m)
conn)
case forall a. Int -> IntMap a -> Maybe a
M.lookup Int
sid IntMap SeldaStmt
stmts of
Just SeldaStmt
stm -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SeldaConnection (Backend m) -> SeldaStmt -> [Param] -> IO [a]
runQuery SeldaConnection (Backend m)
conn SeldaStmt
stm [Param]
args
Maybe SeldaStmt
_ -> do
Maybe (BackendID, CompResult)
compiled <- 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 (Maybe (BackendID, CompResult))
ref
(Text
q, [Either Int Param]
params, [SqlTypeRep]
reps) <- case Maybe (BackendID, CompResult)
compiled of
Just (BackendID
bid, CompResult
comp) | BackendID
bid forall a. Eq a => a -> a -> Bool
== forall b. SeldaBackend b -> BackendID
backendId SeldaBackend (Backend m)
backend -> do
forall (m :: * -> *) a. Monad m => a -> m a
return CompResult
comp
Maybe (BackendID, CompResult)
_ -> do
CompResult
comp <- forall q (m :: * -> *).
(Preparable q, MonadSelda m) =>
Int -> q -> [SqlTypeRep] -> m CompResult
mkQuery Int
firstParamIx q
qry []
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (BackendID, CompResult))
ref (forall a. a -> Maybe a
Just (forall b. SeldaBackend b -> BackendID
backendId SeldaBackend (Backend m)
backend, CompResult
comp))
forall (m :: * -> *) a. Monad m => a -> m a
return CompResult
comp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Dynamic
hdl <- forall b.
SeldaBackend b -> StmtID -> [SqlTypeRep] -> Text -> IO Dynamic
prepareStmt SeldaBackend (Backend m)
backend (Int -> StmtID
StmtID Int
sid) [SqlTypeRep]
reps Text
q
let stm :: SeldaStmt
stm = SeldaStmt
{ stmtHandle :: Dynamic
stmtHandle = Dynamic
hdl
, stmtParams :: [Either Int Param]
stmtParams = [Either Int Param]
params
, stmtText :: Text
stmtText = Text
q
}
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (forall b. SeldaConnection b -> IORef (IntMap SeldaStmt)
connStmts SeldaConnection (Backend m)
conn) forall a b. (a -> b) -> a -> b
$ \IntMap SeldaStmt
m -> (forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
sid SeldaStmt
stm IntMap SeldaStmt
m, ())
forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ SeldaConnection (Backend m) -> SeldaStmt -> [Param] -> IO [a]
runQuery SeldaConnection (Backend m)
conn SeldaStmt
stm [Param]
args
where
runQuery :: SeldaConnection (Backend m) -> SeldaStmt -> [Param] -> IO [a]
runQuery SeldaConnection (Backend m)
conn SeldaStmt
stm [Param]
args = do
let ps :: [Param]
ps = [Either Int Param] -> [Param] -> [Param]
replaceParams (SeldaStmt -> [Either Int Param]
stmtParams SeldaStmt
stm) [Param]
args
hdl :: Dynamic
hdl = SeldaStmt -> Dynamic
stmtHandle SeldaStmt
stm
(Int, [[SqlValue]])
res <- forall b.
SeldaBackend b -> Dynamic -> [Param] -> IO (Int, [[SqlValue]])
runPrepared (forall b. SeldaConnection b -> SeldaBackend b
connBackend SeldaConnection (Backend m)
conn) Dynamic
hdl [Param]
ps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall r. Result r => Proxy r -> [SqlValue] -> Res r
buildResult (forall {k} (t :: k). Proxy t
Proxy :: Proxy (ResultT q))) (forall a b. (a, b) -> b
snd (Int, [[SqlValue]])
res)
instance (SqlType a, Preparable b) => Preparable (Col s a -> b) where
mkQuery :: forall (m :: * -> *).
MonadSelda m =>
Int -> (Col s a -> b) -> [SqlTypeRep] -> m CompResult
mkQuery Int
n Col s a -> b
f [SqlTypeRep]
ts = forall q (m :: * -> *).
(Preparable q, MonadSelda m) =>
Int -> q -> [SqlTypeRep] -> m CompResult
mkQuery (Int
nforall a. Num a => a -> a -> a
+Int
1) (Col s a -> b
f Col s a
x) (SqlTypeRep
t forall a. a -> [a] -> [a]
: [SqlTypeRep]
ts)
where
t :: SqlTypeRep
t = forall a. SqlType a => Proxy a -> SqlTypeRep
sqlType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
x :: Col s a
x = forall {k} (s :: k) a. Exp SQL a -> Col s a
One forall a b. (a -> b) -> a -> b
$ forall a sql. Lit a -> Exp sql a
Lit forall a b. (a -> b) -> a -> b
$ forall a b. SqlTypeRep -> Lit a -> Lit b
LCustom SqlTypeRep
t (forall a e. Exception e => e -> a
throw (Int -> Placeholder
Placeholder Int
n) :: Lit a)
instance Result a => Preparable (Query s a) where
mkQuery :: forall (m :: * -> *).
MonadSelda m =>
Int -> Query s a -> [SqlTypeRep] -> m CompResult
mkQuery Int
_ Query s a
q [SqlTypeRep]
types = forall (m :: * -> *) a.
MonadSelda m =>
(SeldaBackend (Backend m) -> m a) -> m a
withBackend forall a b. (a -> b) -> a -> b
$ \SeldaBackend (Backend m)
b -> do
case forall a s. Result a => PPConfig -> Query s a -> (Text, [Param])
compileWith (forall b. SeldaBackend b -> PPConfig
ppConfig SeldaBackend (Backend m)
b) Query s a
q of
(Text
q', [Param]
ps) -> do
([Either Int Param]
ps', [SqlTypeRep]
types') <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [SqlTypeRep] -> [Param] -> IO ([Either Int Param], [SqlTypeRep])
inspectParams (forall a. [a] -> [a]
reverse [SqlTypeRep]
types) [Param]
ps
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
q', [Either Int Param]
ps', [SqlTypeRep]
types')
{-# NOINLINE prepared #-}
prepared :: (Preparable q, Prepare q f, Equiv q f) => q -> f
prepared :: forall q f. (Preparable q, Prepare q f, Equiv q f) => q -> f
prepared q
q = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
IORef (Maybe (BackendID, CompResult))
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
StmtID
sid <- forall (m :: * -> *). MonadIO m => m StmtID
freshStmtId
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall q f.
(Prepare q f, Preparable q) =>
IORef (Maybe (BackendID, CompResult))
-> StmtID -> q -> [Param] -> f
mkFun IORef (Maybe (BackendID, CompResult))
ref StmtID
sid q
q []
replaceParams :: [Either Int Param] -> [Param] -> [Param]
replaceParams :: [Either Int Param] -> [Param] -> [Param]
replaceParams [Either Int Param]
params = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. Either a b -> b
fromRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}.
(Num a, Eq a) =>
a -> [Either a b] -> [b] -> [Either a b]
go Int
firstParamIx [Either Int Param]
params
where
go :: a -> [Either a b] -> [b] -> [Either a b]
go a
n [Either a b]
ps (b
x:[b]
xs) = a -> [Either a b] -> [b] -> [Either a b]
go (a
nforall a. Num a => a -> a -> a
+a
1) (forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b}. Eq a => a -> b -> Either a b -> Either a b
subst a
n b
x) [Either a b]
ps) [b]
xs
go a
_ [Either a b]
ps [b]
_ = [Either a b]
ps
subst :: a -> b -> Either a b -> Either a b
subst a
n b
x (Left a
n') | a
n forall a. Eq a => a -> a -> Bool
== a
n' = forall a b. b -> Either a b
Right b
x
subst a
_ b
_ Either a b
old = Either a b
old
fromRight :: Either a b -> b
fromRight (Right b
x) = b
x
fromRight Either a b
_ = forall a. HasCallStack => String -> a
error String
"BUG: query parameter not substituted!"
inspectParams :: [SqlTypeRep] -> [Param] -> IO ([Either Int Param], [SqlTypeRep])
inspectParams :: [SqlTypeRep] -> [Param] -> IO ([Either Int Param], [SqlTypeRep])
inspectParams [SqlTypeRep]
ts (Param
x:[Param]
xs) = do
Either Placeholder Param
res <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Param -> Param
forceParam Param
x
let (Either Int Param
x', SqlTypeRep
t) = case Either Placeholder Param
res of
Right Param
p -> (forall a b. b -> Either a b
Right Param
p, Param -> SqlTypeRep
paramType Param
p)
Left (Placeholder Int
ix) -> (forall a b. a -> Either a b
Left Int
ix, [SqlTypeRep]
ts forall a. [a] -> Int -> a
!! Int
ix)
([Either Int Param]
xs', [SqlTypeRep]
ts') <- [SqlTypeRep] -> [Param] -> IO ([Either Int Param], [SqlTypeRep])
inspectParams [SqlTypeRep]
ts [Param]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Int Param
x' forall a. a -> [a] -> [a]
: [Either Int Param]
xs', SqlTypeRep
t forall a. a -> [a] -> [a]
: [SqlTypeRep]
ts')
inspectParams [SqlTypeRep]
_ [] = do
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
forceParam :: Param -> Param
forceParam :: Param -> Param
forceParam p :: Param
p@(Param (LCustom SqlTypeRep
_ Lit a
x)) | Lit a
x seq :: forall a b. a -> b -> b
`seq` Bool
True = Param
p
forceParam Param
p = Param
p