{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      : Database.HDBC.Record.Sequence
-- Copyright   : 2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides operations for sequence tables of relational-query with HDBC.
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


-- | Unsafely get a raw sequence number pool of specified size
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]

-- | Unsafely get a raw lazy pool of sequence number
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


-- | Get a sized sequence number pool corresponding proper table 'r'
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

-- | Get a lazy pool corresponding proper table 'r'
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