723df540ede50c5cc44722e2e6ff9ae8d964e22c
[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 intToSql n =
121 if n < 0 then
122 "-" ^ Int.toString(~n)
123 else
124 Int.toString n
125 fun intFromSql "" = 0
126 | intFromSql s =
127 (case Int.fromString s of
128 NONE => raise Format ("Bad integer: " ^ s)
129 | SOME n => n)
130
131 fun stringToSql s =
132 let
133 fun xch #"'" = "\\'"
134 | xch #"\n" = "\\n"
135 | xch #"\r" = "\\r"
136 | xch c = str c
137 in
138 foldl (fn (c, s) => s ^ xch c) "'" (String.explode s) ^ "'"
139 end
140 fun stringFromSql s = s
141
142 fun realToSql s =
143 if s < 0.0 then
144 "-" ^ Real.toString(~s)
145 else
146 Real.toString s
147 fun realFromSql "" = 0.0
148 | realFromSql s =
149 (case Real.fromString s of
150 NONE => raise Format ("Bad real: " ^ s)
151 | SOME r => r)
152 fun realToString s = realToSql s
153
154 fun toMonth m =
155 let
156 open Date
157 in
158 case m of
159 1 => Jan
160 | 2 => Feb
161 | 3 => Mar
162 | 4 => Apr
163 | 5 => May
164 | 6 => Jun
165 | 7 => Jul
166 | 8 => Aug
167 | 9 => Sep
168 | 10 => Oct
169 | 11 => Nov
170 | 12 => Dec
171 | _ => raise Format "Invalid month number"
172 end
173
174 fun fromMonth m =
175 let
176 open Date
177 in
178 case m of
179 Jan => 1
180 | Feb => 2
181 | Mar => 3
182 | Apr => 4
183 | May => 5
184 | Jun => 6
185 | Jul => 7
186 | Aug => 8
187 | Sep => 9
188 | Oct => 10
189 | Nov => 11
190 | Dec => 12
191 end
192
193 fun pad' (s, 0) = s
194 | pad' (s, n) = pad' ("0" ^ s, n-1)
195 fun pad (n, i) =
196 let
197 val base = Int.toString n
198 in
199 pad' (base, Int.max (i - size base, 0))
200 end
201
202 fun offsetStr NONE = "+00"
203 | offsetStr (SOME n) =
204 let
205 val n = Int32.toInt (Time.toSeconds n) div 3600
206 in
207 if n < 0 then
208 "-" ^ pad (~n, 2)
209 else
210 "+" ^ pad (n, 2)
211 end
212
213 fun timestampToSqlUnquoted t =
214 let
215 val d = Date.fromTimeLocal t
216 in
217 pad (Date.year d, 4) ^ "-" ^ pad (fromMonth (Date.month d), 2) ^ "-" ^ pad (Date.day d, 2) ^
218 " " ^ pad (Date.hour d, 2) ^ ":" ^ pad (Date.minute d, 2) ^ ":" ^ pad (Date.second d, 2) ^
219 ".000000" ^ offsetStr (Date.offset d)
220 end
221 fun timestampToSql t = "'" ^ timestampToSqlUnquoted t ^ "'"
222 fun timestampFromSql s =
223 let
224 val tokens = String.tokens (fn ch => ch = #"-" orelse ch = #" " orelse ch = #":"
225 orelse ch = #"." orelse ch = #"+") s
226 in
227 case tokens of
228 [year, mon, day, hour, minute, second, _, offset] =>
229 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql mon, minute = intFromSql minute,
230 month = toMonth (intFromSql mon),
231 offset = SOME (Time.fromSeconds (Int32.fromInt (intFromSql offset * 3600))),
232 second = intFromSql second div 1000, year = intFromSql year})
233 | [year, mon, day, hour, minute, second, _] =>
234 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql mon, minute = intFromSql minute,
235 month = toMonth (intFromSql mon),
236 offset = NONE,
237 second = intFromSql second div 1000, year = intFromSql year})
238 | [year, mon, day, hour, minute, second] =>
239 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql mon, minute = intFromSql minute,
240 month = toMonth (intFromSql mon),
241 offset = NONE,
242 second = intFromSql second div 1000, year = intFromSql year})
243 | _ => raise Format ("Invalid timestamp " ^ s)
244 end
245
246
247 fun boolToSql true = "TRUE"
248 | boolToSql false = "FALSE"
249
250 fun boolFromSql "FALSE" = false
251 | boolFromSql "f" = false
252 | boolFromSql "false" = false
253 | boolFromSql "n" = false
254 | boolFromSql "no" = false
255 | boolFromSql "0" = false
256 | boolFromSql "" = false
257 | boolFromSql _ = true
258 end
259
260 structure PgClient = SqlClient(PgDriver)