;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: src/dao.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :claw-demo-backend) (defun slot-column-name (symbol-class slot-name) (sql-slot-value symbol-class (intern (if (stringp slot-name) (string-upcase slot-name) (symbol-name slot-name)) :claw-demo-backend))) (defgeneric check-instance-version (base-table &key database) (:documentation "Versioning support for base-table instances")) (defgeneric sign-table-update (base-table) (:documentation "Set insert/modify user and date to the given record")) (defgeneric local-time-to-timestamp (local-time)) (defmethod local-time-to-timestamp ((local-time local-time)) (with-decoded-local-time (:sec sec :minute minute :hour hour :day day :month month :year year) local-time (make-time :year year :month month :day day :hour hour :minute minute :second sec))) (defmethod sign-table-update ((base-table base-table)) (let ((user-name (or (and *claw-server* (current-principal) (principal-name (current-principal))) "anonymous")) (now-timestamp (local-time-to-timestamp (now)))) (when (null (table-insert-user base-table)) (setf (table-insert-user base-table) user-name (table-insert-date base-table) now-timestamp)) (setf (table-update-user base-table) user-name (table-update-date base-table) now-timestamp))) (defun sql-expression-upper (&key string table alias attribute type) (sql-operation 'upper (sql-expression :string string :table table :alias alias :attribute attribute :type type))) (defmethod check-instance-version ((instance base-table) &key (database *claw-demo-db*)) (let* ((instance-version (table-version instance)) (table (view-table (class-of instance))) (instance-id (table-id instance)) (version (first (select (slot-column-name (type-of instance) 'version) :from table :where (sql-operation '= (slot-column-name (type-of instance) 'id) instance-id) :flatp t :refresh t :database database)))) (when (and version (not (= version instance-version))) (error "Wrong version number (given ~d , expected ~d) for record id ~d on table ~a" instance-version version instance-id table)))) (defmethod delete-instance-records :before ((instance base-table)) (check-instance-version instance :database *claw-demo-db*)) (defmethod update-records-from-instance :before ((instance base-table) &key (database *claw-demo-db*)) (check-instance-version instance :database database) (sign-table-update instance) (if (= (table-id instance) 0) (let ((sequence-name (format nil "~a_id_seq" (string-downcase (symbol-name (view-table (class-of instance))))))) (setf (table-id instance) (sequence-next sequence-name :database database))) (incf (table-version instance)))) (defmethod update-record-from-slot :before ((instance base-table) slot &key (database *claw-demo-db*)) (declare (ignore slot database)) (check-instance-version instance)) (defmethod update-records-from-instance :before ((instance user) &key (database *claw-demo-db*)) (let ((id (table-id instance)) (role-list (user-roles instance)) (role-id-column-name (slot-column-name 'user-role 'role-id)) (table-name (symbol-name (view-table (find-class 'user-role))))) (when (and id role-list) (delete-records :from table-name :where (sql-operation 'and (sql-operation '= (slot-column-name 'user-role 'user-id) id) (sql-operation 'not (sql-operation 'in role-id-column-name (loop for user-role in role-list collect (table-id user-role))))) :database database)))) (defmethod update-records-from-instance :after ((instance user) &key (database *claw-demo-db*)) (with-transaction (:database database) (let ((id (table-id instance)) (role-list (user-roles instance))) (delete-records :from (symbol-name (view-table (find-class 'user-role))) :where (sql-operation '= (slot-column-name 'user-role 'user-id) id) :database database) (dolist (role role-list) (update-records-from-instance (make-instance 'user-role :user-id id :role-id (table-id role)) :database database))))) (defmethod update-records-from-instance :before ((instance customer) &key (database *claw-demo-db*)) (let ((id (table-id instance)) (address-list (customer-addresses instance)) (address-id-column-name (slot-column-name 'customer-address 'id)) (table-name (symbol-name (view-table (find-class 'customer-address))))) (when (and id address-list) (delete-records :from table-name :where (sql-operation 'and (sql-operation '= (slot-column-name 'customer-address 'customer-id) id) (sql-operation 'not (sql-operation 'in address-id-column-name (loop for customer-address in address-list collect (table-id customer-address))))) :database database) (setf (customer-addresses instance) address-list)))) (defmethod update-records-from-instance :after ((instance customer) &key (database *claw-demo-db*)) (let ((id (table-id instance))) (dolist (address (customer-addresses instance)) (setf (customer-address-customer-id address) id) (update-records-from-instance address :database database)))) (defmethod delete-instance-records :before ((instance user)) (let ((id (table-id instance))) (when id (delete-records :from (symbol-name (view-table (find-class 'user-role))) :where (sql-operation '= (slot-column-name 'user-role 'role-id) id) :database *claw-demo-db*)))) (defmethod delete-instance-records :before ((instance customer)) (let ((id (table-id instance))) (when id (delete-records :from (symbol-name (view-table (find-class 'customer-address))) :where (sql-operation '= (slot-column-name 'customer-address 'customer-id) id))))) (defmethod delete-instance-records :before ((instance role)) (let ((id (table-id instance))) (when id (delete-records :from (symbol-name (view-table (find-class 'user-role))) :where (sql-operation '= (slot-column-name 'user-role 'role-id) id))))) (defun like-operation (name value &key (insensitive t) (wild-char #\*)) (setf value (format nil "~{~A~^\\\\~}" (split-sequence #\\ value))) (unless (eql wild-char #\%) (setf value (format nil "~{~A~^\\%~}" (split-sequence #\% value)))) (let ((v (if (eql wild-char #\%) value (substitute #\% wild-char value))) (result)) (setf result (sql-operation 'LIKE (if insensitive (sql-operation 'UPPER name) name) (if insensitive (sql-operation 'UPPER v) v))) result)) ;;---- CLSQL EXTENSIONS ------------------------ (in-package #:clsql-sys) (defclass sql-join-exp (sql-ident) ((components :initarg :components) (modifier :initarg :modifier) (on :initarg :on))) (defmethod make-load-form ((sql sql-join-exp) &optional environment) (declare (ignore environment)) (with-slots (components modifier on) sql `(make-instance 'sql-join-exp :components ',components :modifier ',modifier :on ',on))) (defmethod output-sql ((expr sql-join-exp) database) (with-slots (modifier components on) expr (output-sql (first components) database) (write-string " " *sql-stream*) (output-sql modifier database) (write-string " " *sql-stream*) (output-sql (second components) database) (write-string " ON " *sql-stream*) (output-sql on database))) (defsql sql-join (:symbol "join") (&rest rest) (if (= (length rest) 3) (make-instance 'sql-join-exp :modifier 'JOIN :components (butlast rest) :on (third rest)) (error 'sql-user-error "JOIN must have three arguments"))) (defsql sql-left-join (:symbol "left-join") (&rest rest) (if (= (length rest) 3) (make-instance 'sql-join-exp :modifier '|LEFT JOIN| :components (butlast rest) :on (third rest)) (error 'sql-user-error "LEFT-JOIN must have three arguments"))) (defsql sql-right-join (:symbol "right-join") (&rest rest) (if (= (length rest) 3) (make-instance 'sql-join-exp :modifier '|RIGHT JOIN| :components (butlast rest) :on (third rest)) (error 'sql-user-error "RIGHT-JOIN must have three arguments"))) (defsql sql-inner-join (:symbol "inner-join") (&rest rest) (if (= (length rest) 3) (make-instance 'sql-join-exp :modifier '|INNER JOIN| :components (butlast rest) :on (third rest)) (error 'sql-user-error "INNER-JOIN must have three arguments"))) (defsql sql-outer-join (:symbol "outer-join") (&rest rest) (if (= (length rest) 3) (make-instance 'sql-join-exp :modifier '|OUTER JOIN| :components (butlast rest) :on (third rest)) (error 'sql-user-error "OUTER-JOIN must have three arguments"))) (defun select (&rest select-all-args) "Executes a query on DATABASE, which has a default value of *DEFAULT-DATABASE*, specified by the SQL expressions supplied using the remaining arguments in SELECT-ALL-ARGS. The SELECT argument can be used to generate queries in both functional and object oriented contexts. In the functional case, the required arguments specify the columns selected by the query and may be symbolic SQL expressions or strings representing attribute identifiers. Type modified identifiers indicate that the values selected from the specified column are converted to the specified lisp type. The keyword arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY, SET-OPERATION and WHERE are used to specify, using the symbolic SQL syntax, the corresponding components of the SQL query generated by the call to SELECT. RESULT-TYPES is a list of symbols which specifies the lisp type for each field returned by the query. If RESULT-TYPES is nil all results are returned as strings whereas the default value of :auto means that the lisp types are automatically computed for each field. FIELD-NAMES is t by default which means that the second value returned is a list of strings representing the columns selected by the query. If FIELD-NAMES is nil, the list of column names is not returned as a second value. In the object oriented case, the required arguments to SELECT are symbols denoting View Classes which specify the database tables to query. In this case, SELECT returns a list of View Class instances whose slots are set from the attribute values of the records in the specified table. Slot-value is a legal operator which can be employed as part of the symbolic SQL syntax used in the WHERE keyword argument to SELECT. REFRESH is nil by default which means that the View Class instances returned are retrieved from a cache if an equivalent call to SELECT has previously been issued. If REFRESH is true, the View Class instances returned are updated as necessary from the database and the generic function INSTANCE-REFRESHED is called to perform any necessary operations on the updated instances. In both object oriented and functional contexts, FLATP has a default value of nil which means that the results are returned as a list of lists. If FLATP is t and only one result is returned for each record selected in the query, the results are returneds as elements of a list." (flet ((select-objects (target-args) (and target-args (every #'(lambda (arg) (and (symbolp arg) (find-class arg nil))) target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) (unless (or *default-database* (getf qualifier-args :database)) (signal-no-database-error nil)) (cond ((select-objects target-args) (let ((caching (getf qualifier-args :caching *default-caching*)) (result-types (getf qualifier-args :result-types :auto)) (refresh (getf qualifier-args :refresh nil)) (database (or (getf qualifier-args :database) *default-database*)) (order-by (getf qualifier-args :order-by))) (remf qualifier-args :caching) (remf qualifier-args :refresh) (remf qualifier-args :result-types) ;; Add explicity table name to order-by if not specified and only ;; one selected table. This is required so FIND-ALL won't duplicate ;; the field (when (and order-by (= 1 (length target-args))) (let ((table-name (view-table (find-class (car target-args)))) (order-by-list (copy-seq (listify order-by)))) (loop for i from 0 below (length order-by-list) do (etypecase (nth i order-by-list) (sql-ident-attribute (unless (slot-value (nth i order-by-list) 'qualifier) (setf (slot-value (nth i order-by-list) 'qualifier) table-name))) (cons (unless (slot-value (car (nth i order-by-list)) 'qualifier) (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))))) (setf (getf qualifier-args :order-by) order-by-list))) (cond ((null caching) (apply #'find-all target-args (append qualifier-args (list :result-types result-types :refresh refresh)))) (t (let ((cached (records-cache-results target-args qualifier-args database))) (cond ((and cached (not refresh)) cached) ((and cached refresh) (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh))))) (setf (records-cache-results target-args qualifier-args database) results) results)) (t (let ((results (apply #'find-all target-args (append qualifier-args `(:result-types :auto :refresh ,refresh))))) (setf (records-cache-results target-args qualifier-args database) results) results)))))))) (t (let* ((expr (apply #'make-query select-all-args)) (specified-types (mapcar #'(lambda (attrib) (if (typep attrib 'sql-ident-attribute) (let ((type (slot-value attrib 'type))) (if type type t)) t)) (slot-value expr 'selections)))) (destructuring-bind (&key (flatp nil) (result-types :auto) (field-names t) (database *default-database*) &allow-other-keys) qualifier-args (progn (when (listp (slot-value expr 'from)) (let ((join (first (member-if #'(lambda (i) (typep i 'sql-join-exp)) (slot-value expr 'from))))) (when join (setf (slot-value expr 'from) join)))) (query expr :flatp flatp :result-types ;; specifying a type for an attribute overrides result-types (if (some #'(lambda (x) (not (eq t x))) specified-types) specified-types result-types) :field-names field-names :database database))))))))) (export '(sql-join sql-left-join sql-right-join sql-outer-join sql-inner-join sql-upper))