1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
{-# LANGUAGE FlexibleContexts #-}
{-# CFILES hdbc-sqlite3-helper.c #-}
-- above line for hugs
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
import qualified Data.Char
{- | 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 (SqlByteString x)
| BUTF8.toString x == "0" = Just True
| BUTF8.toString x == "1" = Just False
nullable _ = Nothing
typeId SqlNull = SqlUnknownT "Any"
typeId (SqlString t) = typeId' t
typeId (SqlByteString t) = typeId' $ BUTF8.toString t
typeId _ = SqlUnknownT "Unknown"
typeId' t = case map Data.Char.toLower t of
('i':'n':'t':_) -> SqlIntegerT
"text" -> SqlVarCharT
"real" -> SqlRealT
"blob" -> SqlVarBinaryT
"" -> SqlUnknownT "Any"
other -> SqlUnknownT other
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
|
