blob: a8962c8029b4b4e3805b680c45c1a19f92968e7c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
;;; Database helpers
;;;
;;; Most of these functions should have been a part of
;;; guile-dbi. Never too late to contribute upstream!
(define-module (transform sql)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (dbi dbi)
#:export (select-query
call-with-database
call-with-target-database
sql-exec
sql-fold
sql-map
sql-for-each
sql-find))
;; A half-baked macro to make SQL SELECT queries a bit more
;; S-expression friendly
(define-syntax select-query
(lambda (x)
(syntax-case x ()
((_ fields tables raw-forms ...)
#`(string-append "SELECT "
#,(syntax-case #'fields (distinct)
((distinct _ ...)
"DISTINCT ")
(_ ""))
#,(string-join (filter-map (match-lambda
('distinct #f)
(((query alias))
(format #f "~a AS ~a" query alias))
((table column)
(format #f "~a.~a" table column))
((table column alias)
(format #f "~a.~a AS ~a" table column alias))
(field-spec
(error "Invalid field specification" field-spec)))
(syntax->datum #'fields))
", ")
" FROM "
#,(string-join (map (match-lambda
((join table condition)
(format #f "~a ~a ~a"
(case join
((join) "JOIN")
((left-join) "LEFT JOIN")
((inner-join) "INNER JOIN")
(else (error "Invalid join operator" join)))
table condition))
((? symbol? table)
(symbol->string table))
(table-spec
(error "Invalid table specification" table-spec)))
(syntax->datum #'tables))
" ")
#,(syntax-case #'(raw-forms ...) ()
(() "")
(_ " "))
raw-forms ...))
(_ (error "Invalid SQL select query" (syntax->datum x))))))
(define (call-with-database backend connection-string proc)
(let ((db #f))
(dynamic-wind (lambda ()
(set! db (dbi-open backend connection-string)))
(cut proc db)
(cut dbi-close db))))
(define (database-check-status db)
(match (dbi-get_status db)
((code . str)
(unless (zero? code)
(error str)))))
(define (sql-exec db statement)
(dbi-query db statement)
(database-check-status db))
(define (sql-fold proc init db statement)
(sql-exec db statement)
(let loop ((result init))
(let ((row (dbi-get_row db)))
(if row
(loop (proc row result))
result))))
(define (sql-map proc db statement)
(sql-fold (lambda (row result)
(cons (proc row) result))
(list) db statement))
(define (sql-for-each proc db statement)
(sql-fold (lambda (row _)
(proc row))
#f db statement))
(define (sql-find db statement)
(sql-exec db statement)
(dbi-get_row db))
(define (call-with-target-database connection-settings proc)
(call-with-database "mysql" (string-join
(list (assq-ref connection-settings 'sql-username)
(assq-ref connection-settings 'sql-password)
(assq-ref connection-settings 'sql-database)
"tcp"
(assq-ref connection-settings 'sql-host)
(number->string
(assq-ref connection-settings 'sql-port)))
":")
proc))
|
