;; (C) 2008 Jörg F. Wittenberger -*-Scheme-*-

(declare
 (unit sqlite3)
 (uses srfi-1 srfi-18 srfi-69)
 (fixnum)
 (usual-integrations)
 (disable-interrupts)

 (foreign-declare #<<EOF
#include <sqlite3.h>
#include <assert.h>

int rs_sqlite3_auth_restricted(void* userdata, int opcode,
			       const char* arg1, const char* arg2,
			       const char* dbname, const char* trigger)
{
  switch(opcode) {
  case SQLITE_CREATE_INDEX:	/* Index Name      Table Name      */
  case SQLITE_REINDEX:
  case SQLITE_CREATE_TABLE:	/* Table Name      NULL            */
  case SQLITE_ALTER_TABLE:      /* Database Name   Table Name      */
  case SQLITE_CREATE_TEMP_INDEX: /* Index Name      Table Name      */
  case SQLITE_CREATE_TEMP_TABLE:   /* Table Name      NULL            */
  case SQLITE_CREATE_TEMP_TRIGGER: /* Trigger Name    Table Name      */
  case SQLITE_CREATE_TEMP_VIEW:	/* View Name       NULL            */
  case SQLITE_CREATE_TRIGGER:	/* Trigger Name    Table Name      */
  case SQLITE_CREATE_VIEW:	/* View Name       NULL            */
  case SQLITE_DELETE:		/* Table Name      NULL            */
  case SQLITE_DROP_INDEX:	/* Index Name      Table Name      */
  case SQLITE_DROP_TABLE:	/* Table Name      NULL            */
  case SQLITE_DROP_TEMP_INDEX:	/* Index Name      Table Name      */
  case SQLITE_DROP_TEMP_TABLE:	/* Table Name      NULL            */
  case SQLITE_DROP_TEMP_TRIGGER: /* Trigger Name    Table Name      */
  case SQLITE_DROP_TEMP_VIEW:   /* View Name       NULL            */
  case SQLITE_DROP_TRIGGER:	/* Trigger Name    Table Name      */
  case SQLITE_DROP_VIEW:	/* View Name       NULL            */
  case SQLITE_INSERT:		/* Table Name      NULL            */
  case SQLITE_PRAGMA:		/* Pragma Name     1st arg or NULL */
  case SQLITE_READ:		/* Table Name      Column Name     */
  case SQLITE_SELECT:		/* NULL            NULL            */
#if SQLITE_VERSION_NUMBER > 3003007
  case SQLITE_FUNCTION:		/* Function Name   NULL            */
#endif
  case SQLITE_TRANSACTION:	/* NULL            NULL            */
  case SQLITE_UPDATE:		/* Table Name      Column Name     */
    return SQLITE_OK;
  case SQLITE_ATTACH:		/* Filename        NULL            */
  case SQLITE_DETACH:		/* Database Name   NULL            */
  default:
fprintf(stderr, "auth_restricted deny %d\n", opcode);
    return SQLITE_DENY;
  }
}

int rs_sqlite3_auth_restricted_ro(void* userdata, int opcode,
			          const char* arg1, const char* arg2,
				  const char* dbname, const char* trigger)
{
  switch(opcode) {
  case SQLITE_CREATE_INDEX:	/* Index Name      Table Name      */
  case SQLITE_CREATE_TABLE:	/* Table Name      NULL            */
  case SQLITE_ALTER_TABLE:      /* Database Name   Table Name      */
    return SQLITE_DENY;
  case SQLITE_CREATE_TEMP_INDEX: /* Index Name      Table Name      */
  case SQLITE_CREATE_TEMP_TABLE:   /* Table Name      NULL            */
  case SQLITE_CREATE_TEMP_TRIGGER: /* Trigger Name    Table Name      */
  case SQLITE_CREATE_TEMP_VIEW:	/* View Name       NULL            */
    return SQLITE_OK;
  case SQLITE_CREATE_TRIGGER:	/* Trigger Name    Table Name      */
  case SQLITE_CREATE_VIEW:	/* View Name       NULL            */
  case SQLITE_DELETE:		/* Table Name      NULL            */
  case SQLITE_DROP_INDEX:	/* Index Name      Table Name      */
  case SQLITE_DROP_TABLE:	/* Table Name      NULL            */
    return SQLITE_DENY;
  case SQLITE_DROP_TEMP_INDEX:	/* Index Name      Table Name      */
  case SQLITE_DROP_TEMP_TABLE:	/* Table Name      NULL            */
  case SQLITE_DROP_TEMP_TRIGGER: /* Trigger Name    Table Name      */
  case SQLITE_DROP_TEMP_VIEW:   /* View Name       NULL            */
    return SQLITE_OK;
  case SQLITE_DROP_TRIGGER:	/* Trigger Name    Table Name      */
  case SQLITE_DROP_VIEW:	/* View Name       NULL            */
  case SQLITE_INSERT:		/* Table Name      NULL            */
    return SQLITE_DENY;
  case SQLITE_PRAGMA:		/* Pragma Name     1st arg or NULL */
    return SQLITE_DENY;
  case SQLITE_READ:		/* Table Name      Column Name     */
  case SQLITE_SELECT:		/* NULL            NULL            */
#if SQLITE_VERSION_NUMBER > 3003007
  case SQLITE_FUNCTION:		/* Function Name   NULL            */
#endif
    return SQLITE_OK;
  case SQLITE_TRANSACTION:	/* NULL            NULL            */
  case SQLITE_UPDATE:		/* Table Name      Column Name     */
  case SQLITE_ATTACH:		/* Filename        NULL            */
  case SQLITE_DETACH:		/* Database Name   NULL            */
  default:
    return SQLITE_DENY;
  }
}

void sqlite3_concat(sqlite3_context* ctx, int argc, sqlite3_value** argv)
{
  int len=0, i=0, j=0;
  char *r = NULL;
  for(;i<argc; ++i) len+=sqlite3_value_bytes(argv[i]);
  r = malloc(len+1);
  for(i=0, j=0; i<argc; ++i) {
    int s = sqlite3_value_bytes(argv[i]);
    strncpy(r+j, (const char*)sqlite3_value_text(argv[i]), s);
    j += s;
  }
  r[j]='\0';
  sqlite3_result_text(ctx, r, len, free);
}

int sq_sqlite3_create_functions(sqlite3 *conn)
{
  return sqlite3_create_function(conn, "concat", -1, SQLITE_UTF8,
				 NULL, sqlite3_concat, NULL, NULL);
}

static void sqlite3_set_authorizer_restricted_ro(sqlite3 *cnx)
{
 sqlite3_set_authorizer(cnx, rs_sqlite3_auth_restricted_ro, NULL);
}

static void sqlite3_set_authorizer_restricted(sqlite3 *cnx)
{
 sqlite3_set_authorizer(cnx, rs_sqlite3_auth_restricted, NULL);
}

/* setup function table */

static void sqlite3_setup_full(sqlite3 *cnx)
{
  sq_sqlite3_create_functions(cnx);
}

static void sqlite3_setup_restricted(sqlite3 *cnx)
{
  sqlite3_set_authorizer(cnx, rs_sqlite3_auth_restricted, NULL);
  sq_sqlite3_create_functions(cnx);
}

static void sqlite3_setup_restricted_ro(sqlite3 *cnx)
{
  sqlite3_set_authorizer(cnx, rs_sqlite3_auth_restricted_ro, NULL);
  sq_sqlite3_create_functions(cnx);
}

static void (*setup_table[4])(sqlite3 *) = {
  NULL,
  sqlite3_setup_full,
  sqlite3_setup_restricted,
  sqlite3_setup_restricted_ro
};

static void sqlite3_setup(sqlite3 *cnx, int i)
{
  void (*f)(sqlite3 *);
  assert(i<4);
  f=setup_table[i];
  if(f) (*f)(cnx);
}

typedef int (*askemos_request_function_t)(void *);
extern void
start_asynchronous_request(askemos_request_function_t function,
		             void *data, void *callback);

static int
sq_open(const char* dbn, sqlite3 **cnx, int setup, const char*vfs)
{
 int rc = sqlite3_open_v2( dbn,
			   cnx,
			   ( setup == 3 ? SQLITE_OPEN_READONLY :
			     ( SQLITE_OPEN_READWRITE | SQLITE_OPEN_CREATE ) )
                           | SQLITE_OPEN_NOMUTEX,
			   vfs );
 if( rc == SQLITE_OK ) sqlite3_setup(*cnx, setup);
 return rc;
}

//#define TRACE 0

struct open_args {
  sqlite3 *cnx;
  int setup;
  C_word sm;
  char *vfs;
  char dbn[2];
};

static int
pthread_sqlite3_open(void *data)
{
  struct open_args *a = data;
  int rc;

#ifdef TRACE
fprintf(stderr, "DB %s vfs %s SM %ld\n", a->dbn, a->vfs, a->sm);
#endif
/*
  if(a->sm != C_SCHEME_FALSE) {
    struct callback_args *a2 = PTR_TO_DATAPTR(a->sm);
    pthread_cond_init(&a2->cond, NULL);  
    lock_callback_open_parameters(a->sm);
  }
*/
  rc = sqlite3_open_v2( a->dbn,
			&a->cnx,
			( a->setup == 3 ? SQLITE_OPEN_READONLY :
			  ( SQLITE_OPEN_READWRITE | SQLITE_OPEN_CREATE ) )
                        | SQLITE_OPEN_NOMUTEX,
			a->vfs);
  /* unlock_callback_open_parameters(); done within open ASAP */
  sqlite3_setup(a->cnx, a->setup);

  return SQLITE_OK;
}

struct close_args {
 sqlite3 *cnx;
 C_word sm;
};

static int
pthread_sqlite3_close(void *data)
{
  struct close_args *a = data;

#ifdef TRACE
  fprintf(stderr, "close %p\n", a);
#endif
  if(a->sm != C_SCHEME_FALSE) {
/*
    struct callback_args *a2 = PTR_TO_DATAPTR(a->sm);
    pthread_cond_destroy(&a2->cond);  
*/
  }
  return sqlite3_close(a->cnx);
}

struct prepare_args {
  sqlite3_stmt *stmt;
  int tail;
  sqlite3 *db;
  int sql_len;
  int offset;
  char sql[1];
};

int pthread_sqlite3_prepare(void *data)
{
  struct prepare_args *a = data;
  int rc;
  const char *tail;

#ifdef TRACE
  fprintf(stderr, "prepar %p >>%s<< %d %d\n", a->db, a->sql, a->offset, a->sql_len);
#endif

  rc = sqlite3_prepare_v2( a->db,
			   a->sql + a->offset,
			   a->sql_len - a->offset,
			   &a->stmt,
			   &tail );
  if (a->stmt != NULL) {
    a->tail = tail - a->sql;
  }
  return rc;
}

static int
pthread_sqlite3_step(void *data)
{
  sqlite3_stmt *s=data;
  return sqlite3_step(s);
}

EOF
))

