{-# LANGUAGE FlexibleContexts #-}
module Database.HDBC.Record.Sequence (
pool, autoPool,
unsafePool, unsafeAutoPool,
) where
import Control.Applicative ((<$>))
import Control.Monad (when, void)
import System.IO.Unsafe (unsafeInterleaveIO)
import Database.HDBC (IConnection, SqlValue, commit)
import Database.HDBC.Session (withConnectionIO)
import Language.SQL.Keyword (Keyword (FOR, UPDATE))
import Database.Record (FromSql, ToSql, PersistableWidth)
import Database.Relational
(relationalQuery', LiteralSQL, Relation, )
import qualified Database.Relational as Relation
import qualified Database.Relational.Table as Table
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Record.Statement (bind, executeBound)
import Database.HDBC.Record.Query (prepareQuery, fetch)
import Database.HDBC.Record.Update (runUpdate)
import Database.Relational (Sequence (..), Binding, Number, )
import qualified Database.Relational as Relational
unsafePool :: (FromSql SqlValue s, PersistableWidth s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn)
=> IO conn
-> i
-> Sequence s i
-> IO [i]
unsafePool :: IO conn -> i -> Sequence s i -> IO [i]
unsafePool connAct :: IO conn
connAct sz :: i
sz seqt :: Sequence s i
seqt = IO conn -> (conn -> IO [i]) -> IO [i]
forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO IO conn
connAct ((conn -> IO [i]) -> IO [i]) -> (conn -> IO [i]) -> IO [i]
forall a b. (a -> b) -> a -> b
$ \conn :: conn
conn -> do
let t :: Table s
t = Sequence s i -> Table s
forall s i. Sequence s i -> Table s
seqTable Sequence s i
seqt
name :: String
name = Table s -> String
forall r. Table r -> String
Table.name Table s
t
PreparedQuery () s
pq <- conn -> Query () s -> IO (PreparedQuery () s)
forall conn p a.
IConnection conn =>
conn -> Query p a -> IO (PreparedQuery p a)
prepareQuery conn
conn (Query () s -> IO (PreparedQuery () s))
-> Query () s -> IO (PreparedQuery () s)
forall a b. (a -> b) -> a -> b
$ Relation () s -> QuerySuffix -> Query () s
forall p r. Relation p r -> QuerySuffix -> Query p r
relationalQuery' (Table s -> Relation () s
forall r. Table r -> Relation () r
Relation.table Table s
t) [Keyword
FOR, Keyword
UPDATE]
ExecutedStatement s
es <- BoundStatement s -> IO (ExecutedStatement s)
forall a. BoundStatement a -> IO (ExecutedStatement a)
executeBound (BoundStatement s -> IO (ExecutedStatement s))
-> BoundStatement s -> IO (ExecutedStatement s)
forall a b. (a -> b) -> a -> b
$ PreparedQuery () s
pq PreparedQuery () s -> () -> BoundStatement s
forall p a.
ToSql SqlValue p =>
PreparedStatement p a -> p -> BoundStatement a
`bind` ()
i
seq0 <- IO i -> (s -> IO i) -> Maybe s -> IO i
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(String -> IO i
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO i) -> String -> IO i
forall a b. (a -> b) -> a -> b
$ "No record found in sequence table: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
(i -> IO i
forall (m :: * -> *) a. Monad m => a -> m a
return (i -> IO i) -> (s -> i) -> s -> IO i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence s i -> s -> i
forall s i. Sequence s i -> s -> i
seqExtract Sequence s i
seqt)
(Maybe s -> IO i) -> IO (Maybe s) -> IO i
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExecutedStatement s -> IO (Maybe s)
forall a. FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)
fetch ExecutedStatement s
es
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (i
forall a. Bounded a => a
maxBound i -> i -> i
forall a. Num a => a -> a -> a
- i
seq0 i -> i -> Bool
forall a. Ord a => a -> a -> Bool
< i
sz) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Not enough size in sequence table: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ i -> String
forall a. Show a => a -> String
show (i
forall a. Bounded a => a
maxBound i -> i -> i
forall a. Num a => a -> a -> a
- i
seq0) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " < " String -> String -> String
forall a. [a] -> [a] -> [a]
++ i -> String
forall a. Show a => a -> String
show i
sz
let seq1 :: i
seq1 = i
seq0 i -> i -> i
forall a. Num a => a -> a -> a
+ i
sz
IO Integer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Integer -> IO ()) -> IO Integer -> IO ()
forall a b. (a -> b) -> a -> b
$ conn -> Update () -> () -> IO Integer
forall conn p.
(IConnection conn, ToSql SqlValue p) =>
conn -> Update p -> p -> IO Integer
runUpdate conn
conn (i -> Sequence s i -> Update ()
forall s i.
(PersistableWidth s, Integral i, LiteralSQL i) =>
i -> Sequence s i -> Update ()
Relational.updateNumber i
seq1 Sequence s i
seqt) ()
IO () -> (s -> IO ()) -> Maybe s -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> s -> IO ()
forall a b. a -> b -> a
const (IO () -> s -> IO ()) -> (String -> IO ()) -> String -> s -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> s -> IO ()) -> String -> s -> IO ()
forall a b. (a -> b) -> a -> b
$ "More than two record found in seq table: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (Maybe s -> IO ()) -> IO (Maybe s) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExecutedStatement s -> IO (Maybe s)
forall a. FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)
fetch ExecutedStatement s
es
conn -> IO ()
forall conn. IConnection conn => conn -> IO ()
commit conn
conn
[i] -> IO [i]
forall (m :: * -> *) a. Monad m => a -> m a
return [i
seq0 i -> i -> i
forall a. Num a => a -> a -> a
+ 1 .. i
seq1]
unsafeAutoPool :: (FromSql SqlValue s, PersistableWidth s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn)
=> IO conn
-> i
-> Sequence s i
-> IO [i]
unsafeAutoPool :: IO conn -> i -> Sequence s i -> IO [i]
unsafeAutoPool connAct :: IO conn
connAct sz :: i
sz seqt :: Sequence s i
seqt = IO [i]
loop where
loop :: IO [i]
loop = IO [i] -> IO [i]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [i] -> IO [i]) -> IO [i] -> IO [i]
forall a b. (a -> b) -> a -> b
$ do
[i]
hd <- IO conn -> i -> Sequence s i -> IO [i]
forall s i conn.
(FromSql SqlValue s, PersistableWidth s, ToSql SqlValue i,
LiteralSQL i, Bounded i, Integral i, Show i, IConnection conn) =>
IO conn -> i -> Sequence s i -> IO [i]
unsafePool IO conn
connAct i
sz Sequence s i
seqt
([i]
hd [i] -> [i] -> [i]
forall a. [a] -> [a] -> [a]
++) ([i] -> [i]) -> IO [i] -> IO [i]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [i]
loop
pool :: (FromSql SqlValue s, ToSql SqlValue i,
PersistableWidth i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn
-> i
-> Relation () r
-> IO [Number r i]
pool :: IO conn -> i -> Relation () r -> IO [Number r i]
pool connAct :: IO conn
connAct sz :: i
sz =
((i -> Number r i) -> [i] -> [Number r i]
forall a b. (a -> b) -> [a] -> [b]
map i -> Number r i
forall r s i. Binding r s i => i -> Number r i
Relational.unsafeSpecifyNumber ([i] -> [Number r i]) -> IO [i] -> IO [Number r i]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
(IO [i] -> IO [Number r i])
-> (Relation () r -> IO [i]) -> Relation () r -> IO [Number r i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO conn -> i -> Sequence s i -> IO [i]
forall s i conn.
(FromSql SqlValue s, PersistableWidth s, ToSql SqlValue i,
LiteralSQL i, Bounded i, Integral i, Show i, IConnection conn) =>
IO conn -> i -> Sequence s i -> IO [i]
unsafePool IO conn
connAct i
sz
(Sequence s i -> IO [i])
-> (Relation () r -> Sequence s i) -> Relation () r -> IO [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation () r -> Sequence s i
forall r s i. Binding r s i => Relation () r -> Sequence s i
Relational.fromRelation
autoPool :: (FromSql SqlValue s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn
-> i
-> Relation () r
-> IO [Number r i]
autoPool :: IO conn -> i -> Relation () r -> IO [Number r i]
autoPool connAct :: IO conn
connAct sz :: i
sz =
((i -> Number r i) -> [i] -> [Number r i]
forall a b. (a -> b) -> [a] -> [b]
map i -> Number r i
forall r s i. Binding r s i => i -> Number r i
Relational.unsafeSpecifyNumber ([i] -> [Number r i]) -> IO [i] -> IO [Number r i]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
(IO [i] -> IO [Number r i])
-> (Relation () r -> IO [i]) -> Relation () r -> IO [Number r i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO conn -> i -> Sequence s i -> IO [i]
forall s i conn.
(FromSql SqlValue s, PersistableWidth s, ToSql SqlValue i,
LiteralSQL i, Bounded i, Integral i, Show i, IConnection conn) =>
IO conn -> i -> Sequence s i -> IO [i]
unsafeAutoPool IO conn
connAct i
sz
(Sequence s i -> IO [i])
-> (Relation () r -> Sequence s i) -> Relation () r -> IO [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation () r -> Sequence s i
forall r s i. Binding r s i => Relation () r -> Sequence s i
Relational.fromRelation