{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      : Database.HDBC.Record.Query
-- Copyright   : 2013 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides typed 'Query' running sequence
-- which intermediate structures are typed.
module Database.HDBC.Record.Query (
  -- * Prepare
  PreparedQuery, prepare, prepareQuery, withPrepareQuery,

  -- * Fetch strictly
  fetch, fetchAll',
  listToUnique, fetchUnique, fetchUnique',

  runStatement',
  runPreparedQuery',
  runQuery',

  -- * Fetch loop
  foldlFetch, forFetch,

  -- * Fetch with Lazy-IO
  -- $fetchWithLazyIO
  fetchAll,
  runStatement,
  runPreparedQuery,
  runQuery,
  ) where

import Control.Applicative ((<$>), pure)
import Data.Monoid (mempty, (<>))
import Data.Maybe (listToMaybe)
import Data.DList (toList)
import Database.HDBC (IConnection, Statement, SqlValue)
import qualified Database.HDBC as HDBC

import Database.Relational (Query, untypeQuery)
import Database.Record (ToSql, FromSql, toRecord)

import Database.HDBC.Record.Statement
  (unsafePrepare, withUnsafePrepare, PreparedStatement,
   bind, BoundStatement,
   executeBound, ExecutedStatement, executed)


-- | Typed prepared query type.
type PreparedQuery p a = PreparedStatement p a

-- | Typed prepare query operation.
prepare :: IConnection conn
        => conn                   -- ^ Database connection
        -> Query p a              -- ^ Typed query
        -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a'
prepare :: conn -> Query p a -> IO (PreparedQuery p a)
prepare conn :: conn
conn = conn -> String -> IO (PreparedQuery p a)
forall conn p a.
IConnection conn =>
conn -> String -> IO (PreparedStatement p a)
unsafePrepare conn
conn (String -> IO (PreparedQuery p a))
-> (Query p a -> String) -> Query p a -> IO (PreparedQuery p a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query p a -> String
forall p a. Query p a -> String
untypeQuery

-- | Same as 'prepare'.
prepareQuery :: IConnection conn
             => conn                   -- ^ Database connection
             -> Query p a              -- ^ Typed query
             -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a'
prepareQuery :: conn -> Query p a -> IO (PreparedQuery p a)
prepareQuery = conn -> Query p a -> IO (PreparedQuery p a)
forall conn p a.
IConnection conn =>
conn -> Query p a -> IO (PreparedQuery p a)
prepare

-- | Bracketed prepare operation.
--   PreparedStatement is released on closing connection,
--   so connection pooling cases often cause resource leaks.
withPrepareQuery :: IConnection conn
                 => conn                        -- ^ Database connection
                 -> Query p a                   -- ^ Typed query
                 -> (PreparedQuery p a -> IO b) -- ^ Body action to use prepared statement
                 -> IO b                        -- ^ Result action
withPrepareQuery :: conn -> Query p a -> (PreparedQuery p a -> IO b) -> IO b
withPrepareQuery conn :: conn
conn = conn -> String -> (PreparedQuery p a -> IO b) -> IO b
forall conn p a b.
IConnection conn =>
conn -> String -> (PreparedStatement p a -> IO b) -> IO b
withUnsafePrepare conn
conn (String -> (PreparedQuery p a -> IO b) -> IO b)
-> (Query p a -> String)
-> Query p a
-> (PreparedQuery p a -> IO b)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query p a -> String
forall p a. Query p a -> String
untypeQuery

-- | Polymorphic fetch operation.
fetchRecords :: (Functor f, FromSql SqlValue a)
             => (Statement -> IO (f [SqlValue]) )
             -> ExecutedStatement a
             -> IO (f a)
fetchRecords :: (Statement -> IO (f [SqlValue])) -> ExecutedStatement a -> IO (f a)
fetchRecords fetchs :: Statement -> IO (f [SqlValue])
fetchs es :: ExecutedStatement a
es = do
  f [SqlValue]
rows <- Statement -> IO (f [SqlValue])
fetchs (ExecutedStatement a -> Statement
forall a. ExecutedStatement a -> Statement
executed ExecutedStatement a
es)
  f a -> IO (f a)
forall (m :: * -> *) a. Monad m => a -> m a
return (f a -> IO (f a)) -> f a -> IO (f a)
forall a b. (a -> b) -> a -> b
$ ([SqlValue] -> a) -> f [SqlValue] -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SqlValue] -> a
forall q a. FromSql q a => [q] -> a
toRecord f [SqlValue]
rows

{- $fetchWithLazyIO
__CAUTION!!__

/Lazy-IO/ APIs may be harmful in complex transaction with RDBMs interfaces
which require sequential ordered calls of low-level APIs.
 -}

-- | Fetch a record.
fetch :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)
fetch :: ExecutedStatement a -> IO (Maybe a)
fetch =  (Statement -> IO (Maybe [SqlValue]))
-> ExecutedStatement a -> IO (Maybe a)
forall (f :: * -> *) a.
(Functor f, FromSql SqlValue a) =>
(Statement -> IO (f [SqlValue])) -> ExecutedStatement a -> IO (f a)
fetchRecords Statement -> IO (Maybe [SqlValue])
HDBC.fetchRow

