aboutsummaryrefslogtreecommitdiff
path: root/dump/sql.scm
blob: 74f3139bd6b87ebcb76fce47336ae6cecdfdc85f (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
;;; Database helpers
;;;
;;; Most of these functions should have been a part of
;;; guile-dbi. Never too late to contribute upstream!

(define-module (dump 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
            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)
                                                     ((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))