{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Building and executing prepared statements.
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

-- | Index of first argument parameter to a query.
firstParamIx :: Int
firstParamIx :: Int
firstParamIx = Int
0

-- | Result type of a monadic computation.
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
  -- | Prepare the query and parameter list.
  mkQuery :: MonadSelda m
          => Int -- ^ Next argument index.
          -> q   -- ^ The query.
          -> [SqlTypeRep] -- ^ The list of param types so far.
          -> m CompResult

-- | Some parameterized query @q@ that can be prepared into a function @f@
--   in some @MonadSelda@.
class Prepare q f where
  -- | Build the function that prepares and execute the query.
  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
  -- This function uses read/writeIORef instead of atomicModifyIORef.
  -- For once, this is actually safe: the IORef points to a single compiled
  -- statement, so the only consequence of a race between the read and the write
  -- is that the statement gets compiled (note: NOT prepared) twice.
  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
        -- Statement already prepared for this connection; just execute it.
        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
        -- Statement wasn't prepared for this connection; check if it was at
        -- least previously compiled for this backend.
        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

        -- Prepare and execute
        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')

-- | Create a prepared Selda function. A prepared function has zero or more
--   arguments, and will get compiled into a prepared statement by the first
--   backend to execute it. Any subsequent calls to the function for the duration
--   of the connection to the database will reuse the prepared statement.
--
--   Preparable functions are of the form
--   @(SqlType a, SqlType b, ...) => Col s a -> Col s b -> ... -> Query s r@.
--   The resulting prepared function will be of the form
--   @MonadSelda m => a -> b -> ... -> m [Res r]@.
--   Note, however, that when using @prepared@, you must give a concrete type
--   for @m@ due to how Haskell's type class resolution works.
--
--   Prepared functions rely on memoization for just-in-time preparation and
--   caching. This means that if GHC accidentally inlines your prepared function,
--   it may get prepared twice.
--   While this does not affect the correctness of your program, and is
--   fairly unlikely to happen, if you want to be absolutely sure that your
--   queries aren't re-prepared more than absolutely necessary,
--   consider adding a @NOINLINE@ annotation to each prepared function.
--
--   Note that when using a constrained backend type variable (i.e.
--   @foo :: Bar b => SeldaM b [Int]@), optimizations must be enabled for
--   prepared statements to be effective.
--
--   A usage example:
--
-- > persons :: Table (Text, Int)
-- > (persons, name :*: age) = tableWithSelectors "ages" [name :- primary]
-- >
-- > {-# NOINLINE ageOf #-}
-- > ageOf :: Text -> SeldaM [Int]
-- > ageOf = prepared $ \n -> do
-- >   person <- select ages
-- >   restrict $ (person!name .== n)
-- >   return age
{-# 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 []

-- | Replace every indexed parameter with the corresponding provided parameter.
--   Keep all non-indexed parameters in place.
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!"

-- | Inspect a list of parameters, denoting each parameter with either a
--   placeholder index or a literal parameter.
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 ([], [])

-- | Force a parameter deep enough to determine whether it is a placeholder.
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