hsql-postgresql-1.8.2/0000755000175000017500000000000011735605016012140 5ustar iihsql-postgresql-1.8.2/ChangeLog0000644000175000017500000000064711326713166013723 0ustar ii2010-1-24 1.8.1: uses updated exception handling of hsql-1.8.1; refactorings 2009-2-15 1.7.3: filtering out of zombie dir paths returned `pg_config --includedir-server', (headers are usually in the top include directory then) to prevent unnecessary error exit. 2009-2-13 1.7.2: constrained requirement of `base' by `>=4.0.0.0' to stop cabal-install from assuming base-3.?.?.? hsql-postgresql-1.8.2/DB/0000755000175000017500000000000011326641555012431 5ustar iihsql-postgresql-1.8.2/DB/HSQL/0000755000175000017500000000000011326641557013202 5ustar iihsql-postgresql-1.8.2/DB/HSQL/PG/0000755000175000017500000000000011735604224013502 5ustar iihsql-postgresql-1.8.2/DB/HSQL/PG/Core.hs0000644000175000017500000000640511735604064014735 0ustar ii{-| -} module DB.HSQL.PG.Core where import Database.HSQL hiding(fetch,describe,query,execute) import Database.HSQL.Types(Statement(..)) import Foreign(nullPtr) import Foreign.C(CString,newCString,peekCString,withCString) import Control.Exception (throw) import Control.Monad(when,unless) import Control.Concurrent.MVar(MVar,newMVar,modifyMVar,readMVar) import DB.HSQL.PG.Functions import DB.HSQL.PG.Type(mkSqlType) import DB.HSQL.PG.Status(pgTuplesOk,pgCommandOk,pgFatalError) -- | execute :: PGconn -> String -> IO () execute pConn sqlExpr = do pRes <- withCString sqlExpr (pqExec pConn) when (pRes==nullPtr) (do errMsg <- pqErrorMessage pConn >>= peekCString throw (SqlError { seState="E" , seNativeError=fromIntegral pgFatalError , seErrorMsg=errMsg })) status <- pqResultStatus pRes unless (status == pgCommandOk || status == pgTuplesOk) (do errMsg <- pqResultErrorMessage pRes >>= peekCString throw (SqlError { seState="E" , seNativeError=fromIntegral status , seErrorMsg=errMsg })) return () -- | query :: Connection -> PGconn -> String -> IO Statement query conn pConn query = do pRes <- withCString query (pqExec pConn) when (pRes==nullPtr) (do errMsg <- pqErrorMessage pConn >>= peekCString throw (SqlError { seState="E" , seNativeError=fromIntegral pgFatalError , seErrorMsg=errMsg })) status <- pqResultStatus pRes unless (status == pgCommandOk || status == pgTuplesOk) (do errMsg <- pqResultErrorMessage pRes >>= peekCString throw (SqlError { seState="E" , seNativeError=fromIntegral status , seErrorMsg=errMsg })) defs <- if status == pgTuplesOk then pgNFields pRes >>= getFieldDefs pRes 0 else return [] countTuples <- pqNTuples pRes; tupleIndex <- newMVar (-1) refFalse <- newMVar False return (Statement { stmtConn = conn , stmtClose = return () , stmtFetch = fetch tupleIndex countTuples , stmtGetCol = getColValue pRes tupleIndex countTuples , stmtFields = defs , stmtClosed = refFalse }) where getFieldDefs pRes i n | i >= n = return [] | otherwise = do name <- pgFName pRes i >>= peekCString dataType <- pqFType pRes i modifier <- pqFMod pRes i defs <- getFieldDefs pRes (i+1) n return ((name,mkSqlType dataType modifier,True):defs) -- | fetch :: MVar Int -> Int -> IO Bool fetch tupleIndex countTuples = modifyMVar tupleIndex (\index -> return (index+1,index < countTuples-1)) -- | getColValue :: PGresult -> MVar Int -> Int -> Int -> ColDef -> (ColDef -> CString -> Int -> IO a) -> IO a getColValue pRes tupleIndex countTuples colNumber fieldDef f = do index <- readMVar tupleIndex when (index >= countTuples) (throw SqlNoMoreData) isnull <- pqGetisnull pRes index colNumber if isnull == 1 then f fieldDef nullPtr 0 else do 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 hsql-postgresql-1.8.2/DB/HSQL/PG/Functions.hsc0000644000175000017500000000403111326705603016146 0ustar ii{-# LANGUAGE ForeignFunctionInterface #-} {-| Interface to the functions of the the foreign code environment. -} module DB.HSQL.PG.Functions where import Foreign(Ptr,Word32) import Foreign.C(CString) import DB.HSQL.PG.Status(ConnStatusType,ExecStatusType) import DB.HSQL.PG.Type(Oid) #include #include type PGconn = Ptr () type PGresult = Ptr () foreign import ccall "strlen" strlen :: CString -> IO Int {-| 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 foreign import ccall "libpq-fe.h PQfinish" pqFinish :: PGconn -> IO () foreign import ccall "libpq-fe.h PQexec" pqExec :: PGconn -> CString -> IO PGresult foreign import ccall "libpq-fe.h PQresultStatus" pqResultStatus :: PGresult -> IO ExecStatusType foreign import ccall "libpq-fe.h PQresStatus" pqResStatus :: ExecStatusType -> IO CString foreign import ccall "libpq-fe.h PQresultErrorMessage" pqResultErrorMessage :: PGresult -> IO CString foreign import ccall "libpq-fe.h PQnfields" pgNFields :: PGresult -> IO Int foreign import ccall "libpq-fe.h PQntuples" pqNTuples :: PGresult -> IO Int foreign import ccall "libpq-fe.h PQfname" pgFName :: PGresult -> Int -> IO CString foreign import ccall "libpq-fe.h PQftype" pqFType :: PGresult -> Int -> IO Oid foreign import ccall "libpq-fe.h PQfmod" pqFMod :: PGresult -> Int -> IO Int foreign import ccall "libpq-fe.h PQfnumber" pqFNumber :: PGresult -> CString -> IO Int foreign import ccall "libpq-fe.h PQgetvalue" pqGetvalue :: PGresult -> Int -> Int -> IO CString foreign import ccall "libpq-fe.h PQgetisnull" pqGetisnull :: PGresult -> Int -> Int -> IO Int hsql-postgresql-1.8.2/DB/HSQL/PG/Status.hsc0000644000175000017500000000072711326655046015476 0ustar iimodule DB.HSQL.PG.Status where import Foreign(Word32) #include -- | type ConnStatusType = #type ConnStatusType type ExecStatusType = #type ExecStatusType -- | connectionOk:: ConnStatusType connectionOk = (#const CONNECTION_OK) -- | pgTuplesOk:: ExecStatusType pgTuplesOk = (#const PGRES_TUPLES_OK) -- | pgCommandOk:: ExecStatusType pgCommandOk = (#const PGRES_COMMAND_OK) -- | pgFatalError:: ExecStatusType pgFatalError = (#const PGRES_FATAL_ERROR)hsql-postgresql-1.8.2/DB/HSQL/PG/Sql.hs0000644000175000017500000000121711326703776014606 0ustar ii{-| SQL queries. -} module DB.HSQL.PG.Sql where import Database.HSQL.Types(SqlBind(toSqlValue)) -- | retrieval of the names of all tables sqlAllTableNames:: String sqlAllTableNames = "SELECT relname FROM pg_class WHERE relkind='r' AND relname !~ '^pg_'" -- | retrieval of the field defs for a table name sqlAllFieldDefsForTableName:: SqlBind t=> t-> String sqlAllFieldDefsForTableName tableName = "SELECT attname, atttypid, atttypmod, attnotnull " ++"FROM pg_attribute AS cols JOIN pg_class AS ts ON cols.attrelid=ts.oid " ++"WHERE cols.attnum > 0 AND ts.relname="++ (toSqlValue tableName) ++" AND cols.attisdropped = FALSE " hsql-postgresql-1.8.2/DB/HSQL/PG/Type.hsc0000644000175000017500000000376411326712720015131 0ustar iimodule DB.HSQL.PG.Type where import Foreign(Word32) import Database.HSQL(SqlType(..)) #include #include -- | type Oid = #type Oid -- | mkSqlType :: Oid -> Int -> SqlType mkSqlType (#const BPCHAROID) size = SqlChar (size-4) mkSqlType (#const VARCHAROID) size = SqlVarChar (size-4) mkSqlType (#const NAMEOID) size = SqlVarChar 31 mkSqlType (#const TEXTOID) size = SqlText mkSqlType (#const NUMERICOID) size = SqlNumeric ((size-4) `div` 0x10000) ((size-4) `mod` 0x10000) mkSqlType (#const INT2OID) size = SqlSmallInt mkSqlType (#const INT4OID) size = SqlInteger mkSqlType (#const FLOAT4OID) size = SqlReal mkSqlType (#const FLOAT8OID) size = SqlDouble mkSqlType (#const BOOLOID) size = SqlBit mkSqlType (#const BITOID) size = SqlBinary size mkSqlType (#const VARBITOID) size = SqlVarBinary size mkSqlType (#const BYTEAOID) size = SqlTinyInt mkSqlType (#const INT8OID) size = SqlBigInt mkSqlType (#const DATEOID) size = SqlDate mkSqlType (#const TIMEOID) size = SqlTime mkSqlType (#const TIMETZOID) size = SqlTimeTZ mkSqlType (#const ABSTIMEOID) size = SqlAbsTime mkSqlType (#const RELTIMEOID) size = SqlRelTime mkSqlType (#const INTERVALOID) size = SqlTimeInterval mkSqlType (#const TINTERVALOID) size = SqlAbsTimeInterval mkSqlType (#const TIMESTAMPOID) size = SqlDateTime mkSqlType (#const TIMESTAMPTZOID) size = SqlDateTimeTZ mkSqlType (#const CASHOID) size = SqlMoney mkSqlType (#const INETOID) size = SqlINetAddr mkSqlType (#const 829) size = SqlMacAddr -- hack mkSqlType (#const CIDROID) size = SqlCIDRAddr mkSqlType (#const POINTOID) size = SqlPoint mkSqlType (#const LSEGOID) size = SqlLSeg mkSqlType (#const PATHOID) size = SqlPath mkSqlType (#const BOXOID) size = SqlBox mkSqlType (#const POLYGONOID) size = SqlPolygon mkSqlType (#const LINEOID) size = SqlLine mkSqlType (#const CIRCLEOID) size = SqlCircle mkSqlType tp size = SqlUnknown (fromIntegral tp)hsql-postgresql-1.8.2/LICENSE0000644000175000017500000000274311145152653013152 0ustar iiCopyright (c) 2009, Krasimir Angelov All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hsql-postgresql-1.8.2/Database/0000755000175000017500000000000010606505313013637 5ustar iihsql-postgresql-1.8.2/Database/HSQL/0000755000175000017500000000000011735604232014412 5ustar iihsql-postgresql-1.8.2/Database/HSQL/PostgreSQL.hs0000644000175000017500000001141611735604155016760 0ustar ii{-| Module : Database.HSQL.PostgreSQL Copyright : (c) Krasimir Angelov 2003 License : BSD-style Maintainer : ka2_mail@yahoo.com Stability : provisional Portability : portable The module provides an interface to PostgreSQL database -} module Database.HSQL.PostgreSQL(connect, connectWithOptions, module Database.HSQL) where import Foreign(free) import Foreign.C(newCString,peekCString) import Control.Exception (throw) import Control.Monad(unless) import Control.Concurrent.MVar(newMVar) import Database.HSQL hiding(query,execute) import Database.HSQL.Types(Connection(..),Statement(stmtGetCol)) import DB.HSQL.PG.Functions import DB.HSQL.PG.Type(mkSqlType) import DB.HSQL.PG.Core(query,execute,newCStringElseNullPtr) import DB.HSQL.PG.Status(connectionOk) import DB.HSQL.PG.Sql(sqlAllTableNames,sqlAllFieldDefsForTableName) ------------------------------------------------------------------------------ -- Connect/Disconnect ------------------------------------------------------------------------------ -- | 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 pPort pOptions pTty pDatabase pUser pAuthentication free pServer free pPort free pOptions free pTty free pUser free pAuthentication status <- pqStatus pConn unless (status == connectionOk) (do errMsg <- pqErrorMessage pConn >>= peekCString pqFinish pConn throw (SqlError { seState="C" , seNativeError=fromIntegral status , seErrorMsg=errMsg })) refFalse <- newMVar False let connection = Connection { connDisconnect = pqFinish pConn , connExecute = execute pConn , connQuery = query connection pConn , connTables = tables connection pConn , connDescribe = describe connection pConn , connBeginTransaction = execute pConn "BEGIN" , connCommitTransaction = execute pConn "COMMIT" , connRollbackTransaction = execute pConn "ROLLBACK" , connClosed = refFalse } return connection where getFieldValue stmt colNumber fieldDef v = do mb_v <- stmtGetCol stmt colNumber fieldDef fromSqlCStringLen return (case mb_v of { Nothing -> v; Just a -> a }) tables :: Connection -> PGconn -> IO [String] tables connection pConn = do stmt <- query connection pConn sqlAllTableNames collectRows (\s -> getFieldValue s 0 ("relname", SqlVarChar 0, False) "") stmt describe :: Connection -> PGconn -> String -> IO [ColDef] describe connection pConn table = do stmt <- query connection pConn (sqlAllFieldDefsForTableName table) collectRows getColumnInfo stmt where getColumnInfo stmt = do column_name <- getFieldValue stmt 0 ("attname", SqlVarChar 0, False) "" data_type <- getFieldValue stmt 1 ("atttypid", SqlInteger, False) 0 type_mod <- getFieldValue stmt 2 ("atttypmod", SqlInteger, False) 0 notnull <- getFieldValue stmt 3 ("attnotnull", SqlBit, False) False let sqlType = mkSqlType (fromIntegral (data_type :: Int)) (fromIntegral (type_mod :: Int)) return (column_name, sqlType, not notnull) hsql-postgresql-1.8.2/Setup.lhs0000644000175000017500000000766711326672510013767 0ustar ii#!/usr/bin/runghc \begin{code} import Data.Maybe(fromMaybe) 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.Setup(ConfigFlags(configVerbosity),Flag(Flag)) import Distribution.Verbosity(Verbosity,silent) import System.Exit(ExitCode(ExitSuccess),exitWith) import System.Directory(removeFile,findExecutable,doesDirectoryExist) import System.Process(runInteractiveProcess, waitForProcess) import System.IO(hClose, hGetContents, hPutStr, stderr) import Control.Monad(when) import Control.Exception(SomeException,try) main = defaultMainWithHooks autoconfUserHooks{preConf= preConf ,postConf= postConf} where preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo preConf args flags = do try (removeFile "PostgreSQL.buildinfo")::IO (Either SomeException ()) return emptyHookedBuildInfo postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () postConf args flags _ localbuildinfo = do mb_bi <- pqConfigBuildInfo (configVerbosity flags) writeHookedBuildInfo "PostgreSQL.buildinfo" (Just (fromMaybe emptyBuildInfo mb_bi),[]) \end{code} The following code is derived from Distribution.Simple.Configure \begin{code} findProgram :: String -- ^ program name -> Maybe FilePath -- ^ optional explicit path -> IO (Maybe FilePath) findProgram name Nothing = do mb_path <- findExecutable name case mb_path of Nothing -> message ("No " ++ name ++ " found") Just path -> message ("Using " ++ name ++ ": " ++ path) return mb_path findProgram name (Just path) = do message ("Using " ++ name ++ ": " ++ path) return (Just path) 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 if exitCode /= ExitSuccess then do errMsg <- hGetContents err hPutStr stderr errMsg exitWith exitCode else return () hClose inp hClose err hGetContents out message :: String -> IO () message s = putStrLn $ "configure: " ++ s \end{code} Populate BuildInfo using pkg-config tool. \begin{code} 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 verbosity pq_config_path ["--libdir"] let lib_dirs= words res res <- rawSystemGrabOutput verbosity pq_config_path ["--includedir"] let inc_dirs= words res res <- rawSystemGrabOutput verbosity pq_config_path ["--includedir-server"] let inc_dirs_server'= words res inc_dirs_server <-onlyExistingDirsOf inc_dirs_server' let bi= emptyBuildInfo{extraLibDirs= lib_dirs ,includeDirs= inc_dirs++inc_dirs_server} return (Just bi) Nothing -> do message ("The package will be built using default settings for pq library") return Nothing onlyExistingDirsOf:: [FilePath]-> IO [FilePath] onlyExistingDirsOf [] = return [] onlyExistingDirsOf (dirPath:restPaths') = do restPaths <-onlyExistingDirsOf restPaths' exists <-doesDirectoryExist dirPath if exists then return (dirPath:restPaths) else do message ("missing directory: "++dirPath) return restPaths \end{code} hsql-postgresql-1.8.2/PostgreSQL.buildinfo0000664000175000017500000000073111735604163016045 0ustar iibuildable: True build-tools: cpp-options: cc-options: ld-options: pkgconfig-depends: frameworks: c-sources: default-language: other-languages: default-extensions: other-extensions: extensions: extra-libraries: extra-lib-dirs: /usr/lib includes: install-includes: include-dirs: /usr/include/postgresql /usr/include/postgresql/9.1/server hs-source-dirs: other-modules: ghc-prof-options: ghc-shared-options: ghc-options: hugs-options: nhc98-options: jhc-options:hsql-postgresql-1.8.2/hsql-postgresql.cabal0000644000175000017500000000111011735603557016275 0ustar iiName: hsql-postgresql Version: 1.8.2 Synopsis: A Haskell Interface to PostgreSQL via the PQ library. License: BSD3 License-file: LICENSE Author: Krasimir Angelov Category: Database Description: PostgreSQL driver for HSQL. Exposed-modules: DB.HSQL.PG.Core, DB.HSQL.PG.Sql, DB.HSQL.PG.Status, DB.HSQL.PG.Type, DB.HSQL.PG.Functions, Database.HSQL.PostgreSQL Build-depends: base >= 4 && <5, hsql >= 1.8.2 && < 1.9, old-time Maintainer: nick.rudnick@googlemail.com -- Extensions: Build-Type: Custom Extra-libraries: pq