PageRenderTime 87ms CodeModel.GetById 45ms app.highlight 36ms RepoModel.GetById 1ms app.codeStats 0ms

/src/lobos/schema.clj

http://github.com/budu/lobos
Clojure | 760 lines | 570 code | 120 blank | 70 comment | 21 complexity | bae4503939b00068f742e03917ebffed MD5 | raw file
  1; Copyright (c) Nicolas Buduroi. All rights reserved.
  2; The use and distribution terms for this software are covered by the
  3; Eclipse Public License 1.0 which can be found in the file
  4; epl-v10.html at the root of this distribution. By using this software
  5; in any fashion, you are agreeing to be bound by the terms of this
  6; license.
  7; You must not remove this notice, or any other, from this software.
  8
  9(ns lobos.schema
 10  "This namespace include the abstract schema data-structures, an
 11  handful of helpers to create them and the protocol to build the into
 12  an abstract syntax tree of implementation agnostic SQL
 13  statements. Abstract schema data-structures can be divided in two
 14  categories.
 15
 16  First, schema elements which include the `schema` and the `table`
 17  element definitions. Those can be created or dropped, also the `table`
 18  element can be altered.
 19
 20  Then there's the table elements that serves to define tables. There's
 21  the completly abstract `column` and `constraint` elements, which are
 22  only meant to be used directly with the alter action. Each of them
 23  have more specialized function to help you define tables, like the
 24  `unique`, `primary-key`, `foreign-key` and `check` constraints
 25  definitons and the typed data definitions."
 26  (:refer-clojure :exclude [defonce replace
 27                            bigint boolean char double float time])
 28  (:require (lobos [ast :as ast]))
 29  (:use (clojure [walk   :only [postwalk]]
 30                 [set    :only [union]]
 31                 [string :only [replace]])
 32        lobos.utils))
 33
 34(ast/import-all)
 35
 36;; -----------------------------------------------------------------------------
 37
 38;; ## Protocols
 39
 40(defprotocol Alterable
 41  "The Alterable protocol add the possibility of building alter
 42  statements from an object implementing it. *For internal use*."
 43  (build-alter-statement [this action db-spec]))
 44
 45(defprotocol Buildable
 46  "The Buildable protocol is currently used only by table elements.
 47  *For internal use*."
 48  (build-definition [this db-spec]))
 49
 50(defprotocol Creatable
 51  "The Creatable protocol add the possibility of building create
 52  statements from an object implementing it. *For internal use*."
 53  (build-create-statement [this db-spec]))
 54
 55(defprotocol Dropable
 56  "The Dropable protocol add the possibility of building drop
 57  statements from an object implementing it. *For internal use*."
 58  (build-drop-statement [this behavior db-spec]))
 59
 60;; -----------------------------------------------------------------------------
 61
 62;; ## Common Exception
 63
 64(defn name-required
 65  "Throws an IllegalArgumentException when the given name is nil with a
 66  default message using the given type of elements."
 67  [name etype]
 68  (when-not name
 69    (throw (IllegalArgumentException.
 70            (format "A %s definition needs at least a name."
 71                    etype)))))
 72
 73;; -----------------------------------------------------------------------------
 74
 75;; ## Definition Predicate
 76
 77(defn definition?
 78  "Returns true if the given object is an abstract schema element
 79  definition. *For internal use*."
 80  [o]
 81  (isa? (type o) ::definition))
 82
 83;; -----------------------------------------------------------------------------
 84
 85;; ## Expression Definitions
 86
 87(def ^{:doc "A set of symbol representing SQL infix operators."}
 88  sql-infix-operators
 89  '#{;; math operators
 90     + - * /
 91     ;; boolean operators
 92     < > <= >= = != or and in like})
 93
 94(def ^{:doc "A set of symbol representing SQL prefix operators."}
 95  sql-prefix-operators
 96  '#{not})
 97
 98(def ^{:doc "A set of symbol representing SQL functions."}
 99  sql-functions
100  '#{;; string functions
101     length lower position replace str subs trim upper
102     ;; numeric functions
103     abs ceil floor mod
104     ;; datetime functions
105     extract now current_date current_time current_timestamp})
106
107(def sql-symbols
108  (union sql-infix-operators
109         sql-prefix-operators
110         sql-functions))
111
112(defrecord Expression [value]
113  Buildable
114
115  (build-definition [this db-spec]
116    (postwalk
117     #(do
118        (cond (vector? %)
119              (let [[f & n] %]
120                (if (keyword? f)
121                  (condp contains? (-> f name symbol)
122                    sql-infix-operators
123                    (OperatorExpression. db-spec f (first n) (next n))
124                    sql-prefix-operators
125                    (OperatorExpression. db-spec f nil n)
126                    sql-functions
127                    (FunctionExpression. db-spec f n))
128                  %))
129              (and (keyword? %)
130                   (not (contains? sql-symbols (-> % name symbol))))
131              (IdentifierExpression. db-spec % nil)
132              (not (keyword? %))
133              (ScalarExpression. db-spec %)
134              :else %))
135     value)))
136
137(defn expression?
138  "Returns true if the given object is an Expression."
139  [o]
140  (instance? Expression o))
141
142(defmacro expression [form]
143  `(Expression.
144    ~(postwalk
145      #(if (and (seq? %)
146                (sql-symbols (first %)))
147         (apply vector
148                (keyword (first %))
149                (rest %))
150         %)
151      form)))
152
153;; -----------------------------------------------------------------------------
154
155;; ## Index Definitions
156
157(defrecord Index [iname tname columns options]
158  Creatable Dropable
159
160  (build-create-statement [this db-spec]
161    (CreateIndexStatement. db-spec iname tname columns options))
162
163  (build-drop-statement [this behavior db-spec]
164    (DropStatement. db-spec :index iname nil {:tname tname})))
165
166(defn index?
167  "Returns true if the given object is an Index."
168  [o]
169  (instance? Index o))
170
171(defn index
172  "Constructs an index on the specified table and columns. Can take an
173  optional index name and a set of options of which only :unique is
174  available for now. This can be used inside or outside a table
175  definition, in the later case you just have to provide the name of the
176  table as a keyword."
177  {:arglists '([table name? columns & options])}
178  [table & args]
179  (let [tname (if (keyword? table) table (:name table))
180        [name args] (optional keyword? args)
181        [columns & options] args
182        name (or name (make-index-name tname
183                                       (or ((set options) :unique)
184                                           :index)
185                                       columns))]
186       (if (keyword? table)
187         (Index. name tname columns options)
188         (update-in table [:indexes] conj
189                    [name (Index. name tname columns options)]))))
190
191;; -----------------------------------------------------------------------------
192
193;; ## Constraint Definitions
194
195;; `Constraint` records are only used to define unspecified constraint.
196;; These type of constraints are useful with the alter drop action. They
197;; can be be construct using the `constraint` function.
198;; *For internal use*.
199(defrecord Constraint [cname]
200  Buildable
201
202  (build-definition [this db-spec]
203    (ConstraintDefinition. db-spec cname)))
204
205(defn constraint?
206  "Returns true if the given object is a Constraint."
207  [o]
208  (instance? Constraint o))
209
210(defn constraint
211  "Constructs an unspecified abstract constraint definition and add it
212  to the given table. To be used with alter action while dropping a
213  constraint."
214  [table name]
215  (update-in table [:constraints] conj
216             [name (Constraint. name)]))
217
218;; `UniqueConstraint` records can be constructed using the `primary-key` or
219;; `unique` functions. It can represent either a unique or primary key
220;; constraint. *For internal use*.
221(defrecord UniqueConstraint [cname ctype columns]
222  Buildable
223
224  (build-definition [this db-spec]
225    (UniqueConstraintDefinition.
226     db-spec
227     cname
228     ctype
229     columns)))
230
231(defn unique-constraint
232  "Constructs an abstract unique (or primary-key depending on the given
233  type) constraint definition and add it to the given table."
234  [table name type column-names]
235  (let [name (or name (make-index-name table type column-names))]
236    (update-in table [:constraints] conj
237               [name (UniqueConstraint. name type (vec column-names))])))
238
239(defn primary-key
240  "Constructs an abstract primary key constraint definition and add it
241  to the given table. If the name isn't specified, this constraint will
242  be named using its specification."
243  ([table column-names] (primary-key table nil column-names))
244  ([table name column-names]
245     (unique-constraint table name :primary-key column-names)))
246
247(defn unique
248  "Constructs an abstract unique constraint definition and add it to the
249  given table. If the name isn't specified, this constraint will
250  be named using its specification."
251  ([table column-names] (unique table nil column-names))
252  ([table name column-names]
253     (unique-constraint table name :unique column-names)))
254
255;; `ForeignKeyConstraint` record can be constructed using the
256;; `foreign-key` function. *For internal use*.
257(defrecord ForeignKeyConstraint
258  [cname columns parent-table parent-columns match triggered-actions]
259  Buildable
260
261  (build-definition [this db-spec]
262    (ForeignKeyConstraintDefinition.
263     db-spec
264     cname
265     columns
266     parent-table
267     parent-columns
268     match
269     triggered-actions)))
270
271(defn foreign-key
272  "Constructs an abstract foreign key constraint definition and add it
273  to the given table. The `columns` and `parent-table` arguments must be
274  specified. If no `parent-columns` are specified, the `columns` will be
275  used in its place.
276
277  The `match` optional argument can be one of `:full`, `:partial` or
278  `:simple`, but note that this isn't supported by most databases.
279
280  You can specify `triggered-actions` with pairs of keyword, the first
281  of the pairs must be one of `:on-delete` or `:on-update`, while the
282  second one can be one of `:cascade`, `:set-null`, `:restrict`,
283  `:set-default` or `:no-action`. The actions keywords are directly
284  translated to SQL keywords, so you can specify custom ones if the
285  database you're using provide more.
286
287  If the name isn't specified, this constraint will be named
288  using its specification."
289  {:arglists '([table name? column-names parent-table
290                parent-column-names? match? & triggered-actions])}
291  [table & args]
292  (let [[constraint-name args] (optional keyword? args)
293        columns                (first args)
294        parent-table           (second args)
295        args                   (nnext args)
296        [parent-columns args]  (optional vector? args)
297        parent-columns         (or parent-columns columns)
298        [match args]           (optional #{:full :partial :simple} args)
299        triggered-actions      (apply hash-map args)
300        constraint-name        (or constraint-name
301                                   (make-index-name table "fkey" columns))]
302    (update-in table [:constraints] conj
303               [constraint-name
304                (ForeignKeyConstraint. constraint-name
305                                       columns
306                                       parent-table
307                                       parent-columns
308                                       match
309                                       triggered-actions)])))
310
311;; `CheckConstraint` record can be constructed using the
312;; `check` macro or the `chech*` function. *For internal use*.
313(defrecord CheckConstraint
314  [cname condition]
315  Buildable
316
317  (build-definition [this db-spec]
318    (CheckConstraintDefinition.
319     db-spec
320     cname
321     (build-definition condition db-spec))))
322
323(defn check*
324  "Constructs an abstract check constraint definition and add it to the
325  given table. The `constraint-name` argument is mandatory."
326  [table constraint-name condition]
327  (name-required constraint-name "check constraint")
328  (update-in table [:constraints] conj
329             [constraint-name
330              (CheckConstraint. constraint-name
331                                condition)]))
332
333(defmacro check
334  "Constructs an abstract check constraint definition and add it to the
335  given table."
336  [table constraint-name condition]
337  `(check*
338    ~table
339    ~constraint-name
340    (expression ~condition)))
341
342;; -----------------------------------------------------------------------------
343
344;; ## Data-type Definition
345
346;; `DataType` records can be constructed using the `data-type` function.
347;; *For internal use*.
348(defrecord DataType [name args options])
349
350(defn data-type?
351  "Returns true if the given object is a DataType."
352  [o]
353  (instance? DataType o))
354
355(defn data-type
356  "Constructs an abstract data-type definition using the given keyword
357  `name`. Can also take an options list of arguments (`args`) and
358  `options`."
359  [name & [args options]]
360  (check-valid-options options :encoding :collate :time-zone)
361  (update-options
362   (DataType. name (vec args) {})
363   options))
364
365;; -----------------------------------------------------------------------------
366
367;; ## Column Definition
368
369(defn datetime-now-alias
370  "If the given default value, it will be replaced by the standard
371  function returning the current time, date or timestamp depending on
372  the specified data-type. *For internal use*."
373  [name default]
374  (let [value (:value default)]
375    (if (= value [:now])
376      (Expression.
377       (or ({:date [:current_date]
378             :time [:current_time]
379             :timestamp [:current_timestamp]} name) value))
380      default)))
381
382;; `Column` records can be constructed using the `column` function or
383;; the more specific typed column functions. The `build-definition`
384;; method will create the appropriate `DataTypeClause` for data-type
385;; definitions and `*Expression` AST for default values.
386;; *For internal use*.
387(defrecord Column [cname data-type default auto-inc not-null others]
388  Buildable
389
390  (build-definition [this db-spec]
391    (let [{:keys [name args options]} data-type]
392      (ColumnDefinition.
393       db-spec
394       cname
395       (when data-type
396         (DataTypeClause. db-spec name args options))
397       (if (= default :drop)
398         :drop
399         (when default
400           (build-definition
401            (datetime-now-alias name default)
402            db-spec)))
403       (when auto-inc (AutoIncClause. db-spec))
404       not-null
405       others))))
406
407(defn column?
408  "Returns true if the given object is a Column."
409  [o]
410  (instance? Column o))
411
412(defmacro default [form]
413  `[:default (expression ~form)])
414
415(defn column*
416  "Constructs an abstract column definition. It'll parse the column
417  specific options. See the `column` function for more details.
418  *For internal use*."
419  [column-name data-type options]
420  (let [[map-entries others] (separate vector? (filter identity options))
421        [kw-options  others] (separate keyword? others)
422        {:keys [default encoding collate] :as option-map}
423        ;; HACK: trying to get refer option, but it's not a map entry and
424        ;; it's actually consumed by `column`, will clean up later.
425        (into {} (map (fn [[f & r]] [f (first r)]) map-entries))
426        option-set (set kw-options)
427        data-type (update-options data-type
428                                  (assoc (select-keys option-map
429                                                      [:encoding
430                                                       :collate])
431                                    :time-zone (option-set :time-zone)))
432        not-null   (when (:null option-set) false)
433        not-null   (if (and (nil? not-null) (:not-null option-set)) true not-null)
434        auto-inc   (when (:auto-inc option-set) true)]
435    (name-required column-name "column")
436    (check-valid-options (into option-set (keys option-map))
437                         :null :not-null :auto-inc :default :primary-key :unique
438                         :encoding :collate :time-zone :refer)
439    (Column. column-name
440             data-type
441             default
442             auto-inc
443             not-null
444             others)))
445
446(defn column
447  "Constructs an abstract column definition and add it to the given
448  table. Also creates and add the appropriate column constraints when
449  these are specified as options. Here's a list of available options:
450
451   * `:unique` which construct an unique constraint on that column
452   * `:primary-key` which make the current column the primary key
453   * `[:refer tname & options]` which add a foreign key constraint to
454     the specified table. The options are the same as the `foreign-key`
455     function with the exception that you can specify only one parent
456     column.
457   * `:null` allow null values
458   * `:not-null` prevents this column from being null
459   * `:auto-inc` (for integers types) which makes it auto-populated with
460     incremented integers
461   * `[:encoding enc]` (for character types) determines which encoding to
462     use if supported by the database. Also see the natianal character types.
463   * `[:collate type]` (for character types) determines how equality is
464     handled
465   * `:time-zone` (for time types) determines if the type includes a time-zone
466
467  It also can be used in alter modify and rename actions. In that
468  case, if data-type is :to, it acts as a column rename clause and if
469  data-type is :drop-default, it acts as a column drop default clause."
470  {:arglists '([table column-name data-type? & options])}
471  [table column-name & options]
472  (let [[data-type options] (optional #(instance? DataType %) options)
473        reference? #(and (vector? %) (= (first %) :refer))
474        [ptable pcol & others] (->> options (filter reference?) first next)
475        options (filter (comp not reference?) options)
476        option-set (when (seq? options) (set options))
477        add-constraint #(cond (:primary-key option-set)
478                              (primary-key % [column-name])
479                              (:unique option-set)
480                              (unique % [column-name])
481                              ptable
482                              (apply foreign-key % [column-name] ptable
483                                     (when pcol [pcol]) others)
484                              :else %)]
485    (add-constraint
486     (update-in table [:columns] conj
487                [column-name
488                 (case (first options)
489                   :to (Column. column-name nil nil nil nil (second options))
490                   :drop-default (Column. column-name nil :drop nil nil [])
491                   (column* column-name data-type options))]))))
492
493;; -----------------------------------------------------------------------------
494
495;; ## Typed Column Definitions
496
497;; Instead of calling the `column` option directly and including the
498;; data-type argument, you can use typed column definition in which case
499;; each types have their own functions.
500
501;; ### Typed Column Helpers
502
503(defn def-typed-columns*
504  "Helper for macros that create typed columns definitions. It takes a
505  sequence of names and define a function for each of them, a vector of
506  arguments for those functions, `dargs` must specify how to handle
507  these arguement and `options` must specify the generic column options.
508  The optional `docs` arguement is appended to the generic docstring.
509  *For internal use*."
510  [names args dargs options & [docs]]
511  `(do
512     ~@(for [n names]
513         `(defn ~n
514            ~(format (str "Constructs an abstract %s column definition and"
515                          " add it to the given table." docs)
516                     (name n))
517            ~args
518            (let [dargs# ~dargs
519                  options# ~options]
520              (apply column
521                     ~'table
522                     ~'column-name
523                     (data-type ~(keyword n) dargs#)
524                     options#))))))
525
526(defmacro def-simple-typed-columns
527  "Defines typed columns for simple data-types taking no arguments.
528  *For internal use*."
529  [& names]
530  (def-typed-columns*
531    names
532    '[table column-name & options]
533    '[]
534    'options))
535
536(defmacro def-numeric-like-typed-columns
537  "Defines numeric-like typed columns. These typed column funcitons can
538  take an optional `precision` and `scale` argument. *For internal use*."
539  [& names]
540  (def-typed-columns*
541    names
542    '[table column-name & [precision scale & options]]
543    '(-> []
544         (conj-when (integer? precision) precision)
545         (conj-when (integer? scale) scale))
546    '(-> options
547         (conj-when (not (integer? precision)) precision)
548         (conj-when (not (integer? scale)) scale))
549    " Takes an optional `precision` and `scale` arguments."))
550
551(defmacro def-optional-precision-typed-columns
552  "Defines typed columns with optional precision. Used by `float` and
553  time data-types. *For internal use*."
554  [& names]
555  (def-typed-columns*
556    names
557    '[table column-name & [precision & options]]
558    '(conj-when [] (integer? precision) precision)
559    '(conj-when options (not (integer? precision)) precision)
560    " Takes an optional `precision` argument."))
561
562(defmacro def-optional-length-typed-columns
563  "Defines optionally length-bounded typed columns. Used by binary and
564  character types. *For internal use*."
565  [& names]
566  (def-typed-columns*
567    names
568    '[table column-name & [length & options]]
569    '(conj-when [] (integer? length) length)
570    '(conj-when options (not (integer? length)) length)
571    " Takes an optional `length` argument."))
572
573(defmacro def-length-bounded-typed-columns
574  "Defines length-bounded typed columns. Used by variable binary and
575  character types. *For internal use*."
576  [& names]
577  (def-typed-columns*
578    names
579    '[table column-name length & options]
580    '(conj-when [] (integer? length) length)
581    '(conj-when options (not (integer? length)) length)
582    " The `length` arguemnt is mandatory."))
583
584;; ### Numeric Types
585
586(def-simple-typed-columns
587  smallint
588  integer
589  bigint)
590
591(def-numeric-like-typed-columns
592  numeric
593  decimal)
594
595(def-simple-typed-columns
596  real
597  double-precision)
598
599(def double double-precision)
600
601(def-optional-precision-typed-columns
602  float)
603
604;; ### Character Types
605
606(def-optional-length-typed-columns
607  char
608  nchar
609  clob
610  nclob)
611
612(def text clob)
613
614(def ntext nclob)
615
616(def-length-bounded-typed-columns
617  varchar
618  nvarchar)
619
620;; ### Binary Types
621
622(def-optional-length-typed-columns
623  binary
624  blob)
625
626(def-length-bounded-typed-columns
627  varbinary)
628
629;; ### Boolean Type
630
631(def-simple-typed-columns
632  boolean)
633
634;; ### Data/time Types
635
636(def-simple-typed-columns
637  date)
638
639(def-optional-precision-typed-columns
640  time
641  timestamp)
642
643;; -----------------------------------------------------------------------------
644
645;; ## Table Definition
646
647(defn- build-table-elements [db-spec method & elements]
648  (->> (apply concat elements)
649       (map #(when (second %)
650               (method (second %) db-spec)))
651       (filter identity)))
652
653;; `Table` records can be constructed using the `table*` function or
654;; the `table` macro. *For internal use*.
655(defrecord Table [name columns constraints indexes]
656  Alterable Creatable Dropable
657
658  (build-alter-statement [this action db-spec]
659    (let [elements (build-table-elements db-spec
660                                         build-definition
661                                         columns
662                                         constraints)]
663      (for [element elements]
664        (AlterTableStatement.
665         db-spec
666         name
667         action
668         element))))
669
670  (build-create-statement [this db-spec]
671    (conj
672     (build-table-elements db-spec build-create-statement indexes)
673     (CreateTableStatement.
674      db-spec
675      name
676      (build-table-elements db-spec build-definition columns constraints))))
677
678  (build-drop-statement [this behavior db-spec]
679    (DropStatement. db-spec :table name behavior nil)))
680
681(defn table?
682  "Returns true if the given object is a Table."
683  [o]
684  (instance? Table o))
685
686(defn table*
687  "Constructs an abstract table definition. The `table-name` is
688  mandatory."
689  [name & [columns constraints indexes]]
690  (name-required name "table")
691  (Table. name
692          (or columns {})
693          (or constraints {})
694          (or indexes {})))
695
696(defmacro table
697  "Constructs an abstract table definition containing the given
698  elements."
699  [name & elements]
700  `(-> (table* ~name) ~@(reverse elements)))
701
702;; -----------------------------------------------------------------------------
703
704;; ## Schema Definition
705
706;; `Schema` records can be constructed using the `schema` function.
707;; *For internal use*.
708(defrecord Schema [sname tables indexes options]
709  Creatable Dropable
710
711  (build-create-statement [this db-spec]
712    (CreateSchemaStatement.
713     db-spec
714     sname
715     (flatten
716      (map #(build-create-statement (second %) db-spec)
717           (concat tables indexes)))))
718
719  (build-drop-statement [this behavior db-spec]
720    (DropStatement. db-spec :schema sname behavior nil)))
721
722(defn schema?
723  "Returns true if the given object is a Schema."
724  [o]
725  (instance? Schema o))
726
727(defn- filtered-elements->map
728  [pred elements]
729  (into (sorted-map)
730        (map #(vector (:name %) %)
731             (filter pred elements))))
732
733(defn schema
734  "Constructs an abstract schema definition."
735  {:arglists '([schema-name options? & elements])}
736  [schema-name & args]
737  (name-required schema-name "schema")
738  (let [[options elements] (optional (comp not definition?) args)]
739    (Schema.
740     schema-name
741     (filtered-elements->map table? elements)
742     (filtered-elements->map index? elements)
743     (or options {}))))
744
745;; -----------------------------------------------------------------------------
746
747;; ## Definitions Hierarchy
748
749;; The definition hierarchy makes it easy to test if an object represent
750;; an abstract schema element definition. See the `definition?`
751;; predicate.
752(derive Index                ::definition)
753(derive Constraint           ::definition)
754(derive UniqueConstraint     ::definition)
755(derive ForeignKeyConstraint ::definition)
756(derive CheckConstraint      ::definition)
757(derive DataType             ::definition)
758(derive Column               ::definition)
759(derive Table                ::definition)
760(derive Schema               ::definition)