module Database.SQLite.Simple (
open
, close
, query
, query_
, execute
, execute_
, field
, Query
, Connection
, ToRow
, FromRow
, In(..)
, Only(..)
, (:.)(..)
, FormatError(fmtMessage, fmtQuery, fmtParams)
, ResultError(errSQLType, errHaskellType, errMessage)
) where
import Control.Applicative
import Control.Exception
( Exception, throw, throwIO, bracket )
import Control.Monad (void, when)
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString (ByteString)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Database.SQLite.Simple.Types
import qualified Database.SQLite3 as Base
import qualified Data.ByteString.Char8 as B
import Database.SQLite.Simple.FromField (ResultError(..))
import Database.SQLite.Simple.Internal
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToRow (ToRow(..))
import Database.SQLite.Simple.FromRow
data FormatError = FormatError {
fmtMessage :: String
, fmtQuery :: Query
, fmtParams :: [ByteString]
} deriving (Eq, Show, Typeable)
instance Exception FormatError
open :: String -> IO Connection
open fname = Connection <$> Base.open fname
close :: Connection -> IO ()
close (Connection c) = Base.close c
withBind :: Query -> Base.Statement -> [Base.SQLData] -> IO r -> IO r
withBind templ stmt qp action = do
stmtParamCount <- Base.bindParameterCount stmt
when (length qp /= stmtParamCount) (throwColumnMismatch qp stmtParamCount)
mapM_ errorCheckParamName [1..stmtParamCount]
Base.bind stmt qp
action
where
throwColumnMismatch qp nParams =
fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++
show (length qp) ++ " arguments given") templ qp
errorCheckParamName paramNdx = do
name <- Base.bindParameterName stmt paramNdx
case name of
Just n ->
fmtError ("Only unnamed '?' query parameters are accepted, '"++n++"' given")
templ qp
Nothing -> return ()
execute :: (ToRow q) => Connection -> Query -> q -> IO ()
execute (Connection c) template@(Query t) qs = do
bracket (Base.prepare c (T.unpack t)) Base.finalize go
where
go stmt = withBind template stmt (toRow qs) (void $ Base.step stmt)
query :: (ToRow q, FromRow r)
=> Connection -> Query -> q -> IO [r]
query (Connection conn) templ@(Query t) qs = do
bracket (Base.prepare conn (T.unpack t)) Base.finalize go
where
go stmt = withBind templ stmt (toRow qs) (stepStmt stmt >>= finishQuery)
query_ :: (FromRow r) => Connection -> Query -> IO [r]
query_ conn (Query que) = do
result <- exec conn que
finishQuery result
execute_ :: Connection -> Query -> IO ()
execute_ (Connection conn) (Query que) =
bracket (Base.prepare conn (T.unpack que)) Base.finalize go
where
go stmt = void $ Base.step stmt
finishQuery :: (FromRow r) => Result -> IO [r]
finishQuery rows =
mapM doRow $ zip rows [0..]
where
doRow (rowRes, rowNdx) = do
let rw = Row rowNdx rowRes
case runStateT (runReaderT (unRP fromRow) rw) 0 of
Ok (val,col) | col == ncols -> return val
| otherwise -> do
let vals = map (\f -> (gettypename f, f)) rowRes
throw (ConversionFailed
(show ncols ++ " values: " ++ show vals)
(show col ++ " slots in target type")
"mismatch between number of columns to \
\convert and number in target type")
Errors [] -> throwIO $ ConversionFailed "" "" "unknown error"
Errors [x] -> throwIO x
Errors xs -> throwIO $ ManyErrors xs
ncols = length . head $ rows
fmtError :: String -> Query -> [Base.SQLData] -> a
fmtError msg q xs = throw FormatError {
fmtMessage = msg
, fmtQuery = q
, fmtParams = map (B.pack . show) xs
}