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 Control.Monad.State.Lazy as ST

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

import Data.State

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

type DbE a =
 (Error e
 ,MonadError e m
 ,MonadState sg m
 ,LocalState sg StateDb
 ,Monad m
 ) => m a

type DbIO a =
 (LocalState sg StateDb
 ,MonadIO m
 ,MonadState sg m
 ,MonadError e m
 ,Error e
 ,Monad m
 ) => m a

type E a =
 (MonadError e m
 ,Error e
 ) => m a

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

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

setDB :: Ptr Void -> DbE ()
setDB ptr = get >>= \st@(SD { dbP = dbP }) ->
 case dbP of
   Nothing -> put (st { dbP = Just ptr })
   Just _  -> err "Database is allready set"

setST :: Ptr Void -> DbE ()
setST ptr = get >>= \st@(SD { stP = stP }) ->
    case stP of
      Nothing -> put (st { stP = Just ptr })
      Just _  -> err "Statement is allready set"

isSetDB :: DbE Bool
isSetDB = get >>= \(SD { dbP = dbP }) ->
    case dbP of
      Nothing -> return False
      Just _ -> return True

getDB :: DbE (Ptr Void)
getDB = get >>= \(SD { dbP = dbP }) ->
    case dbP of
      Just a  -> return a
      Nothing -> err "Database is not set"

getST :: DbE (Ptr Void)
getST = get >>= \(SD { stP = stP }) ->
    case stP of
      Just a  -> return a
      Nothing -> err "Statement is not set"

clearDB :: DbE ()
clearDB = get >>= \st@(SD { dbP = dbP }) ->
    case dbP of
      Just _  -> put (st { dbP = Nothing })
      Nothing -> err "Database is allready clear"

clearST :: DbE ()
clearST = get >>= \st@(SD { stP = stP }) ->
    case stP of
      Just _  -> put (st { stP = Nothing })
      Nothing -> err "Statement is allready clear"

--

err :: String -> E x
err a = throwError $ strMsg a


errRc :: Int -> String -> DbIO ()
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 :: Bool -> String -> DbIO ()
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 -> DbIO ()
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 :: String -> DbIO ()
open path = do
 pptr <- i malloc
 cstr <- i$ newCString path
 debug (path,cstr,pptr,"open")
 rc <- i$ c_open cstr pptr
 ptr <- i$ peek pptr
 setDB ptr
 fin (errRc rc "open") $ do
   r <- try close
   case r of
     Left _   -> clearDB
     Right () -> return ()
 where i = liftIO

close :: DbIO ()
close = do
 ptr <- getDB
 debug (ptr,"close")
 rc <- liftIO $ c_close ptr
 errRc rc "close"
 clearDB

prepare :: String -> DbIO ()
prepare sql = do
 pptr <- i malloc
 (cstr,len) <- i$ newCStringLen sql
 debug (sql,cstr,len,pptr,"prepare")
 ptr <- getDB
 rc <- i$ c_prepare ptr cstr len pptr nullPtr
 sptr <- i$ peek pptr
 setST sptr
 fin (errRc rc "prepare") $ do
   r <- try finalize
   case r of
     Left _ -> clearST
     Right () -> return ()
 where i = liftIO

finalize :: DbIO ()
finalize = do
 ptr <- getST
 debug (ptr,"finalize")
 rc <- liftIO $ c_finalize ptr
 errRc rc "finalize"
 clearST

reset :: DbIO ()
reset = do
 ptr <- getST
 debug (ptr,"reset")
 rc <- liftIO $ c_reset ptr
 errRc rc "reset"

step :: DbIO 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 :: (Int,Int) -> DbIO ()
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 :: (Int,String) -> DbIO ()
bind_text (num,val) = do
 (cstr,len) <- liftIO $ newCStringLen val
 ptr <- getST
 debug (ptr,"bind_text")
 rc <- liftIO $ c_bind_text ptr num cstr len (-1)
 errRc rc "bind_text"

column_bytes :: Int -> DbIO Int
column_bytes num = do
 ptr <- getST
 debug (ptr,"column_bytes")
 liftIO $ c_column_bytes ptr num

column_count :: DbIO Int
column_count = do
 ptr <- getST
 debug (ptr,"column_count")
 liftIO $ c_column_count ptr

column_int :: Int -> DbIO Int
column_int num = do
 ptr <- getST
 debug (ptr,"column_int")
 liftIO $ c_column_int ptr num

column_double :: Int -> DbIO Double
column_double num = do
 ptr <- getST
 debug (ptr,"column_double")
 liftIO $ c_column_double ptr num

column_type :: Int -> DbIO Int
column_type num = do
 ptr <- getST
 debug (ptr,"column_type")
 liftIO $ c_column_type ptr num

column_text :: Int -> DbIO 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 :: Int -> DbIO 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)