Session.hs

{-# LANGUAGE Rank2Types #-}

-- |
-- Module      : Database.HDBC.Session
-- Copyright   : 2013-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides a base bracketed function
-- to call close correctly against opend DB connection.
module Database.HDBC.Session (
  -- * Bracketed session
  -- $bracketedSession
  transaction,

  withConnectionIO, withConnectionIO_,

  bracketConnection,

  -- * Show errors
  -- $showErrors
  showSqlError, handleSqlError',

  -- * Deprecated
  withConnection,
  withConnectionIO',
  withConnectionCommit,
  ) where

import Database.HDBC (IConnection, handleSql,
                      SqlError(seState, seNativeError, seErrorMsg))
import qualified Database.HDBC as HDBC
import Control.Exception (bracket)


{- $bracketedSession
Bracket function implementation is provided by several packages,
so this package provides base implementation which requires
bracket function and corresponding lift function.
-}

{- $showErrors
Functions to show 'SqlError' type not to show 'String' fields.
-}

-- | show 'SqlError' not to show 'String' fields.
showSqlError :: SqlError -> String
showSqlError se = unlines
  ["seState: '" ++ seState se ++ "'",
   "seNativeError: " ++ show (seNativeError se),
   "seErrorMsg: '" ++ seErrorMsg se ++ "'"]

-- | Like 'handleSqlError', but not to show 'String' fields of SqlError.
handleSqlError' :: IO a -> IO a
handleSqlError' =  handleSql (fail . reformat . showSqlError)  where
  reformat = ("SQL error: \n" ++) . unlines . map ("  " ++) . lines

-- | Generalized session with bracketed HDBC connection.
--   Run a transaction on a HDBC IConnection and close the connection.
bracketConnection :: (Monad m, IConnection conn)
                  => (forall c. m c -> (c -> m ()) -> (c -> m a) -> m a) -- ^ bracket
                  -> (forall b. IO b -> m b)                             -- ^ lift
                  -> IO conn                                             -- ^ Connect action
                  -> (conn -> m a)                                       -- ^ Transaction body
                  -> m a
bracketConnection bracket_ lift connect tbody =
    bracket_ (lift open) (lift . close) bodyWithRollback
  where
    open  = handleSqlError' connect
    close :: IConnection conn => conn -> IO ()
    close =  handleSqlError' . HDBC.disconnect
    bodyWithRollback conn =
      bracket_
      (return ())
      -- Do rollback independent from driver default behavior when disconnect.
      (const . lift . handleSqlError' $ HDBC.rollback conn)
      (const $ tbody conn)

{-# DEPRECATED withConnection "use 'bracketConnection' instead of this." #-}
-- | Deprecated. use 'bracketConnection' instead of this.
withConnection :: (Monad m, IConnection conn)
               => (forall c. m c -> (c -> m ()) -> (c -> m a) -> m a)
               -> (forall b. IO b -> m b)
               -> IO conn
               -> (conn -> m a)
               -> m a
withConnection = bracketConnection

-- | Same as 'withConnectionIO' other than not wrapping transaction body in 'handleSqlError''.
withConnectionIO_ :: IConnection conn
                  => IO conn        -- ^ Connect action
                  -> (conn -> IO a) -- ^ Transaction body
                  -> IO a           -- ^ Result transaction action
withConnectionIO_ = bracketConnection bracket id

-- | Run a transaction on a HDBC 'IConnection' and close the connection.
--   Not issuing commit at last, so if you need, issue commit manually in transaction body.
withConnectionIO :: IConnection conn
                 => IO conn        -- ^ Connect action
                 -> (conn -> IO a) -- ^ Transaction body
                 -> IO a           -- ^ Result transaction action
withConnectionIO connect body = withConnectionIO_ connect $ handleSqlError' . body

{-# DEPRECATED withConnectionIO' "use 'withConnectionIO' instead of this." #-}
-- | Deprecated. use 'withConnectionIO' instead of this.
withConnectionIO' :: IConnection conn
                  => IO conn        -- ^ Connect action
                  -> (conn -> IO a) -- ^ Transaction body
                  -> IO a           -- ^ Result transaction action
withConnectionIO' = withConnectionIO

-- | Run a transaction on a HDBC 'IConnection' and commit at last, and then close the connection.
--   In other words, the transaction with no exception is committed.
--   Handy definition for simple transactions.
transaction :: IConnection conn
            => IO conn        -- ^ Connect action
            -> (conn -> IO a) -- ^ Transaction body
            -> IO a           -- ^ Result transaction action
transaction conn body =
  withConnectionIO conn $ \c -> do
    x <- body c
    HDBC.commit c
    return x

{-# DEPRECATED withConnectionCommit "use 'transaction' instead of this." #-}
-- | Deprecated. use 'transaction' instead of this.
withConnectionCommit :: IConnection conn
                     => IO conn        -- ^ Connect action
                     -> (conn -> IO a) -- ^ Transaction body
                     -> IO a           -- ^ Result transaction action
withConnectionCommit conn body =
  withConnectionIO_ conn $ \c -> do
    x <- body c
    HDBC.commit c
    return x