-- | /Lazy-IO/ version of 'fetchAll''.
fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a]
fetchAll :: ExecutedStatement a -> IO [a]
fetchAll =  (Statement -> IO [[SqlValue]]) -> ExecutedStatement a -> IO [a]
forall (f :: * -> *) a.
(Functor f, FromSql SqlValue a) =>
(Statement -> IO (f [SqlValue])) -> ExecutedStatement a -> IO (f a)
fetchRecords Statement -> IO [[SqlValue]]
HDBC.fetchAllRows

-- | Strictly fetch all records.
fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a]
fetchAll' :: ExecutedStatement a -> IO [a]
fetchAll' =  (Statement -> IO [[SqlValue]]) -> ExecutedStatement a -> IO [a]
forall (f :: * -> *) a.
(Functor f, FromSql SqlValue a) =>
(Statement -> IO (f [SqlValue])) -> ExecutedStatement a -> IO (f a)
fetchRecords Statement -> IO [[SqlValue]]
HDBC.fetchAllRows'

-- | Fetch all records but get only first record.
--   Expecting result records is unique.
fetchUnique :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)
fetchUnique :: ExecutedStatement a -> IO (Maybe a)
fetchUnique es :: ExecutedStatement a
es = do
  [a]
recs <- ExecutedStatement a -> IO [a]
forall a. FromSql SqlValue a => ExecutedStatement a -> IO [a]
fetchAll ExecutedStatement a
es
  let z' :: Maybe a
z' = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe [a]
recs
  Maybe a
z <- Maybe a
z' Maybe a -> IO (Maybe a) -> IO (Maybe a)
forall a b. a -> b -> b
`seq` Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
z'
  Statement -> IO ()
HDBC.finish (Statement -> IO ()) -> Statement -> IO ()
forall a b. (a -> b) -> a -> b
$ ExecutedStatement a -> Statement
forall a. ExecutedStatement a -> Statement
executed ExecutedStatement a
es
  Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
z

-- | Fetch expecting result records is unique.
listToUnique :: [a] -> IO (Maybe a)
listToUnique :: [a] -> IO (Maybe a)
listToUnique =  [a] -> IO (Maybe a)
forall (m :: * -> *) a. MonadFail m => [a] -> m (Maybe a)
d  where
  d :: [a] -> m (Maybe a)
