diff --git a/Database/HSQL/PostgreSQL.hsc b/Database/HSQL/PostgreSQL.hsc --- a/Database/HSQL/PostgreSQL.hsc +++ b/Database/HSQL/PostgreSQL.hsc @@ -11,7 +11,9 @@ -} ----------------------------------------------------------------------------------------- -module Database.HSQL.PostgreSQL(connect, module Database.HSQL) where +module Database.HSQL.PostgreSQL(connect, + connectWithOptions, + module Database.HSQL) where import Database.HSQL import Database.HSQL.Types @@ -19,7 +21,7 @@ import Data.Char import Foreign import Foreign.C -import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..)) +import Control.OldException (throwDyn, catchDyn, dynExceptions, Exception(..)) import Control.Monad(when,unless,mplus) import Control.Concurrent.MVar import System.Time @@ -28,7 +30,7 @@ import Text.Read import Numeric -# include +#include #include #include #include @@ -39,6 +41,9 @@ type ExecStatusType = #type ExecStatusType type Oid = #type Oid +{-| Refer to PostgreSQL manual, chapter 30, `libpq - C library' + (e.g. http://www.postgresql.org/docs/8.3/interactive/libpq.html) +-} foreign import ccall "libpq-fe.h PQsetdbLogin" pqSetdbLogin :: CString -> CString -> CString -> CString -> CString -> CString -> CString -> IO PGconn foreign import ccall "libpq-fe.h PQstatus" pqStatus :: PGconn -> IO ConnStatusType foreign import ccall "libpq-fe.h PQerrorMessage" pqErrorMessage :: PGconn -> IO CString @@ -62,19 +67,48 @@ -- Connect/Disconnect ----------------------------------------------------------------------------------------- --- | Makes a new connection to the database server. -connect :: String -- ^ Server name +-- | Makes a new connection to the database server +connect :: String -- ^ Server name : port nr -> String -- ^ Database name -> String -- ^ User identifier -> String -- ^ Authentication string (password) -> IO Connection connect server database user authentication = do + let (serverAddress,portInput)= break (==':') server + port= if length portInput < 2 + then Nothing + else Just (tail portInput) + connectWithOptions serverAddress + port + Nothing + Nothing + database + user + authentication + + +-- | Makes a new connection to the database server, with specification of port, options & tty +connectWithOptions :: String -- ^ Server name + -> Maybe String -- ^ Port number + -> Maybe String -- ^ Options + -> Maybe String -- ^ TTY + -> String -- ^ Database name + -> String -- ^ User identifier + -> String -- ^ Authentication string (password) + -> IO Connection +connectWithOptions server port options tty database user authentication = do pServer <- newCString server + pPort <- newCStringElseNullPtr port + pOptions <- newCStringElseNullPtr options + pTty <- newCStringElseNullPtr tty pDatabase <- newCString database pUser <- newCString user pAuthentication <- newCString authentication - pConn <- pqSetdbLogin pServer nullPtr nullPtr nullPtr pDatabase pUser pAuthentication + pConn <- pqSetdbLogin pServer pPort pOptions pTty pDatabase pUser pAuthentication free pServer + free pPort + free pOptions + free pTty free pUser free pAuthentication status <- pqStatus pConn @@ -219,3 +253,11 @@ pStr <- pqGetvalue pRes index colNumber strLen <- strlen pStr f fieldDef pStr strLen + + +-- | Convert string by newCString, if provided, else return of nullPtr +newCStringElseNullPtr :: Maybe String -> IO CString +newCStringElseNullPtr Nothing = + return nullPtr +newCStringElseNullPtr (Just string) = + newCString string diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -2,30 +2,34 @@ \begin{code} import Data.Maybe(fromMaybe) -import Distribution.PackageDescription -import Distribution.Setup -import Distribution.Simple +import Distribution.PackageDescription(HookedBuildInfo,emptyHookedBuildInfo + ,PackageDescription,emptyBuildInfo + ,BuildInfo(extraLibDirs,includeDirs)) +import Distribution.PackageDescription.Parse(writeHookedBuildInfo) +import Distribution.Simple(defaultMainWithHooks,autoconfUserHooks + ,preConf,postConf) import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils(rawSystemVerbose) -import System.Info -import System.Exit -import System.Directory +import Distribution.Simple.Setup(ConfigFlags(configVerbosity),Flag(Flag)) +import Distribution.Verbosity(Verbosity,silent) +import System.Exit(ExitCode(ExitSuccess),exitWith) +import System.Directory(removeFile,findExecutable) import System.Process(runInteractiveProcess, waitForProcess) import System.IO(hClose, hGetContents, hPutStr, stderr) import Control.Monad(when) -import Control.Exception(try) +import Control.OldException(try) -main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf} +main = defaultMainWithHooks autoconfUserHooks{preConf= preConf + ,postConf= postConf} where preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo preConf args flags = do try (removeFile "PostgreSQL.buildinfo") return emptyHookedBuildInfo - postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode + postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () postConf args flags _ localbuildinfo = do - mb_bi <- pqConfigBuildInfo (configVerbose flags) + mb_bi <- pqConfigBuildInfo (configVerbosity flags) writeHookedBuildInfo "PostgreSQL.buildinfo" (Just (fromMaybe emptyBuildInfo mb_bi),[]) - return ExitSuccess + \end{code} The following code is derived from Distribution.Simple.Configure @@ -44,9 +48,9 @@ message ("Using " ++ name ++ ": " ++ path) return (Just path) -rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String -rawSystemGrabOutput verbose path args = do - when (verbose > 0) $ +rawSystemGrabOutput :: (Flag Verbosity) -> FilePath -> [String] -> IO String +rawSystemGrabOutput verbosity path args = do + when (verbosity /= Flag silent) $ putStrLn (path ++ concatMap (' ':) args) (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing exitCode <- waitForProcess pid @@ -65,17 +69,17 @@ Populate BuildInfo using pkg-config tool. \begin{code} -pqConfigBuildInfo :: Int -> IO (Maybe BuildInfo) -pqConfigBuildInfo verbose = do +pqConfigBuildInfo :: (Flag Verbosity) -> IO (Maybe BuildInfo) +pqConfigBuildInfo verbosity = do mb_pq_config_path <- findProgram "pg_config" Nothing case mb_pq_config_path of Just pq_config_path -> do message ("configuring pq library") - res <- rawSystemGrabOutput verbose pq_config_path ["--libdir"] + res <- rawSystemGrabOutput verbosity pq_config_path ["--libdir"] let lib_dirs = words res - res <- rawSystemGrabOutput verbose pq_config_path ["--includedir"] + res <- rawSystemGrabOutput verbosity pq_config_path ["--includedir"] let inc_dirs = words res - res <- rawSystemGrabOutput verbose pq_config_path ["--includedir-server"] + res <- rawSystemGrabOutput verbosity pq_config_path ["--includedir-server"] let inc_dirs_server = words res let bi = emptyBuildInfo{extraLibDirs=lib_dirs, includeDirs=inc_dirs++inc_dirs_server} return (Just bi) diff --git a/hsql-postgresql.cabal b/hsql-postgresql.cabal --- a/hsql-postgresql.cabal +++ b/hsql-postgresql.cabal @@ -1,10 +1,12 @@ -name: hsql-postgresql -version: 1.7 -license: BSD3 -author: Krasimir Angelov -category: Database -description: PostgreSQL driver for HSQL. -exposed-modules: Database.HSQL.PostgreSQL -build-depends: base, hsql -extensions: ForeignFunctionInterface, CPP -extra-libraries: pq +Name: hsql-postgresql +Version: 1.7.1 +License: BSD3 +Author: Krasimir Angelov +Category: Database +Description: PostgreSQL driver for HSQL. +Exposed-modules: Database.HSQL.PostgreSQL +Build-depends: base, hsql, old-time +Maintainer: nick.rudnick@googlemail.com +Extensions: ForeignFunctionInterface, CPP +Build-Type: Custom +Extra-libraries: pq