#lang scheme/base (require mzlib/etc mzlib/pregexp scheme/class scheme/match srfi/26/cut (prefix-in postgresql: (planet schematics/spgsql:2/spgsql)) (planet untyped/unlib:3/gen) (planet untyped/unlib:3/symbol) (file "../base.ss") (file "../extract.ss") (file "../era/era.ss") (file "../generic/connection.ss") (file "../generic/database.ss") (file "../generic/snooze-reraise.ss") (file "../sql/sql-struct.ss") (file "sql.ss")) (define database% (class* object% (database<%>) ; Constructor -------------------- (init-field server ; string port ; natural database ; string username ; string password ; (U string #f) ssl ; (U 'yes 'no 'optional) ssl-encrypt) ; (U 'sslv2-or-v3 'sslv2 'sslv3 'tls)] (super-new) ; Methods ----------------------- ; -> connection (define/public (connect) (with-snooze-reraise (exn:fail? "Could not connect to database") (define conn (postgresql:connect '#:server server '#:port port '#:database database '#:user username '#:password password '#:ssl ssl '#:ssl-encrypt ssl-encrypt)) (send conn exec "SET client_min_messages TO WARNING;") (send conn exec "SET datestyle TO ISO;") ;(send conn exec "SET standard_conforming_strings TO on;") (make-connection conn #f))) ; connection -> void (define/public (disconnect conn) (with-snooze-reraise (exn:fail? "Could not disconnect from database") (send (connection-back-end conn) disconnect))) ; connection entity -> void (define/public (create-table conn entity) (with-snooze-reraise (exn:fail? (format "Could not create table for ~a" entity)) (for-each (cut send (connection-back-end conn) exec <>) (map (cut string-append <> ";") (pregexp-split #px";" (create-sql entity)))))) ; connection entity -> void (define/public (drop-table conn entity) (with-snooze-reraise (exn:fail? (format "Could not drop table for ~a" entity)) (for-each (cut send (connection-back-end conn) exec <>) (map (cut string-append <> ";") (pregexp-split #px";" (drop-sql entity)))))) ; connection persistent-struct -> integer ; ; Inserts a new database record for the struct and returns its ID. (define/public (insert-record conn struct) ; symbol (define sequence-name (symbol-append (entity-table-name (struct-entity struct)) '_seq)) ; integer (with-snooze-reraise (exn:fail? (format "Could not insert database record for ~a" struct)) ; The two lines below work as follows: ; - the first line inserts the record, using the SEQUENCE "entity_seq" to determine the new ID ; - the second line reads the current value of "entity_seq", retrieving the ID of the new struct ; Note that there is no transaction around this: the PostgreSQL function "currval" returns ; a session-local value. The INSERT SQL from insert-sql lets PostgreSQL assign a new ID from the ; sequence "entity_seq". Returns the new value of the ID sequence (and thus the ID of the ; just-inserted element): (send (connection-back-end conn) exec (insert-sql struct)) (parse-value type:id (send (connection-back-end conn) query-value (string-append "SELECT currval('" (escape-name sequence-name) "');"))))) ; connection persistent-struct -> void ; ; Inserts a new database record for the struct and returns its ID. (define/public (insert-record/id conn struct) (with-snooze-reraise (exn:fail? (format "Could not insert database record for ~a" struct)) (send (connection-back-end conn) exec (insert-sql struct #t)) (void))) ; connection persistent-struct -> void (define/public (update-record conn struct) (with-snooze-reraise (exn:fail? (format "Could not update database record for ~a" struct)) (send (connection-back-end conn) exec (update-sql struct)) (void))) ; connection guid -> void (define/public (delete-record conn guid) (with-snooze-reraise (exn:fail? (format "Could not delete database record for ~a" guid)) (send (connection-back-end conn) exec (delete-sql guid)) (void))) ; connection query -> result-generator ; ; TODO : This procedure is memory-inefficient, because it retrieves the entire result ; set as a list. We really want to fold over the results, sending individual results to ; the generator as we go. Here's some pseudocode: ; ; (send connection ; for-each ; sql ; (lambda (result) ; ; get result ; ; capture continuation ; ; send continuation and result to generator ; ...)) ; ; (g:map process-data ; (lambda () ; ; call continuation in iterator ; ; get result and next continuation from iterator ; ; store next continuation ; ; emit result ; ...)) (define/public (g:find conn query) (define sql (query-sql query)) (with-snooze-reraise (exn:fail? (format "Could not execute SELECT query:~n~a" (query-sql query))) (g:map (make-struct-extractor (query-extract-info query)) (g:map (make-parser (map expression-type (query-what query))) (g:list (send (connection-back-end conn) map sql vector)))))) ; connection -> boolean (define/public (transaction-allowed? conn) #t) ; connection thunk -> any (define/public (call-with-transaction conn body) ; symbol (define savepoint (gensym 'savepoint)) ; (listof symbol) (define outermost? (not (connection-in-transaction? conn))) ; string (define escaped-savepoint (escape-name savepoint)) ; boolean (define complete? #f) ; Main body: (dynamic-wind (lambda () ; If this is the outermost call to call-with-transaction, start a TRANSACTION: (when outermost? (send (connection-back-end conn) exec "BEGIN;") (set-connection-in-transaction?! conn #t)) ; The actual COMMIT / ROLLBACK process is governed by SAVEPOINTS: (send (connection-back-end conn) exec (string-append "SAVEPOINT " escaped-savepoint ";"))) (lambda () (begin0 (body) (set! complete? #t))) (lambda () ; Commit or roll back: (if complete? (send (connection-back-end conn) exec (string-append "RELEASE SAVEPOINT " escaped-savepoint ";")) (send (connection-back-end conn) exec (string-append "ROLLBACK TO SAVEPOINT " escaped-savepoint ";"))) ; If this is the outermost call to call-with-transaction, exit the TRANSACTION: (when outermost? (set-connection-in-transaction?! conn #f) (send (connection-back-end conn) exec "COMMIT;"))))) ; connection -> (listof symbol) (define/public (table-names conn) (map (cut parse-value type:symbol <>) (send (connection-back-end conn) query-list "SELECT tablename FROM pg_tables WHERE schemaname = 'public' ORDER BY tablename;"))) ; connection (U symbol entity) -> boolean (define/public (table-exists? conn table) ; string (define sql (format "SELECT relname FROM pg_class WHERE relname=~a;" (cond [(entity? table) (escape-value type:symbol (entity-table-name table))] [(symbol? table) (escape-value type:symbol table)] [else (raise-exn exn:fail:snooze (format "Expected (U entity symbol), recevied ~s" table))]))) ; connection -> list (define result (send (connection-back-end conn) query-list sql)) ; boolean (not (null? result))) ; query output-port string -> query ; ; Prints an SQL string to stdout as a side effect. (define/public (dump-sql query [output-port (current-output-port)] [format "~a"]) (fprintf output-port format (query-sql query)) query) )) ; Provide statements ----------------------------- (provide database%)