HDBC-sqlite3-2.3.1.0: Database/HDBC/Sqlite3/Connection.hs
{-# CFILES hdbc-sqlite3-helper.c #-}
-- above line for hugs
{-
Copyright (C) 2005-2009 John Goerzen <jgoerzen@complete.org>
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
-}
module Database.HDBC.Sqlite3.Connection
(connectSqlite3, connectSqlite3Raw, Impl.Connection())
where
import Database.HDBC.Types
import Database.HDBC
import Database.HDBC.DriverUtils
import qualified Database.HDBC.Sqlite3.ConnectionImpl as Impl
import Database.HDBC.Sqlite3.Types
import Database.HDBC.Sqlite3.Statement
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal
import Foreign.Storable
import Database.HDBC.Sqlite3.Utils
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Concurrent.MVar
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BUTF8
{- | Connect to an Sqlite version 3 database. The only parameter needed is
the filename of the database to connect to.
All database accessor functions are provided in the main HDBC module. -}
connectSqlite3 :: FilePath -> IO Impl.Connection
connectSqlite3 =
genericConnect (B.useAsCString . BUTF8.fromString)
{- | Connects to a Sqlite v3 database as with 'connectSqlite3', but
instead of converting the supplied 'FilePath' to a C String by performing
a conversion to Unicode, instead converts it by simply dropping all bits past
the eighth. This may be useful in rare situations
if your application or filesystemare not running in Unicode space. -}
connectSqlite3Raw :: FilePath -> IO Impl.Connection
connectSqlite3Raw = genericConnect withCString
genericConnect :: (String -> (CString -> IO Impl.Connection) -> IO Impl.Connection)
-> FilePath
-> IO Impl.Connection
genericConnect strAsCStrFunc fp =
strAsCStrFunc fp
(\cs -> alloca
(\(p::Ptr (Ptr CSqlite3)) ->
do res <- sqlite3_open cs p
o <- peek p
fptr <- newForeignPtr sqlite3_closeptr o
newconn <- mkConn fp fptr
checkError ("connectSqlite3 " ++ fp) fptr res
return newconn
)
)
mkConn :: FilePath -> Sqlite3 -> IO Impl.Connection
mkConn fp obj =
do children <- newMVar []
begin_transaction obj children
ver <- (sqlite3_libversion >>= peekCString)
return $ Impl.Connection {
Impl.disconnect = fdisconnect obj children,
Impl.commit = fcommit obj children,
Impl.rollback = frollback obj children,
Impl.run = frun obj children,
Impl.runRaw = frunRaw obj children,
Impl.prepare = newSth obj children True,
Impl.clone = connectSqlite3 fp,
Impl.hdbcDriverName = "sqlite3",
Impl.hdbcClientVer = ver,
Impl.proxiedClientName = "sqlite3",
Impl.proxiedClientVer = ver,
Impl.dbTransactionSupport = True,
Impl.dbServerVer = ver,
Impl.getTables = fgettables obj children,
Impl.describeTable = fdescribeTable obj children,
Impl.setBusyTimeout = fsetbusy obj}
fgettables o mchildren =
do sth <- newSth o mchildren True "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name"
execute sth []
res1 <- fetchAllRows' sth
let res = map fromSql $ concat res1
return $ seq (length res) res
fdescribeTable o mchildren name = do
sth <- newSth o mchildren True $ "PRAGMA table_info(" ++ name ++ ")"
execute sth []
res1 <- fetchAllRows' sth
return $ map describeCol res1
where
describeCol (_:name:typ:notnull:df:pk:_) =
(fromSql name, describeType typ notnull df pk)
describeType name notnull df pk =
SqlColDesc (typeId name) Nothing Nothing Nothing (nullable notnull)
nullable SqlNull = Nothing
nullable (SqlString "0") = Just True
nullable (SqlString "1") = Just False
nullable _ = Nothing
typeId SqlNull = SqlUnknownT "Any"
typeId (SqlString ('i':'n':'t':_)) = SqlIntegerT
typeId (SqlString "text") = SqlVarCharT
typeId (SqlString "real") = SqlRealT
typeId (SqlString "blob") = SqlVarBinaryT
typeId (SqlString "") = SqlUnknownT "Any"
typeId (SqlString other) = SqlUnknownT other
typeId _ = SqlUnknownT "Unknown"
fsetbusy o ms = withRawSqlite3 o $ \ppdb ->
sqlite3_busy_timeout ppdb ms
--------------------------------------------------
-- Guts here
--------------------------------------------------
begin_transaction :: Sqlite3 -> ChildList -> IO ()
begin_transaction o children = frun o children "BEGIN" [] >> return ()
frun o mchildren query args =
do sth <- newSth o mchildren False query
res <- execute sth args
finish sth
return res
frunRaw :: Sqlite3 -> ChildList -> String -> IO ()
frunRaw o mchildren query =
do sth <- newSth o mchildren False query
executeRaw sth
finish sth
fcommit o children = do frun o children "COMMIT" []
begin_transaction o children
frollback o children = do frun o children "ROLLBACK" []
begin_transaction o children
fdisconnect :: Sqlite3 -> ChildList -> IO ()
fdisconnect o mchildren = withRawSqlite3 o $ \p ->
do closeAllChildren mchildren
r <- sqlite3_close p
checkError "disconnect" o r
foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_open2"
sqlite3_open :: CString -> (Ptr (Ptr CSqlite3)) -> IO CInt
foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_close_finalizer"
sqlite3_closeptr :: FunPtr ((Ptr CSqlite3) -> IO ())
foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_close_app"
sqlite3_close :: Ptr CSqlite3 -> IO CInt
foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_busy_timeout2"
sqlite3_busy_timeout :: Ptr CSqlite3 -> CInt -> IO ()
foreign import ccall unsafe "sqlite3.h sqlite3_libversion"
sqlite3_libversion :: IO CString