#lang racket/base
(require racket/class
         racket/serialize
         unstable/error)
(provide connection<%>
         dbsystem<%>
         prepared-statement<%>

         connection?
         dbsystem?
         prepared-statement?

         (struct-out statement-binding)

         (struct-out simple-result)
         (struct-out rows-result)
         (struct-out cursor-result)

         init-private

         log-db-error
         log-db-warning
         log-db-info
         log-db-debug

         (struct-out exn:fail:sql)
         raise-sql-error)

;; ----------------------------------------

;; Interfaces

;; connection<%>
(define connection<%>
  (interface ()
    ;; connected? method must return promptly (eg, without acquiring lock)
    connected?    ;; -> boolean

    disconnect    ;; -> void
    get-dbsystem  ;; -> dbsystem<%>
    query         ;; symbol statement -> QueryResult
    prepare       ;; symbol preparable boolean -> prepared-statement<%>
    fetch/cursor  ;; symbol cursor nat -> #f or (listof vector)
    get-base      ;; -> connection<%> or #f (#f means base isn't fixed)
    list-tables   ;; symbol symbol -> (listof string)

    ;; in start-tx and end-tx, the final boolean arg indicates whether the
    ;; transaction is managed manually (#f) or by call-with-tx (#t)
    start-transaction  ;; symbol (U 'serializable ...) any boolean -> void
    end-transaction    ;; symbol (U 'commit 'rollback) boolean -> void
    transaction-status ;; symbol -> (U boolean 'invalid)
    free-statement))   ;; prepared-statement<%> boolean -> void

;; dbsystem<%>
;; Represents brand of database system, SQL dialect, etc
(define dbsystem<%>
  (interface ()
    get-short-name         ;; -> symbol

    get-parameter-handlers ;; (listof typeid) -> (listof ParameterHandler)
    field-dvecs->typeids   ;; (listof field-dvec) -> (listof typeid)

    ;; inspection only
    get-known-types        ;; real -> (listof symbol)
    describe-params        ;; (listof typeid) -> (listof TypeDesc)
    describe-fields))      ;; (listof field-dvec) -> (listof TypeDesc)

;; ParameterHandler = (fsym index datum -> ???)
;; Each system gets to choose its checked-param representation.
;; Maybe check and convert to string. Maybe just check, do binary conversion later.

;; TypeDesc = (list boolean symbol/#f typeid)

;; prepared-statement<%>
(define prepared-statement<%>
  (interface ()
    get-handle         ;; -> Handle (depends on database system)
    set-handle         ;; Handle -> void

    get-close-on-exec? ;; -> boolean
    after-exec         ;; boolean -> void (for close-on-exec)

    get-stmt           ;; -> string/#f
    get-stmt-type      ;; -> symbol/#f

    get-param-count    ;; -> nat
    get-param-typeids  ;; -> (listof typeid)

    get-result-dvecs   ;; -> (listof field-dvec)
    get-result-count   ;; -> nat
    get-result-typeids ;; -> (listof typeid)

    check-owner        ;; symbol connection any -> #t (or error)
    bind               ;; symbol (listof param) -> statement-binding

    ;; inspection only
    get-param-types    ;; -> (listof TypeDesc)
    get-result-types   ;; -> (listof TypeDesc)
    ))

(define (connection? x)
  (is-a? x connection<%>))

(define (dbsystem? x)
  (is-a? x dbsystem<%>))

(define (prepared-statement? x)
  (is-a? x prepared-statement<%>))

;; ----------------------------------------

;; Auxiliary structures

;; A statement-binding is:
;;   - (statement-binding prepared-statement (listof ???))
(struct statement-binding (pst params))

;; An query-result is one of:
;;  - (simple-result alist)
;;  - (rows-result Header data)
;;    for user-visible rows-results: headers present, data is (listof vector)
(serializable-struct simple-result (info) #:transparent)
(serializable-struct rows-result (headers rows) #:transparent)

;; A cursor-result is
;;  - (cursor-result Header prepared-statement ???)
(struct cursor-result (headers pst extra))

;; A Header is (listof FieldInfo)
;; A FieldInfo is an alist, contents dbsys-dependent

;; ----------------------------------------

;; Class utilities

;; Here just because ...

(define-syntax-rule (init-private iid ...)
  (begin (init-private1 iid) ...))

(define-syntax-rule (init-private1 iid)
  (begin (init ([private-iid iid]))
         (define iid private-iid)))

;; ----------------------------------------

;; Logging

(define-logger db)

;; ----------------------------------------

;; Exceptions

#|
Only errors with an associated SQLSTATE are represented by
exn:fail:sql, specifically only errors originating from a database
backend or library. Other errors are typically raised using 'error',
producing plain old exn:fail.

For SQLite, use symbol instead of SQLSTATE string.
|#

;; exn:fail:sql
;; Represents an error with an associated SQLSTATE
(define-struct (exn:fail:sql exn:fail) (sqlstate info))

;; raise-sql-error : symbol string string alist -> raises exn
(define (raise-sql-error who sqlstate message info)
  (raise
   (make-exn:fail:sql (compose-error-message who message
                                             "SQLSTATE" sqlstate)
                      (current-continuation-marks)
                      sqlstate
                      info)))

;; ----------------------------------------

;; Common Errors

(provide error/internal
         error/internal*
         error/not-connected
         error/no-support
         error/need-password
         error/comm
         error/hopeless
         error/unsupported-type
         error/no-convert
         error/invalid-nested-isolation
         error/tx-bad-stmt
         error/unbalanced-tx
         error/unclosed-tx
         error/nested-tx-option
         error/exn-in-rollback
         error/stmt-arity
         error/stmt
         error/want-rows
         error/want-cursor
         error/column-count
         error/row-count
         error/statement-binding-args)

(define (error/internal fsym fmt . args)
  (raise-misc-error fsym "internal error"
                    #:continued (apply format fmt args)))

(define (error/internal* fsym msg . args)
  (apply raise-misc-error fsym "internal error" #:continued msg args))

;; FIXME; clean up
(define (error/comm fsym [when-occurred #f])
  (raise-misc-error fsym "communication failure"
                    "when" when-occurred))

(define (error/no-support fsym feature)
  (raise-misc-error fsym "feature not supported"
                    "feature" feature))

(define (error/hopeless fsym)
  (error fsym "connection is permanently locked due to a terminated thread"))

(define (error/not-connected fsym)
  (error fsym "not connected"))

;; ----

(define (error/invalid-nested-isolation fsym isolation)
  (raise-misc-error fsym "invalid isolation level for nested transaction"
                    '("isolation level" value) isolation))

(define (error/unbalanced-tx fsym mode saved-cwt?)
  (error fsym "~a-transaction without matching start-transaction~a"
         mode (if saved-cwt? " (within the extent of call-with-transaction)" "")))

(define (error/unclosed-tx fsym mode saved-cwt?)
  (error fsym "unclosed nested transaction~a"
         (if saved-cwt? " (within extent of call-with-transaction)" "")))

(define (error/tx-bad-stmt fsym stmt-type-string tx-state)
  (raise-misc-error fsym "statement not allowed in current transaction state"
                    "statement type" stmt-type-string
                    "transaction state" tx-state))

(define (error/nested-tx-option fsym option)
  (raise-misc-error fsym "option not allowed for nested transaction"
                    '("option" value) option))

(define (error/exn-in-rollback fsym e1 e2)
  (raise-misc-error fsym "error during rollback"
    #:continued "secondary error occurred during rollback triggered by primary error"
    '("primary" value) (exn-message e1)
    '("secondary" value) (exn-message e2)))

;; ----

(define (error/stmt-arity fsym expected given)
  (raise-misc-error fsym "wrong number of parameters for query"
                    ;; FIXME: add stmt, use error/stmt
                    "expected" expected
                    "given" given))

;; ----

(define (error/need-password fsym)
  (error fsym "password needed but not supplied"))

;; ----

(define (error/unsupported-type fsym typeid [type #f])
  (raise-misc-error fsym "unsupported type"
                    "type" type
                    "typeid" typeid))

(define (error/no-convert fsym sys type param [note #f] #:contract [ctc #f])
  (raise-misc-error fsym "cannot convert given value to SQL type"
                    '("given" value) param
                    "type" type
                    "expected" (and ctc (format "~.s" ctc))
                    "dialect" sys
                    "note" note))

;; ----

(define (error/stmt fsym stmt message . args)
  (apply raise-misc-error fsym message
         '("statement" value) (or (let loop ([stmt stmt])
                                    (cond [(string? stmt) stmt]
                                          [(statement-binding? stmt) (loop (statement-binding-pst stmt))]
                                          [(prepared-statement? stmt) (loop (send stmt get-stmt))]
                                          [else #f]))
                                  stmt)
         ;; FIXME: include params from statement-binding values?
         ;; must first change statement-binding to store raw params
         args))

(define (error/want-rows fsym sql executed?)
  (error/stmt fsym sql
              (if executed?
                  "query did not return rows"
                  "query does not return rows")))

(define (error/want-cursor fsym sql)
  (error/stmt fsym sql "query did not return cursor"))

(define (error/column-count fsym sql want-columns got-columns executed?)
  (error/stmt fsym sql
              (if executed?
                  "query returned wrong number of columns"
                  "query returns wrong number of columns")
              "expected" want-columns
              "got" got-columns))

(define (error/row-count fsym sql want-rows got-rows)
  (error/stmt fsym sql "query returned wrong number of rows"
              "expected" want-rows
              "got" got-rows))

(define (error/statement-binding-args fsym stmt args)
  (raise-misc-error fsym
                    "cannot execute statement-binding with additional inline arguments"
                    '("statement" value) stmt
                    '("arguments" value) args))