| 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) |