Commit 02caa2ae authored by ryszard.szopa's avatar ryszard.szopa
Browse files

initial commit

darcs-hash:45614809dd7eabc1db93600baa524c0adeedcb28
parents
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(in-package :asdf)
(defpackage :submarine
(:use :cl :s-sql :cl-postgres :sb-mop :iterate))
(in-package :submarine)
;;
;; Utilities
;;
;;
(defun class-name-of (object)
"The class-name of the class of OBJECT."
(class-name (class-of object)))
(defun class-non-transient-slots (class)
"Return the list of non-transient slots of a class."
(remove-if #'transient-p (class-slots class)))
(defun slots-of (object)
"List of names of the slots of OBJECT."
(mapcar #'slot-definition-name (class-slots (class-of object))))
(defun non-transient-slots-of (object)
"List of names of non-transient slots of OBJECT."
(mapcar #'slot-definition-name (remove-if #'transient-p (class-slots (class-of object)))))
(defun slot-value-or-id-if-foreign (object slot)
"SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object in the slot otherwise."
(let ((value (slot-value object slot)))
(or (and (typep value 'dao) (get-id value))
value)))
;;
;; MOP
;;
;;
(defclass db-class (standard-class)
((checked-schema-congruence :initform nil
:reader class-checked-schema-congruence-p)
(indices :initarg :indices :initform () :reader db-class-indices)))
(defmethod validate-superclass ((class db-class)
(superclass standard-class))
t)
(defclass db-class-slot-definition ()
((transient :initform nil :initarg :transient :accessor transient-p
:documentation
"Whether this slot should be treated as transient and
ignored in all database related operations.")))
(defclass db-class-direct-slot-definition
(standard-direct-slot-definition db-class-slot-definition)
())
(defclass db-class-effective-slot-definition
(db-class-slot-definition standard-effective-slot-definition)
())
;; Why we need this method is magic for me... I don't know why the
;; values of initargs are not propagated to the effective slots by
;; default... Copied form mopintro.
(defmethod compute-effective-slot-definition :around
((class db-class) slot-name direct-slot-definitions)
(let ((slotd (call-next-method)))
(setf (transient-p slotd) (every #'transient-p direct-slot-definitions))
slotd))
(defgeneric foreign-type-p (slot)
(:method ((slot db-class-slot-definition))
(typep (find-class (slot-definition-type slot)) 'db-class)))
(defmethod direct-slot-definition-class ((class db-class) &rest initargs)
(declare (ignore initargs))
;(call-next-method)
(find-class 'db-class-direct-slot-definition))
(defmethod effective-slot-definition-class ((class db-class) &rest initargs)
(declare (ignore initargs))
;(call-next-method)
(find-class 'db-class-effective-slot-definition))
(defmethod shared-initialize :after ((class db-class) slots &rest rest)
;; create the right table, or, if a table of the right name exists,
;; check whether it meets the spec. Alter it if this is not the
;; case.
(declare (ignore rest))
(finalize-inheritance class)
(unless (eq (class-name class) 'dao)
(create-table class)))
;;
;; 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."))
(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 all the changes for one table are done in a
transaction, so if at any time you choose abort the changes will be
reverted.)"
(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
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."
(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)))))
(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)
(:documentation "Return nothing if TABLE in the connected-p database meets its
specification. Otherwise, throw an appropriate error.")
(: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))))
;;
;; DAO
;;
;;
(defclass dao ()
((id :type integer :accessor get-id :initarg :id))
(:indices)
(:metaclass db-class)
(:documentation "Base class for any PostgreSQL aware classes."))
;; (defmethod shared-initialize ((instance dao) slots &rest rest)
;; ;; if id is provided, just get fill the slots from the database.
;; ;; otherwise, create a fresh one.
;; ;; If the
;; )
(defgeneric save-dao (object)
(:documentation "Save a dao: update it when it already exists, insert it otherwise.")
(:method ((dao dao))
(if (dao-exists-p dao)
(update-dao dao)
(insert-dao dao))))
(defgeneric save-all-foreign-daos (dao)
(:documentation "Saves recursively all daos in the slots of DAO")
(:method ((dao dao))
(iter (for slot in (non-transient-slots-of dao))
(let ((s-value (slot-value dao slot)))
(when (typep s-value 'dao)
(save-dao s-value))))))
(defgeneric dao-exists-p (dao)
(:documentation "Return a boolean indicating whether the given dao
exists in the database.")
(:method ((dao dao))
(and (slot-boundp dao 'id)
(postmodern::query (:select (:exists (:select 1 :from (class-name-of dao) :where (:= 'id (get-id dao)))))
:single))))
(defun set-fields (object)
(iter (for field in (slots-of object))
(appending `(',field ,(slot-value-or-id-if-foreign object field)))))
(defun id-seq-name (class)
(intern (format nil "~A-ID-SEQ" (class-name class)) :keyword))
(defgeneric insert-dao (dao)
(:documentation "Insert the given dao into the database.")
(:method ((dao dao))
(unless (slot-boundp dao 'id)
(setf (slot-value dao 'id) (postmodern::sequence-next (id-seq-name (class-of dao)))))
(postmodern::execute (sql-compile `(:insert-into ,(class-name-of dao) :set ,@(set-fields dao))))))
(defgeneric update-dao (dao)
(:documentation "Update the dao's representation in the database
with the values in the given object."))
(defmethod update-dao ((dao class))
(postmodern::execute (sql-compile
`(:update ,(class-name-of dao) :set ,@(set-fields dao)
:where (:= 'id (get-id dao))))))
(defgeneric delete-dao (dao)
(:documentation "Delete the given dao from the database."))
(defclass test1 (dao)
((foo :type integer :accessor foo :initarg :foo))
(:metaclass db-class))
(defclass test2 (dao)
((foreign-foo :type test1 :initarg :foo)
(transient-slot :type integer :transient t))
(:metaclass db-class))
; (select object type &optional test)
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(in-package :asdf)
(defpackage :submarine
(:use :cl :s-sql :cl-postgres :sb-mop :iterate))
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(defpackage :submarine-system
(:use :common-lisp :asdf)
(:export :*threads*))
(in-package :submarine-system)
(defsystem :submarine
:depends-on (:postmodern)
:components
((:file "package")
(:file "meta" :depends-on ("package"))))
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment