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 | ||
28 | fun cerrmsg con = Int32.toString (F_PQstatus.f' (C.Ptr.ro' con)) ^ ": " | |
29 | ^ ZString.toML' (F_PQerrorMessage.f' (C.Ptr.ro' con)) | |
30 | ||
31 | 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 | |
32 | ||
33 | fun conn params = | |
34 | let | |
35 | val params = ZString.dupML' params | |
36 | val c = F_PQconnectdb.f' params | |
37 | val _ = C.free' params | |
38 | in | |
39 | if C.Ptr.isNull' c then | |
40 | raise Sql "Null connection returned" | |
41 | else | |
42 | (case F_PQstatus.f' (C.Ptr.ro' c) of | |
43 | 0 => c | |
44 | | _ => | |
45 | let | |
46 | val msg = cerrmsg c | |
47 | in | |
48 | F_PQfinish.f' c; | |
49 | raise Sql msg | |
50 | end) | |
51 | end | |
52 | ||
53 | fun close c = ignore (F_PQfinish.f' c) | |
54 | ||
55 | fun dml c q = | |
56 | let | |
57 | val q = ZString.dupML' q | |
58 | val res = F_PQexec.f' (c, q) | |
59 | val roRes = C.Ptr.ro' res | |
60 | val code = F_PQresultStatus.f' roRes | |
61 | fun done () = (C.free' q; | |
62 | F_PQclear.f' res) | |
63 | in | |
64 | case code of | |
65 | 1 => (done (); | |
66 | "") | |
67 | | _ => | |
68 | let | |
69 | val msg = errmsg (c, res, q) | |
70 | in | |
71 | done (); | |
72 | raise Sql msg | |
73 | end | |
74 | end | |
75 | ||
76 | fun fold c f b q = | |
77 | let | |
78 | val q = ZString.dupML' q | |
79 | val res = F_PQexec.f' (c, q) | |
80 | val roRes = C.Ptr.ro' res | |
81 | fun done () = (C.free' q; | |
82 | F_PQclear.f' res) | |
83 | ||
84 | val code = F_PQresultStatus.f' roRes | |
85 | in | |
86 | case code of | |
87 | 2 => | |
88 | let | |
89 | val nt = F_PQntuples.f' roRes | |
90 | val nf = F_PQnfields.f' roRes | |
91 | ||
92 | fun builder (i, acc) = | |
93 | if i = nt then | |
94 | acc | |
95 | else | |
96 | let | |
97 | fun build (~1, acc) = acc | |
98 | | build (j, acc) = | |
99 | build (j-1, ZString.toML' (F_PQgetvalue.f' (roRes, i, j)) :: acc) | |
100 | in | |
101 | builder (i+1, f (build (nf-1, []), acc)) | |
102 | end | |
103 | in | |
104 | builder (0, b) | |
105 | before done () | |
106 | end | |
107 | | code => | |
108 | let | |
109 | val msg = errmsg (c, res, q) | |
110 | in | |
111 | done (); | |
112 | raise Sql msg | |
113 | end | |
114 | end | |
115 | ||
116 | ||
117 | type timestamp = Time.time | |
118 | exception Format of string | |
119 | ||
c7a46c0f AC |
120 | fun isNull s = s = "" |
121 | ||
f147efc8 AC |
122 | fun intToSql n = |
123 | if n < 0 then | |
124 | "-" ^ Int.toString(~n) | |
125 | else | |
126 | Int.toString n | |
127 | fun intFromSql "" = 0 | |
128 | | intFromSql s = | |
129 | (case Int.fromString s of | |
130 | NONE => raise Format ("Bad integer: " ^ s) | |
131 | | SOME n => n) | |
132 | ||
133 | fun stringToSql s = | |
134 | let | |
135 | fun xch #"'" = "\\'" | |
136 | | xch #"\n" = "\\n" | |
137 | | xch #"\r" = "\\r" | |
138 | | xch c = str c | |
139 | in | |
140 | foldl (fn (c, s) => s ^ xch c) "'" (String.explode s) ^ "'" | |
141 | end | |
142 | fun stringFromSql s = s | |
143 | ||
144 | fun realToSql s = | |
145 | if s < 0.0 then | |
146 | "-" ^ Real.toString(~s) | |
147 | else | |
148 | Real.toString s | |
149 | fun realFromSql "" = 0.0 | |
150 | | realFromSql s = | |
151 | (case Real.fromString s of | |
152 | NONE => raise Format ("Bad real: " ^ s) | |
153 | | SOME r => r) | |
154 | fun realToString s = realToSql s | |
155 | ||
156 | fun toMonth m = | |
157 | let | |
158 | open Date | |
159 | in | |
160 | case m of | |
161 | 1 => Jan | |
162 | | 2 => Feb | |
163 | | 3 => Mar | |
164 | | 4 => Apr | |
165 | | 5 => May | |
166 | | 6 => Jun | |
167 | | 7 => Jul | |
168 | | 8 => Aug | |
169 | | 9 => Sep | |
170 | | 10 => Oct | |
171 | | 11 => Nov | |
172 | | 12 => Dec | |
173 | | _ => raise Format "Invalid month number" | |
174 | end | |
175 | ||
176 | fun fromMonth m = | |
177 | let | |
178 | open Date | |
179 | in | |
180 | case m of | |
181 | Jan => 1 | |
182 | | Feb => 2 | |
183 | | Mar => 3 | |
184 | | Apr => 4 | |
185 | | May => 5 | |
186 | | Jun => 6 | |
187 | | Jul => 7 | |
188 | | Aug => 8 | |
189 | | Sep => 9 | |
190 | | Oct => 10 | |
191 | | Nov => 11 | |
192 | | Dec => 12 | |
193 | end | |
194 | ||
195 | fun pad' (s, 0) = s | |
196 | | pad' (s, n) = pad' ("0" ^ s, n-1) | |
2f09ba1e AC |
197 | fun pad (n, i) = |
198 | let | |
199 | val base = Int.toString n | |
200 | in | |
201 | pad' (base, Int.max (i - size base, 0)) | |
202 | end | |
f147efc8 AC |
203 | |
204 | fun offsetStr NONE = "+00" | |
205 | | offsetStr (SOME n) = | |
206 | let | |
8ed75bde | 207 | val n = LargeInt.toInt (Time.toSeconds n) div 3600 |
f147efc8 AC |
208 | in |
209 | if n < 0 then | |
210 | "-" ^ pad (~n, 2) | |
211 | else | |
212 | "+" ^ pad (n, 2) | |
213 | end | |
214 | ||
2f09ba1e | 215 | fun timestampToSqlUnquoted t = |
f147efc8 AC |
216 | let |
217 | val d = Date.fromTimeLocal t | |
218 | in | |
2f09ba1e | 219 | pad (Date.year d, 4) ^ "-" ^ pad (fromMonth (Date.month d), 2) ^ "-" ^ pad (Date.day d, 2) ^ |
f147efc8 | 220 | " " ^ pad (Date.hour d, 2) ^ ":" ^ pad (Date.minute d, 2) ^ ":" ^ pad (Date.second d, 2) ^ |
2f09ba1e | 221 | ".000000" ^ offsetStr (Date.offset d) |
f147efc8 | 222 | end |
2f09ba1e | 223 | fun timestampToSql t = "'" ^ timestampToSqlUnquoted t ^ "'" |
f147efc8 AC |
224 | fun timestampFromSql s = |
225 | let | |
226 | val tokens = String.tokens (fn ch => ch = #"-" orelse ch = #" " orelse ch = #":" | |
227 | orelse ch = #"." orelse ch = #"+") s | |
228 | in | |
229 | case tokens of | |
230 | [year, mon, day, hour, minute, second, _, offset] => | |
c7a46c0f | 231 | Date.toTime (Date.date {day = intFromSql day, hour = intFromSql hour, minute = intFromSql minute, |
f147efc8 | 232 | month = toMonth (intFromSql mon), |
8ed75bde | 233 | offset = SOME (Time.fromSeconds (LargeInt.fromInt (intFromSql offset * 3600))), |
f147efc8 | 234 | second = intFromSql second div 1000, year = intFromSql year}) |
2f09ba1e | 235 | | [year, mon, day, hour, minute, second, _] => |
c7a46c0f | 236 | Date.toTime (Date.date {day = intFromSql day, hour = intFromSql hour, minute = intFromSql minute, |
2f09ba1e AC |
237 | month = toMonth (intFromSql mon), |
238 | offset = NONE, | |
c7a46c0f | 239 | second = intFromSql second, year = intFromSql year}) |
2f09ba1e | 240 | | [year, mon, day, hour, minute, second] => |
c7a46c0f | 241 | Date.toTime (Date.date {day = intFromSql day, hour = intFromSql hour, minute = intFromSql minute, |
2f09ba1e AC |
242 | month = toMonth (intFromSql mon), |
243 | offset = NONE, | |
244 | second = intFromSql second div 1000, year = intFromSql year}) | |
245 | | _ => raise Format ("Invalid timestamp " ^ s) | |
f147efc8 AC |
246 | end |
247 | ||
248 | ||
249 | fun boolToSql true = "TRUE" | |
250 | | boolToSql false = "FALSE" | |
251 | ||
252 | fun boolFromSql "FALSE" = false | |
253 | | boolFromSql "f" = false | |
254 | | boolFromSql "false" = false | |
255 | | boolFromSql "n" = false | |
256 | | boolFromSql "no" = false | |
257 | | boolFromSql "0" = false | |
258 | | boolFromSql "" = false | |
259 | | boolFromSql _ = true | |
260 | end | |
261 | ||
262 | structure PgClient = SqlClient(PgDriver) |