(module c-sqld-psql mzscheme
(require (lib "foreign.ss")) (unsafe!)
(require "utils.scm")
(provide make-fd_set
free-fd_set
make-timeval
free-timeval
PQconnectdb
PQconnectStart
PQconnectPoll
PQsocket
PQstatus
PQdb
PQuser
PQpass
PQport
PQhost
PQtransactionStatus
PQprotocolVersion
PQserverVersion
PQerrorMessage
PQexec
select
pg-connect
pg-async-connect
pg-finish
pg-escape
pg-query
pg-row
pg-nrows
pg-ncols
pg-column-name
pg-server-version
pg-protocol-version
pg-debug
pg-nodebug
pg-error-message
pg-version
pg-ok?
)
(define (SCHEME-SLEEP-THREAD) (sleep 0.01))
(define (load-lib-internal libs L)
(if (null? libs)
(error (format "Cannot load library: tried ~s~%" L))
(let ((lib (with-handlers ((exn:fail? (lambda (exn) #f)))
(ffi-lib (car libs)))))
(if (eq? lib #f)
(load-lib-internal (cdr libs) L)
lib))))
(define (load-lib L)
(load-lib-internal L L))
(define lib (load-lib '("pq" "libpq" "libpq.dll")))
(define clib (load-lib '("wsock32.dll" #f "libc" "libc.so.6")))
(def-consts (PGRES-POLLING-FAILED 0)
PGRES-POLLING-READING
PGRES-POLLING-WRITING
PGRES-POLLING-OK
PGRES-POLLING-ACTIVE
)
(def-consts (CONNECTION-OK 0)
CONNECTION-BAD
CONNECTION-STARTED
CONNECTION-MADE
CONNECTION-AWAITING-RESPONSE
CONNECTION-AUTH-OK
CONNECTION-SETENV
CONNECTION-SSL-STARTUP
CONNECTION-NEEDED
)
(def-consts (PQTRANS-IDLE 0)
PQTRANS-ACTIVE
PQTRANS-INTRANS
PQTRANS-INERROR
PQTRANS-UNKNOWN
)
(define (make-fd_set socket)
(let ((fdset (malloc (+ (ctype-sizeof _uint) (* (ctype-sizeof _int) 64)) 'raw )))
(if (not (= (ctype-sizeof _uint) (ctype-sizeof _pointer)))
(error "UNEXPECTED: make-fd_set: sizeof _uint <> sizeof _pointer"))
(let ((v (make-cvector* fdset _uint 1)))
(cvector-set! v 0 1))
(let ((p (make-cvector* fdset _int 2)))
(cvector-set! p 1 socket))
fdset))
(define (make-timeval seconds microseconds)
(let ((tv (malloc (* (ctype-sizeof _long) ) 'raw)))
(let ((v (make-cvector* tv _long 2)))
(cvector-set! v 0 seconds)
(cvector-set! v 1 microseconds)
tv)))
(define (free-fd_set set)
(free set))
(define (free-timeval tv)
(free tv))
(define-cpointer-type _PGconn)
(define-cpointer-type _PGresult)
(define (finalize-pgconn pgconn-obj)
(let ((R (unbox pgconn-obj)))
(if (not (eq? R #f))
(PQfinish R))))
(define (finalize-pgresult pgresult-obj)
(if (not (eq? pgresult-obj #f))
(PQclear pgresult-obj)))
(define select (get-ffi-obj "select"
clib
(_fun _int _pointer _pointer _pointer _pointer
-> _int)))
(define PQconnectdb (get-ffi-obj "PQconnectdb"
lib
(_fun (conn : _string)
-> (result : _pointer)
-> (let ((R (box result)))
(if (not (eq? result #f))
(set-cpointer-tag! result PGconn-tag))
(register-finalizer R finalize-pgconn)
R))))
(define PQconnectStart (get-ffi-obj "PQconnectStart"
lib
(_fun (conn : _string)
-> (result : _pointer)
-> (let ((R (box result)))
(if (not (eq? result #f))
(set-cpointer-tag! result PGconn-tag))
(register-finalizer R finalize-pgconn)
R))))
(define PQconnectPoll (get-ffi-obj "PQconnectPoll"
lib
(_fun (PQconn : _PGconn)
-> (PGpoll : _int)
-> PGpoll)))
(define PQsocket (get-ffi-obj "PQsocket"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQstatus (get-ffi-obj "PQstatus"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQdb (get-ffi-obj "PQdb"
lib
(_fun (PQconn : _PGconn)
-> _string)))
(define PQuser (get-ffi-obj "PQuser"
lib
(_fun (PQconn : _PGconn)
-> _string)))
(define PQpass (get-ffi-obj "PQpass"
lib
(_fun (PQconn : _PGconn)
-> _string)))
(define PQhost (get-ffi-obj "PQhost"
lib
(_fun (PQconn : _PGconn)
-> _string)))
(define PQport (get-ffi-obj "PQport"
lib
(_fun (PQconn : _PGconn)
-> _string)))
(define PQtransactionStatus (get-ffi-obj "PQtransactionStatus"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQprotocolVersion (get-ffi-obj "PQprotocolVersion"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQserverVersion (get-ffi-obj "PQserverVersion"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQerrorMessage (get-ffi-obj "PQerrorMessage"
lib
(_fun (PQconn : _PGconn)
-> _string)))
(define PQfinish (get-ffi-obj "PQfinish"
lib
(_fun (PQconn : _PGconn)
-> _void)))
(define PQexec (get-ffi-obj "PQexec"
lib
(_fun (PQconn : _PGconn)
(cmd : _string)
-> (result : _pointer)
-> (if (eq? result #f)
#f
(begin
(set-cpointer-tag! result PGresult-tag)
(register-finalizer result finalize-pgresult)
result)))))
(define PQclear (get-ffi-obj "PQclear"
lib
(_fun (PQresult : _PGresult)
-> _void)))
(define PQresultErrorMessage
(get-ffi-obj "PQresultErrorMessage"
lib
(_fun (PQresult : _PGresult)
-> _string)))
(define PQsendQuery (get-ffi-obj "PQsendQuery"
lib
(_fun (PQconn : _PGconn)
(cmd : _string)
-> _int)))
(define PQgetResult (get-ffi-obj "PQgetResult"
lib
(_fun (PQconn : _PGconn)
-> (result : _pointer)
-> (if (eq? result #f)
#f
(begin
(set-cpointer-tag! result PGresult-tag)
(register-finalizer result finalize-pgresult)
result)))))
(define PQconsumeInput (get-ffi-obj "PQconsumeInput"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQisBusy (get-ffi-obj "PQisBusy"
lib
(_fun (PQconn : _PGconn)
-> _int)))
(define PQntuples (get-ffi-obj "PQntuples"
lib
(_fun (PQresult : _PGresult)
-> _int)))
(define PQnfields (get-ffi-obj "PQnfields"
lib
(_fun (PQresult : _PGresult)
-> _int)))
(define PQfname (get-ffi-obj "PQfname"
lib
(_fun (PQresult : _PGresult)
(column : _int)
-> _string)))
(define PQgetvalue (get-ffi-obj "PQgetvalue"
lib
(_fun (PQresult : _PGresult)
(row : _int)
(col : _int)
-> _string)))
(define PQgetisnull (get-ffi-obj "PQgetisnull"
lib
(_fun (PQresult : _PGresult)
(row : _int)
(col : _int)
-> _int)))
(define PQescapeStringConn (get-ffi-obj "PQescapeStringConn"
lib
(_fun (PQconn : _PGconn)
(to : _string)
(from : _string)
(length : _int)
(error : _pointer)
-> _int)))
(define (pg-connect connstr debug)
(PQconnectdb connstr))
(define (pg-async-connect connstr debug)
(let ((conn (PQconnectStart connstr)))
(if (eq? conn #f)
(error "Cannot allocate memory"))
(let ((status (PQstatus (unbox conn))))
(if (or (= status CONNECTION-OK)
(= status CONNECTION-BAD))
conn
(let* ((socket (PQsocket (unbox conn)))
(tv (make-timeval 0 1000)))
(letrec ((polling (lambda (conn)
(let ((status (PQstatus (unbox conn))))
(debug "status=~a~%" status)
(if (or (= status CONNECTION-OK)
(= status CONNECTION-BAD))
conn
(let ((poll (PQconnectPoll (unbox conn))))
(debug "poll=~s~%" poll)
(let ((fdset (make-fd_set socket)))
(debug "fdset=~s~%" fdset)
(cond ((= poll PGRES-POLLING-READING)
(begin
(while (= (select 0 fdset #f #f tv) 0)
(SCHEME-SLEEP-THREAD))
(free-fd_set fdset)
(debug "fdset freed~%")
(polling conn)))
((= poll PGRES-POLLING-WRITING)
(begin
(while (= (select 0 #f fdset #f tv) 0)
(SCHEME-SLEEP-THREAD))
(free-fd_set fdset)
(debug "fdset freed~%")
(polling conn)))
(else
(begin
(free-fd_set fdset)
(debug "fdset freed~%")
(polling conn)))))))))))
(let ((R (polling conn)))
(free-timeval tv)
(debug "timeval freed~%")
R)))))))
(define (pg-finish conn debug)
(let ((R (unbox conn)))
(PQfinish R)
(set-box! conn #f)))
(define (pg-query conn query debug)
(set! conn (unbox conn))
(let ((r (PQsendQuery conn query)))
(if (= r 0)
'error
(let ((result #f)
(done #f))
(while (eq? done #f)
(begin
(debug "result=~s~%" result)
(while (and (= (PQconsumeInput conn) 1) (= (PQisBusy conn) 1))
(debug "consume-input/is-busy~%"))
(if (= (PQisBusy conn) 0)
(let ((R (PQgetResult conn)))
(if (eq? R #f)
(set! done #t)
(set! result R)))
(begin
(set! result 'error)
(set! done #t)))))
result))))
(define (pg-escape conn from debug)
(let ((b (string->bytes/utf-8 from)))
(let ((L (bytes-length b)))
(let ((out (make-bytes (+ (* L 3)) 0))) (let ((NL (PQescapeStringConn (unbox conn) out from L #f)))
(debug "New length: ~s~%" NL)
(debug "Out : ~s~%" out)
(let ((R (subbytes out 0 NL)))
(bytes->string/utf-8 R)))))))
(define (pg-nrows result)
(PQntuples result))
(define (pg-ncols result)
(PQnfields result))
(define (pg-column-name result i)
(PQfname result i))
(define (pg-row result row null-value)
(letrec ((f (lambda (i N)
(if (< i N)
(cons (if (= (PQgetisnull result row i) 1)
null-value
(PQgetvalue result row i))
(f (+ i 1) N))
'()))))
(if (< row 0)
#f
(if (>= row (PQntuples result))
#f
(f 0 (PQnfields result))))))
(define (pg-debug form . args)
(display (apply format form args))
(flush-output (current-output-port)))
(define (pg-nodebug . args)
#t)
(define (pg-server-version conn)
(PQserverVersion (unbox conn)))
(define (pg-protocol-version conn)
(PQprotocolVersion (unbox conn)))
(define (pg-error-message conn-or-result)
(if (box? conn-or-result)
(if (eq? (unbox conn-or-result) #f)
"No connection to the postgreSQL server"
(PQerrorMessage (unbox conn-or-result)))
(PQresultErrorMessage conn-or-result)))
(define (pg-version)
100)
(define (pg-ok? conn-or-result)
(if (box? conn-or-result)
(if (eq? (unbox conn-or-result) #f)
#f
(string=? (pg-error-message conn-or-result) ""))
(string=? (pg-error-message conn-or-result) "")))
(define (pg-error? conn-or-result)
(not (pg-ok? conn-or-result)))
)