mirror of
https://github.com/dimitri/pgloader.git
synced 2025-08-08 23:37:00 +02:00
76668c2626
The decision to use lots of different packages in pgloader has quite strong downsides at times, and the manual managment of dependencies is one of the, in particular how to avoid circular ones.
382 lines
14 KiB
Common Lisp
382 lines
14 KiB
Common Lisp
;;;
|
||
;;; PostgreSQL catalogs data structures
|
||
;;;
|
||
;;; Advanced (database) pgloader data source have to provide facilities to
|
||
;;; introspect themselves and CAST their catalogs into PostgreSQL compatible
|
||
;;; catalogs as defined here.
|
||
;;;
|
||
;;; Utility function using those definitions are found in schema.lisp in the
|
||
;;; same directory.
|
||
;;;
|
||
(in-package :pgloader.schema)
|
||
|
||
(defmacro push-to-end (item place)
|
||
`(setf ,place (nconc ,place (list ,item))))
|
||
|
||
;;;
|
||
;;; TODO: stop using anonymous data structures for database catalogs,
|
||
;;; currently list of alists of lists... the madness has found its way in
|
||
;;; lots of places tho.
|
||
;;;
|
||
|
||
;;;
|
||
;;; A database catalog is a list of schema each containing a list of tables,
|
||
;;; each being a list of columns.
|
||
;;;
|
||
;;; Column structures details depend on the specific source type and are
|
||
;;; implemented in each source separately.
|
||
;;;
|
||
(defstruct catalog name schema-list)
|
||
(defstruct schema source-name name table-list view-list)
|
||
(defstruct table source-name name schema oid comment
|
||
;; field is for SOURCE
|
||
;; column is for TARGET
|
||
field-list column-list index-list fkey-list)
|
||
|
||
;;;
|
||
;;; The generic PostgreSQL column that the CAST generic function is asked to
|
||
;;; produce, so that we know how to CREATE TABLEs in PostgreSQL whatever the
|
||
;;; source is.
|
||
;;;
|
||
(defstruct column name type-name type-mod nullable default comment transform)
|
||
|
||
;;; those are currently defined in ./schema.lisp
|
||
;; (defstruct index name primary unique columns sql conname condef)
|
||
;; (defstruct fkey
|
||
;; name columns foreign-table foreign-columns update-rule delete-rule)
|
||
|
||
;;;
|
||
;;; Main data collection API
|
||
;;;
|
||
(defgeneric add-schema (object schema-name &key))
|
||
(defgeneric add-table (object table-name &key))
|
||
(defgeneric add-view (object view-name &key))
|
||
(defgeneric add-column (object column &key))
|
||
(defgeneric add-index (object index &key))
|
||
(defgeneric add-fkey (object fkey &key))
|
||
(defgeneric add-comment (object comment &key))
|
||
|
||
(defgeneric table-list (object &key)
|
||
(:documentation "Return the list of tables found in OBJECT."))
|
||
|
||
(defgeneric view-list (object &key)
|
||
(:documentation "Return the list of views found in OBJECT."))
|
||
|
||
(defgeneric find-schema (object schema-name &key)
|
||
(:documentation
|
||
"Find a schema by SCHEMA-NAME in a catalog OBJECT and return the schema"))
|
||
|
||
(defgeneric find-table (object table-name &key)
|
||
(:documentation
|
||
"Find a table by TABLE-NAME in a schema OBJECT and return the table"))
|
||
|
||
(defgeneric find-view (object view-name &key)
|
||
(:documentation
|
||
"Find a table by TABLE-NAME in a schema OBJECT and return the table"))
|
||
|
||
(defgeneric find-fkey (object fkey-name &key key test)
|
||
(:documentation
|
||
"Find a table by FKEY-NAME in a table OBJECT and return the fkey"))
|
||
|
||
(defgeneric maybe-add-schema (object schema-name &key)
|
||
(:documentation "Add a new schema or return existing one."))
|
||
|
||
(defgeneric maybe-add-table (object table-name &key)
|
||
(:documentation "Add a new table or return existing one."))
|
||
|
||
(defgeneric maybe-add-view (object view-name &key)
|
||
(:documentation "Add a new view or return existing one."))
|
||
|
||
(defgeneric maybe-add-fkey (object fkey-name fkey &key key test)
|
||
(:documentation "Add a new fkey or return existing one."))
|
||
|
||
(defgeneric count-tables (object &key)
|
||
(:documentation "Count how many tables we have in total in OBJECT."))
|
||
|
||
(defgeneric count-views (object &key)
|
||
(:documentation "Count how many views we have in total in OBJECT."))
|
||
|
||
(defgeneric count-indexes (object &key)
|
||
(:documentation "Count how many indexes we have in total in OBJECT."))
|
||
|
||
(defgeneric count-fkeys (object &key)
|
||
(:documentation "Count how many forein keys we have in total in OBJECT."))
|
||
|
||
(defgeneric max-indexes-per-table (schema &key)
|
||
(:documentation "Count how many indexes we have maximum per table in SCHEMA."))
|
||
|
||
(defgeneric cast (object)
|
||
(:documentation
|
||
"Cast a FIELD definition from a source database into a PostgreSQL COLUMN
|
||
definition."))
|
||
|
||
|
||
;;;
|
||
;;; Implementation of the methods
|
||
;;;
|
||
(defmethod table-list ((schema schema) &key)
|
||
"Return the list of tables for SCHEMA."
|
||
(schema-table-list schema))
|
||
|
||
(defmethod table-list ((catalog catalog) &key)
|
||
"Return the list of tables for table."
|
||
(apply #'append (mapcar #'table-list (catalog-schema-list catalog))))
|
||
|
||
(defmethod view-list ((schema schema) &key)
|
||
"Return the list of views for SCHEMA."
|
||
(schema-view-list schema))
|
||
|
||
(defmethod view-list ((catalog catalog) &key)
|
||
"Return the list of views for cATALOG."
|
||
(apply #'append (mapcar #'view-list (catalog-schema-list catalog))))
|
||
|
||
(defun create-table (maybe-qualified-name)
|
||
"Create a table instance from the db-uri component, either a string or a
|
||
cons of two strings: (schema . table)."
|
||
(typecase maybe-qualified-name
|
||
(string (make-table :source-name maybe-qualified-name
|
||
:name (apply-identifier-case maybe-qualified-name)))
|
||
|
||
(cons (make-table :source-name maybe-qualified-name
|
||
:name (apply-identifier-case
|
||
(cdr maybe-qualified-name))
|
||
:schema (apply-identifier-case
|
||
(car maybe-qualified-name))))))
|
||
|
||
(defmethod add-schema ((catalog catalog) schema-name &key)
|
||
"Add SCHEMA-NAME to CATALOG and return the new schema instance."
|
||
(let ((schema (make-schema :source-name schema-name
|
||
:name (when schema-name
|
||
(apply-identifier-case schema-name)))))
|
||
(push-to-end schema (catalog-schema-list catalog))
|
||
schema))
|
||
|
||
(defmethod add-table ((schema schema) table-name &key comment)
|
||
"Add TABLE-NAME to SCHEMA and return the new table instance."
|
||
(let ((table
|
||
(make-table :source-name table-name
|
||
:name (apply-identifier-case table-name)
|
||
:schema (schema-name schema)
|
||
:comment (unless (or (null comment) (string= "" comment))
|
||
comment))))
|
||
(push-to-end table (schema-table-list schema))
|
||
table))
|
||
|
||
(defmethod add-view ((schema schema) view-name &key comment)
|
||
"Add TABLE-NAME to SCHEMA and return the new table instance."
|
||
(let ((view
|
||
(make-table :source-name view-name
|
||
:name (apply-identifier-case view-name)
|
||
:schema (schema-name schema)
|
||
:comment (unless (or (null comment) (string= "" comment))
|
||
comment))))
|
||
(push-to-end view (schema-view-list schema))
|
||
view))
|
||
|
||
(defmethod find-schema ((catalog catalog) schema-name &key)
|
||
"Find SCHEMA-NAME in CATALOG and return the SCHEMA object of this name."
|
||
(find schema-name (catalog-schema-list catalog)
|
||
:key #'schema-source-name :test 'string=))
|
||
|
||
(defmethod find-table ((schema schema) table-name &key)
|
||
"Find TABLE-NAME in SCHEMA and return the TABLE object of this name."
|
||
(find table-name (schema-table-list schema)
|
||
:key #'table-source-name :test 'string=))
|
||
|
||
(defmethod find-view ((schema schema) view-name &key)
|
||
"Find TABLE-NAME in SCHEMA and return the TABLE object of this name."
|
||
(find view-name (schema-view-list schema)
|
||
:key #'table-source-name :test 'string=))
|
||
|
||
(defmethod maybe-add-schema ((catalog catalog) schema-name &key)
|
||
"Add SCHEMA-NAME to the schema-list for CATALOG, or return the existing
|
||
schema of the same name if it already exists in the catalog schema-list"
|
||
(let ((schema (find-schema catalog schema-name)))
|
||
(or schema (add-schema catalog schema-name))))
|
||
|
||
(defmethod maybe-add-table ((schema schema) table-name &key comment)
|
||
"Add TABLE-NAME to the table-list for SCHEMA, or return the existing table
|
||
of the same name if it already exists in the schema table-list."
|
||
(let ((table (find-table schema table-name)))
|
||
(or table (add-table schema table-name :comment comment))))
|
||
|
||
(defmethod maybe-add-view ((schema schema) view-name &key comment)
|
||
"Add TABLE-NAME to the table-list for SCHEMA, or return the existing table
|
||
of the same name if it already exists in the schema table-list."
|
||
(let ((table (find-view schema view-name)))
|
||
(or table (add-view schema view-name :comment comment))))
|
||
|
||
(defmethod add-field ((table table) field &key)
|
||
"Add COLUMN to TABLE and return the TABLE."
|
||
(push-to-end field (table-field-list table))
|
||
table)
|
||
|
||
(defmethod add-column ((table table) column &key)
|
||
"Add COLUMN to TABLE and return the TABLE."
|
||
(push-to-end column (table-column-list table))
|
||
table)
|
||
|
||
(defmethod cast ((table table))
|
||
"Cast all fields in table into columns."
|
||
(setf (table-column-list table) (mapcar #'cast (table-field-list table))))
|
||
|
||
(defmethod cast ((schema schema))
|
||
"Cast all fields of all tables in SCHEMA into columns."
|
||
(loop :for table :in (schema-table-list schema)
|
||
:do (cast table))
|
||
|
||
(loop :for view :in (schema-view-list schema)
|
||
:do (cast view)))
|
||
|
||
(defmethod cast ((catalog catalog))
|
||
"Cast all fields of all tables in all schemas in CATALOG into columns."
|
||
(loop :for schema :in (catalog-schema-list catalog)
|
||
:do (cast schema)))
|
||
|
||
(defmethod add-index ((table table) index &key)
|
||
"Add INDEX to TABLE and return the TABLE."
|
||
(push-to-end index (table-index-list table)))
|
||
|
||
(defmethod add-fkey ((table table) fkey &key)
|
||
"Add FKEY to TABLE and return the TABLE."
|
||
(push-to-end fkey (table-fkey-list table)))
|
||
|
||
;;;
|
||
;;; There's no simple equivalent to array_agg() in MS SQL, so the fkey query
|
||
;;; returns a row per fkey column rather than per fkey. Hence this extra
|
||
;;; API:
|
||
;;;
|
||
(defmethod find-fkey ((table table) fkey-name &key key (test #'string=))
|
||
"Find FKEY-NAME in TABLE and return the FKEY object of this name."
|
||
(find fkey-name (table-fkey-list table) :key key :test test))
|
||
|
||
(defmethod maybe-add-fkey ((table table) fkey-name fkey &key key test)
|
||
"Add the foreign key FKEY to the table-fkey-list of TABLE unless it
|
||
already exists, and return the FKEY object."
|
||
(let ((fkey (find-fkey table fkey-name :key key :test test)))
|
||
(or fkey (add-fkey table fkey))))
|
||
|
||
|
||
;;;
|
||
;;; To report stats to the user, count how many objects we are taking care
|
||
;;; of.
|
||
;;;
|
||
(defmethod count-tables ((schema schema) &key)
|
||
"Count tables in given SCHEMA."
|
||
(length (schema-table-list schema)))
|
||
|
||
(defmethod count-tables ((catalog catalog) &key)
|
||
(reduce #'+ (mapcar #'count-tables (catalog-schema-list catalog))))
|
||
|
||
(defmethod count-views ((schema schema) &key)
|
||
"Count tables in given SCHEMA."
|
||
(length (schema-view-list schema)))
|
||
|
||
(defmethod count-views ((catalog catalog) &key)
|
||
(reduce #'+ (mapcar #'count-views (catalog-schema-list catalog))))
|
||
|
||
(defmethod count-indexes ((table table) &key)
|
||
"Count indexes in given TABLE."
|
||
(length (table-index-list table)))
|
||
|
||
(defmethod count-indexes ((schema schema) &key)
|
||
"Count indexes in given SCHEMA."
|
||
(reduce #'+ (mapcar #'count-indexes (schema-table-list schema))))
|
||
|
||
(defmethod count-indexes ((catalog catalog) &key)
|
||
"Count indexes in given SCHEMA."
|
||
(reduce #'+ (mapcar #'count-indexes (catalog-schema-list catalog))))
|
||
|
||
(defmethod count-fkeys ((table table) &key)
|
||
"Count fkeys in given TABLE."
|
||
(length (table-fkey-list table)))
|
||
|
||
(defmethod count-fkeys ((schema schema) &key)
|
||
"Count fkeys in given SCHEMA."
|
||
(reduce #'+ (mapcar #'count-fkeys (schema-table-list schema))))
|
||
|
||
(defmethod count-fkeys ((catalog catalog) &key)
|
||
"Count fkeys in given SCHEMA."
|
||
(reduce #'+ (mapcar #'count-fkeys (catalog-schema-list catalog))))
|
||
|
||
(defmethod max-indexes-per-table ((schema schema) &key)
|
||
"Count how many indexes maximum per table are listed in SCHEMA."
|
||
(reduce #'max (mapcar #'length
|
||
(mapcar #'table-index-list
|
||
(schema-table-list schema)))))
|
||
"Count how many indexes maximum per table are listed in SCHEMA."
|
||
|
||
(defmethod max-indexes-per-table ((catalog catalog) &key)
|
||
"Count how many indexes maximum per table are listed in SCHEMA."
|
||
(reduce #'max (mapcar #'max-indexes-per-table (catalog-schema-list catalog))))
|
||
|
||
;;;
|
||
;;; Not a generic/method because only used for the table object, and we want
|
||
;;; to use the usual structure print-method in stack traces.
|
||
;;;
|
||
(defgeneric format-table-name (object)
|
||
(:documentation "Format the OBJECT name for PostgreSQL."))
|
||
|
||
(defmethod format-table-name ((table table))
|
||
"TABLE should be a table instance, but for hysterical raisins might be a
|
||
CONS of a schema name and a table name, or just the table name as a
|
||
string."
|
||
(format nil "~@[~a.~]~a" (table-schema table) (table-name table)))
|
||
|
||
|
||
;;;
|
||
;;; Still lacking round tuits here, so for the moment the representation of
|
||
;;; a table name is either a string or a cons built from schema and
|
||
;;; table-name.
|
||
;;;
|
||
(defmacro with-schema ((var table-name) &body body)
|
||
"When table-name is a CONS, SET search_path TO its CAR and return its CDR,
|
||
otherwise just return the TABLE-NAME. A PostgreSQL connection must be
|
||
established when calling this function."
|
||
`(let ((,var
|
||
(typecase ,table-name
|
||
(table (if (table-schema ,table-name)
|
||
(let ((sql (format nil "SET search_path TO ~a;"
|
||
(table-schema ,table-name))))
|
||
(pgloader.pgsql:pgsql-execute sql)
|
||
(table-name ,table-name))
|
||
(table-name ,table-name)))
|
||
(cons (let ((sql (format nil "SET search_path TO ~a;"
|
||
(car ,table-name))))
|
||
(pgloader.pgsql:pgsql-execute sql)
|
||
(cdr ,table-name)))
|
||
(string ,table-name))))
|
||
,@body))
|
||
|
||
|
||
|
||
;;;
|
||
;;; PostgreSQL column and type output
|
||
;;;
|
||
(defun format-default-value (default &optional transform)
|
||
"Returns suitably quoted default value for CREATE TABLE command."
|
||
(cond
|
||
((null default) "NULL")
|
||
((and (stringp default) (string= "NULL" default)) default)
|
||
((and (stringp default) (string= "CURRENT_TIMESTAMP" default)) default)
|
||
((and (stringp default) (string= "CURRENT TIMESTAMP" default))
|
||
"CURRENT_TIMESTAMP")
|
||
((and (stringp default) (string= "newsequentialid()" default))
|
||
"uuid_generate_v1()")
|
||
(t
|
||
;; apply the transformation function to the default value
|
||
(if transform (format-default-value (funcall transform default))
|
||
(format nil "'~a'" default)))))
|
||
|
||
(defmethod format-column ((column column))
|
||
"Format the PostgreSQL data type."
|
||
(with-slots (name type-name type-mod nullable default transform) column
|
||
(format nil
|
||
"~a ~22t ~a~:[~*~;~a~]~:[ not null~;~]~:[~; default ~a~]"
|
||
name
|
||
type-name
|
||
type-mod
|
||
type-mod
|
||
nullable
|
||
default default)))
|