(ns clojure-sql.dsl (:refer-clojure :exclude [sort group take drop]) (:require [clojure.set :as set] [clojure.walk :as walk] [clojure-sql.query :as q] [clojure-sql.util :as u])) ;; ============================================================== ;; The DSL for making query maps ;; ============================================================== ;; important sections: ;; -PROJECTION- ;; -TABLES- ;; -FILTERS- ;; -SORTING- ;; -GROUPING- ;; -GROUPED FILTERS- ;; { ;; :tables => tablename -> table_alias ;; :fields => (table_alias, fieldname) -> field_alias ;; :joins => [left-table type right-table on?] ;; :where => expression ;; :sort => [(field, direction)] ;; :group => [field] ;; :having => expression ;; } (defn ^:private ambiguous-error [field & [query]] (throw (ex-info (str "Ambiguous field " field " in query with more than one table") {:field field :query query}))) (defn ^:private same-rename-error [alias renames & [query]] (throw (ex-info (str "Cannot rename multiple fields to the same alias: " alias) {:alias alias :renames renames :query query}))) (defn ^:private missing-rename-error [field renames & [query]] (throw (ex-info (str "Cannot rename field not present in query: " field) {:field field :query query :renames renames}))) (defn ^:private common-fields-error [left right common-fields] (throw (ex-info "Cannot join with common fields unless natural join" {:left left :right right :common-fields common-fields}))) (defn ^:private cross-join-duplicate-fields [common-fields left right] (throw (ex-info "Cross join will introduce ambiguous duplicate fields" {:left left :right right :common-fields common-fields}))) (defn ^:private cross-join-condition-error [condition left right] (throw (ex-info "Cannot have a cross join with condition (maybe you wanted either a selection or an inner join)" {:left left :right right :condition condition}))) (defn ^:private invalid-join-type [type left right] (throw (ex-info (str "Invalid join type: " type) {:left left :right right :type type }))) (defn ^:private invalid-union [queries] (throw (ex-info "Cannot union queries with different fields" {:queries queries}))) (defn table [arg] (q/map->Query (let [alias (keyword (gensym (if (u/named? arg) (name arg) "table")))] {:tables {alias arg} :joins [alias]}))) (defn ^:private rename-table [query from to] (q/map->Query (walk/prewalk-replace {from to} (into {} query)))) (defn ^:private resolve-field [table aliases field] (let [field-alias-lookup aliases] (or (and field-alias-lookup (field-alias-lookup field)) (if table [table field] (ambiguous-error field))))) (defn ^:private process-expression [table aliases expression] (cond (vector? expression) (list 'quote (mapv (partial process-expression table aliases) expression)) (sequential? expression) (map (partial process-expression table aliases) expression) (keyword? expression) (resolve-field table aliases expression) :else expression)) (defn project [query fields] (let [table (if (= (count (:tables query)) 1) (-> query :tables first key)) alias-lookup (or (:fields query) {}) get-real-name #(process-expression table alias-lookup %) fields (if (map? fields) fields (zipmap fields fields))] (assoc query :fields (reduce (fn [fields [field alias]] (if (contains? fields alias) (same-rename-error alias fields query) (assoc fields alias (get-real-name field)))) {} fields)))) (defn ^:private rename-with-fn [query field-renames] (update-in query [:fields] (fn [fields] (reduce (fn [fields [old-alias field]] (let [new-alias (or (field-renames old-alias) old-alias)] (if (contains? fields new-alias) (same-rename-error new-alias field-renames query) (assoc fields new-alias field)))) {} fields)))) (defn ^:private rename-with-map [query field-renames] (doseq [[field alias] field-renames] (if-not (contains? (:fields query) field) (missing-rename-error field field-renames query))) (rename-with-fn query field-renames)) (defn rename [query field-renames] (if (map? field-renames) (rename-with-map query field-renames) (rename-with-fn query field-renames))) (defn prefix-names-matching [pred prefix] (fn [alias] (if (pred alias) (keyword (str prefix (name alias))) alias))) (defn prefix-names [prefix] (prefix-names-matching (constantly true) prefix)) (defn ^:private combine-conjunctions [& wheres] (reduce (fn [acc where] (cond (nil? acc) where (nil? where) acc :else (or (if (and (sequential? where) (= (name (first where)) "and")) `(and ~acc ~@(next where))) (if (and (sequential? acc) (= (name (first acc)) "and")) `(and ~@(next acc) ~where)) `(and ~acc ~where)))) nil wheres)) (defn ^:private joinable? [query] (and (nil? (:group query)) (nil? (:having query)) (nil? (:take query)) (nil? (:drop query)))) (defn ^:private convert-to-subquery [query] (-> (table query) (project (keys (:fields query))))) (defn ^:private remove-sort [query] (dissoc query :sort)) (defn ^:private make-join-subquery [query] (if (joinable? query) query (if (or (:take query) (:drop query)) (convert-to-subquery query) (convert-to-subquery (remove-sort query))))) (def ^:private valid-join-type? (comp boolean #{:cross :inner :outer :full-outer})) (defn join [left right & {:keys [on type]}] (if (= type :right) (join right left :on on :type :left) (let [type (if (= type :left) :outer type) left (make-join-subquery left) right (make-join-subquery right) common-tables (set/intersection (set (keys (:tables left))) (set (keys (:tables right)))) right (reduce (fn [query [alias table]] (rename-table query alias (keyword (gensym (name table))))) right (:tables right)) ;;_ (assert (empty? common-tables) "Cannot join two tables with the same name") merged-tables (merge (:tables left) (:tables right)) common-fields (set/intersection (set (keys (:fields left))) (set (keys (:fields right)))) merged-fields (merge (:fields right) (:fields left)) ;; favour the left name for outer joins join-condition (cond (nil? on) (let [implicit (map (fn [field] `(~'= ~(resolve-field (:table left) (or (:fields left) {}) field) ~(resolve-field (:table right) (or (:fields right) {}) field))) common-fields)] (if (next implicit) (seq (cons `and implicit)) ;; more than one, so add an "and" around them (first implicit))) (seq common-fields) (common-fields-error left right common-fields) :else (process-expression nil merged-fields on)) type (or type (if join-condition :inner) :cross) [join-condition where] (if (contains? #{:outer :full-outer} type) [(combine-conjunctions (:where right) join-condition) (:where left)] [join-condition (combine-conjunctions (:where left) (:where right))])] (if-not (valid-join-type? type) (throw (invalid-join-type type left right))) (if (and (= type :cross) join-condition) (if (seq common-fields) (cross-join-duplicate-fields common-fields left right) (cross-join-condition-error join-condition left right))) (-> left (assoc :fields merged-fields :tables merged-tables :joins {:left (:joins left) :right (:joins right) :type type :on join-condition} :where where :sort (seq (concat (:sort left) (:sort right)))))))) (defn select [query expression] (let [table-name (if (= (count (:tables query)) 1) (-> query :tables first key)) old-where (:where query) resolved-expression (process-expression table-name (:fields query) expression) new-where (combine-conjunctions old-where resolved-expression)] (assoc query :where new-where))) (defn sort [query fields] (let [table-name (if (= (count (:tables query)) 1) (-> query :tables first key)) fields-seq (if (sequential? fields) fields [fields]) fields-lookup (or (:fields query) {})] (assoc query :sort (for [field fields-seq] (if (vector? field) [(resolve-field table-name fields-lookup (first field)) (second field)] [(resolve-field table-name fields-lookup field) :asc]))))) (defn group [query fields] (let [table-name (if (= (count (:tables query)) 1) (-> query :tables first key)) fields-seq (if (sequential? fields) fields [fields]) fields-lookup (or (:fields query) {})] (assoc query :group (map (partial resolve-field table-name fields-lookup) fields-seq)))) (defn having [query expression] (let [table-name (if (= (count (:tables query)) 1) (-> query :tables first key)) old-having (:having query) resolved-expression (process-expression table-name (:fields query) expression) new-having (combine-conjunctions old-having resolved-expression)] (assoc query :having new-having))) (defn take [query n] (if-let [old-take (:take query)] (assoc query :take (min old-take n)) (assoc query :take n))) (defn drop [query n] (let [query (if-let [old-take (:take query)] (assoc query :take (- old-take n)) query)] (if-let [old-drop (:drop query)] (assoc query :drop (+ old-drop n)) (assoc query :drop n))))