Commons.hs

{-- |
Module      : Commons
Description : Common definitions used by other modules
Copyright   : (c) Mihai Giurgeanu, 2017
License     : GPL-3
Maintainer  : mihai.giurgeanu@gmail.com
Stability   : experimental
Portability : Portable
--}

module Database.TransferDB.Commons where

import Prelude hiding (fail, log)

import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, asks)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Fail (MonadFail, fail)
import Control.Logging(loggingLogger, LogLevel(LevelError), log)

import Data.Text (Text)
import Data.String (fromString)

import SQL.CLI (SQLHENV, SQLHDBC, sql_handle_env, sql_handle_stmt, sql_null_data, sql_char)
import SQL.CLI.Utils (connect, freeHandle, disconnect, tables, allocHandle, getData, forAllRecords)
import SQL.CLI.ODBC (setupEnv)

import System.IO (hPutStrLn, stderr)

import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Storable (peek, poke)
import Foreign.C.String (peekCString)
import Foreign.Ptr (castPtr)

-- | runs the 'run' action, then, runs the 'afterRun' action no matter if the
-- 'run' action failed or succeeded
finally :: Monad m => m a -> ReaderT r (MaybeT m) b -> ReaderT r (MaybeT m) b
finally afterRun run = do
  env <- ask
  lift $ MaybeT $ runMaybeT (runReaderT run env) >>= (\ result -> afterRun >> return result)


-- | a 'MaybeT' only variant of 'finally'; it runs the second action and, then
-- the first action and returns the result of the second action
finally' :: (MonadIO m, MonadFail m) => IO a -> MaybeT IO b -> m b
finally' afterRun run = do
  result <- liftIO $ runMaybeT run >>= (\result -> afterRun >> return result)
  maybe (fail "action failed in finally'") return result

-- | calls fail on the MonadFail logging an error message
faillog :: (MonadIO m, MonadFail m) => String -> m a
faillog = faillogS $ fromString ""

-- | the variant of 'faillog' taking a log source as parameter
faillogS :: (MonadIO m, MonadFail m) => Text -> String -> m a
faillogS source msg = (liftIO $ loggingLogger LevelError source msg) >> fail msg

-- | setup db environment and connect to database
withConnection :: (MonadIO m)
  => String                             -- ^ datasource name
  -> String                             -- ^ user name
  -> String                             -- ^ password
  -> (SQLHENV -> SQLHDBC -> (ReaderT r (MaybeT m) a))         -- ^ a function that gets the newly allocated environment and connection handlers
  -> ReaderT r (MaybeT m) a
withConnection d u p f = do
  liftIO $ log $ fromString $ "connect to " ++ d
  henv <- setupEnv
  let freeEnvHandle = do
        liftIO $ log $ fromString "free environment handle"
        liftIO $ freeHandle sql_handle_env henv
    in finally freeEnvHandle $ do

    hdbc <- connect henv d u p
    let freeHDBC = do
          liftIO $ log $ fromString $ "disconnect from " ++ d
          liftIO $ disconnect hdbc
      in finally freeHDBC $ f henv hdbc

withConnection' :: (MonadIO m, HasDBInfo r) => (SQLHENV -> SQLHDBC -> (ReaderT r (MaybeT m) a)) -> ReaderT r (MaybeT m) a
withConnection' f = do
  dbi <- asks extractDBInfo
  let d = dbi_Datasource dbi
      u = dbi_User       dbi
      p = dbi_Password   dbi
  withConnection d u p f


-- | connect to database in an existing db environment
withEnvConnection :: (MonadIO m)
  => SQLHENV                            -- ^ handle to environment
  -> String                             -- ^ datasource name
  -> String                             -- ^ user name
  -> String                             -- ^ password
  -> (SQLHENV -> SQLHDBC -> (ReaderT r (MaybeT m) a))         -- ^ a function that gets the newly allocated environment and connection handlers
  -> ReaderT r (MaybeT m) a
withEnvConnection henv d u p f = do
  liftIO $ log $ fromString $ "withEnvConnection' using environment handle " ++ (show henv)
  hdbc <- connect henv d u p
  let freeHDBC = do
        liftIO $ log $ fromString $ "disconnect from " ++ d
        liftIO $ disconnect hdbc
    in finally freeHDBC $ f henv hdbc

-- | call 'withEnvConnect' within a 'ReaderT' environment containing database connnetion info
withEnvConnection' :: (MonadIO m, HasDBInfo r) => SQLHENV -> (SQLHENV -> SQLHDBC -> (ReaderT r (MaybeT m) a)) -> ReaderT r (MaybeT m) a
withEnvConnection' henv f = do
  dbi <- asks extractDBInfo
  let d = dbi_Datasource dbi
      u = dbi_User       dbi
      p = dbi_Password   dbi
  withEnvConnection henv d u p f

-- | call 'connect' within a ReaderT environment containing database connnetion info
connect' :: (MonadIO m, MonadFail m, HasDBInfo r) => SQLHENV -> ReaderT r m SQLHDBC
connect' henv = do
  dbi <- asks extractDBInfo
  let d = dbi_Datasource dbi
      u = dbi_User       dbi
      p = dbi_Password   dbi
  connect henv d u p
  
-- | the environment used to run the program
data ProgramOptions = ProgramOptions {
  po_Source           :: DBInfo,
  po_Dest             :: DBInfo
  }

-- | Information about source or destination db
data DBInfo = DBInfo {
  dbi_Datasource    :: String,
  dbi_User          :: String,
  dbi_Password      :: String,
  dbi_Schema        :: String
  }

class HasDBInfo a where
  extractDBInfo :: a -> DBInfo

instance HasDBInfo DBInfo where
  extractDBInfo = id

-- | an instance that deals only with source db
instance HasDBInfo ProgramOptions where
  extractDBInfo = po_Source


-- | run an action in the current environment on each table name from the current schema,
-- passing an accumulator value; returns the value of the accumulor
forAllTables :: (MonadFail m, MonadIO m, HasDBInfo r) => SQLHDBC -> a -> (a -> String -> ReaderT r (MaybeT m) a) -> ReaderT r (MaybeT m) a
forAllTables hdbc arg f = do
  tables_stmt <- allocHandle sql_handle_stmt hdbc
  liftIO $ log $ fromString $ "forAllTables allocated tables statement: " ++ (show tables_stmt)
  schema <- asks $ dbi_Schema.extractDBInfo

  finally (liftIO $ freeHandle sql_handle_stmt tables_stmt) $ do
    result <- liftIO $ runMaybeT $ tables tables_stmt Nothing (Just schema) Nothing (Just "TABLE")  
    let readTableName = liftIO $ allocaBytes 255
          (\ p_tableName ->
             alloca
             (\ p_tableName_ind -> do
                 poke p_tableName_ind 0
                 _ <- getData tables_stmt 3 sql_char p_tableName 255 p_tableName_ind
                 tableName_ind <- liftIO $ peek p_tableName_ind
                 tableName <- if tableName_ind == sql_null_data
                   then return Nothing
                   else (liftIO . peekCString . castPtr) p_tableName >>= (return.Just)
                 return tableName))
        withTableName arg' = do
          tableName <- readTableName
          maybe (return arg') (f arg') tableName
    result <- forAllRecords tables_stmt withTableName arg
    return result