Low.hs

{-# options -ffi #-}

module Database.Sqlite3.Low where

import System.IO
import Data.Word
import Foreign
import Foreign.C
import qualified Data.ByteString as B

foreign import ccall unsafe "sqlite3_open" open' 
 :: CString -> Ptr (Ptr Void) -> IO Int

foreign import ccall unsafe "sqlite3_close" close'
 :: Ptr Void -> IO Int

foreign import ccall unsafe "sqlite3_errmsg" errmsg'
 :: Ptr Void -> IO CString

foreign import ccall unsafe "sqlite3_prepare_v2" prepare'
 :: Ptr Void -> CString -> Int -> Ptr (Ptr Void) -> Ptr CString -> IO Int

foreign import ccall unsafe "sqlite3_finalize" finalize'
 :: Ptr Void -> IO Int

foreign import ccall unsafe "sqlite3_reset" reset'
 :: Ptr Void -> IO Int

foreign import ccall unsafe "sqlite3_bind_int" bind_int'
 :: Ptr Void -> Int -> Int -> IO Int

foreign import ccall unsafe "sqlite3_bind_text" bind_text'
 :: Ptr Void -> Int -> CString -> Int -> Int -> IO Int

foreign import ccall unsafe "sqlite3_step" step'
 :: Ptr Void -> IO Int

foreign import ccall unsafe "sqlite3_column_blob" column_blob'
 :: Ptr Void -> Int -> IO CString

foreign import ccall unsafe "sqlite3_column_bytes" column_bytes'
 :: Ptr Void -> Int -> IO Int

foreign import ccall unsafe "sqlite3_column_count" column_count'
 :: Ptr Void -> IO Int

foreign import ccall unsafe "sqlite3_column_int" column_int'
 :: Ptr Void -> Int -> IO Int

foreign import ccall unsafe "sqlite3_column_double" column_double'
 :: Ptr Void -> Int -> IO Double

foreign import ccall unsafe "sqlite3_column_text" column_text'
 :: Ptr Void -> Int -> IO CString

foreign import ccall unsafe "sqlite3_column_type" column_type'
 :: Ptr Void -> Int -> IO Int

--

type Bytes = B.ByteString
type Void = Word8
data DB = DB (Ptr Void)
data Stmt = Stmt (Ptr Void)

open :: String -> IO DB
open path = do
 pptr <- malloc
 rc <- withCString path $ \cstr -> open' cstr pptr
 ptr <- peek pptr
 dbErrRc rc ptr "open"
 return (DB ptr)

close :: DB -> IO ()
close (DB db) = do
 rc <- close' db
 dbErrRc rc db "close"

prepare :: DB -> String -> IO Stmt
prepare (DB db) sql = do
 pptr <- malloc
 rc <- withCStringLen sql $ \(sql',len) ->
      prepare' db sql' len pptr nullPtr
 dbErrRc rc db "prepare"
 ptr <- peek pptr
 return (Stmt ptr)

finalize :: Stmt -> IO ()
finalize (Stmt st) = do
 rc <- finalize' st
 errRc rc "finalize"

reset :: Stmt -> IO ()
reset (Stmt st) = do
 rc <- reset' st
 errRc rc "reset"

step :: Stmt -> IO Bool
step (Stmt st) = do
 rc <- step' st
 errIf (rc /= 100 && rc /= 101) ("step: "++show rc)
 return (if rc == 101 then True else False)

bind_int :: Stmt -> Int -> Int -> IO ()
bind_int (Stmt st) num val = do
 debug ("bind_int",st,num,val)
 rc <- bind_int' st num val
 errRc rc "bind_int"

bind_text :: Stmt -> Int -> String -> IO ()
bind_text (Stmt st) num str' =
 (debug ("bind_text",st,num,str') >>) $
 withCStringLen str' $ \(str,len) -> do
  rc <- bind_text' st num str len (-1)
  errRc rc "bind_text"

column_blob :: Stmt -> Int -> IO Bytes
column_blob (Stmt st) num = do
 by <- column_bytes' st num
 bl <- column_blob'  st num
 return $ B.packCStringLen (bl,by)

column_bytes :: Stmt -> Int -> IO Int
column_bytes (Stmt st) num = column_bytes' st num

column_count :: Stmt -> IO Int
column_count (Stmt st) = column_count' st

column_int :: Stmt -> Int -> IO Int
column_int (Stmt st) num = column_int' st num

column_double :: Stmt -> Int -> IO Double
column_double (Stmt st) = column_double' st

column_text :: Stmt -> Int -> IO String
column_text (Stmt st) num = do
 by <- column_bytes' st num
 tx <- column_text'  st num
 peekCStringLen (tx,by)

column_type :: Stmt -> Int -> IO Int
column_type (Stmt st) num = column_type' st num

--

debug :: Show a => a -> IO ()
--debug = hPutStr stderr . ("DEBUG: "++) . (++"\n") . show
debug _ = return ()

err msg = ioError $ userError $ "Sqlite3: "++msg

errIf False _ = return ()
errIf True msg = err $ "Foreign: "++msg

errRc 0 _ = return ()
errRc rc msg = err $ "Foreign: "++msg++": rc="++show rc

dbErrRc 0 _ _ = return ()
dbErrRc rc db msg = do
 reason <- errmsg' db >>= peekCString
 err $ "Foreign: "++msg++": (rc="++show rc++") "++reason