{-| 
-}
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 -> 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


-- | Convert string by newCString, if provided, else return of nullPtr
newCStringElseNullPtr :: Maybe String -> IO CString
newCStringElseNullPtr Nothing =
    return nullPtr
newCStringElseNullPtr (Just string) =
    newCString string