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