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
|
-----------------------------------------------------------------------------------------
{-| Module : Database.HSQL.SQLite
Copyright : (c) Krasimir Angelov 2003
License : BSD-style
Maintainer : kr.angelov@gmail.com
Stability : provisional
Portability : portable
The module provides interface to SQLite
-}
-----------------------------------------------------------------------------------------
module Database.HSQL.SQLite(connect, module Database.HSQL) where
import Database.HSQL
import Database.HSQL.Types
import Foreign
import Foreign.C
import System.IO
import Control.Monad(when)
import Control.Exception(throwDyn)
import Control.Concurrent.MVar
#include <fcntl.h>
#include <sqlite.h>
type SQLite = Ptr ()
foreign import ccall sqlite_open :: CString -> CInt -> Ptr CString -> IO SQLite
foreign import ccall sqlite_close :: SQLite -> IO ()
foreign import ccall sqlite_exec :: SQLite -> CString -> FunPtr () -> Ptr () -> Ptr CString -> IO CInt
foreign import ccall sqlite_get_table :: SQLite -> CString -> Ptr (Ptr CString) -> Ptr CInt -> Ptr CInt -> Ptr CString -> IO CInt
foreign import ccall sqlite_free_table :: Ptr CString -> IO ()
foreign import ccall sqlite_freemem :: CString -> IO ()
foreign import ccall "strlen" strlen :: CString -> IO CInt
-----------------------------------------------------------------------------------------
-- routines for handling exceptions
-----------------------------------------------------------------------------------------
handleSqlResult :: CInt -> Ptr CString -> IO ()
handleSqlResult res ppMsg
| res == (#const SQLITE_OK) = return ()
| otherwise = do
pMsg <- peek ppMsg
msg <- peekCString pMsg
sqlite_freemem pMsg
throwDyn (SqlError "E" (fromIntegral res) msg)
-----------------------------------------------------------------------------------------
-- Connect
-----------------------------------------------------------------------------------------
connect :: FilePath -> IOMode -> IO Connection
connect fpath mode =
alloca $ \ppMsg ->
withCString fpath $ \pFPath -> do
sqlite <- sqlite_open pFPath 0 ppMsg
when (sqlite == nullPtr) $ do
pMsg <- peek ppMsg
msg <- peekCString pMsg
free pMsg
throwDyn (SqlError
{ seState = "C"
, seNativeError = 0
, seErrorMsg = msg
})
refFalse <- newMVar False
let connection = Connection
{ connDisconnect = sqlite_close sqlite
, connClosed = refFalse
, connExecute = execute sqlite
, connQuery = query connection sqlite
, connTables = tables connection sqlite
, connDescribe = describe connection sqlite
, connBeginTransaction = execute sqlite "BEGIN TRANSACTION"
, connCommitTransaction = execute sqlite "COMMIT TRANSACTION"
, connRollbackTransaction = execute sqlite "ROLLBACK TRANSACTION"
}
return connection
where
oflags1 = case mode of
ReadMode -> (#const O_RDONLY)
WriteMode -> (#const O_WRONLY)
ReadWriteMode -> (#const O_RDWR)
AppendMode -> (#const O_APPEND)
execute :: SQLite -> String -> IO ()
execute sqlite query =
withCString query $ \pQuery -> do
alloca $ \ppMsg -> do
res <- sqlite_exec sqlite pQuery nullFunPtr nullPtr ppMsg
handleSqlResult res ppMsg
query :: Connection -> SQLite -> String -> IO Statement
query connection sqlite query = do
withCString query $ \pQuery -> do
alloca $ \ppResult -> do
alloca $ \pnRow -> do
alloca $ \pnColumn -> do
alloca $ \ppMsg -> do
res <- sqlite_get_table sqlite pQuery ppResult pnRow pnColumn ppMsg
handleSqlResult res ppMsg
pResult <- peek ppResult
rows <- fmap fromIntegral (peek pnRow)
columns <- fmap fromIntegral (peek pnColumn)
defs <- getFieldDefs pResult 0 columns
refFalse <- newMVar False
refIndex <- newMVar 0
return (Statement
{ stmtConn = connection
, stmtClose = sqlite_free_table pResult
, stmtFetch = fetch refIndex rows
, stmtGetCol = getColValue pResult refIndex columns rows
, stmtFields = defs
, stmtClosed = refFalse
})
where
getFieldDefs :: Ptr CString -> Int -> Int -> IO [FieldDef]
getFieldDefs pResult index count
| index >= count = return []
| otherwise = do
name <- peekElemOff pResult index >>= peekCString
defs <- getFieldDefs pResult (index+1) count
return ((name,SqlText,True):defs)
tables :: Connection -> SQLite -> IO [String]
tables connection sqlite = do
stmt <- query connection sqlite "select tbl_name from sqlite_master"
collectRows (\stmt -> getFieldValue stmt "tbl_name") stmt
describe :: Connection -> SQLite -> String -> IO [FieldDef]
describe connection sqlite table = do
stmt <- query connection sqlite ("pragma table_info("++table++")")
collectRows getRow stmt
where
getRow stmt = do
name <- getFieldValue stmt "name"
notnull <- getFieldValue stmt "notnull"
return (name, SqlText, notnull=="0")
fetch tupleIndex countTuples =
modifyMVar tupleIndex (\index -> return (index+1,index < countTuples))
getColValue pResult refIndex columns rows colNumber (name,sqlType,nullable) f = do
index <- readMVar refIndex
when (index > rows) (throwDyn SqlNoData)
pStr <- peekElemOff pResult (columns*index+colNumber)
if pStr == nullPtr
then return Nothing
else do
strLen <- strlen pStr
mb_value <- f sqlType pStr (fromIntegral strLen)
case mb_value of
Just v -> return (Just v)
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
|
