(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
                 )
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Library loading
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (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")))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Constants
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (def-consts (PGRES-POLLING-FAILED 0) 
                    PGRES-POLLING-READING 
                    PGRES-POLLING-WRITING
                    PGRES-POLLING-OK
                    PGRES-POLLING-ACTIVE
                    ) ;; polling
        
        (def-consts (CONNECTION-OK 0)
                    CONNECTION-BAD
                    CONNECTION-STARTED
                    CONNECTION-MADE
                    CONNECTION-AWAITING-RESPONSE
                    CONNECTION-AUTH-OK
                    CONNECTION-SETENV
                    CONNECTION-SSL-STARTUP
                    CONNECTION-NEEDED
                    ) ;; status
        
        (def-consts (PQTRANS-IDLE 0)
                    PQTRANS-ACTIVE
                    PQTRANS-INTRANS
                    PQTRANS-INERROR
                    PQTRANS-UNKNOWN
                    ) ;; transaction status
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Types
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define (make-fd_set socket)
          (let ((fdset (malloc (+ (ctype-sizeof _uint) (* (ctype-sizeof _int) 64)) 'raw )))
            ;; assume _uint and _pointer the same sizeof!
            (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))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; types
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define-cpointer-type _PGconn)
        (define-cpointer-type _PGresult)
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Finalizers
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (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)))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; FFI functions
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (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 : _PGconn)
                                                  -> (let ((R (box result)))
                                                       (register-finalizer R finalize-pgconn)
                                                       R))))
        
        (define PQconnectStart (get-ffi-obj "PQconnectStart"
                                            lib
                                            (_fun (conn : _string)
                                                  -> (result : _PGconn)
                                                  -> (let ((R (box result)))
                                                       (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)))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Exported funcs
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (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)))  ;;; utf-8 stuff
                (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? conn)
          (string=? (PQerrorMessage (unbox conn)) ""))
        
        (define (pg-error-message conn-or-result)
          (if (box? conn-or-result)
              (PQerrorMessage (unbox conn-or-result))
              (PQresultErrorMessage conn-or-result)))
        
        (define (pg-version)
          100)

        )