diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/clojure_sql/compiler.clj | 187 | ||||
| -rw-r--r-- | src/clojure_sql/core.clj | 392 | ||||
| -rw-r--r-- | src/clojure_sql/dsl.clj | 169 | ||||
| -rw-r--r-- | src/clojure_sql/query.clj | 20 |
4 files changed, 392 insertions, 376 deletions
diff --git a/src/clojure_sql/compiler.clj b/src/clojure_sql/compiler.clj new file mode 100644 index 0000000..ca8d2d9 --- /dev/null +++ b/src/clojure_sql/compiler.clj @@ -0,0 +1,187 @@ +(ns clojure-sql.compiler + (:require [clojure.string :as string])) + + + +(defn add-parentheses [s] + (str \( s \))) + + +;; ============================================================== +;; DB specific escaping methods +;; ============================================================== + +(defmulti field-name (fn [db _] db)) +(defmethod field-name :default [_ field] + (str \" (name field) \")) + +(defmulti table-name (fn [db _] db)) +(defmethod table-name :default [_ table] + (str \" (name table) \")) + +(defmulti function-name (fn [db _] db)) +(defmethod function-name :default [_ function] + (str \" (name function) \")) + + + + + +;; ============================================================== +;; Utility functions for the compile-* functions +;; ============================================================== + +;; compile-* multimethods are of the signature: +;; (db, expr) -> [SQL & replacements] + +(def is-unary? (comp boolean '#{"not"} name)) +(def is-binary? (comp boolean '#{"=" "<" ">" "<=" ">=" "is" "in" "+" "-" "/" "*"} name)) +(def is-operator? (comp boolean '#{"and" "or"} name)) + +(defn c-return [val] [val]) +(defn c-lift [f & orig-args] + (fn [& c-args] + (apply vector + (apply f (concat orig-args + (map first c-args))) + (apply concat (map rest c-args))))) +(def c-str (c-lift str)) +(def c-join (fn [sep args] + (apply vector + (string/join sep (map first args)) + (apply concat (map rest args))))) +(def c-add-parentheses (c-lift add-parentheses)) + + + +;; ============================================================== +;; compile-* functions (turning a map into a query string) +;; ============================================================== + +(defmulti compile-expression (fn [db _] db)) +(defmethod compile-expression :default [db ex] + (condp #(%1 %2) ex + nil? (c-return "NULL") + vector? (c-return (str (table-name db (first ex)) \. (field-name db (second ex)))) + keyword? (c-return (field-name db ex)) + string? ["?" ex] ;;(sql-string db ex) + symbol? (c-return (string/upper-case (name ex))) + sequential? (-> (condp #(%1 %2) (first ex) + is-unary? (if (= (count ex) 2) + (->> ex + (map (partial compile-expression db)) + (c-join " ")) + (throw (ex-info "Unary operators can only take one argument." + {:operator (first ex) + :arguments (rest ex)}))) + is-binary? (if (= (count ex) 3) + (->> (rest ex) + (map (partial compile-expression db)) + (interpose (compile-expression db (first ex))) + (c-join " ")) + (throw (ex-info "Binary operators must take two arguments." + {:operator (first ex) + :arguments (rest ex)}))) + is-operator? (->> (rest ex) + (map (partial compile-expression db)) + (interpose (compile-expression db (first ex))) + (c-join " ")) + (->> (rest ex) + (map (partial compile-expression db)) + (c-join ", ") + c-add-parentheses + (c-str (c-return (function-name db (first ex)))))) + c-add-parentheses) + (c-return ex))) + +(defn ^:private make-table-name [db table & [alias]] + (if (or (= table alias) (nil? alias)) + (table-name db table) + (str (table-name db table) " AS " (field-name db alias))) ) + +(defn ^:private make-field-name [db table field & [alias]] + (if (or (= field alias) (nil? alias)) + (str (table-name db table) \. (field-name db field)) + (str (table-name db table) \. (field-name db field) " AS " (field-name db alias)))) + +(defmulti compile-fields (fn [db _] db)) +(defmethod compile-fields :default [db fields-map] + (if (seq fields-map) + (->> (for [[[table field] alias] fields-map] + (make-field-name db table field alias)) + (string/join ", ") + c-return) + (c-return "*"))) + +(defmulti compile-tables (fn [db _] db)) +(defmethod compile-tables :default [db tables-map] + (->> (for [[table alias] tables-map] + (make-table-name db table alias)) + (string/join ", ") + c-return)) + +(defmulti compile-join (fn [db _] db)) +(defmethod compile-join :default [db [type table-map on]] + (c-str (c-return (case type + :left " LEFT OUTER" + :right " RIGHT OUTER" + " INNER")) + (c-return " JOIN ") + (compile-tables db table-map) + (c-return " ON ") + (compile-expression db on))) + +(defmulti compile-joins (fn [db _] db)) +(defmethod compile-joins :default [db joins] + (->> joins + (map (partial compile-join db)) + (c-join ""))) + +(defmulti compile-where (fn [db _] db)) +(defmethod compile-where :default [db expr] + (if expr + (c-str (c-return " WHERE ") (compile-expression db expr)))) + +(defmulti compile-sort-by (fn [db _] db)) +(defmethod compile-sort-by :default [db fields] + (if fields + (->> (for [[[table field] dir] fields] + (str (make-field-name db table field) \space (string/upper-case (name dir)))) + (string/join ",") + (apply str " ORDER BY ") + c-return))) + +(defmulti compile-query (fn [db _] db)) +(defmethod compile-query :default [db {:keys [table fields joins where sort-by]}] + (c-str (c-return "SELECT ") + (compile-fields db fields) + (if table + (c-return " FROM ")) + (compile-tables db table) + (compile-joins db joins) + (compile-where db where) + (compile-sort-by db sort-by))) + + + +;; ============================================================== +;; A few DB specific overrides +;; ============================================================== + + +;; SQL SERVER +(defmethod field-name :sql-server [_ field] + (str \[ (name field) \])) + +(defmethod table-name :sql-server [_ table] + (str \[ (name table) \])) + +;; mySQL +(defmethod field-name :mysql [_ field] + (str \` (name field) \`)) + +(defmethod table-name :mysql [_ table] + (str \` (name table) \`)) + + + diff --git a/src/clojure_sql/core.clj b/src/clojure_sql/core.clj index ae0eb75..cdfa1c9 100644 --- a/src/clojure_sql/core.clj +++ b/src/clojure_sql/core.clj @@ -1,381 +1,22 @@ (ns clojure-sql.core (:refer-clojure :exclude [sort-by]) (:require [clojure.set :as set] - [clojure.string :as string] + [clojure-sql.compiler :as c] + [clojure-sql.dsl :as d] [clojure-sql.util :as u] [clojure.walk])) -(declare compile-query) +(def table d/table) +(def project d/project) +(def rename d/rename) +(def join d/join) +(def select d/select) +(def sort-by d/sort-by) +(def insert! d/insert!) +(def update! d/update!) +(def delete! d/delete!) -(def ^:private ^:dynamic *database-type* nil) -(defn set-database-type! [new-type] - (alter-var-root #'*database-type* (constantly new-type))) - -(def ^:private ^:dynamic *query-deref-behaviour* #(compile-query *database-type* %)) -(defn set-query-deref-behaviour! [f] - (alter-var-root #'*query-deref-behaviour* (constantly f))) - -(defrecord ^:private Query [] - clojure.lang.IDeref - (deref [this] (*query-deref-behaviour* this))) -(defmethod print-method Query [query writer] - (binding [*out* writer] - (pr (compile-query nil query)))) - - - - -(defn add-parentheses [s] - (str \( s \))) - -;; ============================================================== -;; DB specific escaping methods -;; ============================================================== - -(defmulti field-name (fn [db _] db)) -(defmethod field-name :default [_ field] - (str \" (name field) \")) - -(defmulti table-name (fn [db _] db)) -(defmethod table-name :default [_ table] - (str \" (name table) \")) - -(defmulti function-name (fn [db _] db)) -(defmethod function-name :default [_ function] - (str \" (name function) \")) - - - - - -;; ============================================================== -;; Utility functions for the compile-* functions -;; ============================================================== - -;; compile-* multimethods are of the signature: -;; (db, expr) -> [SQL & replacements] - -(def is-unary? (comp boolean '#{"not"} name)) -(def is-binary? (comp boolean '#{"=" "<" ">" "<=" ">=" "is" "in" "+" "-" "/" "*"} name)) -(def is-operator? (comp boolean '#{"and" "or"} name)) - -(defn c-return [val] [val]) -(defn c-lift [f & orig-args] - (fn [& c-args] - (apply vector - (apply f (concat orig-args - (map first c-args))) - (apply concat (map rest c-args))))) -(def c-str (c-lift str)) -(def c-join (fn [sep args] - (apply vector - (string/join sep (map first args)) - (apply concat (map rest args))))) -(def c-add-parentheses (c-lift add-parentheses)) - - - -;; ============================================================== -;; compile-* functions (turning a map into a query string) -;; ============================================================== - -(defmulti compile-expression (fn [db _] db)) -(defmethod compile-expression :default [db ex] - (condp #(%1 %2) ex - nil? (c-return "NULL") - vector? (c-return (str (table-name db (first ex)) \. (field-name db (second ex)))) - keyword? (c-return (field-name db ex)) - string? ["?" ex] ;;(sql-string db ex) - symbol? (c-return (string/upper-case (name ex))) - sequential? (-> (condp #(%1 %2) (first ex) - is-unary? (if (= (count ex) 2) - (->> ex - (map (partial compile-expression db)) - (c-join " ")) - (throw (ex-info "Unary operators can only take one argument." - {:operator (first ex) - :arguments (rest ex)}))) - is-binary? (if (= (count ex) 3) - (->> (rest ex) - (map (partial compile-expression db)) - (interpose (compile-expression db (first ex))) - (c-join " ")) - (throw (ex-info "Binary operators must take two arguments." - {:operator (first ex) - :arguments (rest ex)}))) - is-operator? (->> (rest ex) - (map (partial compile-expression db)) - (interpose (compile-expression db (first ex))) - (c-join " ")) - (->> (rest ex) - (map (partial compile-expression db)) - (c-join ", ") - c-add-parentheses - (c-str (c-return (function-name db (first ex)))))) - c-add-parentheses) - (c-return ex))) - -(defn ^:private make-table-name [db table & [alias]] - (if (or (= table alias) (nil? alias)) - (table-name db table) - (str (table-name db table) " AS " (field-name db alias))) ) - -(defn ^:private make-field-name [db table field & [alias]] - (if (or (= field alias) (nil? alias)) - (str (table-name db table) \. (field-name db field)) - (str (table-name db table) \. (field-name db field) " AS " (field-name db alias)))) - -(defmulti compile-fields (fn [db _] db)) -(defmethod compile-fields :default [db fields-map] - (if (seq fields-map) - (->> (for [[[table field] alias] fields-map] - (make-field-name db table field alias)) - (string/join ", ") - c-return) - (c-return "*"))) - -(defmulti compile-tables (fn [db _] db)) -(defmethod compile-tables :default [db tables-map] - (->> (for [[table alias] tables-map] - (make-table-name db table alias)) - (string/join ", ") - c-return)) - -(defmulti compile-join (fn [db _] db)) -(defmethod compile-join :default [db [type table-map on]] - (c-str (c-return (case type - :left " LEFT OUTER" - :right " RIGHT OUTER" - " INNER")) - (c-return " JOIN ") - (compile-tables db table-map) - (c-return " ON ") - (compile-expression db on))) - -(defmulti compile-joins (fn [db _] db)) -(defmethod compile-joins :default [db joins] - (->> joins - (map (partial compile-join db)) - (c-join " "))) - -(defmulti compile-where (fn [db _] db)) -(defmethod compile-where :default [db expr] - (if expr - (c-str (c-return " WHERE ") (compile-expression db expr)))) - -(defmulti compile-sort-by (fn [db _] db)) -(defmethod compile-sort-by :default [db fields] - (if fields - (->> (for [[[table field] dir] fields] - (str (make-field-name db table field) \space (string/upper-case (name dir)))) - (string/join ",") - (apply str " ORDER BY ") - c-return))) - -(defmulti compile-query (fn [db _] db)) -(defmethod compile-query :default [db {:keys [table fields joins where sort-by]}] - (c-str (c-return "SELECT ") - (compile-fields db fields) - (if table - (c-return " FROM ")) - (compile-tables db table) - (compile-joins db joins) - (compile-where db where) - (compile-sort-by db sort-by))) - - - -;; SQL SERVER -(defmethod field-name :sql-server [_ field] - (str \[ (name field) \])) - -(defmethod table-name :sql-server [_ table] - (str \[ (name table) \])) - -;; mySQL -(defmethod field-name :mysql [_ field] - (str \` (name field) \`)) - -(defmethod table-name :mysql [_ table] - (str \` (name table) \`)) - - - - - - - - - - - - - - - - -;; ============================================================== -;; The DSL for making query maps -;; ============================================================== - -;; important sections: -;; -PROJECTION- -;; -TABLES- -;; -FILTERS- -;; GROUPING -;; GROUPED FILTERS -;; -SORTING- - -;; { -;; :table => tablename -> table_alias, -;; :fields => (table_alias, fieldname) -> field_alias -;; :joins => [tablename -> (type, table_alias, on)] -;; :where => expression -;; :sort-by => [(field, direction)] -;; } - -(defn table [arg] - (into (->Query) - (if (map? arg) - {:table arg} - {:table {arg arg}}))) - -(defn ambiguous-error [field & [query]] - (throw (ex-info (str "Ambiguous field " field " in query with more than one table") - {:field field - :query query}))) - -(defn project [query fields] - (let [table (if-not (:joins query) - (-> query :table first val)) - alias-lookup (u/flip-map (:fields query)) - original-name (fn [field] - (if (vector? field) - field - (or (get alias-lookup field nil) - (if table - [table field] - (ambiguous-error field query)))))] - (assoc query - :fields (->> (for [[key val] (if (map? fields) - fields - (zipmap fields fields))] - [(original-name key) val]) - (into {}))))) - -(defn rename [query field-renames] - {:pre [(map? field-renames) - ;; the intersection of the new aliases with the old aliases NOT renamed by this operation - (empty? (set/intersection (set (vals field-renames)) - (set/difference (set (vals (:fields query))) - (set (keys field-renames)))))]} - (let [fields (:fields query) - alias-lookup (u/flip-map (:fields query)) - original-name (fn [field] - (cond (vector? field) field - (contains? alias-lookup field) (get alias-lookup field) - :else (throw (ex-info (str "Cannot rename field " (pr-str field) ". Field does not exist in query.") - {:field field - :query query - :renames field-renames}))) - (get alias-lookup field))] - (update-in query - [:fields] #(->> (for [[key val] field-renames] - ;(if (contains? val (:fields query))) - [(original-name key) val]) - (into %))))) - -(defn ^:private resolve-field [table aliases field] - (let [field-alias-lookup (u/flip-map aliases)] - (or (field-alias-lookup field) - (if table - [table field] - (ambiguous-error field))))) - -(defn ^:private resolve-fields [table aliases expression] - (clojure.walk/postwalk (fn [expr] - (cond - (keyword? expr) (resolve-field table aliases expr) - :else expr)) - expression)) - -(defn ^:private combine-wheres [& 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 join [left right & {:keys [on type]}] - (let [joins-vector (or (:join left) []) - common-fields (set/intersection (set (vals (:fields left))) - (set (vals (:fields right)))) - joined-fields (if (:type :right) - (merge (->> (:fields left) - (filter (comp not common-fields val)) - (into {})) - (:fields right)) - (merge (:fields left) - (->> (:fields right) - (filter (comp not common-fields val)) - (into {})))) - implicit-on (if (seq common-fields) - (map (fn [field] - `(= ~(resolve-field (:table left) (:fields left) field) - ~(resolve-field (:table right) (:fields right) field))) - common-fields)) - on (if on - [(resolve-fields nil joined-fields on)]) - join-condition (if-let [condition (seq (concat implicit-on on))] - `(and ~@condition) - true)] - (-> left - (assoc :fields joined-fields) - (assoc :joins (into (conj joins-vector - [(or type :inner) (:table right) join-condition]) - (:joins right))) - (assoc :where (combine-wheres (:where left) (:where right)))))) - -(defn select [query expression] - (let [table-name (if-not (:joins query) - (-> query :table first val)) - old-where (:where query) - resolved-expression (resolve-fields table-name (:fields query) expression) - new-where (combine-wheres old-where resolved-expression)] - (assoc query :where new-where))) - -(defn sort-by [query fields] - (let [table-name (if-not (:joins query) - (-> query :table first val)) - fields-seq (if (sequential? fields) - fields - [fields])] - (assoc query - :sort-by (for [field fields-seq] - (if (vector? field) - (resolve-field table-name (:fields query) field) - [(resolve-field table-name (:fields query) field) :asc]))))) - - -(defn insert! [query & records] - {:pre [(empty? (:joins query))]} - ;; some code here - ) - -(defn update! [query & partial-records] - ;; some code here - ) - -(defn delete! [query] - ;; some code here - ) (comment @@ -395,14 +36,14 @@ (rename {:id :pid})) (-> (table {:others :o}) (project {:id :oid})) - '(= :pid :oid)) - uid-pid-match) + :on '(= :pid :oid)) + :on uid-pid-match) (select is-carlo) (project [:fname :sname :oid])))) (-> (table :users) (join (table :something-else-with-a-username) - true) + :on true) (select '(or (= :username "john") (not (= :username "carlo")))) (project [:username])) @@ -413,14 +54,13 @@ (join (-> (table {:nodes :parent}) (project [:id, :name]) (rename {:name :parent.name})) - '(= :parent-id :id)) + :on '(= :parent-id :id)) (project [:child.name :parent.name])) (-> (table :users) (project [:id]) (join (-> (table :people) - (project [:id])) - true)) + (project [:id])))) (-> (table :users) (project [:id :name]) (rename {:id :name diff --git a/src/clojure_sql/dsl.clj b/src/clojure_sql/dsl.clj new file mode 100644 index 0000000..006e637 --- /dev/null +++ b/src/clojure_sql/dsl.clj @@ -0,0 +1,169 @@ +(ns clojure-sql.dsl + (:refer-clojure :exclude [sort-by]) + (:require [clojure.set :as set] + [clojure.walk] + [clojure-sql.query :as q] + [clojure-sql.util :as u])) + + +;; ============================================================== +;; The DSL for making query maps +;; ============================================================== + +;; important sections: +;; -PROJECTION- +;; -TABLES- +;; -FILTERS- +;; GROUPING +;; GROUPED FILTERS +;; -SORTING- + +;; { +;; :table => tablename -> table_alias, +;; :fields => (table_alias, fieldname) -> field_alias +;; :joins => [tablename -> (type, table_alias, on)] +;; :where => expression +;; :sort-by => [(field, direction)] +;; } + +(defn table [arg] + (into (q/->Query) + (if (map? arg) + {:table arg} + {:table {arg arg}}))) + +(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 project [query fields] + (let [table (if-not (:joins query) + (-> query :table first val)) + alias-lookup (u/flip-map (:fields query)) + original-name (fn [field] + (if (vector? field) + field + (or (get alias-lookup field nil) + (if table + [table field] + (ambiguous-error field query)))))] + (assoc query + :fields (->> (for [[key val] (if (map? fields) + fields + (zipmap fields fields))] + [(original-name key) val]) + (into {}))))) + +(defn rename [query field-renames] + {:pre [(map? field-renames) + ;; the intersection of the new aliases with the old aliases NOT renamed by this operation + (empty? (set/intersection (set (vals field-renames)) + (set/difference (set (vals (:fields query))) + (set (keys field-renames)))))]} + (let [fields (:fields query) + alias-lookup (u/flip-map (:fields query)) + original-name (fn [field] + (cond (vector? field) field + (contains? alias-lookup field) (get alias-lookup field) + :else (throw (ex-info (str "Cannot rename field " (pr-str field) ". Field does not exist in query.") + {:field field + :query query + :renames field-renames}))) + (get alias-lookup field))] + (update-in query + [:fields] #(->> (for [[key val] field-renames] + ;(if (contains? val (:fields query))) + [(original-name key) val]) + (into %))))) + +(defn ^:private resolve-field [table aliases field] + (let [field-alias-lookup (u/flip-map aliases)] + (or (field-alias-lookup field) + (if table + [table field] + (ambiguous-error field))))) + +(defn ^:private resolve-fields [table aliases expression] + (clojure.walk/postwalk (fn [expr] + (cond + (keyword? expr) (resolve-field table aliases expr) + :else expr)) + expression)) + +(defn ^:private combine-wheres [& 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 join [left right & {:keys [on type]}] + (let [joins-vector (or (:join left) []) + common-fields (set/intersection (set (vals (:fields left))) + (set (vals (:fields right)))) + joined-fields (if (:type :right) + (merge (->> (:fields left) + (filter (comp not common-fields val)) + (into {})) + (:fields right)) + (merge (:fields left) + (->> (:fields right) + (filter (comp not common-fields val)) + (into {})))) + implicit-on (if (seq common-fields) + (map (fn [field] + `(= ~(resolve-field (:table left) (:fields left) field) + ~(resolve-field (:table right) (:fields right) field))) + common-fields)) + on (if on + [(resolve-fields nil joined-fields on)]) + join-condition (if-let [condition (seq (concat implicit-on on))] + `(and ~@condition) + true)] + (-> left + (assoc :fields joined-fields) + (assoc :joins (into (conj joins-vector + [(or type :inner) (:table right) join-condition]) + (:joins right))) + (assoc :where (combine-wheres (:where left) (:where right)))))) + +(defn select [query expression] + (let [table-name (if-not (:joins query) + (-> query :table first val)) + old-where (:where query) + resolved-expression (resolve-fields table-name (:fields query) expression) + new-where (combine-wheres old-where resolved-expression)] + (assoc query :where new-where))) + +(defn sort-by [query fields] + (let [table-name (if-not (:joins query) + (-> query :table first val)) + fields-seq (if (sequential? fields) + fields + [fields])] + (assoc query + :sort-by (for [field fields-seq] + (if (vector? field) + (resolve-field table-name (:fields query) field) + [(resolve-field table-name (:fields query) field) :asc]))))) + + +(defn insert! [query & records] + {:pre [(empty? (:joins query))]} + ;; some code here + ) + +(defn update! [query & partial-records] + ;; some code here + ) + +(defn delete! [query] + ;; some code here + ) diff --git a/src/clojure_sql/query.clj b/src/clojure_sql/query.clj new file mode 100644 index 0000000..239aab4 --- /dev/null +++ b/src/clojure_sql/query.clj @@ -0,0 +1,20 @@ +(ns clojure-sql.query + (:require [clojure-sql.compiler :as c])) + + +(def ^:private ^:dynamic *database-type* nil) +(defn set-database-type! [new-type] + (alter-var-root #'*database-type* (constantly new-type)) + nil) + +(def ^:private ^:dynamic *query-deref-behaviour* #(c/compile-query *database-type* %)) +(defn set-query-deref-behaviour! [f] + (alter-var-root #'*query-deref-behaviour* (constantly f)) + nil) + +(defrecord ^:private Query [] + clojure.lang.IDeref + (deref [this] (*query-deref-behaviour* this))) +(defmethod print-method Query [query writer] + (binding [*out* writer] + (pr (c/compile-query nil query)))) |