src/backend/clsql.lisp

   1 (in-package :meta-model)
   2
   3 (eval-when (:compile-toplevel :load-toplevel :execute)
   4  (use-package :clsql))
   5
   6 (export 'def-meta-model-from-table)
   7 (export 'def-meta-models)
   8 (export 'def-view-class/meta)
   9 (export 'list-base-classes)
  10
  11
  12
  13 (defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only-p nil) (database *default-database*))
  14   (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
  15            (get-def (slot) (caar (query
  16                                   (format nil                                                             "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
  17            (get-default-value (slot)
  18              (let ((def (get-def slot)))
  19                (if def
  20                    (caar (query (format nil "SELECT ~A" def)))))))
  21
  22     (dolist (slot (list-slots view))
  23       (when (and (primary-key-p view slot)
  24                  (or (not (slot-boundp view slot))
  25                      (equal (slot-value view slot) nil)))
  26         (setf (slot-value view slot) (get-default-value slot))
  27         (when (and (primary-key-p view slot)
  28                    (not (slot-value view slot))
  29                    (not  fill-gaps-only-p))
  30           (error "No default value for primary key : ~A" slot))))
  31     (when fill-gaps-only-p
  32       (update-objects-joins (list view))
  33       (return-from sync-instance))
  34     (update-records-from-instance view :database database)
  35     (update-instance-from-records view :database database)
  36     (update-objects-joins (list view))))
  37
  38
  39
  40 (defparameter *clsql-base-classes* (list) )
  41
  42 (defmethod list-base-classes ((type (eql :clsql)))
  43   *clsql-base-classes*)
  44
  45 (defmethod def-base-type-class-expander ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
  46   `(def-view-class ,name ()
  47                    ,(meta-model.metadata model)))
  48
  49 (defmethod def-base-type-class-expander :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
  50   (unless (member name *clsql-base-classes*)
  51     (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
  52
  53 (defparameter *sql-type-map* '((:INT4 integer) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
  54
  55 (defun gen-type (table column)
  56   (cadr (assoc
  57          (cadr (assoc
  58                 column
  59                 (list-attribute-types table)
  60                 :test #'equalp ))
  61          *sql-type-map*)))
  62
  63 (defun sql->sym (name &optional (package nil))
  64   (flet ((xform (x)
  65            (string-upcase (substitute #\- #\_ x))))
  66     (if package
  67         (intern (xform (string name)) package)
  68         (intern (xform (string name))))))
  69
  70 (defun table->slots (table pkey &optional (accesor-prefix table) (prefix-all-p nil))
  71   (mapcar
  72    #'(lambda (col)
  73        (flet ((accessor-name (col)
  74                 (let ((name (sql->sym col)))
  75                   (if (or prefix-all-p
  76                           (and (fboundp name)
  77                                (eq (type-of (symbol-function name)) 'function)))
  78                       (sql->sym (concatenate 'string
  79                                              (string accesor-prefix) "-" col))
  80                       name))))
  81
  82          `(,(sql->sym col)
  83             :accessor ,(accessor-name col)
  84             :initarg ,(sql->sym col "KEYWORD")
  85             :type ,(gen-type table col)
  86             :db-kind
  87             ,(if (equalp col pkey)
  88                  `:key
  89                  `:base))))
  90    (list-attributes table)))
  91
  92 (defun view-class-definition-list ()
  93   (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
  94                 (list-tables)))
  95
  96 (defmacro def-meta-models ()
  97   (let ((defs (view-class-definition-list)))
  98     `(progn ,@defs)))
  99
 100
 101 (defun get-pkeys ()
 102   (let ((keys '()))
 103     (dolist (row (get-pkeys-query))
 104       (setf keys (acons (car row) (list (cadr row)) keys)))
 105     keys))
 106
 107 (defun get-pkeys-query()
 108   (query
 109                     "SELECT  pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
 110                  , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
 111                  , CASE
 112                    WHEN contype = 'p' THEN
 113                          'PRIMARY KEY'
 114                    ELSE
 115                          'UNIQUE'
 116                    END as constraint_type
 117           FROM
 118                 pg_class, pg_attribute,
 119           pg_catalog.pg_constraint AS c
 120           JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
 121          WHERE contype IN ('p', 'u')
 122            AND deptype = 'i'
 123            and conrelid = pg_class.oid
 124             and pg_attribute.attnum = ANY (c.conkey)
 125              and pg_attribute.attrelid = pg_class.oid"))
 126
 127 ;;here is how this works
 128 ;;from the postgres system tables we get
 129 ;;list of all the has-a relationships.
 130 ;;the inverse of a has-a is an implicit has-many
 131 ;;and any relation having more than one foreign key
 132 ;;is a join table hosting a many-to-many relationship
 133
 134 (defun get-fkey-explosions ()
 135   (let ((key-table (get-fkey-explosions-query))
 136         (keys '()))
 137     (dolist (row key-table)
 138       (setf row (mapcar #'(lambda (x)
 139                             (sql->sym x))
 140                         row))
 141       ;;this one does the has-a
 142       (setf keys (acons (car row) (gen-has-a row)
 143                         keys))
 144       ;;the inverse of the previous represents a has-many.
 145       (setf keys
 146             (acons (fourth row) (gen-has-many row)
 147                    keys))
 148
 149       ;;many-to-many
 150       (dolist (mrow
 151                 (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
 152                                              (equal (last row) (last r))))
 153                            (mapcar #'(lambda (x)
 154                                        (mapcar #'sql->sym x))
 155                                    key-table)))
 156         (setf keys (acons (fourth row)
 157                           (gen-many-to-many mrow (third row) (second row))
 158                           keys))))
 159     keys ))
 160
 161
 162 (defun get-fkey-explosions-query ()
 163 ;;these query's are a mess, i don't even know how they work :)
 164   (query "
 165 SELECT pg_class.relname,
 166        pg_attribute.attname,
 167        fa.attname  ,
 168        f.relname
 169 FROM   pg_class,
 170        pg_constraint,
 171        pg_attribute,
 172        pg_class as f  ,
 173        pg_attribute as fa
 174 WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
 175 AND pg_class.oid = pg_constraint.conrelid
 176 AND pg_attribute.attnum = ANY (pg_constraint.conkey)
 177 AND pg_attribute.attrelid = pg_class.oid
 178 AND f.oid = confrelid
 179 AND fa.attrelid = f.oid
 180 AND fa.attnum = ANY (pg_constraint.confkey)"))
 181
 182
 183 ;; i chose keyword args here so as to make the code more understandable.
 184 ;; it didn't really work.
 185 (defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
 186   `(,(intern name)
 187     :accessor ,(intern name)
 188     :db-kind :join
 189     :db-info (:join-class ,join-class
 190               :home-key ,home-key
 191               :foreign-key ,foreign-key
 192               :set ,set)))
 193
 194 (defun gen-has-a (row)
 195   (gen-join-slot
 196    :name
 197    (format nil "~A->~A" (string (car row))(string (second row)))
 198    :home-key (second row)
 199    :foreign-key (third row)
 200    :join-class (fourth row)))
 201
 202 (defun gen-has-many (row)
 203   (gen-join-slot
 204    :name
 205    (format nil "~A->~A" (string (car row))(string (second row)))
 206    :home-key (third row)
 207    :foreign-key (second row)
 208    :join-class (car row)
 209    :set t))
 210
 211 (defun gen-many-to-many (row home-key foreign-key)
 212  (let ((name (sql->sym (string-upcase (format nil "~A->~A" (string (car row)) (string (second row)))))))
 213    (setf row (mapcar #'sql->sym row))
 214    `(,name
 215      :accessor ,name
 216      :db-kind :join
 217      :db-info (:join-class ,(car row)
 218                :home-key ,home-key
 219                :foreign-key ,foreign-key
 220                :target-slot ,name
 221                :set t))))
 222
 223 (defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
 224   (declare (ignorable database))
 225   (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
 226            (get-def (slot) (caar (query
 227                                   (format nil                                                             "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
 228            (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
 229
 230     (dolist (slot (list-slots view))
 231       (when (and (primary-key-p view slot)
 232                  (or (not (slot-boundp view slot))
 233                      (equal (slot-value view slot) nil)))
 234         (setf (slot-value view slot) (get-default-value slot))))))
 235
 236 ;;;;
 237
 238 (defmacro def-view-class/meta (name supers slots &rest args)
 239   "Create and instrument CLSQL view-class NAME and
 240 appropriate meta-model class its default name is %NAME-meta-model."
 241
 242   (let ((model-name (cond ((eq :model-name (car args))
 243                            (pop args)   ; remove keyword
 244                            (pop args))  ; get value
 245                           (t (intern (format nil "%~S-META-MODEL" name))))))
 246
 247     `(progn
 248       (let* ((m (def-meta-model ,model-name ,supers ,slots ,args))
 249              (i (make-instance m)))
 250         (setf (meta-model.base-type i) :clsql)
 251         (prog1 (eval (def-base-class-expander i ',name ',args))
 252           (defmethod meta-model.metadata ((self ,name))
 253             (meta-model.metadata i)))))))
 254
 255 (defmacro def-view-class/table (table &optional (name (sql->sym table)) model-name)
 256   "takes the name of a table as a string and
 257 creates a clsql view-class"
 258   (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp)))
 259          (table-slots (table->slots table pkey name))
 260          (join-slots
 261           (let ((slots nil))
 262             (dolist (exp (get-fkey-explosions))
 263               (when (equalp (car exp) (sql->sym table))
 264                 (setf slots (cons (cdr exp) slots))))
 265             slots)))
 266     `(eval-when (:compile-toplevel :load-toplevel :execute)
 267       (def-view-class/meta ,name
 268           ()
 269         ,(append table-slots join-slots)
 270         ,@(when model-name (list :model-name model-name))))))
 271
 272
 273 (defmethod prepare-slot-name-for-select ((i standard-db-object) slot-name)
 274   (clsql:sql-expression :attribute slot-name))
 275
 276 (def-compare-expr standard-db-object expr-= sql-=)
 277 (def-compare-expr standard-db-object expr-< sql-<)
 278 (def-compare-expr standard-db-object expr-> sql->)
 279 (def-compare-expr standard-db-object expr-ends-with sql-like :value-format "%~A")
 280 (def-compare-expr standard-db-object expr-starts-with sql-like :value-format "~A%")
 281 (def-compare-expr standard-db-object expr-contains sql-like :value-format "%~A%")
 282
 283 (def-logical-expr standard-db-object expr-and #'sql-and)
 284
 285 (def-logical-expr standard-db-object expr-or #'sql-or)
 286
 287 (def-logical-expr standard-db-object expr-not #'sql-not)
 288
 289 (defmethod select-instances ((instance standard-db-object) &rest query)
 290   (unless (keywordp (car query))
 291     (setf query (cons :where query)))
 292   (apply #'select (class-name (class-of instance)) :flatp t query))