db.lisp 6.98 KB
Newer Older
ryszard.szopa's avatar
ryszard.szopa committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-

(in-package :submarine)


;;
;; Database stuff
;;
;;


(defgeneric create-table (class)
  (:documentation "Create a table whose columns match the fields of
CLASS in the connected database. If CLASS is a symbol, the class it
names is used."))

(defmethod create-table ((class db-class))
  (unless (class-finalized-p class)
    (error "The class is not finalized."))
ryszard.szopa's avatar
ryszard.szopa committed
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
  (with-class-connection (class)
    (handler-case 
        (let ((class-name (class-name class)))
          (labels ((index-name (fields)
                     (format nil "~A~{_~A~}_index" (to-sql-name class-name) (mapcar #'to-sql-name fields)))
                   (type-and-reference (slot)
                     (if (foreign-type-p slot)
                         (list :type 'integer :references (list (list (slot-definition-type slot) 'id) :cascade)) ;is this cascade ok?
                         `(:type ,(slot-definition-type  slot)))))
            (postmodern:execute
             (sql-compile
              `(:create-table ,class-name
                ,(iter (for slot in (class-non-transient-slots  class))
                       (collect
                           (cons (slot-definition-name slot) (type-and-reference slot))))
                (:primary-key id))))      ;id is hardcoded as a primary key
            
            (dolist (index (mapcar (lambda (x) (if (consp x) x (list x)))(db-class-indices class)))
              (postmodern:execute (sql-compile  `(:create-index (:raw ,(index-name index))
                                                  :on ,class-name
                                                  :fields ,@index))))
            (postmodern:execute (:create-sequence (id-seq-name class)))))
      (database-error (err)
        (if (string= (database-error-code err) "42P07") ;table already exists
            (progn
              (postmodern:with-transaction ()
                ;; FIXME: This may be considered as a quick
                ;; hack. S-SQL should be changed to support ALTER
                ;; commands.
                (handler-case
                    (database-consistent-with-specification class)
                  (sql-column-does-not-exist (err)
                    (restart-case (error err)
                      
                      (fix-it () :report "Add the column to the
   table. (Note that allocate-instance the changes for one table are done in a
ryszard.szopa's avatar
ryszard.szopa committed
56
57
   transaction, so if at any time you choose abort the changes will be
   reverted.)"
ryszard.szopa's avatar
ryszard.szopa committed
58
59
60
61
62
63
                              (postmodern:execute (format nil "ALTER TABLE ~A ADD COLUMN ~A ~A;"
                                                          (table-name err) (column-name err) (column-type err))))
                      (ignore () ())))
                  (sql-column-error (err)
                    (restart-case (error err)
                      (fix-it () :report "Alter the type of the
ryszard.szopa's avatar
ryszard.szopa committed
64
65
66
   column. (Note that all the changes for one table are done in a
   transaction, so if at any time you choose abort the changes will be
   reverted."
ryszard.szopa's avatar
ryszard.szopa committed
67
68
69
70
71
72
                              (postmodern:execute (format nil "ALTER TABLE ~A ALTER COLUMN ~A TYPE ~A"
                                                          (table-name err) (column-name err) (needed-type err))))
                      (ignore () ())))))
              
              (warn "Table ~A already exists." (class-name class)))
            (error err))))))
ryszard.szopa's avatar
ryszard.szopa committed
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95

(defmethod create-table ((name symbol))
  (let ((class (find-class name)))
    (create-table class)))


(define-condition sql-error (simple-error)
  ((table :initarg :table-name :reader table-name))
  (:documentation "Base class for SQL related errors."))

(define-condition sql-column-error (sql-error)
  ((name :initarg :name :reader column-name)
   (needed-type :initarg :needed :reader needed-type)
   (actual-type :initarg :actual :reader actual-type))
  (:documentation "An error symbolizing that there is a column of the
right name in the table, but its type is wrong"))

(define-condition sql-column-does-not-exist (sql-error)
  ((name :initarg :name :reader column-name)
   (type :initarg :type :reader column-type))
  (:documentation "Condition signaling a missing column in an existing table."))

(defgeneric database-consistent-with-specification (class)
ryszard.szopa's avatar
ryszard.szopa committed
96
97
98
99
  (:documentation "Return nothing if TABLE in the connected-p database
meets its specification. Otherwise, throw an appropriate error.  There
must exist a connection to the DATABASE in order to run this
function.")
ryszard.szopa's avatar
ryszard.szopa committed
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
  (:method ((class db-class))
    (let ((class-name (class-name class)))
      (labels
          ((prepare-field (field)
             (list (sql-ize (slot-definition-name field))
                   (string-downcase (sql-type-name (or (and (foreign-type-p field) 'integer)
                                                       (slot-definition-type field))))))
           (extract-type (field)
             (read-from-string (second field)))
           (field= (field1 field2)
             (and
              (equal (car field1) (car field2))
              (string= (extract-type field1) (extract-type field2)))))
        (let ((fields 
               (mapcar #'prepare-field (class-non-transient-slots class)))
              (columns (postmodern::query (sql (:select 'column-name 'data-type
                                            :from 'information_schema.columns
                                            :where (:= 'table-name (sql-ize class-name)))))))
          ;; we test whether there are any additional columns in the table
          ;; in the database
          (iter (for column in columns)
                (unless (member column fields :test #'equal)
                  (warn "There's an additional column \"~A\" of type ~A in
table ~A. This may indicate that something is wrong." (first column) (second column) class-name)))

          ;; we test if all the specified fields have an appropriate column
          ;; counterpart in the db
          (iter (for field in fields)
                (unless (and
                         (member field columns :test #'field=))
                  (if (member (car field) (mapcar #'car columns) :test #'string=)
                      ;; column exists, but type is wrong
                      (error 'sql-column-error
                             :table-name class-name
                             :name (first field)
                             :needed (second field)
                             :actual (assoc (car field) columns :test #'string=)
                             :format-control "Column ~A exists in table ~A, but its type is wrong."
                             :format-arguments (list field class-name))
                      ;; the column does not exist
                      (error 'sql-column-does-not-exist
                             :table-name class-name
                             :name (first field)
                             :type (second field)
                             :format-control "Column ~A in table ~A does not exist."
                             :format-arguments (list (car field) class-name)))))))
      (values))))