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 < countTuples1))
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) (throw 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
newCStringElseNullPtr :: Maybe String -> IO CString
newCStringElseNullPtr Nothing =
return nullPtr
newCStringElseNullPtr (Just string) =
newCString string