(module sqlite mzscheme
(require (lib "etc.ss")
(lib "list.ss")
(lib "plt-match.ss")
(all-except (lib "contract.ss") ->)
(rename (lib "contract.ss") c-> ->)
"sqlite-ffi.ss")
(define-struct (exn:sqlite exn) ())
(define-struct db (_db_ptr _errMsg_ptr _callback_ptr))
(define (db-handle db)
(ptr-ref (db-_db_ptr db) _sqlite3_ptr))
(define-struct statement (_stmt_ptr))
(define (statement-handle stmt)
(ptr-ref (statement-_stmt_ptr stmt) _sqlite3_stmt_ptr))
(provide SQLITE_OK
SQLITE_ERROR)
(provide/contract
[db-handle (db? . c-> . cpointer?)]
[statement-handle (statement? . c-> . cpointer?)]
[open (path? . c-> . db?)]
[close (db? . c-> . void?)]
[exec (db? string? (list? list? . c-> . integer?) . c-> . void?)]
[exec/ignore (db? string? . c-> . void?)]
[select (db? string? . c-> . (listof list?))]
[prepare (db? string? . c-> . statement?)]
[load-params ((statement?) (listof (union string? number? bytes?)) . ->* . (void?))]
[step (statement? . c-> . (union (listof (union string? number? false/c bytes?)) false/c))]
[run ((statement?) (listof (union string? number? bytes?)) . ->* . (void?))]
[reset (statement? . c-> . void?)]
[finalize (statement? . c-> . void?)]
[errmsg (db? . c-> . string?)]
[changes-count (db? . c-> . integer?)]
[total-changes-count (db? . c-> . integer?)]
[step* (statement? . c-> . (listof (listof (union string? number? false/c bytes?))))])
(provide transaction/lock
transaction)
(define (list->equal-sublists n l)
(let loop ([l l] [i 0] [r `()])
(if (null? l)
(reverse r)
(loop (cdr l) (modulo (+ i 1) n)
(if (= i 0)
(append (list (list (car l)))
r)
(append (list (append (car r) (list (car l))))
(cdr r)))))))
(define (wrap-finalizer o f)
(register-finalizer o f)
o)
(define (handle-status s)
(if (or (= s SQLITE_OK)
(= s SQLITE_ROW)
(= s SQLITE_DONE))
s
(raise (make-exn:sqlite (string->immutable-string (format "SQLite Error: ~a" (lookup-status-message s)))
(current-continuation-marks)))))
(define (lookup-status-message s)
(cdr (assoc s
`([,SQLITE_ERROR . "Generic error, perhaps call errmsg?"]
[,SQLITE_INTERNAL . "An internal logic error in SQLite"]
[,SQLITE_PERM . "Access permission denied"]
[,SQLITE_ABORT . "Callback routine requested an abort"]
[,SQLITE_BUSY . "The database file is locked"]
[,SQLITE_LOCKED . "table in the database is locked"]
[,SQLITE_NOMEM . "A malloc() failed"]
[,SQLITE_READONLY . "Attempt to write a readonly database"]
[,SQLITE_INTERRUPT . "Operation terminated by sqlite3_interrupt()"]
[,SQLITE_IOERR . "Some kind of disk I/O error occurred"]
[,SQLITE_CORRUPT . "The database disk image is malformed"]
[,SQLITE_NOTFOUND . "(Internal Only) Table or record not found"]
[,SQLITE_FULL . "Insertion failed because database is full"]
[,SQLITE_CANTOPEN . "Unable to open the database file"]
[,SQLITE_PROTOCOL . "Database lock protocol error"]
[,SQLITE_EMPTY . "Database is empty"]
[,SQLITE_SCHEMA . "The database schema changed"]
[,SQLITE_TOOBIG . "Too much data for one row of a table"]
[,SQLITE_CONSTRAINT . "Abort due to contraint violation"]
[,SQLITE_MISMATCH . "Data type mismatch"]
[,SQLITE_MISUSE . "Library used incorrectly"]
[,SQLITE_NOLFS . "Uses OS features not supported on host"]
[,SQLITE_AUTH . "Authorization denied"]
[,SQLITE_FORMAT . "Auxiliary database format error"]
[,SQLITE_RANGE . "2nd parameter to sqlite3_bind out of range"]
[,SQLITE_NOTADB . "File opened that is not a database file"]))))
(define (open db-path)
(let ([r (wrap-finalizer (make-db (malloc _sqlite3_ptr_ptr)
(malloc _string_ptr)
(malloc _pointer))
close)])
(when (handle-status (sqlite3_open db-path (db-_db_ptr r)))
r)))
(define (close db)
(let ([o-_db_ptr (db-_db_ptr db)])
(set-db-_db_ptr! db #f)
(set-db-_errMsg_ptr! db #f)
(set-db-_callback_ptr! db #f)
(when o-_db_ptr
(handle-status (sqlite3_close (db-handle (make-db o-_db_ptr #f #f)))))
(void)))
(define (exec db sql callback)
(let ([exec-callback (lambda (arg_ptr column-count_int column-values_ptr column-names_ptr)
(callback
(cvector->list (make-cvector* column-names_ptr _string column-count_int))
(cvector->list (make-cvector* column-values_ptr _string column-count_int))))])
(handle-status
(sqlite3_exec (db-handle db)
sql
(contract
(cpointer? integer? cpointer? cpointer? . c-> . integer?)
exec-callback
'positive 'negative)
(db-_callback_ptr db)
(db-_errMsg_ptr db)))
(void)))
(define (exec/ignore db sql)
(exec db sql (lambda (c v) 0)))
(define (select db sql)
(let ([result_ptr_ptr (wrap-finalizer (malloc _string_array_ptr)
(lambda (ptr)
(when ptr
(sqlite3_free_table (ptr-ref ptr _string_array)))))]
[row-count_ptr (malloc _int_ptr)]
[column-count_ptr (malloc _int_ptr)])
(when (handle-status (sqlite3_get_table (db-handle db)
sql
result_ptr_ptr
row-count_ptr
column-count_ptr
(db-_errMsg_ptr db)))
(list->equal-sublists (ptr-ref column-count_ptr _int)
(cvector->list (make-cvector* (ptr-ref result_ptr_ptr _string_array) _string
(* (+ (ptr-ref row-count_ptr _int) 1)
(ptr-ref column-count_ptr _int))))))))
(define (prepare db sql)
(let ([stmt (wrap-finalizer (make-statement (malloc _sqlite3_stmt_ptr_ptr))
finalize)])
(when (handle-status
(sqlite3_prepare (db-handle db)
sql
(string-length sql)
(statement-_stmt_ptr stmt)
(db-_errMsg_ptr db)))
stmt)))
(define (load-params stmt . params)
(begin (reset stmt)
(for-each
(lambda (i)
(let* ([param (list-ref params i)]
[pi (+ i 1)]
[ctype (sqlite3_column_decltype (statement-handle stmt) pi)]
[itype (cond
[(integer? param) "INTEGER"]
[(number? param) "FLOAT"]
[(string? param) "TEXT"]
[(bytes? param) "BLOB"]
[else "NULL"])])
(handle-status
(match (or ctype itype)
["NULL" (sqlite3_bind_null (statement-handle stmt) pi)]
["INTEGER" (sqlite3_bind_int (statement-handle stmt) pi param)]
["FLOAT" (sqlite3_bind_double (statement-handle stmt) pi param)]
[(or "STRING" "TEXT") (sqlite3_bind_text (statement-handle stmt) pi param)]
["BLOB" (sqlite3_bind_blob (statement-handle stmt) pi param)]))))
(build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))))
(define (step stmt)
(let ([s (handle-status (sqlite3_step (statement-handle stmt)))])
(cond
[(= s SQLITE_ROW)
(map (lambda (i)
(match (sqlite3_column_decltype (statement-handle stmt) i)
["NULL" #f]
["INTEGER" (sqlite3_column_int (statement-handle stmt) i)]
["FLOAT" (sqlite3_column_double (statement-handle stmt) i)]
[(or #f "STRING" "TEXT") (sqlite3_column_text (statement-handle stmt) i)]
["BLOB" (sqlite3_column_blob (statement-handle stmt) i)]))
(build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))]
[(= s SQLITE_DONE)
#f])))
(define (run stmt . params)
(begin (apply load-params stmt params)
(handle-status (sqlite3_step (statement-handle stmt)))
(void)))
(define (reset stmt)
(handle-status (sqlite3_reset (statement-handle stmt)))
(void))
(define (finalize stmt)
(let ([o-_stmt_ptr (statement-_stmt_ptr stmt)])
(set-statement-_stmt_ptr! stmt #f)
(when o-_stmt_ptr
(handle-status (sqlite3_finalize (statement-handle (make-statement o-_stmt_ptr)))))
(void)))
(define (lock-type->string lock-type)
(case lock-type
[(none) ""]
[(deferred) "DEFERRED"]
[(immediate) "IMMEDIATE"]
[(exclusive) "EXCLUSIVE"]))
(define (transaction/lock0 db lock-type body-f)
(let ([end (lambda () (exec/ignore db "ROLLBACK TRANSACTION"))])
(exec/ignore db (format "BEGIN ~a TRANSACTION" (lock-type->string lock-type)))
(let/ec fail
(body-f fail)
(set! end (lambda () (exec/ignore db "COMMIT TRANSACTION"))))
(end)))
(define-syntax transaction/lock
(syntax-rules ()
[(_ db lock-type fail body ...)
(transaction/lock0 db 'lock-type (lambda (fail) body ...))]))
(define-syntax transaction
(syntax-rules ()
[(_ db fail body ...)
(transaction/lock db none fail body ...)]))
(define (errmsg db)
(sqlite3_errmsg (db-handle db)))
(define (changes-count db)
(sqlite3_changes (db-handle db)))
(define (total-changes-count db)
(sqlite3_total_changes (db-handle db)))
(define (step* stmt)
(let loop ([r (list)])
(let ([c (step stmt)])
(if (not c)
(reverse r)
(loop (cons c r)))))))