{-# LINE 1 "Database/HDBC/ODBC/Statement.hsc" #-}
-- -*- mode: haskell; -*-
{-# LINE 2 "Database/HDBC/ODBC/Statement.hsc" #-}
{-# CFILES hdbc-odbc-helper.c #-}
-- Above line for hugs
{-
Copyright (C) 2005-2006 John Goerzen <jgoerzen@complete.org>

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
-}
module Database.HDBC.ODBC.Statement where
import Database.HDBC.Types
import Database.HDBC
import Database.HDBC.DriverUtils
import Database.HDBC.ODBC.Types
import Database.HDBC.ODBC.Utils
import Database.HDBC.ODBC.TypeConv
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Concurrent.MVar
import Foreign.C.String
import Foreign.Marshal
import Foreign.Storable
import Control.Monad
import Data.List
import Data.Word
import Data.Int
import Control.Exception
import System.IO
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BUTF8
import qualified Data.ByteString.Unsafe as B

l _ = return ()
--l m = hPutStrLn stderr ("\n" ++ m)


{-# LINE 52 "Database/HDBC/ODBC/Statement.hsc" #-}

{-# LINE 53 "Database/HDBC/ODBC/Statement.hsc" #-}

{-# LINE 54 "Database/HDBC/ODBC/Statement.hsc" #-}


{-# LINE 58 "Database/HDBC/ODBC/Statement.hsc" #-}

{-# LINE 59 "Database/HDBC/ODBC/Statement.hsc" #-}

{-# LINE 60 "Database/HDBC/ODBC/Statement.hsc" #-}

data SState = 
    SState { stomv :: MVar (Maybe Stmt),
             dbo :: Conn,
             squery :: String,
             colinfomv :: MVar [(String, SqlColDesc)]}

-- FIXME: we currently do no prepare optimization whatsoever.

newSState :: Conn -> String -> IO SState
newSState indbo query =
    do newstomv <- newMVar Nothing
       newcolinfomv <- newMVar []
       return SState {stomv = newstomv, 
                      dbo = indbo, squery = query,
                      colinfomv = newcolinfomv}

wrapStmt :: SState -> Statement
wrapStmt sstate =
    Statement {execute = fexecute sstate,
                           executeMany = fexecutemany sstate,
                           finish = public_ffinish sstate,
                           fetchRow = ffetchrow sstate,
                           originalQuery = (squery sstate),
                           getColumnNames = readMVar (colinfomv sstate)
                                            >>= (return . map fst),
                           describeResult = readMVar (colinfomv sstate)}

newSth :: Conn -> ChildList -> String -> IO Statement               
newSth indbo mchildren query = 
    do l "in newSth"
       sstate <- newSState indbo query
       let retval = wrapStmt sstate
       addChild mchildren retval
       return retval

makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
                     withConn iconn $ \cconn -> 
                     withCString "" $ \emptycs ->
    do rc1 <- sqlAllocStmtHandle 3 cconn psthptr
{-# LINE 100 "Database/HDBC/ODBC/Statement.hsc" #-}
       sthptr <- peek psthptr
       wrappedsthptr <- withRawConn iconn
                        (\rawconn -> wrapstmt sthptr rawconn)
       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
       checkError (name ++ " allocHandle") (DbcHandle cconn) rc1
       return fsthptr

wrapTheStmt iconn fsthptr =
    do sstate <- newSState iconn ""
       sstate <- newSState iconn ""
       swapMVar (stomv sstate) (Just fsthptr)
       let sth = wrapStmt sstate
       return sth

fgettables iconn =
    do fsthptr <- makesth iconn "fgettables"
       withStmt fsthptr (\sthptr ->
                             simpleSqlTables sthptr >>=
                                checkError "gettables simpleSqlTables" 
                                               (StmtHandle sthptr)
                        )
       sth <- wrapTheStmt iconn fsthptr
       results <- fetchAllRows' sth
       l (show results)
       return $ map (\x -> fromSql (x !! 2)) results

fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ 
                                 \(cs, csl) ->
    do fsthptr <- makesth iconn "fdescribetable"
       withStmt fsthptr (\sthptr ->
                             simpleSqlColumns sthptr cs (fromIntegral csl) >>=
                               checkError "fdescribetable simpleSqlColumns"
                                          (StmtHandle sthptr)
                        )
       sth <- wrapTheStmt iconn fsthptr
       results <- fetchAllRows' sth
       l (show results)
       return $ map fromOTypeCol results

{- For now, we try to just  handle things as simply as possible.
FIXME lots of room for improvement here (types, etc). -}
fexecute sstate args = withConn (dbo sstate) $ \cconn ->
                       B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ 
                            \(cquery, cqlen) ->
                       alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
    do l "in fexecute"
       public_ffinish sstate  
       rc1 <- sqlAllocStmtHandle 3 cconn psthptr
{-# LINE 148 "Database/HDBC/ODBC/Statement.hsc" #-}
       sthptr <- peek psthptr
       wrappedsthptr <- withRawConn (dbo sstate)
                        (\rawconn -> wrapstmt sthptr rawconn)
       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
       checkError "execute allocHandle" (DbcHandle cconn) rc1

       sqlPrepare sthptr cquery (fromIntegral cqlen) >>= 
            checkError "execute prepare" (StmtHandle sthptr)

       argsToFree <- zipWithM (bindCol sthptr) args [1..]

       r <- sqlExecute sthptr
            
       -- Our bound columns must be valid through this point,
       -- but we don't care after here.
       mapM (\(x, y) -> touchForeignPtr x >> touchForeignPtr y)
                (concat argsToFree) 

       case r of
         100 -> return () -- Update that did nothing
{-# LINE 168 "Database/HDBC/ODBC/Statement.hsc" #-}
         x -> checkError "execute execute" (StmtHandle sthptr) x

       rc <- getNumResultCols sthptr
       
       case rc of
         0 -> do rowcount <- getSqlRowCount sthptr
                 ffinish fsthptr
                 swapMVar (colinfomv sstate) []
                 touchForeignPtr fsthptr
                 return (fromIntegral rowcount)
         colcount -> do fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)
                        swapMVar (stomv sstate) (Just fsthptr)
                        touchForeignPtr fsthptr
                        return 0

getNumResultCols sthptr = alloca $ \pcount ->
    do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" 
                                          (StmtHandle sthptr)
       peek pcount
    
-- Bind a parameter column before execution.

bindCol sthptr arg icol =  alloca $ \pdtype ->
                           alloca $ \pcolsize ->
                           alloca $ \pdecdigits ->
                           alloca $ \pnullable ->
{- We have to start by getting the SQL type of the column so we can
   send the correct type back to the server.  Sigh.  If the ODBC
   backend won't tell us the type, we fake it.

   We've got an annoying situation with error handling.  Must make
   sure that all data is freed, but if there's an error, we have to raise
   it and the caller never gets to freed the allocated data to-date.
   So, make sure we either free of have foreignized everything before
   control passes out of this function. -}

    do rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits
                      pnullable
       when (not (isOK rc1)) $ -- Some drivers don't support that call
          do poke pdtype 1
{-# LINE 208 "Database/HDBC/ODBC/Statement.hsc" #-}
             poke pcolsize 0
             poke pdecdigits 0
       coltype <- peek pdtype
       colsize <- peek pcolsize
       decdigits <- peek pdecdigits
       case arg of
         SqlNull -> -- NULL parameter, bind it as such.
                    do rc2 <- sqlBindParameter sthptr (fromIntegral icol)
                              1
{-# LINE 217 "Database/HDBC/ODBC/Statement.hsc" #-}
                              1 coltype colsize decdigits
{-# LINE 218 "Database/HDBC/ODBC/Statement.hsc" #-}
                              nullPtr 0 nullData
                       checkError ("bindparameter " ++ show icol)
                                      (StmtHandle sthptr) rc2
                       return []
         x -> do -- Otherwise, we have to allocate RAM, make sure it's
                 -- not freed now, and pass it along...
                  (csptr, cslen) <- cstrUtf8BString (fromSql x)
                  do pcslen <- malloc 
                     poke pcslen (fromIntegral cslen)
                     rc2 <- sqlBindParameter sthptr (fromIntegral icol)
                       1
{-# LINE 229 "Database/HDBC/ODBC/Statement.hsc" #-}
                       1 coltype 
{-# LINE 230 "Database/HDBC/ODBC/Statement.hsc" #-}
                       (if isOK rc1 then colsize else fromIntegral cslen + 1) decdigits
                       csptr (fromIntegral cslen + 1) pcslen
                     if isOK rc2
                        then do -- We bound it.  Make foreignPtrs and return.
                                fp1 <- newForeignPtr finalizerFree pcslen
                                fp2 <- newForeignPtr finalizerFree csptr
                                return [(fp1, fp2)]
                        else do -- Binding failed.  Free the data and raise
                                -- error.
                                free pcslen
                                free csptr
                                checkError ("bindparameter " ++ show icol) 
                                               (StmtHandle sthptr) rc2
                                return [] -- will never get hit
       
getSqlRowCount cstmt = alloca $ \prows ->
     do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt)
        peek prows

{- General algorithm: find out how many columns we have, check the type
of each to see if it's NULL.  If it's not, fetch it as text and return that.
-}

cstrUtf8BString :: B.ByteString -> IO CStringLen
cstrUtf8BString bs = do
    B.unsafeUseAsCStringLen bs $ \(s,len) -> do
        res <- mallocBytes (len+1)
        -- copy in
        copyBytes res s len
        -- null terminate
        poke (plusPtr res len) (0::CChar)
        -- return ptr
        return (res, len)


ffetchrow :: SState -> IO (Maybe [SqlValue])
ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> 
             case stmt of
               Nothing -> l "ffr nos" >> return (stmt, Nothing)
               Just cmstmt -> withStmt cmstmt $ \cstmt ->
                 do rc <- sqlFetch cstmt
                    if rc == 100
{-# LINE 272 "Database/HDBC/ODBC/Statement.hsc" #-}
                       then do l "no more rows"
                               -- Don't use public_ffinish here
                               ffinish cmstmt
                               return (Nothing, Nothing)
                       else do l "getting stuff"
                               checkError "sqlFetch" (StmtHandle cstmt) rc
                               ncols <- getNumResultCols cstmt
                               res <- mapM (getCol cstmt ) 
                                      [1..ncols]
                               return (stmt, Just res)
    where getCol cstmt icol =
             do let defaultLen = 128
                colinfo <- readMVar (colinfomv sstate)
                let cBinding = case colType (snd (colinfo !! ((fromIntegral icol) - 1))) of
                                 SqlBinaryT -> -2
{-# LINE 287 "Database/HDBC/ODBC/Statement.hsc" #-}
                                 SqlVarBinaryT -> -2
{-# LINE 288 "Database/HDBC/ODBC/Statement.hsc" #-}
                                 SqlLongVarBinaryT -> -2
{-# LINE 289 "Database/HDBC/ODBC/Statement.hsc" #-}
                                 _ -> 1
{-# LINE 290 "Database/HDBC/ODBC/Statement.hsc" #-}
                alloca $ \plen ->
                 allocaBytes defaultLen $ \buf ->
                   do res <- sqlGetData cstmt (fromIntegral icol) cBinding
                                        buf (fromIntegral defaultLen) plen
                      case res of
                        0 ->
{-# LINE 296 "Database/HDBC/ODBC/Statement.hsc" #-}
                            do len <- peek plen
                               case len of
                                 -1 -> return SqlNull
{-# LINE 299 "Database/HDBC/ODBC/Statement.hsc" #-}
                                 -4 -> fail $ "Unexpected SQL_NO_TOTAL"
{-# LINE 300 "Database/HDBC/ODBC/Statement.hsc" #-}
                                 len -> do bs <- B.packCStringLen (buf, fromIntegral len)
                                           l $ "col is: " ++ show (BUTF8.toString bs)
                                           return (SqlByteString bs)
                        1 ->
{-# LINE 304 "Database/HDBC/ODBC/Statement.hsc" #-}
                            do len <- peek plen
                               allocaBytes (fromIntegral len + 1) $ \buf2 ->
                                 do sqlGetData cstmt (fromIntegral icol) cBinding
                                               buf2 (fromIntegral len + 1) plen
                                               >>= checkError "sqlGetData" (StmtHandle cstmt)
                                    len2 <- peek plen
                                    let firstbuf = case cBinding of
                                                     -2 -> defaultLen
{-# LINE 312 "Database/HDBC/ODBC/Statement.hsc" #-}
                                                     _ -> defaultLen - 1 -- strip off NUL
                                    bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf))
                                          (B.packCStringLen (buf2, fromIntegral len2))
                                    l $ "col is: " ++ (BUTF8.toString bs)
                                    return (SqlByteString bs)
                        res -> raiseError "sqlGetData" res (StmtHandle cstmt)


fgetcolinfo cstmt =
    do ncols <- getNumResultCols cstmt
       mapM getname [1..ncols]
    where getname icol = alloca $ \colnamelp ->
                         allocaBytes 128 $ \cscolname ->
                         alloca $ \datatypeptr ->
                         alloca $ \colsizeptr ->
                         alloca $ \nullableptr ->
              do sqlDescribeCol cstmt icol cscolname 127 colnamelp 
                                datatypeptr colsizeptr nullPtr nullableptr
                 colnamelen <- peek colnamelp
                 colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen)
                 let colname = BUTF8.toString colnamebs
                 datatype <- peek datatypeptr
                 colsize <- peek colsizeptr
                 nullable <- peek nullableptr
                 return $ fromOTypeInfo colname datatype colsize nullable

-- FIXME: needs a faster algorithm.
fexecutemany :: SState -> [[SqlValue]] -> IO ()
fexecutemany sstate arglist =
    mapM_ (fexecute sstate) arglist >> return ()

-- Finish and change state
public_ffinish sstate = 
    do l "public_ffinish"
       modifyMVar_ (stomv sstate) worker
    where worker Nothing = return Nothing
          worker (Just sth) = ffinish sth >> return Nothing

ffinish :: Stmt -> IO ()
ffinish p = withRawStmt p $ sqlFreeHandleSth_app 


foreign import ccall unsafe "hdbc-odbc-helper.h wrapobjodbc"
  wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt)

foreign import ccall unsafe "sql.h SQLDescribeCol"
{-# LINE 358 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlDescribeCol :: Ptr CStmt   
                 -> Int16 -- ^ Column number
{-# LINE 360 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> CString     -- ^ Column name
                 -> Int16 -- ^ Buffer length
{-# LINE 362 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> Ptr (Int16) -- ^ name length ptr
{-# LINE 363 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> Ptr (Int16) -- ^ data type ptr
{-# LINE 364 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> Ptr (Word32) -- ^ column size ptr
{-# LINE 365 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> Ptr (Int16) -- ^ decimal digits ptr
{-# LINE 366 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> Ptr (Int16) -- ^ nullable ptr
{-# LINE 367 "Database/HDBC/ODBC/Statement.hsc" #-}
                 -> IO Int16
{-# LINE 368 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLGetData"
{-# LINE 370 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlGetData :: Ptr CStmt       -- ^ statement handle
             -> Word16 -- ^ Column number
{-# LINE 372 "Database/HDBC/ODBC/Statement.hsc" #-}
             -> Int16 -- ^ target type
{-# LINE 373 "Database/HDBC/ODBC/Statement.hsc" #-}
             -> CString -- ^ target value pointer (void * in C)
             -> Int32 -- ^ buffer len
{-# LINE 375 "Database/HDBC/ODBC/Statement.hsc" #-}
             -> Ptr (Int32)
{-# LINE 376 "Database/HDBC/ODBC/Statement.hsc" #-}
             -> IO Int16
{-# LINE 377 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "hdbc-odbc-helper.h sqlFreeHandleSth_app"
  sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO ()

foreign import ccall unsafe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer"
  sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ())

foreign import ccall unsafe "sql.h SQLPrepare"
{-# LINE 385 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlPrepare :: Ptr CStmt -> CString -> Int32 
{-# LINE 386 "Database/HDBC/ODBC/Statement.hsc" #-}
             -> IO Int16
{-# LINE 387 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLExecute"
{-# LINE 389 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlExecute :: Ptr CStmt -> IO Int16
{-# LINE 390 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLAllocHandle"
{-# LINE 392 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlAllocStmtHandle :: Int16 -> Ptr CConn ->
{-# LINE 393 "Database/HDBC/ODBC/Statement.hsc" #-}
                        Ptr (Ptr CStmt) -> IO Int16
{-# LINE 394 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLNumResultCols"
{-# LINE 396 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlNumResultCols :: Ptr CStmt -> Ptr Int16 
{-# LINE 397 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> IO Int16
{-# LINE 398 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLRowCount"
{-# LINE 400 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlRowCount :: Ptr CStmt -> Ptr Int32 -> IO Int16
{-# LINE 401 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLBindParameter"
{-# LINE 403 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlBindParameter :: Ptr CStmt -- ^ Statement handle
                   -> Word16 -- ^ Parameter Number
{-# LINE 405 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Int16 -- ^ Input or output
{-# LINE 406 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Int16 -- ^ Value type
{-# LINE 407 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Int16 -- ^ Parameter type
{-# LINE 408 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Word32 -- ^ column size
{-# LINE 409 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Int16 -- ^ decimal digits
{-# LINE 410 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> CString   -- ^ Parameter value pointer
                   -> Int32 -- ^ buffer length
{-# LINE 412 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Ptr Int32 -- ^ strlen_or_indptr
{-# LINE 413 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> IO Int16
{-# LINE 414 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "hdbc-odbc-helper.h &nullData"
  nullData :: Ptr Int32
{-# LINE 417 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLDescribeParam"
{-# LINE 419 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlDescribeParam :: Ptr CStmt 
                   -> Word16 -- ^ parameter number
{-# LINE 421 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Ptr Int16 -- ^ data type ptr
{-# LINE 422 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Ptr Word32 -- ^ parameter size ptr
{-# LINE 423 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Ptr Int16 -- ^ dec digits ptr
{-# LINE 424 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> Ptr Int16 -- ^ nullable ptr
{-# LINE 425 "Database/HDBC/ODBC/Statement.hsc" #-}
                   -> IO Int16
{-# LINE 426 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "sql.h SQLFetch"
{-# LINE 428 "Database/HDBC/ODBC/Statement.hsc" #-}
  sqlFetch :: Ptr CStmt -> IO Int16
{-# LINE 429 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlTables"
  simpleSqlTables :: Ptr CStmt -> IO Int16
{-# LINE 432 "Database/HDBC/ODBC/Statement.hsc" #-}

foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlColumns"
  simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> 
                      Int16 -> IO Int16
{-# LINE 436 "Database/HDBC/ODBC/Statement.hsc" #-}