hsql-postgresql 1.7 → 1.7.1
raw patch · 3 files changed
+84/−36 lines, 3 filesdep +old-timesetup-changednew-uploader
Dependencies added: old-time
Files
- Database/HSQL/PostgreSQL.hsc +48/−6
- Setup.lhs +24/−20
- hsql-postgresql.cabal +12/−10
Database/HSQL/PostgreSQL.hsc view
@@ -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 <time.h>+#include <time.h> #include <libpq-fe.h> #include <postgres.h> #include <catalog/pg_type.h>@@ -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
Setup.lhs view
@@ -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)
hsql-postgresql.cabal view
@@ -1,10 +1,12 @@-name: hsql-postgresql-version: 1.7-license: BSD3-author: Krasimir Angelov <kr.angelov@gmail.com>-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 <kr.angelov@gmail.com>+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