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 (defparameter *clsql-base-classes* (list) )
  12
  13 (defmethod list-base-classes ((type (eql :clsql)))
  14   *clsql-base-classes*)
  15
  16 (defmethod def-base-class-expander ((model meta-model-class) (base-type (eql :clsql)) (name t) (args t))
  17   `(def-view-class ,name ()
  18                    ,(meta-model.metadata model)))
  19
  20 (defmethod def-base-class-expander :after ((model meta-model-class) (base-type (eql :clsql)) (name t) (args t))
  21   (unless (member name *clsql-base-classes*)
  22     (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
  23
  24 (defparameter *sql-type-map* '((:INT4 integer) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
  25
  26 (defun gen-type (table column)
  27   (cadr (assoc
  28          (cadr (assoc
  29                 column
  30                 (list-attribute-types table)
  31                 :test #'equalp ))
  32          *sql-type-map*)))
  33
  34 (defun sql->sym (name &optional (package nil))
  35   (flet ((xform (x)
  36            (string-upcase (substitute #\- #\_ x))))
  37     (if package
  38         (intern (xform (string name)) package)
  39         (intern (xform (string name))))))
  40
  41 (defun table->slots (table pkey)
  42   (mapcar
  43    #'(lambda (col)
  44        `(,(sql->sym col)
  45          :accessor ,(sql->sym col)
  46          :initarg ,(sql->sym col "KEYWORD")
  47          :type ,(gen-type table col)
  48          :db-kind
  49          ,(if (equalp col pkey)
  50               `:key
  51               `:base)))
  52    (list-attributes table)))
  53
  54 (defun view-class-definition-list ()
  55   (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
  56                 (list-tables)))
  57
  58 (defmacro def-meta-models ()
  59   (let ((defs (view-class-definition-list)))
  60     `(progn ,@defs)))
  61
  62
  63
  64
  65
  66 (defun get-pkeys ()
  67   (let ((keys '()))
  68     (dolist (row (get-pkeys-query))
  69       (setf keys (acons (car row) (list (cadr row)) keys)))
  70     keys))
  71
  72 (defun get-pkeys-query()
  73   (query
  74                     "SELECT  pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
  75                  , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
  76                  , CASE
  77                    WHEN contype = 'p' THEN
  78                          'PRIMARY KEY'
  79                    ELSE
  80                          'UNIQUE'
  81                    END as constraint_type
  82           FROM
  83                 pg_class, pg_attribute,
  84           pg_catalog.pg_constraint AS c
  85           JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
  86          WHERE contype IN ('p', 'u')
  87            AND deptype = 'i'
  88            and conrelid = pg_class.oid
  89             and pg_attribute.attnum = ANY (c.conkey)
  90              and pg_attribute.attrelid = pg_class.oid"))
  91
  92 ;;here is how this works
  93 ;;from the postgres system tables we get
  94 ;;list of all the has-a relationships.
  95 ;;the inverse of a has-a is an implicit has-many
  96 ;;and any relation having more than one foreign key
  97 ;;is a join table hosting a many-to-many relationship
  98
  99 (defun get-fkey-explosions ()
 100   (let ((key-table (get-fkey-explosions-query))
 101         (keys '()))
 102     (dolist (row key-table)
 103       (setf row (mapcar #'(lambda (x)
 104                             (sql->sym x))
 105                         row))
 106       ;;this one does the has-a
 107       (setf keys (acons (car row) (gen-has-a row)
 108                         keys))
 109       ;;the inverse of the previous represents a has-many.
 110       (setf keys
 111             (acons (fourth row) (gen-has-many row)
 112                    keys))
 113
 114       ;;many-to-many
 115       (dolist (mrow
 116                 (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
 117                                              (equal (last row) (last r))))
 118                            (mapcar #'(lambda (x)
 119                                        (mapcar #'sql->sym x))
 120                                    key-table)))
 121         (setf keys (acons (fourth row)
 122                           (gen-many-to-many mrow (third row) (second row))
 123                           keys))))
 124     keys ))
 125
 126
 127 (defun get-fkey-explosions-query ()
 128 ;;these query's are a mess, i don't even know how they work :)
 129   (query "
 130 SELECT pg_class.relname,
 131        pg_attribute.attname,
 132        fa.attname  ,
 133        f.relname
 134 FROM   pg_class,
 135        pg_constraint,
 136        pg_attribute,
 137        pg_class as f  ,
 138        pg_attribute as fa
 139 WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
 140 AND pg_class.oid = pg_constraint.conrelid
 141 AND pg_attribute.attnum = ANY (pg_constraint.conkey)
 142 AND pg_attribute.attrelid = pg_class.oid
 143 AND f.oid = confrelid
 144 AND fa.attrelid = f.oid
 145 AND fa.attnum = ANY (pg_constraint.confkey)"))
 146
 147
 148 ;; i chose keyword args here so as to make the code more understandable.
 149 ;; it didn't really work.
 150 (defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
 151   `(,(intern name)
 152     :accessor ,(intern name)
 153     :db-kind :join
 154     :db-info (:join-class ,join-class
 155               :home-key ,home-key
 156               :foreign-key ,foreign-key
 157               :set ,set)))
 158
 159 (defun gen-has-a (row)
 160   (gen-join-slot
 161    :name
 162    (format nil "~A->~A" (string (car row))(string (second row)))
 163    :home-key (second row)
 164    :foreign-key (third row)
 165    :join-class (fourth row)))
 166
 167 (defun gen-has-many (row)
 168   (gen-join-slot
 169    :name
 170    (format nil "~A->~A" (string (car row))(string (second row)))
 171    :home-key (third row)
 172    :foreign-key (second row)
 173    :join-class (car row)
 174    :set t))
 175
 176 (defun gen-many-to-many (row home-key foreign-key)
 177  (let ((name (sql->sym (string-upcase (format nil "~A->~A" (string (car row)) (string (second row)))))))
 178    (setf row (mapcar #'sql->sym row))
 179    `(,name
 180      :accessor ,name
 181      :db-kind :join
 182      :db-info (:join-class ,(car row)
 183                :home-key ,home-key
 184                :foreign-key ,foreign-key
 185                :target-slot ,name
 186                :set t))))
 187
 188 (defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
 189   (declare (ignorable database))
 190   (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
 191            (get-def (slot) (caar (query
 192                                   (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)))))
 193            (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
 194
 195     (dolist (slot (list-slots view))
 196       (when (and (primary-key-p view slot)
 197                  (or (not (slot-boundp view slot))
 198                      (equal (slot-value view slot) nil)))
 199         (setf (slot-value view slot) (get-default-value slot))))))
 200
 201 ;;;;
 202
 203 (defmacro def-view-class/meta (name supers slots &rest args)
 204     `(progn
 205         (let* ((m (def-meta-model model-name ,supers ,slots ,args))
 206                (i (make-instance m)))
 207           (prog1 (eval (def-base-class-expander i :clsql ',name ',args))
 208         (defmethod meta-model.metadata ((self ,name))
 209           (meta-model.metadata i))))))
 210
 211
 212 (defmacro def-view-class/table (table &optional name)
 213   "takes the name of a table as a string and
 214 creates a clsql view-class"
 215   (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp)))
 216          (table-slots (table->slots table pkey))
 217          (join-slots
 218           (let ((slots nil))
 219             (dolist (exp (get-fkey-explosions))
 220               (when (equalp (car exp) (sql->sym table))
 221                 (setf slots (cons (cdr exp) slots))))
 222             slots)))
 223     `(def-view-class/meta ,(if name name (sql->sym table))
 224       ()
 225       ,(append table-slots join-slots))))
 226
 227
 228