1#lang racket/base 2(require (for-syntax racket/base 3 setup/cross-system) 4 racket/runtime-path 5 racket/string 6 ffi/unsafe 7 ffi/unsafe/define 8 setup/cross-system) 9(require "ffi-constants.rkt") 10(provide (all-from-out "ffi-constants.rkt") 11 (protect-out (all-defined-out))) 12 13;; raco distribute should include Racket's sqlite3 if present 14(define-runtime-path sqlite-so 15 #:runtime?-id runtime? 16 (case (if runtime? (system-type) (cross-system-type)) 17 [(windows) '(so "sqlite3")] 18 [else '(so "libsqlite3" ("0" #f))])) 19 20(define sqlite-lib 21 (case (system-type) 22 [(windows) (ffi-lib sqlite-so #:fail (lambda () #f))] 23 [else (ffi-lib sqlite-so '("0" #f) #:fail (lambda () #f))])) 24 25(define-ffi-definer define-sqlite 26 sqlite-lib 27 #:default-make-fail make-not-available) 28 29; Types 30(define-cpointer-type _sqlite3_database) 31(define-cpointer-type _sqlite3_statement) 32 33;; -- Functions -- 34 35;; -- DB -- 36 37(define-sqlite sqlite3_libversion_number 38 (_fun -> _int)) 39 40(define-sqlite sqlite3_open 41 (_fun (filename ignored-flags) :: 42 ((bytes-append filename #"\0") : _bytes) 43 (db : (_ptr o _sqlite3_database)) 44 -> (result : _int) 45 -> (values db result))) 46 47(define-sqlite sqlite3_open_v2 48 (_fun (filename flags) :: 49 ((bytes-append filename #"\0") : _bytes) 50 (db : (_ptr o _sqlite3_database)) 51 (flags : _int) 52 (vfs : _pointer = #f) 53 -> (result : _int) 54 -> (values db result)) 55 #:fail (lambda () sqlite3_open)) 56 57(define-sqlite sqlite3_close 58 (_fun _sqlite3_database 59 -> _int)) 60 61(define-sqlite sqlite3_busy_timeout 62 (_fun _sqlite3_database _int -> _int)) 63 64;; -- Stmt -- 65 66(define (trim-and-copy-buffer buffer) 67 (let* ([buffer (string->bytes/utf-8 (string-trim #:left? #f buffer))] 68 [n (bytes-length buffer)] 69 [rawcopy (malloc (add1 n) 'atomic-interior)]) 70 (memcpy rawcopy buffer n) 71 (ptr-set! rawcopy _byte n 0) 72 rawcopy)) 73 74(define (c-string-length p) 75 (let loop ([i 0]) 76 (if (zero? (ptr-ref p _byte i)) 77 i 78 (loop (add1 i))))) 79 80(define (points-to-end? tail sql-buffer) 81 (ptr-equal? tail 82 (ptr-add sql-buffer (c-string-length sql-buffer)))) 83 84(define-sqlite sqlite3_prepare 85 (_fun #:blocking? #t 86 (db sql) :: 87 (db : _sqlite3_database) 88 (sql-buffer : _gcpointer = (trim-and-copy-buffer sql)) 89 ((c-string-length sql-buffer) : _int) 90 (statement : (_ptr o _sqlite3_statement/null atomic-interior)) 91 (tail : (_ptr o _pointer atomic-interior)) ;; points into sql-buffer (atomic-interior) 92 -> (result : _int) 93 -> (values result statement (and tail 94 (not (points-to-end? tail sql-buffer)))))) 95 96(define-sqlite sqlite3_prepare_v2 97 (_fun #:blocking? #t 98 (db sql) :: 99 (db : _sqlite3_database) 100 (sql-buffer : _gcpointer = (trim-and-copy-buffer sql)) 101 ((c-string-length sql-buffer) : _int) 102 ;; bad prepare statements set statement to NULL, with no error reported 103 (statement : (_ptr o _sqlite3_statement/null atomic-interior)) 104 (tail : (_ptr o _pointer atomic-interior)) ;; points into sql-buffer (atomic-interior) 105 -> (result : _int) 106 -> (values result statement (and tail 107 (not (points-to-end? tail sql-buffer))))) 108 #:fail (lambda () sqlite3_prepare)) 109 110(define-sqlite sqlite3_finalize 111 (_fun _sqlite3_statement 112 -> _int 113 ;; sqlite3_finalize returns error code of last stmt execution, 114 ;; not of finalization; so just ignore 115 -> (void))) 116 117(define-sqlite sqlite3_bind_parameter_count 118 (_fun _sqlite3_statement 119 -> _int)) 120 121(define-sqlite sqlite3_column_count 122 (_fun _sqlite3_statement 123 -> _int)) 124(define-sqlite sqlite3_column_name 125 (_fun _sqlite3_statement _int 126 -> _string)) 127(define-sqlite sqlite3_column_decltype 128 (_fun _sqlite3_statement _int 129 -> _string)) 130 131;; ---------------------------------------- 132 133(define-sqlite sqlite3_errcode 134 (_fun _sqlite3_database -> _int)) 135(define-sqlite sqlite3_errmsg 136 (_fun _sqlite3_database -> _string)) 137 138(define-sqlite sqlite3_extended_result_codes 139 (_fun _sqlite3_database _bool -> _int) 140 ;; Ok if it's unavailable: 141 #:fail (lambda () (lambda (db on?) 0))) 142 143;; ---------------------------------------- 144 145(define-sqlite sqlite3_bind_int 146 (_fun _sqlite3_statement _int _int -> _int)) 147(define-sqlite sqlite3_bind_int64 148 (_fun _sqlite3_statement _int _int64 -> _int)) 149(define-sqlite sqlite3_bind_double 150 (_fun _sqlite3_statement _int _double -> _int)) 151(define-sqlite sqlite3_bind_text 152 (_fun (stmt col the-string) :: 153 (stmt : _sqlite3_statement) 154 (col : _int) 155 (string-ptr : _string = the-string) 156 (string-len : _int = (string-utf-8-length the-string)) 157 (destructor : _intptr = SQLITE_TRANSIENT) 158 -> _int)) 159(define-sqlite sqlite3_bind_blob 160 (_fun (stmt col the-bytes) :: 161 (stmt : _sqlite3_statement) 162 (col : _int) 163 (byte-ptr : _bytes = the-bytes) 164 (byte-len : _int = (bytes-length the-bytes)) 165 (destructor : _intptr = SQLITE_TRANSIENT) 166 -> _int)) 167(define-sqlite sqlite3_bind_null 168 (_fun _sqlite3_statement _int -> _int)) 169 170(define-sqlite sqlite3_reset 171 (_fun _sqlite3_statement -> _int)) 172 173(define-sqlite sqlite3_clear_bindings 174 (_fun _sqlite3_statement -> _int) 175 #:fail (lambda () 176 ;; Old versions of SQLite don't have sqlite3_clear_bindings(). 177 ;; With this fallback, some SQLite internal parameter 178 ;; buffers won't get cleared at the end of statement 179 ;; execution; they'll get cleared when the statement is 180 ;; next executed or when the statement is closed instead. 181 (lambda (stmt) 0))) 182 183;; ---------------------------------------- 184 185(define-sqlite sqlite3_step 186 (_fun #:blocking? #t 187 _sqlite3_statement -> _int)) 188 189(define-sqlite sqlite3_column_type 190 (_fun _sqlite3_statement _int -> _int)) 191(define-sqlite sqlite3_column_int 192 (_fun _sqlite3_statement _int -> _int)) 193(define-sqlite sqlite3_column_int64 194 (_fun _sqlite3_statement _int -> _int64)) 195(define-sqlite sqlite3_column_double 196 (_fun _sqlite3_statement _int -> _double)) 197(define-sqlite sqlite3_column_text 198 (_fun _sqlite3_statement _int -> _string)) 199(define-sqlite sqlite3_column_bytes 200 (_fun _sqlite3_statement _int -> _int)) 201(define-sqlite sqlite3_column_blob 202 (_fun (stmt : _sqlite3_statement) 203 (col : _int) 204 -> (blob : _pointer) 205 -> (let* ([len (sqlite3_column_bytes stmt col)] 206 [bstr (make-bytes len)]) 207 (memcpy bstr blob len) 208 bstr))) 209 210;; ---------------------------------------- 211 212(define-sqlite sqlite3_get_autocommit 213 (_fun _sqlite3_database 214 -> _bool)) 215 216(define-sqlite sqlite3_sql 217 (_fun _sqlite3_statement 218 -> _string)) 219 220(define-sqlite sqlite3_changes 221 (_fun _sqlite3_database 222 -> _int)) 223 224(define-sqlite sqlite3_total_changes 225 (_fun _sqlite3_database 226 -> _int)) 227 228(define-sqlite sqlite3_last_insert_rowid 229 (_fun _sqlite3_database 230 -> _int64)) 231 232;; ---------------------------------------- 233 234(define SQLITE_DBCONFIG_ENABLE_LOAD_EXTENSION 1005) ;; int int* 235 236(define-sqlite sqlite3_db_config 237 (_fun _sqlite3_database _int _int (out : (_ptr o _int)) 238 -> (r : _int) -> r)) ;; FIXME: return out? 239 240(define-sqlite sqlite3_enable_load_extension 241 (_fun _sqlite3_database _int -> _int)) 242 243(define-sqlite sqlite3_load_extension 244 ;; FIXME: handle error string? 245 (_fun _sqlite3_database _path (_pointer = #f) (_pointer = #f) 246 -> _int)) 247 248;; ---------------------------------------- 249 250(define-cpointer-type _sqlite3_context) 251(define-cpointer-type _sqlite3_value) 252 253(define-sqlite sqlite3_value_type (_fun _sqlite3_value -> _int)) 254(define-sqlite sqlite3_value_double (_fun _sqlite3_value -> _double)) 255(define-sqlite sqlite3_value_int64 (_fun _sqlite3_value -> _int64)) 256(define-sqlite sqlite3_value_bytes (_fun _sqlite3_value -> _int)) 257(define-sqlite sqlite3_value_blob (_fun _sqlite3_value -> _pointer)) 258(define-sqlite sqlite3_value_text (_fun _sqlite3_value -> _pointer)) 259 260(define (pointer->bytes p len) 261 (define bstr (make-bytes len)) 262 (memcpy bstr p len) 263 bstr) 264 265(define _sqlite3_value* 266 (make-ctype _sqlite3_value 267 #f 268 (lambda (v) 269 (define type (sqlite3_value_type v)) 270 (cond [(= type SQLITE_INTEGER) (sqlite3_value_int64 v)] 271 [(= type SQLITE_FLOAT) (sqlite3_value_double v)] 272 [(= type SQLITE_TEXT) 273 (bytes->string/utf-8 (pointer->bytes (sqlite3_value_text v) 274 (sqlite3_value_bytes v)))] 275 [(= type SQLITE_BLOB) 276 (pointer->bytes (sqlite3_value_blob v) 277 (sqlite3_value_bytes v))] 278 [else (error '_sqlite3_value* "cannot convert: ~e (type = ~s)" v type)])))) 279 280(define default-async-apply (lambda (p) (p))) 281 282(define-sqlite sqlite3_create_function_v2/scalar 283 (_fun (db name arity flags proc) :: 284 (db : _sqlite3_database) 285 (name : _string/utf-8) 286 (arity : _int) 287 (_int = (bitwise-ior SQLITE_UTF8 288 (if (memq 'direct-only flags) SQLITE_DIRECTONLY 0) 289 (if (memq 'deterministic flags) SQLITE_DETERMINISTIC 0))) 290 (_pointer = #f) 291 (proc : (_fun #:async-apply default-async-apply 292 _sqlite3_context _int _pointer -> _void)) 293 (_fpointer = #f) 294 (_fpointer = #f) 295 (_fpointer = #f) 296 -> _int) 297 #:c-id sqlite3_create_function_v2) 298 299(define-sqlite sqlite3_create_function_v2/aggregate 300 (_fun (db name arity flags step final) :: 301 (db : _sqlite3_database) 302 (name : _string/utf-8) 303 (arity : _int) 304 (_int = (bitwise-ior SQLITE_UTF8 305 (if (memq 'direct-only flags) SQLITE_DIRECTONLY 0) 306 (if (memq 'deterministic flags) SQLITE_DETERMINISTIC 0))) 307 (_pointer = #f) 308 (_fpointer = #f) 309 (step : (_fun #:async-apply default-async-apply 310 _sqlite3_context _int _pointer -> _void)) 311 (final : (_fun #:async-apply default-async-apply 312 _sqlite3_context -> _void)) 313 (_fpointer = #f) 314 -> _int) 315 #:c-id sqlite3_create_function_v2) 316 317(define-sqlite sqlite3_aggregate_context 318 (_fun _sqlite3_context _int -> _pointer)) 319 320(define-sqlite sqlite3_result_null (_fun _sqlite3_context -> _void)) 321(define-sqlite sqlite3_result_int64 (_fun _sqlite3_context _int64 -> _void)) 322(define-sqlite sqlite3_result_double (_fun _sqlite3_context _double* -> _void)) 323(define-sqlite sqlite3_result_blob 324 (_fun _sqlite3_context 325 (buf : _bytes) 326 (_int = (bytes-length buf)) 327 (_intptr = SQLITE_TRANSIENT) 328 -> _void)) 329(define-sqlite sqlite3_result_text 330 (_fun _sqlite3_context 331 (buf : _string/utf-8) 332 (_int = (string-utf-8-length buf)) 333 (_intptr = SQLITE_TRANSIENT) 334 -> _void)) 335(define-sqlite sqlite3_result_error 336 (_fun _sqlite3_context (s : _string/utf-8) (_int = (string-utf-8-length s)) -> _void)) 337 338(define ((wrap-fun who proc) ctx argc argp) 339 (define args (get-args argc argp)) 340 (call/wrap who ctx (lambda () (sqlite3_result* ctx (apply proc args))))) 341 342;; sqlite3 supports an "aggregate context" for storing aggregate 343;; state, but it's hidden from Racket's GC. So instead we make a 344;; closure with Racket-visible state and use sqlite's aggregate 345;; context just to tell us whether we need to reset the Racket-level 346;; state. The connection object is responsible for preventing the 347;; closure from being prematurely collected. 348 349;; An aggbox is (box (U aggerror Any)); aggerror indicates that 350;; sqlite3_result_error has already been called to report an error. 351(define aggerror (gensym 'error)) 352 353(define ((wrap-agg-step who proc aggbox agginit) ctx argc argp) 354 (define args (get-args argc argp)) 355 (define aggctx (sqlite3_aggregate_context ctx 1)) 356 (when (zero? (ptr-ref aggctx _byte)) 357 (set-box! aggbox agginit) 358 (ptr-set! aggctx _byte 1)) 359 (unless (eq? (unbox aggbox) aggerror) 360 (set-box! aggbox (call/wrap who ctx (lambda () (apply proc (unbox aggbox) args)))))) 361 362(define ((wrap-agg-final who proc aggbox agginit) ctx) 363 (define aggctx (sqlite3_aggregate_context ctx 1)) 364 (unless (eq? (unbox aggbox) aggerror) 365 (define r (call/wrap who ctx (lambda () (proc (unbox aggbox))))) 366 (set-box! aggbox #f) 367 (unless (eq? r aggerror) 368 (sqlite3_result* ctx r)))) 369 370(define (call/wrap who ctx proc) 371 (with-handlers 372 ([(lambda (e) #t) 373 (lambda (e) 374 (define err 375 (format "[racket:~a] ~a" 376 who 377 (cond [(exn? e) (exn-message e)] 378 [else (format "caught non-exception\n caught: ~e" e)]))) 379 (sqlite3_result_error ctx err) 380 aggerror)]) 381 (call-with-continuation-barrier proc))) 382 383(define (get-args argc argp) 384 (for/list ([i (in-range argc)]) 385 (ptr-ref argp _sqlite3_value* i))) 386 387(define (sqlite3_result* ctx r) 388 (cond [(fixnum? r) (sqlite3_result_int64 ctx r)] ;; FIXME: fixnum -> int64 389 [(real? r) (sqlite3_result_double ctx r)] 390 [(string? r) (sqlite3_result_text ctx r)] 391 [(bytes? r) (sqlite3_result_blob ctx r)] 392 [else (sqlite3_result_error ctx (format "bad result: ~e" r))])) 393