diff options
Diffstat (limited to 'squee.scm')
| -rw-r--r-- | squee.scm | 372 |
1 files changed, 372 insertions, 0 deletions
diff --git a/squee.scm b/squee.scm new file mode 100644 index 0000000..443fa09 --- /dev/null +++ b/squee.scm @@ -0,0 +1,372 @@ +;;; squee --- A guile interface to postgres via the ffi + +;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org> + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (squee) + #:use-module (system foreign) + #:use-module (rnrs enums) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (srfi srfi-26) + #:export (;; The important ones + connect-to-postgres-paramstring + exec-query + pg-conn-finish + + ;; enums and indexes of enums + conn-status-enum conn-status-enum-index + polling-status-enum polling-status-index + exec-status-enum exec-status-enum-index + transaction-status-enum transaction-status-enum-index + verbosity-enum verbosity-enum-index + ping-enum ping-enum-index + + ;; **repl and error messages only!** + enum-set-ref + + ;; Connection stuff + <pg-conn> pg-conn? wrap-pg-conn unwrap-pg-conn + + ;; @@: We don't export the result pointer though! + ;; as this needs to be cleared to avoid memory + ;; leaks... + ;; + ;; We might provide a (exec-with-result-ptr) + ;; that cleans up the result pointer after calling + ;; some thunk though? + ;; + ;; These are still useful for building your own + ;; serializer though... + result-num-rows result-num-cols result-get-value + result-serializer-simple-list result-metadata)) + +(define libpq (dynamic-link "libpq")) + +;; --------------------- +;; Enums from libpq-fe.h +;; --------------------- + +(define conn-status-enum + (make-enumeration + '(connection-ok + connection-bad + connection-started connection-made + connection-awaiting-response connection-auth-ok + connection-auth-ok connection-setenv + connection-ssl-startup + connection-needed))) + +(define conn-status-enum-index + (enum-set-indexer conn-status-enum)) + +(define polling-status-enum + (make-enumeration + '(polling-failed + polling-reading + polling-writing + polling-ok + polling-active))) + +(define polling-status-enum-index + (enum-set-indexer polling-status-enum)) + +(define exec-status-enum + (make-enumeration + '(empty-query + command-ok tuples-ok + copy-out copy-in + bad-response + nonfatal-error fatal-error + copy-both + single-tuple))) + +(define exec-status-enum-index + (enum-set-indexer exec-status-enum)) + +(define transaction-status-enum + (make-enumeration + '(idle active intrans inerror unknown))) + +(define transaction-status-enum-index + (enum-set-indexer transaction-status-enum)) + +(define verbosity-enum + (make-enumeration + '(terse default verbose))) + +(define verbosity-enum-index + (enum-set-indexer verbosity-enum)) + +(define ping-enum + (make-enumeration + '(ok reject no-response no-attempt))) + +(define ping-enum-index + (enum-set-indexer ping-enum)) + +(define-wrapped-pointer-type <pg-conn> + pg-conn? + wrap-pg-conn unwrap-pg-conn + (lambda (pg-conn port) + (format port "#<pg-conn ~x (~a)>" + (pointer-address (unwrap-pg-conn pg-conn)) + (let ((status (pg-conn-status pg-conn))) + (cond ((eq? status (conn-status-enum-index 'connection-ok)) + "connected") + ((eq? status (conn-status-enum-index 'connection-bad)) + (let ((conn-error (pg-conn-error-message pg-conn))) + (if (equal? conn-error "") + "disconnected" + (format #f "disconnected, error: ~s" conn-error)))) + (#t + (symbol->string + (pg-conn-status-symbol pg-conn)))))))) + + +;; This one should NOT be exposed to the outside world! We have our +;; own result structure... + +(define-wrapped-pointer-type <result-ptr> + result-ptr? + wrap-result-ptr unwrap-result-ptr + (lambda (result-ptr port) + (format port "#<result-ptr ~x>" + (pointer-address (unwrap-result-ptr result-ptr))))) + + +(define (enum-set-ref enum-set k) + "Take an ENUM-SET and get the item at position K + +This is O(n) but theoretically we don't use it much. +Again, REPL only!" + (list-ref (enum-set->list enum-set) k)) + + +(define-syntax-rule (define-foreign-libpq name return_type func_name arg_types) + (define name + (pointer->procedure return_type + (dynamic-func func_name libpq) + arg_types))) + + +(define-foreign-libpq %PQconnectdb '* "PQconnectdb" (list '*)) +(define-foreign-libpq %PQstatus int "PQstatus" (list '*)) +(define-foreign-libpq %PQerrorMessage '* "PQerrorMessage" (list '*)) +(define-foreign-libpq %PQfinish void "PQfinish" (list '*)) +(define-foreign-libpq %PQntuples int "PQntuples" (list '*)) +(define-foreign-libpq %PQnfields int "PQnfields" (list '*)) + + +(define-foreign-libpq %PQexec '* "PQexec" (list '* '*)) +(define-foreign-libpq %PQexecParams + '* ;; Returns a PGresult + "PQexecParams" + (list '* ;; connection + '* ;; command, a string + int ;; number of parameters + '* ;; paramTypes, ok to leave NULL + '* ;; paramValues, here goes your actual parameters! + '* ;; paramLengths, ok to leave NULL + '* ;; paramFormats, ok to leave NULL + int)) ;; resultFormat... probably 0! + +(define-foreign-libpq %PQresultStatus int "PQresultStatus" (list '*)) +(define-foreign-libpq %PQresStatus '* "PQresStatus" (list int)) +(define-foreign-libpq %PQresultErrorMessage '* "PQresultErrorMessage" (list '*)) +(define-foreign-libpq %PQclear void "PQclear" (list '*)) + +(define-foreign-libpq %PQcmdtuples '* "PQcmdTuples" (list '*)) +(define-foreign-libpq %PQntuples int "PQntuples" (list '*)) +(define-foreign-libpq %PQnfields int "PQnfields" (list '*)) +(define-foreign-libpq %PQgetisnull int "PQgetisnull" (list '* int int)) +(define-foreign-libpq %PQgetvalue '* "PQgetvalue" (list '* int int)) + + +;; Via mark_weaver. Thanks Mark! +;; +;; So, apparently we can use a struct of strings just like an array +;; of strings. Because magic, and because Mark thinks the C standard +;; allows it enough! + +(define (string-pointer-list->string-array ls) + "Take a list of strings, generate a C-compatible list of free strings" + (make-c-struct + (make-list (+ 1 (length ls)) '*) + (append ls (list %null-pointer)))) + +(define (pg-conn-status pg-conn) + "Get the connection status from a postgres connection" + (%PQstatus (unwrap-pg-conn pg-conn))) + +(define (pg-conn-status-symbol pg-conn) + "Human readable version of the pg-conn status. + +Inefficient... don't use this in normal code... it's just for you and +the REPL! (Well, we do use it for errors, because those are +comparatively \"rare\" so this is okay.) Compare against the enum +value of the symbol instead." + (let ((status (pg-conn-status pg-conn))) + (if (< status (length (enum-set->list conn-status-enum))) + (enum-set-ref conn-status-enum + (pg-conn-status pg-conn)) + ;; Weird, this is bigger than our enum of statuses + (string->symbol + (format #f "unknown-status-~a" status))))) + + +(define (pg-conn-error-message pg-conn) + "Get an error message for this connection" + (pointer->string (%PQerrorMessage (unwrap-pg-conn pg-conn)))) + + +(define (pg-conn-finish pg-conn) + "Close out a database connection. + +If the connection is already closed, this simply returns #f." + (if (eq? (pg-conn-status pg-conn) + (conn-status-enum-index 'connection-ok)) + (begin + (%PQfinish (unwrap-pg-conn pg-conn)) + #t) + #f)) + +(define (connect-to-postgres-paramstring paramstring) + "Open a connection to the database via a parameter string" + (let* ((conn-pointer (%PQconnectdb (string->pointer paramstring))) + (pg-conn (wrap-pg-conn conn-pointer))) + (if (eq? conn-pointer %null-pointer) + (throw 'psql-connect-error + #f "Unable to establish connection")) + (let ((status (pg-conn-status pg-conn))) + (if (eq? status (conn-status-enum-index 'connection-ok)) + pg-conn + (throw 'psql-connect-error + (enum-set-ref conn-status-enum status) + (pg-conn-error-message pg-conn)))))) + + +(define (result-num-rows result-ptr) + (%PQntuples (unwrap-result-ptr result-ptr))) + +(define (result-num-cols result-ptr) + (%PQnfields (unwrap-result-ptr result-ptr))) + +(define (result-get-value result-ptr row col) + (let ((res (unwrap-result-ptr result-ptr))) + (and (eqv? (%PQgetisnull res row col) 0) + (pointer->string + (%PQgetvalue res row col))))) + + +;; @@: We ought to also have a vector version... +;; and other serializations... +(define (result-serializer-simple-list result-ptr) + "Get a simple list of lists representing the result of the query" + (let ((rows-range (iota (result-num-rows result-ptr))) + (cols-range (iota (result-num-cols result-ptr)))) + (map + (lambda (row-i) + (map + (lambda (col-i) + (result-get-value result-ptr row-i col-i)) + cols-range)) + rows-range))) + +;; TODO +(define (result-metadata result-ptr) + #f) + + +(define (result-ptr-clear result-ptr) + (%PQclear (unwrap-result-ptr result-ptr))) + +(define (result-error-message result-ptr) + (%PQresultErrorMessage (unwrap-result-ptr result-ptr))) + + +(define* (exec-query pg-conn command #:optional (params '()) + #:key (serializer result-serializer-simple-list)) + (let* ((param-pointers + (map (lambda (param) + (if param + (string->pointer param) + %null-pointer)) + params)) + (command-pointer + (string->pointer command)) + (param-array-pointer + (string-pointer-list->string-array param-pointers)) + (result-ptr + (wrap-result-ptr + (if (null? params) + (%PQexec + (unwrap-pg-conn pg-conn) + command-pointer) + (%PQexecParams + (unwrap-pg-conn pg-conn) + command-pointer + (length params) + %null-pointer + param-array-pointer + %null-pointer %null-pointer 0))))) + + ;; Protect the pointers, and thus the memory regions they point to + ;; from garbage collection, until %PQexecParams has returned + (identity param-pointers) + (identity command-pointer) + (identity param-array-pointer) + + (if (eq? result-ptr %null-pointer) + ;; Presumably a database connection issue... + (throw 'psql-query-error + ;; See below for psql-query-error param definition + #f #f (pg-conn-error-message pg-conn))) + + (let ((status (%PQresultStatus (unwrap-result-ptr result-ptr)))) + (cond + ;; This is the kind of query that returns tuples + ((eq? status (exec-status-enum-index 'tuples-ok)) + (let ((serialized-result (serializer result-ptr)) + (metadata (result-metadata result-ptr))) + ;; Gotta clear the result to prevent memory leaks + (result-ptr-clear result-ptr) + (values serialized-result metadata))) + + ;; This doesn't return tuples, eg it's a DELETE or something. + ((eq? status (exec-status-enum-index 'command-ok)) + (let ((metadata (result-metadata result-ptr)) + (rows (%PQcmdtuples (unwrap-result-ptr result-ptr)))) + ;; Gotta clear the result to prevent memory leaks + (result-ptr-clear result-ptr) + ;; Return the number of affected rows. + (values (string->number + (pointer->string rows)) metadata))) + + ;; Uhoh, anything else is an error! + (#t + (let ((status-message (pointer->string (%PQresStatus status))) + (error-message (pointer->string + (%PQresultErrorMessage (unwrap-result-ptr + result-ptr))))) + (result-ptr-clear result-ptr) + (throw 'psql-query-error + ;; @@: Do we need result-status? + ;; (error-symbol result-status result-error-message) + (enum-set-ref exec-status-enum status) + status-message error-message))))))) + +;; (define conn (connect-to-postgres-paramstring "dbname=sandbox")) |