module Database.SQLite3.Direct (
open,
close,
errmsg,
exec,
prepare,
getStatementDatabase,
step,
reset,
finalize,
clearBindings,
bindParameterCount,
bindParameterName,
columnCount,
bindInt64,
bindDouble,
bindText,
bindBlob,
bindNull,
columnType,
columnInt64,
columnDouble,
columnText,
columnBlob,
Database(..),
Statement(..),
ColumnType(..),
StepResult(..),
Error(..),
Utf8(..),
ParamIndex(..),
ColumnIndex(..),
ColumnCount,
) where
import Database.SQLite3.Bindings
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BSU
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Control.Applicative ((<$>))
import Data.ByteString (ByteString)
import Data.String (IsString(..))
import Foreign
import Foreign.C
newtype Database = Database (Ptr CDatabase)
deriving (Eq, Show)
newtype Statement = Statement (Ptr CStatement)
deriving (Eq, Show)
data StepResult
= Row
| Done
deriving (Eq, Show)
newtype Utf8 = Utf8 ByteString
deriving (Eq, Show)
instance IsString Utf8 where
fromString = Utf8 . T.encodeUtf8 . T.pack
packUtf8 :: a -> (Utf8 -> a) -> CString -> IO a
packUtf8 n f cstr | cstr == nullPtr = return n
| otherwise = f . Utf8 <$> BS.packCString cstr
packCStringLen :: CString -> CNumBytes -> IO ByteString
packCStringLen cstr len =
BS.packCStringLen (cstr, fromIntegral len)
unsafeUseAsCStringLenNoNull :: ByteString -> (CString -> CNumBytes -> IO a) -> IO a
unsafeUseAsCStringLenNoNull bs cb
| BS.null bs = cb (intPtrToPtr 1) 0
| otherwise = BSU.unsafeUseAsCStringLen bs $ \(ptr, len) ->
cb ptr (fromIntegral len)
wrapNullablePtr :: (Ptr a -> b) -> Ptr a -> Maybe b
wrapNullablePtr f ptr | ptr == nullPtr = Nothing
| otherwise = Just (f ptr)
type Result a = Either Error a
toResult :: a -> CError -> Result a
toResult a (CError 0) = Right a
toResult _ code = Left $ decodeError code
toResultM :: Monad m => m a -> CError -> m (Result a)
toResultM m (CError 0) = m >>= return . Right
toResultM _ code = return $ Left $ decodeError code
toStepResult :: CError -> Result StepResult
toStepResult code =
case decodeError code of
ErrorRow -> Right Row
ErrorDone -> Right Done
err -> Left err
open :: Utf8 -> IO (Either (Error, Utf8) Database)
open (Utf8 path) =
BS.useAsCString path $ \path' ->
alloca $ \database -> do
rc <- c_sqlite3_open path' database
db <- Database <$> peek database
case toResult () rc of
Left err -> do
msg <- errmsg db
_ <- close db
return $ Left (err, msg)
Right () ->
if db == Database nullPtr
then fail "sqlite3_open unexpectedly returned NULL"
else return $ Right db
close :: Database -> IO (Either Error ())
close (Database db) =
toResult () <$> c_sqlite3_close db
errmsg :: Database -> IO Utf8
errmsg (Database db) =
c_sqlite3_errmsg db >>= packUtf8 (Utf8 BS.empty) id
exec :: Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec (Database db) (Utf8 sql) =
BS.useAsCString sql $ \sql' ->
alloca $ \msgPtrOut -> do
rc <- c_sqlite3_exec db sql' nullFunPtr nullPtr msgPtrOut
case toResult () rc of
Left err -> do
msgPtr <- peek msgPtrOut
msg <- packUtf8 (Utf8 BS.empty) id msgPtr
c_sqlite3_free msgPtr
return $ Left (err, msg)
Right () -> return $ Right ()
prepare :: Database -> Utf8 -> IO (Either Error (Maybe Statement))
prepare (Database db) (Utf8 sql) =
BS.useAsCString sql $ \sql' ->
alloca $ \statement ->
c_sqlite3_prepare_v2 db sql' (1) statement nullPtr >>=
toResultM (wrapNullablePtr Statement <$> peek statement)
getStatementDatabase :: Statement -> IO Database
getStatementDatabase (Statement stmt) = do
db <- c_sqlite3_db_handle stmt
if db == nullPtr
then fail $ "sqlite3_db_handle(" ++ show stmt ++ ") returned NULL"
else return (Database db)
step :: Statement -> IO (Either Error StepResult)
step (Statement stmt) =
toStepResult <$> c_sqlite3_step stmt
reset :: Statement -> IO (Either Error ())
reset (Statement stmt) =
toResult () <$> c_sqlite3_reset stmt
finalize :: Statement -> IO (Either Error ())
finalize (Statement stmt) =
toResult () <$> c_sqlite3_finalize stmt
clearBindings :: Statement -> IO ()
clearBindings (Statement stmt) = do
_ <- c_sqlite3_clear_bindings stmt
return ()
bindParameterCount :: Statement -> IO ParamIndex
bindParameterCount (Statement stmt) =
c_sqlite3_bind_parameter_count stmt
bindParameterName :: Statement -> ParamIndex -> IO (Maybe Utf8)
bindParameterName (Statement stmt) idx =
c_sqlite3_bind_parameter_name stmt idx >>=
packUtf8 Nothing Just
columnCount :: Statement -> IO ColumnCount
columnCount (Statement stmt) =
c_sqlite3_column_count stmt
bindInt64 :: Statement -> ParamIndex -> Int64 -> IO (Either Error ())
bindInt64 (Statement stmt) idx value =
toResult () <$> c_sqlite3_bind_int64 stmt idx value
bindDouble :: Statement -> ParamIndex -> Double -> IO (Either Error ())
bindDouble (Statement stmt) idx value =
toResult () <$> c_sqlite3_bind_double stmt idx value
bindText :: Statement -> ParamIndex -> Utf8 -> IO (Either Error ())
bindText (Statement stmt) idx (Utf8 value) =
unsafeUseAsCStringLenNoNull value $ \ptr len ->
toResult () <$>
c_sqlite3_bind_text stmt idx ptr len c_SQLITE_TRANSIENT
bindBlob :: Statement -> ParamIndex -> ByteString -> IO (Either Error ())
bindBlob (Statement stmt) idx value =
unsafeUseAsCStringLenNoNull value $ \ptr len ->
toResult () <$>
c_sqlite3_bind_blob stmt idx ptr len c_SQLITE_TRANSIENT
bindNull :: Statement -> ParamIndex -> IO (Either Error ())
bindNull (Statement stmt) idx =
toResult () <$> c_sqlite3_bind_null stmt idx
columnType :: Statement -> ColumnIndex -> IO ColumnType
columnType (Statement stmt) idx =
decodeColumnType <$> c_sqlite3_column_type stmt idx
columnInt64 :: Statement -> ColumnIndex -> IO Int64
columnInt64 (Statement stmt) idx =
c_sqlite3_column_int64 stmt idx
columnDouble :: Statement -> ColumnIndex -> IO Double
columnDouble (Statement stmt) idx =
c_sqlite3_column_double stmt idx
columnText :: Statement -> ColumnIndex -> IO Utf8
columnText (Statement stmt) idx = do
ptr <- c_sqlite3_column_text stmt idx
len <- c_sqlite3_column_bytes stmt idx
Utf8 <$> packCStringLen ptr len
columnBlob :: Statement -> ColumnIndex -> IO ByteString
columnBlob (Statement stmt) idx = do
ptr <- c_sqlite3_column_blob stmt idx
len <- c_sqlite3_column_bytes stmt idx
packCStringLen ptr len