spgsql.ss
;; Copyright 2000-2005 Ryan Culpepper
;; Released under the terms of the modified BSD license (see the file
;; COPYRIGHT for terms).

;; This file provides all the necessary structures, objects, and functions
;; for using spgsql to open a connection to a PostgreSQL database.

(module spgsql mzscheme
  (require "private/connection-structures.ss"
           "private/connection.ss"
           "private/exceptions.ss"
           "private/sql-types.ss"
           "crypto/md5.scm"
           "crypto/crypt.scm"
           (lib "class.ss"))
  
  (provide connection<%>
           (all-from "private/sql-types.ss")
           ;; exceptions
           (struct exn:spgsql ())
           (struct exn:spgsql:fatal ())
           (struct exn:spgsql:nonfatal ())
           (struct exn:spgsql:auth (type))
           (struct exn:spgsql:communication (type))
           (struct exn:spgsql:internal (location))
           (struct exn:spgsql:query ())
           (struct exn:spgsql:user (type)))
  
  (provide connect)
  
  (define connect
    (case-lambda
      [(server port dbname username)
       (connect/fixed server port dbname username #f)]
      [(server port dbname username password)
       (connect/fixed server port dbname username password)]))

  (define (connect/fixed server port dbname username password)
    (let* [(port (or port 5432))
           (dbname (or dbname "template1"))
           (cx (make-object connection%))
           (auth (send cx connect server port dbname username))]
      (let loop [(auth auth)]
        (cond [(OkConnection? auth)
               cx]
              [(EncryptedPasswordResult? auth)
               (when (not (string? password))
                 (raise-auth-error 
                  'password "You must supply a string as password"))
               (when (not crypt)
                 (raise-internal-error 
                  'crypt-not-supported
                  (string-append 
                   "Backend requested a crypt-encrypted password, which is not "
                   "available on this system.")))
               (loop ((EncryptedPasswordResult-callback auth)
                      (crypt password (EncryptedPasswordResult-salt auth))))]
              [(UnencryptedPasswordResult? auth)
               (when (not (string? password))
                 (raise-auth-error 
                  'password "You must supply a string as password"))
               (loop ((UnencryptedPasswordResult-callback auth) password))]
              [(MD5PasswordResult? auth)
               (when (not (string? password))
                 (raise-sp-user-error 
                  'password "You must supply a string as password"))
               (loop ((MD5PasswordResult-callback auth)
                      (md5password username password 
                                   (MD5PasswordResult-salt auth))))]
              [else
               (send cx disconnect)
               (raise-auth-error 
                'unsupported 
                (string-append 
                 "Authentication failed: the backend sent an "
                 "authentication request which spgsql cannot handle"))]))))

  ;; list-databases : connection% -> (listof string)
  (define (list-databases c)
    (send c query-list "select datname from pg_database"))
  
  ;; list-tables : connection% boolean -> (listof string)
  (define (list-tables c include-sys-catalogs?)
    (if include-sys-catalogs?
        (send c query-list "select relname from pg_class where relkind = 'r'")
        (send c query-list 
              (sql-format "select pg_class.relname "
                          "from pg_class left join pg_namespace "
                          "on pg_namespace.oid = pg_class.relnamespace"
                          "where pg_namespace.nspname !~~ '^pg_'"))))

  ;; list-fields : connection% string -> (listof string)
  (define (list-fields c table)
    (send c query-list
          (sql-format "select A.attname from pg_attribute A, pg_class T "
                      "where A.attrelid = T.relfilenode "
                      "and T.relname = '~a' and A.attnum > 0"
                      `(sql ,table))))

  ;; create-database : connection string -> void
  (define (create-database c dbname)
    (send c exec
          (sql-format "create database ~a"
                      `(sql ,dbname))))
  
  ;; SYNTAX: with-transaction
  (define-syntax with-transaction
    (syntax-rules ()
      [(_ connection body ...)
       (let [(c connection)]
         (unless (is-a? c connection%)
           (error 'with-transaction 
                  "expected a connection% object, given ~v" c))
         (begin 
           (send c exec "begin transaction")
           (begin0
             (begin body ...)
             (send c exec "commit transaction"))))]))
  )