HsSqlite3.hs

module Database.HsSqlite3
 ( module Database.Sqlite3.Low
 , Val ( IntV, Int64V, DoubleV, TextV, BlobV, NullV )
 , fetch
 , bind
 , row
 , test
 , sql
 ) where

import Data.Char
import Control.Monad
import Data.Int
import Database.Sqlite3.Low
import qualified Data.ByteString as B
import Control.Arrow
import Data.Typeable

import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.State.Lazy

import Data.Monoid

import Data.State hiding (fetch)

import qualified Codec.Binary.UTF8.String as UTF8

--

class ValID a where
 valID  :: a -> Int

class ValFetch a where
 valFetch :: (Int,Int) -> DbIO a

class ValBind a where
 valBind :: (Int,a) -> DbIO ()

class ValID a => ValCast a b where
 valCast :: a -> b

data Val
 = IntV    Int
 | Int64V  Int64
 | DoubleV Double
 | TextV   String
 | BlobV   B.ByteString
 | NullV
 deriving Show

instance ValID Val where
 valID (IntV    _) = 1
 valID (Int64V  _) = 1
 valID (DoubleV _) = 2
 valID (TextV   _) = 3
 valID (BlobV   _) = 4
 valID  NullV      = 5

instance ValFetch Val where
 valFetch (t,n) = do
  case t of
   1 -> liftM IntV    $ column_int n
   2 -> liftM DoubleV $ column_double n
   3 -> liftM TextV   $ column_text n
   4 -> liftM BlobV   $ column_blob n
   5 -> return NullV

instance ValBind Val where
 valBind (t,v) = do
  case v of
   IntV a -> bind_int (t,a)
   TextV a -> bind_text (t,a)

instance ValCast Val Int where
 valCast (IntV a) = a

instance ValCast Val Double where
 valCast (DoubleV a) = a

instance ValCast Val String where
 valCast (TextV a) = a

instance ValCast Val B.ByteString where
 valCast (BlobV a) = a

instance ValCast Val () where
 valCast NullV = ()

instance ValID Int          where valID _ = 1
instance ValID Double       where valID _ = 2
instance ValID String       where valID _ = 3
instance ValID B.ByteString where valID _ = 4
instance ValID ()           where valID _ = 5

reqType :: Int -> (Int -> DbIO a) -> (Int,Int) -> DbIO a
reqType t' a (t,v) =  do
 errIf (t'/=t) "ValFetch"
 a v

instance ValFetch Int where
 valFetch = reqType 1 column_int

instance ValFetch Double where
 valFetch = reqType 2 column_double

instance ValFetch String where
 valFetch = reqType 3 column_text

instance ValFetch B.ByteString where
 valFetch = reqType 4 column_blob

instance ValFetch () where
 valFetch = reqType 5 (\_ -> return ())

instance ValBind Int where
 valBind = bind_int

instance ValBind String where
 valBind = bind_text

instance ValCast Int Val where
 valCast a = IntV a

instance ValCast Double Val where
 valCast a = DoubleV a

instance ValCast String Val where
 valCast a = TextV a

instance ValCast B.ByteString Val where
 valCast a = BlobV a

instance ValCast () Val where
 valCast a = NullV

--

fetch :: ValFetch a => String -> DbIO [[a]]
fetch sql = do
 liftIO $ putStr $ UTF8.encodeString $ sql++"\n"
 prepare sql
 stat <- step
 case stat of
  True -> finalize >> return []
  False -> do
   cn <- column_count
   ty <- mapM column_type [0..cn-1]
   let ft = mapM valFetch (zip ty [0..])
   x <- ft
   xs <- fetchRow ft
   finalize
   return (x:xs)
 where
  fetchRow ft = do
   end <- step
   case end of
    True -> return []
    False -> do
     x <- ft
     xs <- fetchRow ft
     return (x:xs)

sql :: String -> DbIO ()
sql sql = do
 liftIO $ putStr $ UTF8.encodeString $ sql++"\n"
 prepare sql
 step
 finalize

bind :: String -> [[Val]] -> DbIO ()
bind sql tab = do
 liftIO $ putStr $ UTF8.encodeString $ sql++"\n"
 debug tab
 prepare sql
 mapM_ (\row -> mapM_ (\(v,n) -> valBind (n,v)) (zip row [1..]) >> step >> reset) tab
 finalize

fetchOne' :: ValFetch a => String -> Int -> DbIO [[a]]
fetchOne' sql num = fetch sql'
 where sql' = concat [sql," LIMIT 1 OFFSET ", show num]

row :: ValFetch a => String -> Int -> DbIO [a]
row sql num = liftM head $ fetchOne' sql num

test :: String -> DbIO Bool
test sql = do
 tab :: [[Val]] <- fetchOne' sql 0
 case length tab of
  1 -> return True
  _ -> return False



Patch from Evgeny:

Utilization of types
For fetch
> tab :: [Nil :. Int :. Int :. Double] <- fetch "SELECT * FROM test01"
>  liftIO $ mapM print tab

And for bind
> bind "INSERT INTO test01 VALUES(?,?,?)" $
>  replicate 7 $
>    Nil :. (1::Int) :. (2::Int) :. (3.0::Double)

This is stack with different types
> Nil :. (1::Int) :. (2::Int) :. (3.0::Double)

Definition of stack
> data Stack a where
>    Nil  :: Stack ()
>    (:.) :: Stack a -> b -> Stack (Stack a, b)

This is class for new kinds of values.
"T" means used in type stack ... type manipulations ...
> class Cell a where
>   bindT   :: Int -> a -> Db ()
>   columnT :: Int -> Db a
>   idT     :: a -> Int

> instance Cell Int where
>   idT _    = 1
>   columnT  = columnInt
>   bindT    = bindInt

> instance Cell Double where
>  idT _    = 2
>  columnT  = columnDouble
>  bindT    = bindDouble

Equality test of derived types and database types
> fetchBody derived = do
>  cn <- columnCount
>  dbTypes <- mapM columnType $ enumFromThenTo (cn-1) (cn-2) 0
>  case dbTypes == derived of
   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
>   False -> fail "different database and haskell types"
>   True  -> return ()
>  x  <- columnStack
>  xs <- fetchTail
>  finalize
>  return (x:xs)

Middle level:

Abstract away from state and errors
> class DbError e where
>  makeErr :: CInt -> e
>  castErr :: e -> Maybe CInt

> class MonadIO m => MonadDb m where
>  getDb     :: m (Ptr L.Sqlite3)
>  putDb     :: Ptr L.Sqlite3 -> m ()
>  cleanDb   :: m ()
>  isDbReady :: m Bool
>  getSt     :: m (Ptr L.Stmt)
>  putSt     :: Ptr L.Stmt -> m ()
>  cleanSt   :: m ()
>  isStReady :: m Bool

Simple instance for MonadDb (in Sqlite3.hs)
> data SimpleState = SimpleState
> { database  :: Maybe (Ptr L.Sqlite3)
> , statement :: Maybe (Ptr L.Stmt ) }
> ...
> instance MonadDb (StateT SimpleState (ErrorT (Either CInt String) IO)) where

 > getDb = get >>= maybe (fail "Empty database")  return . database
 > getSt = get >>= maybe (fail "Empty statement") return . statement

 > putDb x = modify $ \a -> a { database  = Just x }
 > putSt x = modify $ \a -> a { statement = Just x }

 > cleanDb = modify $ \a -> a { database  = Nothing }
 > cleanSt = modify $ \a -> a { statement = Nothing }

 > isDbReady = get >>= return . maybe False (const True) . database
 > isStReady = get >>= return . maybe False (const True) . statement






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)