[Pkg-haskell-commits] r1064 - in /packages/haskell-hsql-postgresql: ./ branches/ branches/upstream/ branches/upstream/current/ branches/upstream/current/Database/ branches/upstream/current/Database/HSQL/
arjan at users.alioth.debian.org
arjan at users.alioth.debian.org
Mon Feb 4 05:57:12 UTC 2008
Author: arjan
Date: Mon Feb 4 05:57:12 2008
New Revision: 1064
URL: http://svn.debian.org/wsvn/pkg-haskell/?sc=1&rev=1064
Log:
[svn-inject] Installing original source of haskell-hsql-postgresql
Added:
packages/haskell-hsql-postgresql/
packages/haskell-hsql-postgresql/branches/
packages/haskell-hsql-postgresql/branches/upstream/
packages/haskell-hsql-postgresql/branches/upstream/current/
packages/haskell-hsql-postgresql/branches/upstream/current/Database/
packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/
packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/PostgreSQL.hsc (with props)
packages/haskell-hsql-postgresql/branches/upstream/current/Setup.lhs (with props)
packages/haskell-hsql-postgresql/branches/upstream/current/hsql-postgresql.cabal (with props)
Added: packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/PostgreSQL.hsc
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/PostgreSQL.hsc?rev=1064&op=file
==============================================================================
--- packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/PostgreSQL.hsc (added)
+++ packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/PostgreSQL.hsc Mon Feb 4 05:57:12 2008
@@ -1,0 +1,221 @@
+-----------------------------------------------------------------------------------------
+{-| Module : Database.HSQL.PostgreSQL
+ Copyright : (c) Krasimir Angelov 2003
+ License : BSD-style
+
+ Maintainer : ka2_mail at yahoo.com
+ Stability : provisional
+ Portability : portable
+
+ The module provides interface to PostgreSQL database
+-}
+-----------------------------------------------------------------------------------------
+
+module Database.HSQL.PostgreSQL(connect, module Database.HSQL) where
+
+import Database.HSQL
+import Database.HSQL.Types
+import Data.Dynamic
+import Data.Char
+import Foreign
+import Foreign.C
+import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..))
+import Control.Monad(when,unless,mplus)
+import Control.Concurrent.MVar
+import System.Time
+import System.IO.Unsafe
+import Text.ParserCombinators.ReadP
+import Text.Read
+import Numeric
+
+# include <time.h>
+#include <libpq-fe.h>
+#include <postgres.h>
+#include <catalog/pg_type.h>
+
+type PGconn = Ptr ()
+type PGresult = Ptr ()
+type ConnStatusType = #type ConnStatusType
+type ExecStatusType = #type ExecStatusType
+type Oid = #type Oid
+
+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
+
+foreign import ccall "strlen" strlen :: CString -> IO Int
+
+-----------------------------------------------------------------------------------------
+-- Connect/Disconnect
+-----------------------------------------------------------------------------------------
+
+-- | Makes a new connection to the database server.
+connect :: String -- ^ Server name
+ -> String -- ^ Database name
+ -> String -- ^ User identifier
+ -> String -- ^ Authentication string (password)
+ -> IO Connection
+connect server database user authentication = do
+ pServer <- newCString server
+ pDatabase <- newCString database
+ pUser <- newCString user
+ pAuthentication <- newCString authentication
+ pConn <- pqSetdbLogin pServer nullPtr nullPtr nullPtr pDatabase pUser pAuthentication
+ free pServer
+ free pUser
+ free pAuthentication
+ status <- pqStatus pConn
+ unless (status == (#const CONNECTION_OK)) (do
+ errMsg <- pqErrorMessage pConn >>= peekCString
+ pqFinish pConn
+ throwDyn (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
+ execute :: PGconn -> String -> IO ()
+ execute pConn sqlExpr = do
+ pRes <- withCString sqlExpr (pqExec pConn)
+ when (pRes==nullPtr) (do
+ errMsg <- pqErrorMessage pConn >>= peekCString
+ throwDyn (SqlError {seState="E", seNativeError=(#const PGRES_FATAL_ERROR), seErrorMsg=errMsg}))
+ status <- pqResultStatus pRes
+ unless (status == (#const PGRES_COMMAND_OK) || status == (#const PGRES_TUPLES_OK)) (do
+ errMsg <- pqResultErrorMessage pRes >>= peekCString
+ throwDyn (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
+ throwDyn (SqlError {seState="E", seNativeError=(#const PGRES_FATAL_ERROR), seErrorMsg=errMsg}))
+ status <- pqResultStatus pRes
+ unless (status == (#const PGRES_COMMAND_OK) || status == (#const PGRES_TUPLES_OK)) (do
+ errMsg <- pqResultErrorMessage pRes >>= peekCString
+ throwDyn (SqlError {seState="E", seNativeError=fromIntegral status, seErrorMsg=errMsg}))
+ defs <- if status == (#const PGRES_TUPLES_OK) 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)
+
+ 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)
+
+ 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 "select relname from pg_class where relkind='r' and relname !~ '^pg_'"
+ collectRows (\s -> getFieldValue s 0 ("relname", SqlVarChar 0, False) "") stmt
+
+ describe :: Connection -> PGconn -> String -> IO [FieldDef]
+ describe connection pConn table = do
+ stmt <- query connection pConn
+ ("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 table++
+ " and cols.attisdropped = False ")
+
+ 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)
+
+ fetch :: MVar Int -> Int -> IO Bool
+ fetch tupleIndex countTuples =
+ modifyMVar tupleIndex (\index -> return (index+1,index < countTuples-1))
+
+ getColValue :: PGresult -> MVar Int -> Int -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
+ getColValue pRes tupleIndex countTuples colNumber fieldDef f = do
+ index <- readMVar tupleIndex
+ when (index >= countTuples) (throwDyn SqlNoData)
+ 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
Propchange: packages/haskell-hsql-postgresql/branches/upstream/current/Database/HSQL/PostgreSQL.hsc
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-postgresql/branches/upstream/current/Setup.lhs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-postgresql/branches/upstream/current/Setup.lhs?rev=1064&op=file
==============================================================================
--- packages/haskell-hsql-postgresql/branches/upstream/current/Setup.lhs (added)
+++ packages/haskell-hsql-postgresql/branches/upstream/current/Setup.lhs Mon Feb 4 05:57:12 2008
@@ -1,0 +1,85 @@
+#!/usr/bin/runghc
+
+\begin{code}
+import Data.Maybe(fromMaybe)
+import Distribution.PackageDescription
+import Distribution.Setup
+import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Utils(rawSystemVerbose)
+import System.Info
+import System.Exit
+import System.Directory
+import System.Process(runInteractiveProcess, waitForProcess)
+import System.IO(hClose, hGetContents, hPutStr, stderr)
+import Control.Monad(when)
+import Control.Exception(try)
+
+main = defaultMainWithHooks defaultUserHooks{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 args flags _ localbuildinfo = do
+ mb_bi <- pqConfigBuildInfo (configVerbose flags)
+ writeHookedBuildInfo "PostgreSQL.buildinfo" (Just (fromMaybe emptyBuildInfo mb_bi),[])
+ return ExitSuccess
+\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 :: Int -> FilePath -> [String] -> IO String
+rawSystemGrabOutput verbose path args = do
+ when (verbose > 0) $
+ 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 :: Int -> IO (Maybe BuildInfo)
+pqConfigBuildInfo verbose = 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"]
+ let lib_dirs = words res
+ res <- rawSystemGrabOutput verbose pq_config_path ["--includedir"]
+ let inc_dirs = words res
+ res <- rawSystemGrabOutput verbose 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)
+ Nothing -> do
+ message ("The package will be built using default settings for pq library")
+ return Nothing
+\end{code}
Propchange: packages/haskell-hsql-postgresql/branches/upstream/current/Setup.lhs
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-postgresql/branches/upstream/current/hsql-postgresql.cabal
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-postgresql/branches/upstream/current/hsql-postgresql.cabal?rev=1064&op=file
==============================================================================
--- packages/haskell-hsql-postgresql/branches/upstream/current/hsql-postgresql.cabal (added)
+++ packages/haskell-hsql-postgresql/branches/upstream/current/hsql-postgresql.cabal Mon Feb 4 05:57:12 2008
@@ -1,0 +1,10 @@
+name: hsql-postgresql
+version: 1.7
+license: BSD3
+author: Krasimir Angelov <kr.angelov at gmail.com>
+category: Database
+description: PostgreSQL driver for HSQL.
+exposed-modules: Database.HSQL.PostgreSQL
+build-depends: base, hsql
+extensions: ForeignFunctionInterface, CPP
+extra-libraries: pq
Propchange: packages/haskell-hsql-postgresql/branches/upstream/current/hsql-postgresql.cabal
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-haskell-commits
mailing list