(module
 sqlite3
 (
  sql-field sql-index
  sql-with-tupels%-fold-left
  sqlite3-exec
  sql-close
  sql-result?
  sql-value
  sql-connect
  sql-with-tupels

  sqlite3-step
  sql-ref
  sqlite3-statement-name
  sqlite3-open-restricted-ro
  sqlite3-statement-container
  sqlite3-database-prep-cache
  sqlite3-database-name
  sqlite3-error?
  sqlite3-changes
  sqlite3-statement?
  sqlite3-statement-raw-pointer
  sqlite3-database-open-statements
  sqlite3-error-cond
  sqlite3-open sqlite3-close
  sqlite3-open-restricted
  sqlite3-error-args
  make-sqlite3-statement
  )

(import scheme foreign
	(except chicken condition?) srfi-18 srfi-34 srfi-35
	srfi-1 srfi-69 extras util)

(define (make-gc-root obj)
  ((foreign-lambda*
    c-pointer ((scheme-object obj))
    "C_GC_ROOT *r=CHICKEN_new_gc_root();"
    "CHICKEN_gc_root_set(r, obj);"
    "return(r);")
   obj))

(define delete-gc-root
  (foreign-lambda void "CHICKEN_delete_gc_root" c-pointer))

(define (make-object-table)
  (make-hash-table eq? eq?-hash))

(define *the-db-drivers* '())

(define (sql-connect driver db host user pass)
  (let ((entry (assoc driver *the-db-drivers*)))
    (if entry
	((cdr entry) db host user pass)
	(error (string-append "sql-connect unsupported driver '"
			      driver
			      "' requested.")))))
(define (sql-close obj)
  ((cond
    ((sqlite3-database? obj) sqlite3-close))
   obj))

(define sql-result? vector?)

(define (sql-value result row field)
  ((cond
    ((sql-result? result) sqlite3-value))
   result row field))

(define (sql-field result field)
  ((cond
    ((sql-result? result) sqlite3-field))
   result field))

(define (sql-with-tupels connection query proc)
  ((cond
    ((sqlite3-database? connection) sqlite3-with-tupels))
   connection query proc))

;; WARNING: sql-index, sql-field and sql-value are experimental.

(define (sql-index self field)
  (and (fx> (vector-length self) 0)
       (vassoc field (vector-ref self 0))))

(define (sqlite3-field self field)
  (vector-ref (vector-ref self 0) field))

(define (sqlite3-value self row field)
  (vector-ref (vector-ref self (add1 row))
	      (or (cond
		   ((integer? field) field)
		   ((string? field) (sql-index self field))
		   ((symbol? field) (sql-index self (symbol->string field)))
		   (else (error (format "sql-value bad index type ~s" field))))
		  (error (format "no field ~a in ~a" field
				 (vector-ref self 0))))))

(define (sql-ref self row field)
  (cond
   ((and row field) (sql-value self row field))
   (field (sql-index self field))
   (else (sub1 (vector-length self)))))

(define (one-shot-sql-tupels%-fold-left db query setup-seeds fold-function seeds)
  (define (range n)
    (let loop ((i 0))
      (if (eqv? i n) '() (cons i (loop (add1 i))))))
  ;; TODO fix the mxsql-driver to actually return the value!
  (sql-with-tupels
   db query
   (lambda (result rows cols)
     (if (eqv? rows 0)
         (apply list->values (append! seeds (setup-seeds result rows cols)))
         (let ((cols (range cols)))
           (let loop ((seeds (append! seeds (setup-seeds result rows cols)))
                      (row 0))
             (if (eqv? row rows)
                 (apply list->values seeds)
                 (receive (proceed . seeds)
                          (apply fold-function
                                 (map (lambda (field)
                                        (sql-value result row field))
                                      cols)
                                 seeds)
                          (if proceed
                              (loop seeds (add1 row))
                              (apply list->values seeds))))))))))

(define (sql-with-tupels%-fold-left db query setup-seeds fold-function seed . seeds)
  (one-shot-sql-tupels%-fold-left db query setup-seeds fold-function (cons seed seeds)))

(define-foreign-type <raw-sqlite3-database> (c-pointer "sqlite3"))

(define-record-type <sqlite3-database>
  (make-sqlite3-database raw-pointer open-statemets prep-cache name)
  sqlite3-database?
  (raw-pointer sqlite3-database-raw-pointer)
  (open-statemets sqlite3-database-open-statements)
  (prep-cache sqlite3-database-prep-cache)
  (name sqlite3-database-name))

(define (sqlite3-with-tupels self query proc)
  ;; FIXME we need to write a per connection thread.
  (let* ((result ; (sqlite3-async-exec self query)
		(sqlite3-exec self query))
	 (rows (vector-length result)))
    (if (eqv? rows 0)
	(proc result 0 0)
	(proc result (sub1 rows) (vector-length (vector-ref result 0))))))

(define (vassoc val vec)
  (do ((i 0 (add1 i)))
      ((or (eqv? i (vector-length vec))
	   (equal? val (vector-ref vec i)))
       (and (fx< i (vector-length vec)) i))))


(define-condition-type &sqlite3-error &error sqlite3-error?
  (code sqlite3-error-cond)
  (args sqlite3-error-args))

(define-foreign-variable SQLITE_OTHER int "SQLITE_OTHER")
(define-foreign-variable SQLITE_OK int "SQLITE_OK")
(define-foreign-variable SQLITE_ERROR int "SQLITE_ERROR")
(define-foreign-variable SQLITE_INTERNAL int "SQLITE_INTERNAL")
(define-foreign-variable SQLITE_PERM int "SQLITE_PERM")
(define-foreign-variable SQLITE_ABORT int "SQLITE_ABORT")
(define-foreign-variable SQLITE_BUSY int "SQLITE_BUSY")
(define-foreign-variable SQLITE_LOCKED int "SQLITE_LOCKED")
(define-foreign-variable SQLITE_NOMEM int "SQLITE_NOMEM")
(define-foreign-variable SQLITE_READONLY int "SQLITE_READONLY")
(define-foreign-variable SQLITE_INTERRUPT int "SQLITE_INTERRUPT")
(define-foreign-variable SQLITE_IOERR int "SQLITE_IOERR")
(define-foreign-variable SQLITE_CORRUPT int "SQLITE_CORRUPT")
(define-foreign-variable SQLITE_NOTFOUND int "SQLITE_NOTFOUND")
(define-foreign-variable SQLITE_FULL int "SQLITE_FULL")
(define-foreign-variable SQLITE_CANTOPEN int "SQLITE_CANTOPEN")
(define-foreign-variable SQLITE_PROTOCOL int "SQLITE_PROTOCOL")
(define-foreign-variable SQLITE_EMPTY int "SQLITE_EMPTY")
(define-foreign-variable SQLITE_SCHEMA int "SQLITE_SCHEMA")
(define-foreign-variable SQLITE_TOOBIG int "SQLITE_TOOBIG")
(define-foreign-variable SQLITE_CONSTRAINT int "SQLITE_CONSTRAINT")
(define-foreign-variable SQLITE_MISMATCH int "SQLITE_MISMATCH")
(define-foreign-variable SQLITE_MISUSE int "SQLITE_MISUSE")
(define-foreign-variable SQLITE_NOLFS int "SQLITE_NOLFS")
(define-foreign-variable SQLITE_AUTH int "SQLITE_AUTH")
(define-foreign-variable SQLITE_ROW int "SQLITE_ROW")
(define-foreign-variable SQLITE_DONE int "SQLITE_DONE")

(define-foreign-type <raw-sqlite3-database> (c-pointer "sqlite3"))
(define-foreign-type <raw-sqlite3-statement> (c-pointer "sqlite3_stmt"))

(define-record-type <sqlite3-statement>
  (make-sqlite3-statement raw-pointer container name)
  sqlite3-statement?
  (raw-pointer sqlite3-statement-raw-pointer)
  (container sqlite3-statement-container)
  (name sqlite3-statement-name)
  )

(define (sqlite3-run-fn param fn)
  (let ((mux (make-mutex 'sqlite3))
	(result #f))
    (let* ((cb (lambda (x) (set! result x) (mutex-unlock! mux)))
	   (callback (make-gc-root cb)))
      (mutex-lock! mux)
      (do ((exit #f))
	  (exit (delete-gc-root callback) (values result param))
	(fn param callback)
	(mutex-lock! mux)
	(set! exit #t)))))

(define (sqlite3-error-message d)
  ((foreign-lambda c-string "sqlite3_errmsg" <raw-sqlite3-database>)
   (sqlite3-database-raw-pointer d)))

(define-foreign-type <sqlite3-open-args> (c-pointer "struct open_args"))

(define open-args
  (foreign-lambda*
   <sqlite3-open-args>
   ((scheme-object dbn)
    (integer dbnlen)
    (integer setup)
    (scheme-object vfs)
    (integer vfslen)
    (scheme-object sm))
   #<<EOF
struct open_args *a=malloc(sizeof(struct prepare_args) + dbnlen + vfslen);
a->cnx = NULL;
strncpy(a->dbn, C_c_string(dbn), dbnlen);
a->dbn[dbnlen]='\0';
a->setup = setup;
a->sm=sm;
if( vfs == C_SCHEME_FALSE ) {
  a->vfs=NULL;
} else {
  a->vfs = a->dbn+dbnlen+1;
  strncpy(a->vfs, C_c_string(vfs), vfslen);
  a->vfs[vfslen]='\0';
}
return(a);
EOF
))

(define sqlite3-start-open
  (foreign-lambda* void ((<sqlite3-open-args> s) (c-pointer callback))
		   "start_asynchronous_request(pthread_sqlite3_open, s, callback);"))

(define (sqlite3-open* dbn setup vfs sm)
  (call-with-values
      (lambda ()
	(sqlite3-run-fn (open-args dbn (string-length dbn)
				   setup
				   vfs (if vfs (string-length vfs) 0)
				   sm)
			sqlite3-start-open))
    (lambda (result param)
      (if (eqv? result SQLITE_OK)
	  ((foreign-lambda*
	    <raw-sqlite3-database>
	    ((<sqlite3-open-args> a))
	    "sqlite3 *cnx = a->cnx; free(a); return(cnx);")
	   param)
	  (begin
	    ((foreign-lambda* void ((<sqlite3-open-args> a)) "free(a);") param)
	    (error (format "sqlite3-open* returned ~a" result)))))))

(define (sqlite3-open dbn)
  (make-sqlite3-database (sqlite3-open* dbn 1 #f #f) (make-object-table) (make-string-table) dbn))

(define (sqlite3-open-restricted dbn . vfs)
  (make-sqlite3-database
   (sqlite3-open* dbn 2 (and (pair? vfs) (car vfs)) #f)
   (make-object-table) (make-string-table) dbn))

(define (sqlite3-open-restricted-ro dbn . vfs)
  (and (file-exists? dbn)
       (make-sqlite3-database
	(sqlite3-open* dbn 3 (and (pair? vfs) (car vfs)) #f)
	(make-object-table) (make-string-table) dbn)))

(define-foreign-type <sqlite3-close-args> (c-pointer "struct close_args"))

(define sqlite3-start-close
  (foreign-lambda* void ((<sqlite3-open-args> s) (c-pointer callback))
		   "start_asynchronous_request(pthread_sqlite3_close, s, callback);"))

(define close-args
  (foreign-lambda*
   <sqlite3-close-args>
   ((<raw-sqlite3-database> db)
    (scheme-object sm))
   #<<EOF
struct close_args *a=malloc(sizeof(struct close_args));
a->cnx = db;
a->sm=sm;
return(a);
EOF
))

(define (sqlite3-close db)
  (let ((param (close-args (sqlite3-database-raw-pointer db) #f)))
    (call-with-values
	(lambda ()
	  (sqlite3-run-fn param sqlite3-start-close))
      (lambda (rc dbo)
	;; (set-callback-args! db #f)
	(if (not (eqv? rc SQLITE_OK))
	    (condition (&message (message (sqlite3-error-message db)))))))))

(define sqlite3-changes
  (foreign-lambda integer "sqlite3_changes" <raw-sqlite3-database>))

(define sqlite3-finalize*
  (foreign-lambda integer "sqlite3_finalize" <raw-sqlite3-statement>))

(define (sqlite3-finalize db stmt)
  (let ((v (sqlite3-finalize* stmt)))
    (or (eqv? v SQLITE_OK)
	(raise (condition (&message (message (sqlite3-error-message db))))))))

(define-foreign-type <sqlite3-prepare-args> (c-pointer "struct prepare_args"))

(define prepare-args
  (foreign-lambda*
   <sqlite3-prepare-args>
   ((<raw-sqlite3-database> db)
    (scheme-object sql)
    (integer sqllen)
    (integer offset))
   "struct prepare_args *a=malloc(sizeof(struct prepare_args) + sqllen);"
   "a->stmt = NULL;"
   "a->db = db;"
   "strncpy(a->sql,C_c_string(sql), sqllen); a->sql[sqllen]='\\0';"
   "a->sql_len = sqllen;"
   "a->offset = offset;"
   "return(a);"
   ))

(define sqlite3-start-prepare
  (foreign-lambda* void ((<sqlite3-prepare-args> s) (c-pointer callback))
		   "start_asynchronous_request(pthread_sqlite3_prepare, s, callback);"))

(define (sqlite3-prepare db sql offset)
  (let ((param (prepare-args (sqlite3-database-raw-pointer db) sql (string-length sql) offset)))
    (call-with-values
	(lambda ()
	  (sqlite3-run-fn param sqlite3-start-prepare))
      (lambda (rc param)
	(if (eqv? rc SQLITE_OK)
	    (let-location
	     ((stmt <raw-sqlite3-statement>)
	      (n integer))
	     ((foreign-lambda*
	       void
	       ((<sqlite3-prepare-args> a)
		((c-pointer <raw-sqlite3-statement>) stmt)
		((c-pointer integer) n))
	       "*stmt=a->stmt; *n=a->tail; free(a);")
	      param (location stmt) (location n))
	     (values stmt n))
	    (begin
	      ((foreign-lambda*  void ((<sqlite3-prepare-args> a)) "free(a);") param)
	      (raise (condition (&message (message (sqlite3-error-message db)))))))))))

(define sqlite3-step*
  (foreign-lambda integer "sqlite3_step" <raw-sqlite3-statement>))

(define sqlite3-db-handle
  (foreign-lambda void "sqlite3_db_handle" <raw-sqlite3-statement>))

(define (sqlite3-step db stmt)
  (let ((rc (sqlite3-step* stmt)))
    (cond
     ((eqv? rc SQLITE_ROW) #t)
     ((eqv? rc SQLITE_DONE) #f)
     (else (raise (condition (&message (message (sqlite3-error-message db))))) ))))

(define sqlite3-start-step
  (foreign-lambda* void ((<raw-sqlite3-statement> s) (c-pointer callback))
		   "start_asynchronous_request(pthread_sqlite3_step, s, callback);"))

(define sqlite3-column-count
  (foreign-lambda integer "sqlite3_column_count" <raw-sqlite3-statement>))

(define sqlite3-column-name
  (foreign-lambda c-string "sqlite3_column_name" <raw-sqlite3-statement> integer))

(define (sqlite3-columns st)
  (let ((n (sqlite3-column-count st)))
    (let loop ((i 0))
      (if (eqv? i n) '()
	  (cons (sqlite3-column-name st i) (loop (add1 i)))))))

;;;
;;;  Return a list of lists
;;;

(define sqlite3-empty-result '#(#()))

(define (sqlite3-bind . args)
  (error "NYI: arguments to sqlite3-exec"))

(define-foreign-variable SQLITE_INTEGER int "SQLITE_INTEGER")
(define-foreign-variable SQLITE_FLOAT int "SQLITE_FLOAT")
(define-foreign-variable SQLITE_NULL int "SQLITE_NULL")
(define-foreign-variable SQLITE_TEXT int "SQLITE_TEXT")
(define-foreign-variable SQLITE_BLOB int "SQLITE_BLOB")

(define sqlite3-column-type
  (foreign-lambda int "sqlite3_column_type" <raw-sqlite3-statement> integer))

(define sqlite3-column-int64
  (foreign-lambda integer64 "sqlite3_column_int64" <raw-sqlite3-statement> integer))

(define sqlite3-column-float
  (foreign-lambda double "sqlite3_column_double" <raw-sqlite3-statement> integer))

(define sqlite3-column-text
  (foreign-lambda c-string "sqlite3_column_text" <raw-sqlite3-statement> integer))

(define (sqlite3-column-null x i) #f)

(define sqlite3-values
  (let ((l `((,SQLITE_INTEGER . ,sqlite3-column-int64)
	     (,SQLITE_FLOAT . ,sqlite3-column-float)
	     (,SQLITE_NULL . ,sqlite3-column-null)
	     (,SQLITE_TEXT . ,sqlite3-column-text)
	     (,SQLITE_BLOB . ,sqlite3-column-text))))
    (lambda (st)
      (let ((n (sqlite3-column-count st)))
	(let loop ((i 0))
	  (if (eqv? i n) '()
	      (cons ((cdr (assq (sqlite3-column-type st i) l)) st i)
		    (loop (add1 i)))))))))
(define (sqlite3-for-each db s fn)
  (let* ((mux (make-mutex 'sqlite3-for-each))
	 (rc #f)
	 (cb (lambda (x) (set! rc x) (mutex-unlock! mux)))
	 (callback (make-gc-root cb)))
    (mutex-lock! mux)
    (do ((exit #f))
	(exit (delete-gc-root callback) #t)
      (sqlite3-start-step s callback)
      (mutex-lock! mux)
      (cond
       ((eqv? rc SQLITE_ROW) (apply fn (sqlite3-values s)))
       ((eqv? rc SQLITE_DONE) (set! exit #t) #f)
       (else (delete-gc-root callback)
	     (raise (condition (&message (message (sqlite3-error-message db))))))))))

(define (sqlite3-exec db stmt . args)
  (let loop ((n 0)
	     (r0 sqlite3-empty-result))
    (if (fx< n (string-length stmt))
	(call-with-values (lambda () (sqlite3-prepare db stmt n))
	  (lambda (p n)
	    (if p
		(let ((r '()))
		  ;;
		  (begin
		    (if (pair? args) (apply sqlite3-bind p args))
		    ;;
		    (guard
		     (ex (else (sqlite3-finalize db p)
			       (raise ex)))
		     (sqlite3-for-each
		      db p
		      (lambda args
			(set! r (cons (list->vector args) r)))))
		    (let ((r0 (list->vector
			       (cons
				(list->vector (sqlite3-columns p))
				(reverse! r)))))
		      (sqlite3-finalize db p)
		      (loop n r0))))
		r0)))
	r0)))

)

(import (prefix sqlite3 m:))

(define sql-result? m:sql-result?)
(define sql-field m:sql-field)
(define sql-index m:sql-index)
(define sql-with-tupels%-fold-left m:sql-with-tupels%-fold-left)
(define sqlite3-exec m:sqlite3-exec)
(define sql-close m:sql-close)
(define sql-value m:sql-value)
(define sql-connect m:sql-connect)
(define sql-with-tupels m:sql-with-tupels)

(define sqlite3-step m:sqlite3-step)
(define sql-ref m:sql-ref)
(define sqlite3-statement-name m:sqlite3-statement-name)
(define sqlite3-open-restricted-ro m:sqlite3-open-restricted-ro)
(define sqlite3-statement-container m:sqlite3-statement-container)
(define sqlite3-database-prep-cache m:sqlite3-database-prep-cache)
(define sqlite3-database-name m:sqlite3-database-name)
(define sqlite3-error? m:sqlite3-error?)
(define sqlite3-changes m:sqlite3-changes)
(define sqlite3-statement? m:sqlite3-statement?)
(define sqlite3-statement-raw-pointer m:sqlite3-statement-raw-pointer)
(define sqlite3-database-open-statements m:sqlite3-database-open-statements)
(define sqlite3-error-cond m:sqlite3-error-cond)
(define sqlite3-open m:sqlite3-open)
(define sqlite3-close m:sqlite3-close)
(define sqlite3-open-restricted m:sqlite3-open-restricted)
(define sqlite3-error-args m:sqlite3-error-args)
(define make-sqlite3-statement m:make-sqlite3-statement)