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) = pad' (Int.toString n, i)
 196
 197     fun offsetStr NONE = "+00"
 198       | offsetStr (SOME n) =
 199         let
 200             val n = Int32.toInt (Time.toSeconds n) div 3600
 201         in
 202             if n < 0 then
 203                 "-" ^ pad (~n, 2)
 204             else
 205                 "+" ^ pad (n, 2)
 206         end
 207
 208     fun timestampToSql t =
 209         let
 210             val d = Date.fromTimeLocal t
 211         in
 212             "'" ^ pad (Date.year d, 4) ^ "-" ^ pad (fromMonth (Date.month d), 2) ^ "-" ^ pad (Date.day d, 2) ^
 213             " " ^ pad (Date.hour d, 2) ^ ":" ^ pad (Date.minute d, 2) ^ ":" ^ pad (Date.second d, 2) ^
 214             ".000000+" ^ offsetStr (Date.offset d) ^ "'"
 215         end
 216     fun timestampFromSql s =
 217         let
 218             val tokens = String.tokens (fn ch => ch = #"-" orelse ch = #" " orelse ch = #":"
 219                                                  orelse ch = #"." orelse ch = #"+") s
 220         in
 221             case tokens of
 222                 [year, mon, day, hour, minute, second, _, offset] =>
 223                 Date.toTime (Date.date {day = intFromSql day, hour = intFromSql mon, minute = intFromSql minute,
 224                                         month = toMonth (intFromSql mon),
 225                                         offset = SOME (Time.fromSeconds (Int32.fromInt (intFromSql offset * 3600))),
 226                                         second = intFromSql second div 1000, year = intFromSql year})
 227               | _ => raise Format "Invalid timestamp"
 228         end
 229
 230
 231     fun boolToSql true = "TRUE"
 232       | boolToSql false = "FALSE"
 233
 234     fun boolFromSql "FALSE" = false
 235       | boolFromSql "f" = false
 236       | boolFromSql "false" = false
 237       | boolFromSql "n" = false
 238       | boolFromSql "no" = false
 239       | boolFromSql "0" = false
 240       | boolFromSql "" = false
 241       | boolFromSql _ = true
 242 end
 243
 244 structure PgClient = SqlClient(PgDriver)