Low.hs

{-# options -fglasgow-exts -ffi #-}

module Database.Sqlite3.Low where

import Foreign
import Foreign.C

import System.IO
import System.IO.Unsafe
import System.IO.Error hiding (try)

import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.State.Lazy hiding (get,put)

import qualified Codec.Binary.UTF8.String as UTF8
import qualified Data.ByteString as B

import Data.StateLocal hiding (getST)

import Data.Typeable

type Void = Word8

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

--

data StateDb = SD
 { dbP :: Maybe (Ptr Void)
 , stP :: Maybe (Ptr Void)
 } deriving (Show, Typeable)

instance ZeroState StateDb where
 zeroST = SD
  { dbP = Nothing
  , stP = Nothing }

setDB :: (Error e, MonadError e m, LocalState sg StateDb) => Ptr Void -> StateT sg m ()
setDB ptr = get >>= \st@(SD { dbP = dbP }) ->
 case dbP of
   Nothing -> put (st { dbP = Just ptr })
   Just _  -> lift $ throwError $ strMsg
    "Database is allready set"

setST :: (Error e, MonadError e m, LocalState sg StateDb) => Ptr Void -> StateT sg m ()
setST ptr = get >>= \st@(SD { stP = stP }) ->
    case stP of
      Nothing -> put (st { stP = Just ptr })
      Just _  -> lift $ throwError $ strMsg
        "Statement is allready set"

isSetDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m Bool
isSetDB = get >>= \(SD { dbP = dbP }) ->
    case dbP of
      Nothing -> return False
      Just _ -> return True

getDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m (Ptr Void)
getDB = get >>= \(SD { dbP = dbP }) ->
    case dbP of
      Just a  -> return a
      Nothing -> lift $ throwError $ strMsg
        "Database is not set"

getST :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m (Ptr Void)
getST = get >>= \(SD { stP = stP }) ->
    case stP of
      Just a  -> return a
      Nothing -> lift $ throwError $ strMsg
        "Statement is not set"

clearDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m ()
clearDB = get >>= \st@(SD { dbP = dbP }) ->
    case dbP of
      Just _  -> put (st { dbP = Nothing })
      Nothing -> lift $ throwError $ strMsg
        "Database is allready clear"

clearST :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m ()
clearST = get >>= \st@(SD { stP = stP }) ->
    case stP of
      Just _  -> put (st { stP = Nothing })
      Nothing -> lift $ throwError $ strMsg
        "Statement is allready clear"

--

err :: String -> StateT s IO ()
err = liftIO .  throwError .  strMsg

errRc :: LocalState s StateDb => Int -> String -> StateT s IO ()
errRc 0 _ = return ()
errRc rc msg = do
 ans <- isSetDB
 case ans of
  True -> do
    ptr <- getDB
    cstr <- liftIO $ c_errmsg ptr
    reason <- liftIO $ peekCString cstr
    err $ "Foreign: "++msg++": (rc="++show rc++") "++reason
  False ->
    err $ "Foreign: "++msg++": (rc="++show rc++")"

errIf :: LocalState s StateDb => Bool -> String -> StateT s IO ()
errIf False _ = return ()
errIf True msg = do
 ans <- isSetDB
 case ans of
  True -> do
    ptr <- getDB
    cstr <- liftIO $ c_errmsg ptr
    reason <- liftIO $ peekCString cstr
    err $ "Foreign: "++msg++": "++reason
  False ->
    err $ "Foreign: "++msg


--debug a = liftIO $ hPutStr stderr $ "DEBUG: " ++ show a ++ "\n"

debug :: Show a => a -> StateT s IO ()
debug a = liftIO $ hPutStr stderr ("DEBUG: " ++ show a ++ "\n")

cont :: ((a -> IO (b,s)) -> IO (b,s)) -> (a -> StateT s IO b) -> StateT s IO b
cont f g = StateT $ \st -> liftIO $ f $ \a -> (runStateT (g a)) st

fin a b = catchError a (\e -> b >> throwError e)

try a = catchError (liftM Right a) (\e -> return $ Left e)

--

open :: LocalState s StateDb => String -> StateT s IO ()
open path =
 cont alloca $ \pptr ->
 cont (withCString path) $ \cstr -> do
  debug (cstr,pptr,"open")
  rc <- liftIO $ c_open cstr pptr
  ptr <- liftIO $ peek pptr
  setDB ptr
  fin (errRc rc "open") $ do
    r <- try close
    case r of
     Left _ -> clearDB
     Right () -> return ()

close :: LocalState s StateDb => StateT s IO ()
close = do
 ptr <- getDB
 debug (ptr,"close")
 rc <- liftIO $ c_close ptr
 errRc rc "close"
 clearDB

prepare :: LocalState s StateDb => String -> StateT s IO ()
prepare sql =
 cont alloca $ \pptr ->
 cont (withCStringLen sql) $ \(cstr,len) -> do
  ptr <- getDB
  debug (cstr,len,pptr,"prepare")
  rc <- liftIO $ c_prepare ptr cstr len pptr nullPtr
  sptr <- liftIO $ peek pptr
  setST sptr
  fin (errRc rc "prepare") $ do
   r <- try finalize
   case r of
    Left _ -> clearST
    Right () -> return ()

finalize :: LocalState s StateDb => StateT s IO ()
finalize = do
 ptr <- getST
 debug (ptr,"finalize")
 rc <- liftIO $ c_finalize ptr
 errRc rc "finalize"
 clearST

reset :: LocalState s StateDb => StateT s IO ()
reset = do
 ptr <- getST
 debug (ptr,"reset")
 rc <- liftIO $ c_reset ptr
 errRc rc "reset"

step :: LocalState s StateDb => StateT s IO Bool
step = do
 ptr <- getST
 debug (ptr,"step")
 rc <- liftIO $ c_step ptr
 errIf (rc /= 100 && rc /= 101) $ "step: "++show rc
 return (rc == 101)

bind_int :: LocalState s StateDb => (Int,Int) -> StateT s IO ()
bind_int (num,val) = do
 ptr <- getST
 debug (ptr,"bind_int")
 rc <- liftIO $ c_bind_int ptr num val
 errRc rc "bind_int"

bind_text :: LocalState s StateDb => (Int,String) -> StateT s IO ()
bind_text (num,val) =
 cont (withCStringLen val) $ \(cstr,len) -> do
  ptr <- getST
  debug (ptr,"bind_text")
  rc <- liftIO $ c_bind_text ptr num cstr len (-1)
  errRc rc "bind_text"

column_bytes :: LocalState s StateDb => Int -> StateT s IO Int
column_bytes num = do
 ptr <- getST
 debug (ptr,"column_bytes")
 liftIO $ c_column_bytes ptr num

column_count :: LocalState s StateDb => StateT s IO Int
column_count = do
 ptr <- getST
 debug (ptr,"column_count")
 liftIO $ c_column_count ptr

column_int :: LocalState s StateDb => Int -> StateT s IO Int
column_int num = do
 ptr <- getST
 debug (ptr,"column_int")
 liftIO $ c_column_int ptr num

column_double :: LocalState s StateDb => Int -> StateT s IO Double
column_double num = do
 ptr <- getST
 debug (ptr,"column_double")
 liftIO $ c_column_double ptr num

column_type :: LocalState s StateDb => Int -> StateT s IO Int
column_type num = do
 ptr <- getST
 debug (ptr,"column_type")
 liftIO $ c_column_type ptr num

column_text :: LocalState s StateDb => Int -> StateT s IO String
column_text num = do
 ptr <- getST
 by <- column_bytes num
 debug (ptr,by,"column_text")
 tx <- liftIO $ c_column_text ptr num
 utf <- liftIO $ peekCStringLen (tx,by)
 return $ UTF8.decodeString utf

column_blob :: LocalState s StateDb => Int -> StateT s IO B.ByteString
column_blob num = do
 ptr <- getST
 debug (ptr,"column_blob")
 by <- column_bytes num
 bl <- liftIO $ c_column_blob ptr num
 return $ B.packCStringLen (bl,by)