Various improvements made while working on relwiki
[hcoop/smlsql.git] / libpq / pg.sml
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
120 fun isNull s = s = ""
121
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)
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
203
204 fun offsetStr NONE = "+00"
205 | offsetStr (SOME n) =
206 let
207 val n = Int32.toInt (Time.toSeconds n) div 3600
208 in
209 if n < 0 then
210 "-" ^ pad (~n, 2)
211 else
212 "+" ^ pad (n, 2)
213 end
214
215 fun timestampToSqlUnquoted t =
216 let
217 val d = Date.fromTimeLocal t
218 in
219 pad (Date.year d, 4) ^ "-" ^ pad (fromMonth (Date.month d), 2) ^ "-" ^ pad (Date.day d, 2) ^
220 " " ^ pad (Date.hour d, 2) ^ ":" ^ pad (Date.minute d, 2) ^ ":" ^ pad (Date.second d, 2) ^
221 ".000000" ^ offsetStr (Date.offset d)
222 end
223 fun timestampToSql t = "'" ^ timestampToSqlUnquoted t ^ "'"
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] =>
231 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql hour, minute = intFromSql minute,
232 month = toMonth (intFromSql mon),
233 offset = SOME (Time.fromSeconds (Int32.fromInt (intFromSql offset * 3600))),
234 second = intFromSql second div 1000, year = intFromSql year})
235 | [year, mon, day, hour, minute, second, _] =>
236 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql hour, minute = intFromSql minute,
237 month = toMonth (intFromSql mon),
238 offset = NONE,
239 second = intFromSql second, year = intFromSql year})
240 | [year, mon, day, hour, minute, second] =>
241 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql hour, minute = intFromSql minute,
242 month = toMonth (intFromSql mon),
243 offset = NONE,
244 second = intFromSql second div 1000, year = intFromSql year})
245 | _ => raise Format ("Invalid timestamp " ^ s)
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)