{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}
{-# INCLUDE <libpq-fe.h> #-}
{-# LINE 1 "Database/PostgreSQL.hsc" #-}

{-# LINE 2 "Database/PostgreSQL.hsc" #-}
module Database.PostgreSQL where

import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Trans
import Data.List
import Data.Maybe
import Foreign
import Foreign.C


{-# LINE 13 "Database/PostgreSQL.hsc" #-}

-- Generic stuff

newtype DatabaseT m a = DatabaseT (StateT DatabaseHandle m a)
    deriving (Monad, MonadIO, MonadTrans)

class (MonadIO m, Error e, MonadError e m)
   => MonadDatabase e m where
    getConnection :: m DatabaseHandle

instance (MonadIO m, Error e, MonadError e m)
      => MonadDatabase e (DatabaseT m) where
    getConnection = DatabaseT get

instance (MonadIO (t m), MonadError e (t m), MonadTrans t,
          MonadDatabase e m, Monad (t m))
      => MonadDatabase e (t m) where
    getConnection = lift getConnection

instance MonadError e m => MonadError e (DatabaseT m) where
    throwError x = DatabaseT (throwError x)
    catchError (DatabaseT f) g = DatabaseT
                               $ catchError f (\x -> case g x of
                                                         DatabaseT y -> y)

-- Postgres stuff

data PGconn
newtype DatabaseHandle = DatabaseHandle (Ptr PGconn)

foreign import ccall unsafe "static libpq-fe.h PQconnectdb"
    pqConnectDB :: CString -> IO (Ptr PGconn)

type ConnStatusType = Word32
{-# LINE 47 "Database/PostgreSQL.hsc" #-}
-- XXX Incomplete list:
connection_OK :: ConnStatusType
connection_OK = 0
{-# LINE 50 "Database/PostgreSQL.hsc" #-}
connection_bad :: ConnStatusType
connection_bad = 1
{-# LINE 52 "Database/PostgreSQL.hsc" #-}
foreign import ccall unsafe "static libpq-fe.h PQstatus"
    pqStatus :: Ptr PGconn -> IO ConnStatusType

foreign import ccall unsafe "static libpq-fe.h PQerrorMessage"
    pqErrorMessage :: Ptr PGconn -> IO CString

data PGresult

foreign import ccall unsafe "static libpq-fe.h PQexec"
    pqExec :: Ptr PGconn -> CString -> IO (Ptr PGresult)

execute :: MonadDatabase e m => String -> m ()
execute sql = do DatabaseHandle dbh <- getConnection
                 checkResultStatus "execute" $ withCString sql $ pqExec dbh

type Oid = Word32
{-# LINE 68 "Database/PostgreSQL.hsc" #-}

withCStrings :: [String] -> (Ptr CString -> IO a) -> IO a
withCStrings all_xs f = go [] all_xs
    where go acc [] = withArray (reverse acc) f
          go acc (x:xs) = withCString x $ \s -> go (s:acc) xs

foreign import ccall unsafe "static libpq-fe.h PQexecParams"
    pqExecParams :: Ptr PGconn  -- Connection
                 -> CString     -- command
                 -> CInt        -- nParams
                 -> Ptr Oid     -- paramTypes
                 -> Ptr CString -- paramValues
                 -> Ptr CInt    -- paramLengths
                 -> Ptr CInt    -- paramFormats
                 -> CInt        -- resultFormat
                 -> IO (Ptr PGresult)
execParams :: MonadDatabase e m => String -> [String] -> m ()
execParams sql params
 = do let nparams = genericLength params
          -- We don't currently let the user tell us which Oid they want
          -- to use
          oids = nullPtr
          -- XXX We should really use binary mode, in which case we'd
          -- need to give lengths, but for now we are using text mode,
          -- so we don't
          lengths = nullPtr
      DatabaseHandle dbh <- getConnection
      checkResultStatus "execParams" $
          withCString sql $ \sql' ->
          withCStrings params $ \params' ->
          -- XXX For now we use text mode (0), but we really ought to
          -- use binary
          withArray (genericReplicate nparams 0) $ \formats ->
          -- XXX Again, should use binary (1) rather than text (0)
          pqExecParams dbh sql' nparams oids params' lengths formats 0

-- Docs in http://www.postgresql.org/docs/7.4/interactive/libpq-exec.html
-- PGresult *PQexecPrepared(PGconn *conn,
--                          const char *stmtName,
--                          int nParams,
--                          const char * const *paramValues,
--                          const int *paramLengths,
--                          const int *paramFormats,
--                          int resultFormat);
-- Uses statements created with an SQL "PREPARE" command

type ExecStatusType = Word32
{-# LINE 115 "Database/PostgreSQL.hsc" #-}
-- XXX Incomplete list:
pgres_empty_query :: ExecStatusType
pgres_empty_query = 0
{-# LINE 118 "Database/PostgreSQL.hsc" #-}
pgres_command_OK :: ExecStatusType
pgres_command_OK = 1
{-# LINE 120 "Database/PostgreSQL.hsc" #-}
-- can be 0 rows:
pgres_tuples_OK :: ExecStatusType
pgres_tuples_OK = 2
{-# LINE 123 "Database/PostgreSQL.hsc" #-}
foreign import ccall unsafe "static libpq-fe.h PQresultStatus"
    pqResultStatus :: Ptr PGresult -> IO ExecStatusType
-- PGRES_COPY_OUT
-- PGRES_COPY_IN
-- PGRES_BAD_RESPONSE
-- PGRES_NONFATAL_ERROR (not returned directly XXX)
-- PGRES_FATAL_ERROR (null equiv to this)

foreign import ccall unsafe "static libpq-fe.h PQresStatus"
    pqResStatus :: ExecStatusType -> IO CString

foreign import ccall unsafe "static libpq-fe.h PQresultErrorMessage"
    pqResultErrorMessage :: Ptr PGresult -> IO CString

checkResultStatus :: MonadDatabase e m => String -> IO (Ptr PGresult) -> m ()
checkResultStatus s f
 = do res <- liftIO f
      res' <- liftIO $ pqResultStatus res
      when (res' `notElem` [pgres_command_OK, pgres_tuples_OK]) $ do
          err_msg <- liftIO $ pqResultErrorMessage res >>= peekCString
          err_code <- liftIO $ pqResStatus res' >>= peekCString
          let err = s ++ " failed (" ++ err_code ++ "): " ++ err_msg
          throwError $ strMsg err

-- char *PQresultErrorMessage(const PGresult *res);

-- void PQclear(PQresult *res); (essentially = free)

-- int PQntuples(const PGresult *res);

-- char* PQgetvalue(const PGresult *res, int row_number, int column_number);
-- int PQgetisnull(const PGresult *res, int row_number, int column_number);
-- int PQgetlength(const PGresult *res, int row_number, int column_number);

-- XXX Other functions for async requests
-- http://www.postgresql.org/docs/7.4/interactive/libpq-async.html

foreign import ccall unsafe "static libpq-fe.h PQfinish"
    pqFinish :: Ptr PGconn -> IO ()

-- XXX Should use bracket or somesuch, but we have the old IO/MonadIO problem
withDatabaseRaw :: MonadIO m => String -> DatabaseT m a -> m a
withDatabaseRaw conninfo (DatabaseT f)
 = do dbh <- liftIO $ withCString conninfo pqConnectDB
      if dbh == nullPtr
        then error "XXX dbh was NULL - can't happen?"
        else do stat <- liftIO $ pqStatus dbh
                if stat /= connection_OK
                  then do err <- liftIO $ pqErrorMessage dbh >>= peekCString
                          error err -- XXX
                  else do res <- evalStateT f (DatabaseHandle dbh)
                          liftIO $ pqFinish dbh
                          return res

data ConnectionInfo = ConnectionInfo { host :: Maybe String,
                                       hostaddr :: Maybe String,
                                       port :: Maybe String,
                                       dbname :: Maybe String,
                                       user :: Maybe String,
                                       password :: Maybe String,
                                       connect_timeout :: Maybe String,
                                       options :: Maybe String,
                                       sslmode :: Maybe String,
                                       service :: Maybe String }

defaultConnectionInfo :: ConnectionInfo
defaultConnectionInfo = ConnectionInfo { host = Nothing,
                                         hostaddr = Nothing,
                                         port = Nothing,
                                         dbname = Nothing,
                                         user = Nothing,
                                         password = Nothing,
                                         connect_timeout = Nothing,
                                         options = Nothing,
                                         sslmode = Nothing,
                                         service = Nothing }

withDatabase :: MonadIO m => ConnectionInfo -> DatabaseT m a -> m a
withDatabase conninfo f
 = withDatabaseRaw conninfo' f
    where conninfo' = concat $ intersperse " " $ catMaybes [
                          mkSetting "host" host,
                          mkSetting "hostaddr" hostaddr,
                          mkSetting "port" port,
                          mkSetting "dbname" dbname,
                          mkSetting "user" user,
                          mkSetting "password" password,
                          mkSetting "connect_timeout" connect_timeout,
                          mkSetting "options" options,
                          mkSetting "sslmode" sslmode,
                          mkSetting "service" service]
          mkSetting name extract
              = case extract conninfo of
                    Just val -> Just (name ++ "='" ++ escape val ++ "'")
                    Nothing -> Nothing
          escape ('\'':cs) = '\\':'\'':escape cs
          escape ('\\':cs) = '\\':'\\':escape cs
          escape (c:cs) = c:escape cs
          escape "" = ""