d []      = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
  d [r :: a
r]     = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
r
  d (_:_:_) = String -> m (Maybe a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "fetchUnique': more than one record found."

-- | Fetch all records but get only first record.
--   Expecting result records is unique.
--   Error when records count is more than one.
fetchUnique' :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)
fetchUnique' :: ExecutedStatement a -> IO (Maybe a)
fetchUnique' es :: ExecutedStatement a
es = do
  [a]
recs <- ExecutedStatement a -> IO [a]
forall a. FromSql SqlValue a => ExecutedStatement a -> IO [a]
fetchAll ExecutedStatement a
es
  Maybe a
z <- [a] -> IO (Maybe a)
forall a. [a] -> IO (Maybe a)
listToUnique [a]
recs
  Statement -> IO ()
HDBC.finish (Statement -> IO ()) -> Statement -> IO ()
forall a b. (a -> b) -> a -> b
$ ExecutedStatement a -> Statement
forall a. ExecutedStatement a -> Statement
executed ExecutedStatement a
es
  Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
z

-- | Fetch fold-left loop convenient for
--   the sequence of cursor-solid lock actions.
--   Each action is executed after each fetch.
foldlFetch :: FromSql SqlValue a
           => (b -> a -> IO b)    -- ^ action executed after each fetch
           -> b                   -- ^ zero element of result
           -> ExecutedStatement a -- ^ statement to fetch from
           -> IO b
foldlFetch :: (b -> a -> IO b) -> b -> ExecutedStatement a -> IO b
foldlFetch f :: b -> a -> IO b
f z :: b
z st :: ExecutedStatement a
st =
    b -> IO b
go b
z
  where
    go :: b -> IO b
go ac :: b
ac = do
      let step :: a -> IO b
step = (b -> IO b
go (b -> IO b) -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO b -> IO b) -> (a -> IO b) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> IO b
f b
ac
      IO b -> (a -> IO b) -> Maybe a -> IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
ac) a -> IO b
step (Maybe a -> IO b) -> IO (Maybe a) -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExecutedStatement a -> IO (Maybe a)
forall a. FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)
fetch ExecutedStatement a
st

-- | Fetch loop convenient for
--   the sequence of cursor-solid lock actions.
--   Each action is executed after each fetch.
forFetch :: FromSql SqlValue a
         => ExecutedStatement a -- ^ statement to fetch from
         -> (a -> IO b)         -- ^ action executed after each fetch
         -> IO [b]
forFetch :: ExecutedStatement a -> (a -> IO b) -> IO [b]
forFetch st :: ExecutedStatement a
st action :: a -> IO b
action =
  DList b -> [b]
