-- | 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) -}