Commit | Line | Data |
---|---|---|
f147efc8 AC |
1 | (* |
2 | * SQL database interfaces for Standard ML | |
3 | * Copyright (C) 2003 Adam Chlipala | |
4 | * | |
5 | * This library is free software; you can redistribute it and/or | |
6 | * modify it under the terms of the GNU Lesser General Public | |
7 | * License as published by the Free Software Foundation; either | |
8 | * version 2.1 of the License, or (at your option) any later version. | |
9 | * | |
10 | * This library is distributed in the hope that it will be useful, | |
11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | * Lesser General Public License for more details. | |
14 | * | |
15 | * You should have received a copy of the GNU Lesser General Public | |
16 | * License along with this library; if not, write to the Free Software | |
17 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
18 | *) | |
19 | ||
20 | structure PgDriver :> SQL_DRIVER = | |
21 | struct | |
22 | val print = TextIO.print | |
23 | ||
24 | type conn = (ST_pg_conn.tag, C.rw) C.su_obj C.ptr' | |
25 | ||
26 | exception Sql of string | |
27 | ||
d08450a7 AC |
28 | type value = string option |
29 | ||
f147efc8 AC |
30 | fun cerrmsg con = Int32.toString (F_PQstatus.f' (C.Ptr.ro' con)) ^ ": " |
31 | ^ ZString.toML' (F_PQerrorMessage.f' (C.Ptr.ro' con)) | |
32 | ||
33 | fun errmsg (con, res, query) = Int32.toString (F_PQresultStatus.f' (C.Ptr.ro' res)) ^ ": " ^ ZString.toML' (F_PQresultErrorMessage.f' (C.Ptr.ro' res)) ^ ": " ^ ZString.toML' query | |
34 | ||
35 | fun conn params = | |
36 | let | |
37 | val params = ZString.dupML' params | |
38 | val c = F_PQconnectdb.f' params | |
39 | val _ = C.free' params | |
40 | in | |
41 | if C.Ptr.isNull' c then | |
42 | raise Sql "Null connection returned" | |
43 | else | |
44 | (case F_PQstatus.f' (C.Ptr.ro' c) of | |
45 | 0 => c | |
46 | | _ => | |
47 | let | |
48 | val msg = cerrmsg c | |
49 | in | |
50 | F_PQfinish.f' c; | |
51 | raise Sql msg | |
52 | end) | |
53 | end | |
54 | ||
55 | fun close c = ignore (F_PQfinish.f' c) | |
56 | ||
57 | fun dml c q = | |
58 | let | |
59 | val q = ZString.dupML' q | |
60 | val res = F_PQexec.f' (c, q) | |
61 | val roRes = C.Ptr.ro' res | |
62 | val code = F_PQresultStatus.f' roRes | |
63 | fun done () = (C.free' q; | |
64 | F_PQclear.f' res) | |
65 | in | |
66 | case code of | |
67 | 1 => (done (); | |
68 | "") | |
69 | | _ => | |
70 | let | |
71 | val msg = errmsg (c, res, q) | |
72 | in | |
73 | done (); | |
74 | raise Sql msg | |
75 | end | |
76 | end | |
77 | ||
d08450a7 AC |
78 | fun makeValue v = |
79 | if C.Ptr.isNull' v then | |
80 | NONE | |
81 | else | |
82 | SOME (ZString.toML' v) | |
83 | ||
f147efc8 AC |
84 | fun fold c f b q = |
85 | let | |
86 | val q = ZString.dupML' q | |
87 | val res = F_PQexec.f' (c, q) | |
88 | val roRes = C.Ptr.ro' res | |
89 | fun done () = (C.free' q; | |
90 | F_PQclear.f' res) | |
91 | ||
92 | val code = F_PQresultStatus.f' roRes | |
93 | in | |
94 | case code of | |
95 | 2 => | |
96 | let | |
97 | val nt = F_PQntuples.f' roRes | |
98 | val nf = F_PQnfields.f' roRes | |
99 | ||
100 | fun builder (i, acc) = | |
101 | if i = nt then | |
102 | acc | |
103 | else | |
104 | let | |
105 | fun build (~1, acc) = acc | |
106 | | build (j, acc) = | |
8c0e7607 AC |
107 | build (j-1, |
108 | if F_PQgetisnull.f' (roRes, i, j) <> 0 then | |
109 | NONE :: acc | |
110 | else | |
111 | makeValue (F_PQgetvalue.f' (roRes, i, j)) :: acc) | |
f147efc8 AC |
112 | in |
113 | builder (i+1, f (build (nf-1, []), acc)) | |
114 | end | |
115 | in | |
116 | builder (0, b) | |
117 | before done () | |
118 | end | |
119 | | code => | |
120 | let | |
121 | val msg = errmsg (c, res, q) | |
122 | in | |
123 | done (); | |
124 | raise Sql msg | |
125 | end | |
126 | end | |
127 | ||
128 | ||
129 | type timestamp = Time.time | |
130 | exception Format of string | |
131 | ||
d08450a7 AC |
132 | fun valueOf v = |
133 | case v of | |
134 | NONE => raise Sql "Trying to read NULL value" | |
135 | | SOME v => v | |
136 | ||
137 | fun isNull s = | |
138 | case s of | |
139 | NONE => true | |
140 | | _ => false | |
c7a46c0f | 141 | |
f147efc8 AC |
142 | fun intToSql n = |
143 | if n < 0 then | |
144 | "-" ^ Int.toString(~n) | |
145 | else | |
146 | Int.toString n | |
d08450a7 AC |
147 | fun intFromSql' "" = 0 |
148 | | intFromSql' s = | |
f147efc8 AC |
149 | (case Int.fromString s of |
150 | NONE => raise Format ("Bad integer: " ^ s) | |
151 | | SOME n => n) | |
d08450a7 | 152 | fun intFromSql v = intFromSql' (valueOf v) |
f147efc8 AC |
153 | |
154 | fun stringToSql s = | |
155 | let | |
156 | fun xch #"'" = "\\'" | |
157 | | xch #"\n" = "\\n" | |
158 | | xch #"\r" = "\\r" | |
159 | | xch c = str c | |
160 | in | |
69b0d5cf | 161 | foldl (fn (c, s) => s ^ xch c) "E'" (String.explode s) ^ "'" |
f147efc8 | 162 | end |
d08450a7 | 163 | val stringFromSql = valueOf |
f147efc8 AC |
164 | |
165 | fun realToSql s = | |
166 | if s < 0.0 then | |
167 | "-" ^ Real.toString(~s) | |
168 | else | |
169 | Real.toString s | |
d08450a7 AC |
170 | fun realFromSql' "" = 0.0 |
171 | | realFromSql' s = | |
f147efc8 AC |
172 | (case Real.fromString s of |
173 | NONE => raise Format ("Bad real: " ^ s) | |
174 | | SOME r => r) | |
d08450a7 | 175 | fun realFromSql v = realFromSql' (valueOf v) |
f147efc8 AC |
176 | fun realToString s = realToSql s |
177 | ||
178 | fun toMonth m = | |
179 | let | |
180 | open Date | |
181 | in | |
182 | case m of | |
183 | 1 => Jan | |
184 | | 2 => Feb | |
185 | | 3 => Mar | |
186 | | 4 => Apr | |
187 | | 5 => May | |
188 | | 6 => Jun | |
189 | | 7 => Jul | |
190 | | 8 => Aug | |
191 | | 9 => Sep | |
192 | | 10 => Oct | |
193 | | 11 => Nov | |
194 | | 12 => Dec | |
195 | | _ => raise Format "Invalid month number" | |
196 | end | |
197 | ||
198 | fun fromMonth m = | |
199 | let | |
200 | open Date | |
201 | in | |
202 | case m of | |
203 | Jan => 1 | |
204 | | Feb => 2 | |
205 | | Mar => 3 | |
206 | | Apr => 4 | |
207 | | May => 5 | |
208 | | Jun => 6 | |
209 | | Jul => 7 | |
210 | | Aug => 8 | |
211 | | Sep => 9 | |
212 | | Oct => 10 | |
213 | | Nov => 11 | |
214 | | Dec => 12 | |
215 | end | |
216 | ||
217 | fun pad' (s, 0) = s | |
218 | | pad' (s, n) = pad' ("0" ^ s, n-1) | |
2f09ba1e AC |
219 | fun pad (n, i) = |
220 | let | |
221 | val base = Int.toString n | |
222 | in | |
223 | pad' (base, Int.max (i - size base, 0)) | |
224 | end | |
f147efc8 AC |
225 | |
226 | fun offsetStr NONE = "+00" | |
227 | | offsetStr (SOME n) = | |
228 | let | |
8ed75bde | 229 | val n = LargeInt.toInt (Time.toSeconds n) div 3600 |
f147efc8 AC |
230 | in |
231 | if n < 0 then | |
232 | "-" ^ pad (~n, 2) | |
233 | else | |
234 | "+" ^ pad (n, 2) | |
235 | end | |
236 | ||
2f09ba1e | 237 | fun timestampToSqlUnquoted t = |
f147efc8 AC |
238 | let |
239 | val d = Date.fromTimeLocal t | |
240 | in | |
2f09ba1e | 241 | pad (Date.year d, 4) ^ "-" ^ pad (fromMonth (Date.month d), 2) ^ "-" ^ pad (Date.day d, 2) ^ |
f147efc8 | 242 | " " ^ pad (Date.hour d, 2) ^ ":" ^ pad (Date.minute d, 2) ^ ":" ^ pad (Date.second d, 2) ^ |
2f09ba1e | 243 | ".000000" ^ offsetStr (Date.offset d) |
f147efc8 | 244 | end |
2f09ba1e | 245 | fun timestampToSql t = "'" ^ timestampToSqlUnquoted t ^ "'" |
d08450a7 | 246 | fun timestampFromSql' s = |
f147efc8 AC |
247 | let |
248 | val tokens = String.tokens (fn ch => ch = #"-" orelse ch = #" " orelse ch = #":" | |
249 | orelse ch = #"." orelse ch = #"+") s | |
250 | in | |
251 | case tokens of | |
252 | [year, mon, day, hour, minute, second, _, offset] => | |
d08450a7 AC |
253 | Date.toTime (Date.date {day = valOf (Int.fromString day), hour = valOf (Int.fromString hour), minute = valOf (Int.fromString minute), |
254 | month = toMonth (valOf (Int.fromString mon)), | |
255 | offset = SOME (Time.fromSeconds (LargeInt.fromInt (valOf (Int.fromString offset) * 3600))), | |
256 | second = valOf (Int.fromString second) div 1000, year = valOf (Int.fromString year)}) | |
2f09ba1e | 257 | | [year, mon, day, hour, minute, second, _] => |
d08450a7 AC |
258 | Date.toTime (Date.date {day = valOf (Int.fromString day), hour = valOf (Int.fromString hour), minute = valOf (Int.fromString minute), |
259 | month = toMonth (valOf (Int.fromString mon)), | |
2f09ba1e | 260 | offset = NONE, |
d08450a7 | 261 | second = valOf (Int.fromString second), year = valOf (Int.fromString year)}) |
2f09ba1e | 262 | | [year, mon, day, hour, minute, second] => |
d08450a7 AC |
263 | Date.toTime (Date.date {day = valOf (Int.fromString day), hour = valOf (Int.fromString hour), minute = valOf (Int.fromString minute), |
264 | month = toMonth (valOf (Int.fromString mon)), | |
2f09ba1e | 265 | offset = NONE, |
d08450a7 | 266 | second = valOf (Int.fromString second) div 1000, year = valOf (Int.fromString year)}) |
2f09ba1e | 267 | | _ => raise Format ("Invalid timestamp " ^ s) |
f147efc8 | 268 | end |
d08450a7 | 269 | fun timestampFromSql v = timestampFromSql' (valueOf v) |
f147efc8 AC |
270 | |
271 | ||
272 | fun boolToSql true = "TRUE" | |
273 | | boolToSql false = "FALSE" | |
274 | ||
d08450a7 AC |
275 | fun boolFromSql' "FALSE" = false |
276 | | boolFromSql' "f" = false | |
277 | | boolFromSql' "false" = false | |
278 | | boolFromSql' "n" = false | |
279 | | boolFromSql' "no" = false | |
280 | | boolFromSql' "0" = false | |
281 | | boolFromSql' "" = false | |
282 | | boolFromSql' _ = true | |
283 | ||
284 | fun boolFromSql v = boolFromSql' (valueOf v) | |
f147efc8 AC |
285 | end |
286 | ||
69b0d5cf | 287 | structure PgClient = SqlClient(PgDriver) |