forall a. DList a -> [a]
toList (DList b -> [b]) -> IO (DList b) -> IO [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (DList b -> a -> IO (DList b))
-> DList b -> ExecutedStatement a -> IO (DList b)
forall a b.
FromSql SqlValue a =>
(b -> a -> IO b) -> b -> ExecutedStatement a -> IO b
foldlFetch (\ac :: DList b
ac x :: a
x -> ((DList b
ac DList b -> DList b -> DList b
forall a. Semigroup a => a -> a -> a
<>) (DList b -> DList b) -> (b -> DList b) -> b -> DList b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> DList b
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (b -> DList b) -> IO b -> IO (DList b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO b
action a
x) DList b
forall a. Monoid a => a
mempty ExecutedStatement a
st

-- | /Lazy-IO/ version of 'runStatement''.
runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a]
runStatement :: BoundStatement a -> IO [a]
runStatement =  (IO (ExecutedStatement a)
-> (ExecutedStatement a -> IO [a]) -> IO [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExecutedStatement a -> IO [a]
forall a. FromSql SqlValue a => ExecutedStatement a -> IO [a]
fetchAll) (IO (ExecutedStatement a) -> IO [a])
-> (BoundStatement a -> IO (ExecutedStatement a))
-> BoundStatement a
-> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundStatement a -> IO (ExecutedStatement a)
forall a. BoundStatement a -> IO (ExecutedStatement a)
executeBound

-- | Execute a parameter-bounded statement and strictly fetch all records.
runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a]
runStatement' :: BoundStatement a -> IO [a]
runStatement' =  (IO (ExecutedStatement a)
-> (ExecutedStatement a -> IO [a]) -> IO [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExecutedStatement a -> IO [a]
forall a. FromSql SqlValue a => ExecutedStatement a -> IO [a]
fetchAll') (IO (ExecutedStatement a) -> IO [a])
-> (BoundStatement a -> IO (ExecutedStatement a))
-> BoundStatement a
-> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundStatement a -> IO (ExecutedStatement a)
forall a. BoundStatement a -> IO (ExecutedStatement a)
executeBound

-- | /Lazy-IO/ version of 'runPreparedQuery''.
runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a)
                 => PreparedQuery p a -- ^ Statement to bind to
                 -> p                 -- ^ Parameter type
                 -> IO [a]            -- ^ Action to get records
runPreparedQuery :: PreparedQuery p a -> p -> IO [a]
runPreparedQuery ps :: PreparedQuery p a
ps = BoundStatement a -> IO [a]
forall a. FromSql SqlValue a => BoundStatement a -> IO [a]
runStatement (BoundStatement a -> IO [a])
-> (p -> BoundStatement a) -> p -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreparedQuery p a -> p -> BoundStatement a
forall p a.
ToSql SqlValue p =>
PreparedStatement p a -> p -> BoundStatement a
bind PreparedQuery p a
ps

-- | Bind parameters, execute statement and strictly fetch all records.
runPreparedQuery' :: (ToSql SqlValue p, FromSql SqlValue a)
                  => PreparedQuery p a -- ^ Statement to bind to
                  -> p                 -- ^ Parameter type
                  -> IO [a]            -- ^ Action to get records
runPreparedQuery' :: PreparedQuery p a -> p -> IO [a]
runPreparedQuery' ps :: PreparedQuery p a
ps = BoundStatement a -> IO [a]
forall a. FromSql SqlValue a => BoundStatement a -> IO [a]
runStatement' (BoundStatement a -> IO [a])
-> (p -> BoundStatement a) -> p -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreparedQuery p a -> p -> BoundStatement a
forall p a.
ToSql SqlValue p =>
PreparedStatement p a -> p -> BoundStatement a
bind PreparedQuery p a
ps

-- | /Lazy-IO/ version of 'runQuery''.
runQuery :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a)
         => conn      -- ^ Database connection
         -> Query p a -- ^ Query to get record type 'a' requires parameter 'p'
         -> p         -- ^ Parameter type
         -> IO [a]    -- ^ Action to get records
runQuery :: conn -> Query p a -> p -> IO [a]
runQuery conn :: conn
conn q :: Query p a
q p :: p
p = conn -> Query p a -> IO (PreparedQuery p a)
forall conn p a.
IConnection conn =>
conn -> Query p a -> IO (PreparedQuery p a)
prepare conn
conn Query p a
q IO (PreparedQuery p a) -> (PreparedQuery p a -> IO [a]) -> IO [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PreparedQuery p a -> p -> IO [a]
forall p a.
(ToSql SqlValue p, FromSql SqlValue a) =>
PreparedQuery p a -> p -> IO [a]
`runPreparedQuery` p
p)

-- | Prepare SQL, bind parameters, execute statement and strictly fetch all records.
runQuery' :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a)
          => conn      -- ^ Database connection
          -> Query p a -- ^ Query to get record type 'a' requires parameter 'p'
          -> p         -- ^ Parameter type
          -> IO [a]    -- ^ Action to get records
runQuery' :: conn -> Query p a -> p -> IO [a]
runQuery' conn :: conn
conn q :: Query p a
q p :: p
p = conn -> Query p a -> (PreparedQuery p a -> IO [a]) -> IO [a]
forall conn p a b.
IConnection conn =>
conn -> Query p a -> (PreparedQuery p a -> IO b) -> IO b
withPrepareQuery conn
conn Query p a
q (PreparedQuery p a -> p -> IO [a]
forall p a.
(ToSql SqlValue p, FromSql SqlValue a) =>
PreparedQuery p a -> p -> IO [a]
`runPreparedQuery'` p
p)