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,
 108                                            if F_PQgetisnull.f' (roRes, i, j) <> 0 then
 109                                                NONE :: acc
 110                                            else
 111                                                makeValue (F_PQgetvalue.f' (roRes, i, j)) :: acc)
 112                             in
 113                                 builder (i+1, f (build (nf-1, []), acc))
 114                             end
 115                 in
 116                     builder (0, b)
 117                     before done ()
 118                 end
 119               | code =>
 120                 let
 121                     val msg = errmsg (c, res, q)
 122                 in
 123                     done ();
 124                     raise Sql msg
 125                 end
 126         end
 127
 128
 129     type timestamp = Time.time
 130     exception Format of string
 131
 132     fun valueOf v =
 133         case v of
 134             NONE => raise Sql "Trying to read NULL value"
 135           | SOME v => v
 136
 137     fun isNull s =
 138         case s of
 139             NONE => true
 140           | _ => false
 141
 142     fun intToSql n =
 143         if n < 0 then
 144             "-" ^ Int.toString(~n)
 145         else
 146             Int.toString n
 147     fun intFromSql' "" = 0
 148       | intFromSql' s =
 149         (case Int.fromString s of
 150              NONE => raise Format ("Bad integer: " ^ s)
 151            | SOME n => n)
 152     fun intFromSql v = intFromSql' (valueOf v)
 153
 154     fun stringToSql s =
 155         let
 156             fun xch #"'" = "\\'"
 157               | xch #"\n" = "\\n"
 158               | xch #"\r" = "\\r"
 159               | xch c = str c
 160         in
 161             foldl (fn (c, s) => s ^ xch c) "'" (String.explode s) ^ "'"
 162         end
 163     val stringFromSql = valueOf
 164
 165     fun realToSql s =
 166         if s < 0.0 then
 167             "-" ^ Real.toString(~s)
 168         else
 169             Real.toString s
 170     fun realFromSql' "" = 0.0
 171       | realFromSql' s =
 172         (case Real.fromString s of
 173              NONE => raise Format ("Bad real: " ^ s)
 174            | SOME r => r)
 175     fun realFromSql v = realFromSql' (valueOf v)
 176     fun realToString s = realToSql s
 177
 178     fun toMonth m =
 179         let
 180             open Date
 181         in
 182             case m of
 183                 1 => Jan
 184               | 2 => Feb
 185               | 3 => Mar
 186               | 4 => Apr
 187               | 5 => May
 188               | 6 => Jun
 189               | 7 => Jul
 190               | 8 => Aug
 191               | 9 => Sep
 192               | 10 => Oct
 193               | 11 => Nov
 194               | 12 => Dec
 195               | _ => raise Format "Invalid month number"
 196         end
 197
 198     fun fromMonth m =
 199         let
 200             open Date
 201         in
 202             case m of
 203                 Jan => 1
 204               | Feb => 2
 205               | Mar => 3
 206               | Apr => 4
 207               | May => 5
 208               | Jun => 6
 209               | Jul => 7
 210               | Aug => 8
 211               | Sep => 9
 212               | Oct => 10
 213               | Nov => 11
 214               | Dec => 12
 215         end
 216
 217     fun pad' (s, 0) = s
 218       | pad' (s, n) = pad' ("0" ^ s, n-1)
 219     fun pad (n, i) =
 220         let
 221             val base = Int.toString n
 222         in
 223             pad' (base, Int.max (i - size base, 0))
 224         end
 225
 226     fun offsetStr NONE = "+00"
 227       | offsetStr (SOME n) =
 228         let
 229             val n = LargeInt.toInt (Time.toSeconds n) div 3600
 230         in
 231             if n < 0 then
 232                 "-" ^ pad (~n, 2)
 233             else
 234                 "+" ^ pad (n, 2)
 235         end
 236
 237     fun timestampToSqlUnquoted t =
 238         let
 239             val d = Date.fromTimeLocal t
 240         in
 241             pad (Date.year d, 4) ^ "-" ^ pad (fromMonth (Date.month d), 2) ^ "-" ^ pad (Date.day d, 2) ^
 242             " " ^ pad (Date.hour d, 2) ^ ":" ^ pad (Date.minute d, 2) ^ ":" ^ pad (Date.second d, 2) ^
 243             ".000000" ^ offsetStr (Date.offset d)
 244         end
 245     fun timestampToSql t = "'" ^ timestampToSqlUnquoted t ^ "'"
 246     fun timestampFromSql' s =
 247         let
 248             val tokens = String.tokens (fn ch => ch = #"-" orelse ch = #" " orelse ch = #":"
 249                                                  orelse ch = #"." orelse ch = #"+") s
 250         in
 251             case tokens of
 252                 [year, mon, day, hour, minute, second, _, offset] =>
 253                 Date.toTime (Date.date {day = valOf (Int.fromString day), hour = valOf (Int.fromString hour), minute = valOf (Int.fromString minute),
 254                                         month = toMonth (valOf (Int.fromString mon)),
 255                                         offset = SOME (Time.fromSeconds (LargeInt.fromInt (valOf (Int.fromString offset) * 3600))),
 256                                         second = valOf (Int.fromString second) div 1000, year = valOf (Int.fromString year)})
 257               | [year, mon, day, hour, minute, second, _] =>
 258                 Date.toTime (Date.date {day = valOf (Int.fromString day), hour = valOf (Int.fromString hour), minute = valOf (Int.fromString minute),
 259                                         month = toMonth (valOf (Int.fromString mon)),
 260                                         offset = NONE,
 261                                         second = valOf (Int.fromString second), year = valOf (Int.fromString year)})
 262               | [year, mon, day, hour, minute, second] =>
 263                 Date.toTime (Date.date {day = valOf (Int.fromString day), hour = valOf (Int.fromString hour), minute = valOf (Int.fromString minute),
 264                                         month = toMonth (valOf (Int.fromString mon)),
 265                                         offset = NONE,
 266                                         second = valOf (Int.fromString second) div 1000, year = valOf (Int.fromString year)})
 267               | _ => raise Format ("Invalid timestamp " ^ s)
 268         end
 269     fun timestampFromSql v = timestampFromSql' (valueOf v)
 270
 271
 272     fun boolToSql true = "TRUE"
 273       | boolToSql false = "FALSE"
 274
 275     fun boolFromSql' "FALSE" = false
 276       | boolFromSql' "f" = false
 277       | boolFromSql' "false" = false
 278       | boolFromSql' "n" = false
 279       | boolFromSql' "no" = false
 280       | boolFromSql' "0" = false
 281       | boolFromSql' "" = false
 282       | boolFromSql' _ = true
 283
 284     fun boolFromSql v = boolFromSql' (valueOf v)
 285 end
 286
 287 structure PgClient = SqlClient(PgDriver)