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)