module Database.SQLite3 (
open,
close,
exec,
prepare,
step,
reset,
finalize,
clearBindings,
bindParameterCount,
bindParameterName,
columnCount,
bindSQLData,
bind,
bindInt,
bindInt64,
bindDouble,
bindText,
bindBlob,
bindNull,
column,
columns,
columnType,
columnInt64,
columnDouble,
columnText,
columnBlob,
Database,
Statement,
SQLData(..),
SQLError(..),
ColumnType(..),
StepResult(..),
Error(..),
ParamIndex(..),
ColumnIndex(..),
ColumnCount,
) where
import Database.SQLite3.Direct
( Database
, Statement
, ColumnType(..)
, StepResult(..)
, Error(..)
, ParamIndex(..)
, ColumnIndex(..)
, ColumnCount
, Utf8(..)
, clearBindings
, bindParameterCount
, columnCount
, columnType
, columnBlob
, columnInt64
, columnDouble
)
import qualified Database.SQLite3.Direct as Direct
import Prelude hiding (error)
import qualified Data.Text as T
import Control.Applicative ((<$>))
import Control.Exception (Exception, evaluate, throw, throwIO)
import Control.Monad (when, zipWithM_)
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (UnicodeException(..), lenientDecode)
import Data.Typeable
data SQLData
= SQLInteger !Int64
| SQLFloat !Double
| SQLText !Text
| SQLBlob !ByteString
| SQLNull
deriving (Eq, Show, Typeable)
data SQLError = SQLError
{ sqlError :: !Error
, sqlErrorDetails :: Text
, sqlErrorContext :: Text
}
deriving Typeable
instance Show SQLError where
show SQLError{ sqlError = code
, sqlErrorDetails = details
, sqlErrorContext = context
}
= T.unpack $ T.concat
[ "SQLite3 returned "
, T.pack $ show code
, " while attempting to perform "
, context
, ": "
, details
]
instance Exception SQLError
fromUtf8 :: String -> Utf8 -> IO Text
fromUtf8 desc (Utf8 bs) =
evaluate $ decodeUtf8With (\_ c -> throw (DecodeError desc c)) bs
toUtf8 :: Text -> Utf8
toUtf8 = Utf8 . encodeUtf8
data DetailSource
= DetailDatabase Database
| DetailStatement Statement
| DetailMessage Utf8
renderDetailSource :: DetailSource -> IO Utf8
renderDetailSource src = case src of
DetailDatabase db ->
Direct.errmsg db
DetailStatement stmt -> do
db <- Direct.getStatementDatabase stmt
Direct.errmsg db
DetailMessage msg ->
return msg
throwSQLError :: DetailSource -> Text -> Error -> IO a
throwSQLError detailSource context error = do
Utf8 details <- renderDetailSource detailSource
throwIO SQLError
{ sqlError = error
, sqlErrorDetails = decodeUtf8With lenientDecode details
, sqlErrorContext = context
}
checkError :: DetailSource -> Text -> Either Error a -> IO a
checkError ds fn = either (throwSQLError ds fn) return
checkErrorMsg :: Text -> Either (Error, Utf8) a -> IO a
checkErrorMsg fn result = case result of
Left (err, msg) -> throwSQLError (DetailMessage msg) fn err
Right a -> return a
appendShow :: Show a => Text -> a -> Text
appendShow txt a = txt `T.append` (T.pack . show) a
open :: Text -> IO Database
open path =
Direct.open (toUtf8 path)
>>= checkErrorMsg ("open " `appendShow` path)
close :: Database -> IO ()
close db =
Direct.close db >>= checkError (DetailDatabase db) "close"
exec :: Database -> Text -> IO ()
exec db sql =
Direct.exec db (toUtf8 sql)
>>= checkErrorMsg ("exec " `appendShow` sql)
prepare :: Database -> Text -> IO Statement
prepare db sql = do
m <- Direct.prepare db (toUtf8 sql)
>>= checkError (DetailDatabase db) ("prepare " `appendShow` sql)
case m of
Nothing -> fail "Direct.SQLite3.prepare: empty query string"
Just stmt -> return stmt
step :: Statement -> IO StepResult
step statement =
Direct.step statement >>= checkError (DetailStatement statement) "step"
reset :: Statement -> IO ()
reset statement = do
_ <- Direct.reset statement
return ()
finalize :: Statement -> IO ()
finalize statement = do
_ <- Direct.finalize statement
return ()
bindParameterName :: Statement -> ParamIndex -> IO (Maybe Text)
bindParameterName stmt idx = do
m <- Direct.bindParameterName stmt idx
case m of
Nothing -> return Nothing
Just name -> Just <$> fromUtf8 desc name
where
desc = "Database.SQLite3.bindParameterName: Invalid UTF-8"
bindBlob :: Statement -> ParamIndex -> ByteString -> IO ()
bindBlob statement parameterIndex byteString =
Direct.bindBlob statement parameterIndex byteString
>>= checkError (DetailStatement statement) "bind blob"
bindDouble :: Statement -> ParamIndex -> Double -> IO ()
bindDouble statement parameterIndex datum =
Direct.bindDouble statement parameterIndex datum
>>= checkError (DetailStatement statement) "bind double"
bindInt :: Statement -> ParamIndex -> Int -> IO ()
bindInt statement parameterIndex datum =
Direct.bindInt64 statement
parameterIndex
(fromIntegral datum)
>>= checkError (DetailStatement statement) "bind int"
bindInt64 :: Statement -> ParamIndex -> Int64 -> IO ()
bindInt64 statement parameterIndex datum =
Direct.bindInt64 statement parameterIndex datum
>>= checkError (DetailStatement statement) "bind int64"
bindNull :: Statement -> ParamIndex -> IO ()
bindNull statement parameterIndex =
Direct.bindNull statement parameterIndex
>>= checkError (DetailStatement statement) "bind null"
bindText :: Statement -> ParamIndex -> Text -> IO ()
bindText statement parameterIndex text =
Direct.bindText statement parameterIndex (toUtf8 text)
>>= checkError (DetailStatement statement) "bind text"
bindSQLData :: Statement -> ParamIndex -> SQLData -> IO ()
bindSQLData statement idx datum =
case datum of
SQLInteger v -> bindInt64 statement idx v
SQLFloat v -> bindDouble statement idx v
SQLText v -> bindText statement idx v
SQLBlob v -> bindBlob statement idx v
SQLNull -> bindNull statement idx
bind :: Statement -> [SQLData] -> IO ()
bind statement sqlData = do
nParams <- fromIntegral <$> bindParameterCount statement
when (nParams /= length sqlData) $
fail ("mismatched parameter count for bind. Prepared statement "++
"needs "++ show nParams ++ ", " ++ show (length sqlData) ++" given")
zipWithM_ (bindSQLData statement) [1..] sqlData
columnText :: Statement -> ColumnIndex -> IO Text
columnText statement columnIndex =
Direct.columnText statement columnIndex
>>= fromUtf8 "Database.SQLite3.columnText: Invalid UTF-8"
column :: Statement -> ColumnIndex -> IO SQLData
column statement idx = do
theType <- columnType statement idx
case theType of
IntegerColumn -> SQLInteger <$> columnInt64 statement idx
FloatColumn -> SQLFloat <$> columnDouble statement idx
TextColumn -> SQLText <$> columnText statement idx
BlobColumn -> SQLBlob <$> columnBlob statement idx
NullColumn -> return SQLNull
columns :: Statement -> IO [SQLData]
columns statement = do
count <- columnCount statement
mapM (column statement) [0..count1]