hsSqlite3-0.0.5.20081031: src/Database/Sqlite3/Low.hs

-- | This is intended to be a low level wrapper over sqlite3
-- library. These design decisions guide this module:
--
-- * Portability.
--
-- * It is meant to be as  close as possible to a bijection over sqlite3
-- objects, constants and functions.  The original documentation for any
-- sqlite3 name should be sufficient to understand its wrapper.
--
-- * Everything not UTF-8 has been removed in favor of UTF-8.
--
-- * @sqlite3_@  prefix has  been removed from  all object  and function
-- names since it can be mapped to a qualified module import.
--
-- * Mutex related  names are not wrapped, as  they would just duplicate
-- existing functionality.
--
-- * All  sqlite3 experimental  or obsolete code  (marked with  @exp@ or
-- @obs@ in the official documentation) has not been wrapped, as well as
-- the testing interface (@sqlite3_test_control@ and related constants).
--
-- *  Preprocessor  constant definitions  have  been  replaced by  equal
-- values.  All  were  typed  to  CInt,  except  for  SQLITE_STATIC  and
-- SQLITE_TRANSIENT (mapped  to sqliteStatic and  sqliteTransient) which
-- were  typed as  function pointers  as faithfully  as possible  to the
-- underline C  code. Version information  constants are not  mapped for
-- portability,  and   the  user  can   always  call  the   mappings  of
-- sqlite3_libversion and sqlite3_libversion_number functions instead.

module Database.Sqlite3.Low where
import Foreign
import Foreign.C
import Data.Bits

-- * Objects

data Sqlite3 = Sqlite3
data Blob = Blob
data Context = Context
data File = File
data Int64 = Int64
data Uint64 = Uint64
data IoMethods = IoMethods
data Stmt = Stmt
data Value = Value
data Vfs = Vfs

foreign import ccall "&sqlite3_temp_directory" tempDirectory
 :: Ptr CString

-- * Constants

-- | Error codes

[sqliteOk, sqliteError, sqliteInternal, sqlitePerm, sqliteAbort,
 sqliteBusy, sqliteLocked, sqliteNoMem, sqliteReadOnly,
 sqliteInterrupt, sqliteIoErr, sqliteCorrupt, sqliteNotFound,
 sqliteFull, sqliteCantOpen, sqliteProtocol, sqliteEmpty,
 sqliteSchema, sqliteTooBig, sqliteConstraint, sqliteMismatch,
 sqliteMisuse, sqliteNoLfs, sqliteAuth, sqliteFormat, sqliteRange,
 sqliteNotADb, sqliteRow, sqliteDone] = [0..26] ++ [100,101] ::
 [CInt]

-- | Flags for the xAccess VFS method

[sqliteAccessExists, sqliteAccessReadWrite, sqliteAccessRead] =
 [0..2] :: [CInt]

-- | Authorizer Action Codes

[sqliteCreateIndex, sqliteCreateTable, sqliteCreateTempIndex,
 sqliteCreateTempTable, sqliteCreateTempTrigger,
 sqliteCreateTempView, sqliteCreateTrigger, sqliteCreateView,
 sqliteDelete, sqliteDropIndex, sqliteDropTable,
 sqliteDropTempIndex, sqliteDropTempTable, sqliteDropTempTrigger,
 sqliteDropTempView, sqliteDropTrigger, sqliteDropView,
 sqliteInsert, sqlitePragma, sqliteRead, sqliteSelect,
 sqliteTransaction, sqliteUpdate, sqliteAttach, sqliteDetach,
 sqliteAlterTable, sqliteReindex, sqliteAnalyze,
 sqliteCreateVtable, sqliteDropVtable, sqliteFunction] = [1..31] ::
 [CInt]

-- | Text Encodings

sqliteUtf8 = 1 :: CInt

-- | Fundamental Datatypes

[sqliteInteger, sqliteFloat, sqliteText, sqliteBlob, sqliteNull] =
 [1..5] :: [CInt]

-- | Authorizer Return Codes

[sqliteDeny, sqliteIgnore] = [1,2] :: [CInt]

-- | Standard File Control Opcodes

sqliteFcntlLockstate = 1 :: CInt

-- | Device Characteristics

[sqliteIocapAtomic, sqliteIocapAtomic512, sqliteIocapAtomic1K,
 sqliteIocapAtomic2K, sqliteIocapAtomic4K, sqliteIocapAtomic8K,
 sqliteIocapAtomic16K, sqliteIocapAtomic32K, sqliteIocapAtomic64K,
 sqliteIocapSafeAppend, sqliteIocapSequential] = map bit [0..10] ::
 [CInt]

-- | Extended Result Codes

[sqliteIoErrRead, sqliteIoErrShortRead, sqliteIoErrWrite,
 sqliteIoErrFsync, sqliteIoErrDirFsync, sqliteIoErrTruncate,
 sqliteIoErrFstat, sqliteIoErrUnlock, sqliteIoErrRdlock,
 sqliteIoErrDelete, sqliteIoErrBlocked, sqliteIoErrNomem,
 sqliteIoErrAccess, sqliteIoErrCheckreservedlock, sqliteIoErrLock]
 = map ( (sqliteIoErr .|.) . (flip shift $ 8) ) [1..15] :: [CInt]

-- | Run-Time Limit Categories

[sqliteLimitLength, sqliteLimitSqlLength, sqliteLimitColumn,
 sqliteLimitExprDepth, sqliteLimitCompoundSelect,
 sqliteLimitVdbeOp, sqliteLimitFunctionArg, sqliteLimitAttached,
 sqliteLimitLikePatternLength, sqliteLimitVariableNumber] = [0..9]
 :: [CInt]

-- | File Locking Levels

[sqliteLockNone, sqliteLockShared, sqliteLockReserved,
 sqliteLockPending, sqliteLockExclusive] = [0..4] :: [CInt]

-- | Flags For File Open Operations

[sqliteOpenReadOnly, sqliteOpenReadWrite, sqliteOpenCreate,
 sqliteOpenDeleteOnClose, sqliteOpenExclusive, sqliteOpenMainDb,
 sqliteOpenTempDb, sqliteOpenTransientDb, sqliteOpenMainJournal,
 sqliteOpenTempJournal, sqliteOpenSubjournal,
 sqliteOpenMasterJournal, sqliteOpenNoMutex, sqliteOpenFullMutex] =
 map bit $ [0..4] ++ [8..16] :: [CInt]

-- | Constants Defining Special Destructor Behavior

[sqliteStatic, sqliteTransient] = map cast [0,-1]
  where
    cast :: IntPtr -> FunPtr (Ptr () -> ())
    cast n = (castPtrToFunPtr . intPtrToPtr) n

-- | Synchronization Type Flags

[sqliteSyncNormal, sqliteSyncFull, sqliteSyncDataonly] = [0x2,
 0x3, 0x10] :: [CInt]

-- * Functions

foreign import ccall "sqlite3_close" close
 :: Ptr Sqlite3 -> IO CInt

foreign import ccall "sqlite3_exec" exec
 :: Ptr Sqlite3 -> CString -> FunPtr (Ptr () -> CInt -> Ptr CString
        -> Ptr CString -> IO CInt) -> Ptr () -> Ptr CString -> IO CInt

foreign import ccall "sqlite3_free" free
 :: Ptr a -> IO ()

foreign import ccall "sqlite3_open" open
 :: CString -> (Ptr (Ptr Sqlite3)) -> IO CInt







{- Code not yet adapted to new version

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 $ UTF8.encodeString 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)

-}