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