;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; proxy.ss
;; kill-safe proxy for spgsql.ss 
;; copyright: the same copyright as (planet schematics/spgsql/spgsql)
;; yc 4/25/2009 - initial version 
#lang scheme/base 
(require (planet bonzailab/config)
         (planet schematics/spgsql/spgsql)
         mzlib/trace
         scheme/class
         )

(define connection-proxy%
  (class object%
    
    (super-new)

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; fields
    ;; inner - the connection that is being proxied 
    (init-field inner)
    
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; worker
    ;; the main proc that handles the proxy call via thread message passing
    ;; the args expected from the thread are: 
    ;; (listof thread? connection key args)
    ;; exceptions are trapped and returned as well 
    (define (worker (args (thread-receive)))
      (define (helper thd conn key args)
        (with-handlers ((exn? (lambda (e)
                                (thread-send thd e #f))))
          (thread-send thd
                       (case key
                         ;; query API 
                         ((exec)
                          (send/apply conn exec args))
                         ((query-list)
                          (send conn query-list (car args)))
                         ((query-row)
                          (send conn query-row (car args)))
                         ((query-maybe-row)
                          (send conn query-maybe-row (car args)))
                         ((query-value)
                          (send conn query-value (car args)))
                         ((query-maybe-value)
                          (send conn query-maybe-value (car args)))
                         ((map)
                          (send/apply  conn map args))
                         ((for-each)
                          (send/apply conn for-each args))
                         ((mapfilter)
                          (send/apply conn mapfilter args))
                         ((fold)
                          (send/apply conn fold args))
                         ;; prepare API
                         ((prepare-exec)
                          (send conn prepare-exec (car args)))
                         ((prepare-query-list)
                          (send conn prepare-query-list (car args)))
                         ((prepare-query-row)
                          (send conn prepare-query-row (car args)))
                         ((prepare-query-maybe-row)
                          (send conn prepare-query-maybe-row (car args)))
                         ((prepare-query-value)
                          (send conn prepare-query-value (car args)))
                         ((prepare-query-maybe-value)
                          (send conn prepare-query-maybe-value (car args)))
                         ((prepare-map)
                          (send/apply conn prepare-map args))
                         ((prepare-for-each)
                          (send/apply conn prepare-for-each args))
                         ((prepare-mapfilter)
                          (send/apply conn prepare-mapfilter args))
                         ((prepare-fold)
                          (send/apply conn prepare-fold args))
                         ;; low level API 
                         ((query)
                          (send conn query (car args)))
                         ((query-multiple)
                          (send conn query-multiple args))
                         ((prepare)
                          (send conn prepare (car args)))
                         ((prepare-multiple) 
                          (send conn prepare-multiple args))
                         ((bind-prepared-statement)
                          (send/apply  conn bind-prepared-statement args))
                         ;; admin API 
                         ((disconnect)
                          (send conn disconnect))
                         ((connected?)
                          (send conn connected?))
                         (else
                          (error 'worker "~a not supported" key)))
                       #f
                       )))
      (apply helper args)
      (worker)) 

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; worker-thread 
    ;; the thread that serializes the calls
    (define worker-thread (thread worker))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; call-worker
    ;; the entrance point to communicate with the worker thread
    ;; handle thread in kill-safe fashion
    ;; and if the returned value is an exn it will be raised again 
    (define (call-worker key (args '()))
      (thread-resume worker-thread (current-thread))
      (thread-send worker-thread (list (current-thread) inner key args))
      (let ((res (thread-receive)))
        (if (exn? res) (raise res)
            res)))
    
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; proxy API
    
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; high level query APIs 
    (define/public (exec . stmts)
      (call-worker 'exec stmts))
    
    (define/public (query-list stmt)
      (call-worker 'query-list (list stmt)))
    
    (define/public (query-row stmt)
      (call-worker 'query-row (list stmt)))
    
    (define/public (query-maybe-row stmt)
      (call-worker 'query-maybe-row (list stmt)))
    
    (define/public (query-value stmt) 
      (call-worker 'query-value (list stmt))) 
    
    (define/public (query-maybe-value stmt)
      (call-worker 'query-maybe-value (list stmt)))
    
    (define/public (map stmt proc)
      (call-worker 'map (list stmt proc)))
    
    (define/public (for-each stmt proc)
      (call-worker 'for-each (list stmt proc)))
    
    (define/public (mapfilter stmt map-proc filter-proc)
      (call-worker 'mapfilter (list stmt map-proc filter-proc)))
    
    (define/public (fold stmt proc init)
      (call-worker 'fold (list stmt proc init)))
    
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; high level prepared APIs 
    (define/public (prepare-exec preparable)
      (call-worker 'prepare-exec (list preparable)))
    
    (define/public (prepare-query-list preparable)
      (call-worker 'prepare-query-list (list preparable)))
    
    (define/public (prepare-query-row preparable)
      (call-worker 'prepare-query-row (list preparable)))
    
    (define/public (prepare-query-maybe-row preparable)
      (call-worker 'prepare-query-maybe-row (list preparable)))
    
    (define/public (prepare-query-value preparable)
      (call-worker 'prepare-query-value (list preparable)))
    
    (define/public (prepare-query-maybe-value preparable)
      (call-worker 'prepare-query-maybe-value (list preparable)))
    
    (define/public (prepare-map preparable proc)
      (call-worker 'prepare-map (list preparable proc)))
    
    (define/public (prepare-for-each preparable proc)
      (call-worker 'prepare-for-each (list preparable proc)))
    
    (define/public (prepare-mapfilter preparable map-proc filter-proc)
      (call-worker 'prepare-mapfilter (list preparable map-proc filter-proc)))
    
    (define/public (prepare-fold preparable proc init)
      (call-worker 'prepare-fold (list preparable proc init)))
    
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; low level APIs
    (define/public (query stmt)
      (call-worker 'query (list stmt)))
    
    (define/public (query-multiple stmts)
      (call-worker 'query-multiple stmts))
    
    (define/public (prepare preparable)
      (call-worker 'prepare (list preparable)))
    
    (define/public (prepare-multiple preparables)
      (call-worker 'prepare-multiple preparables))
    
    (define/public (bind-prepared-statement prepared params)
      (call-worker 'bind-prepared-statement (list prepared params)))
    
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; admin APIs 
    (define/public (connected?)
      (call-worker 'connected?))
    
    (define/public (disconnect)
      (call-worker 'disconnect))
    
    ))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; proxy-connect
;; wrapper for connecting to spgsql 
(define (proxy-connect #:server (server #f)
                       #:port (port #f)
                       #:socket (socket #f)
                       #:user (user #f)
                       #:database (database #f)
                       #:password (password #f)
                       #:allow-cleartext-password? (allow-cleartext-password? #f)
                       #:ssl (ssl 'no)
                       #:ssl-encrypt (ssl-encrypt 'sslv2-or-v3)
                       )
  (let ((c (connect #:server server
                       #:port port
                       #:socket socket
                       #:user user
                       #:database database
                       #:password password
                       #:allow-cleartext-password? allow-cleartext-password?
                       #:ssl ssl
                       #:ssl-encrypt ssl-encrypt)))
    (new connection-proxy% (inner c))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; provide 
(provide proxy-connect)