Source

Lein-LB / src / leiningen / lb.clj

Full commit
shantanuk 751b803 
Shantanu Kumar 5d59e58 













shantanuk 751b803 
Shantanu Kumar 5d59e58 



shantanuk 751b803 


Shantanu Kumar 5d59e58 







Shantanu Kumar db41939 
shantanuk 751b803 
Shantanu Kumar 5d59e58 
Shantanu Kumar b3f21c8 






shantanuk 751b803 

Shantanu Kumar 5d59e58 



shantanuk 5c4c0c4 

Shantanu Kumar 5d59e58 



shantanuk 5c4c0c4 
shantanuk 751b803 
Shantanu Kumar 5d59e58 











shantanuk 751b803 

Shantanu Kumar 5d59e58 



shantanuk 751b803 
Shantanu Kumar 5d59e58 



































































































Shantanu Kumar db41939 


Shantanu Kumar 5d59e58 



























































shantanuk 5c4c0c4 
Shantanu Kumar 5d59e58 





























































































































shantanuk 751b803 

Shantanu Kumar db41939 



























shantanuk 751b803 

Shantanu Kumar 5d59e58 






































shantanuk 751b803 
Shantanu Kumar db41939 
Shantanu Kumar 5d59e58 
shantanuk 751b803 
Shantanu Kumar 5d59e58 
shantanuk 751b803 
Shantanu Kumar 5d59e58 





Shantanu Kumar db41939 

Shantanu Kumar 5d59e58 
Shantanu Kumar db41939 






Shantanu Kumar 5d59e58 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
(ns leiningen.lb
  (:import
    (java.util.regex Pattern)
    (javax.sql       DataSource))
  (:require
    [clojure.java.io :as io]
    [clojure.string  :as sr]
    [clojure.pprint  :as pp]
    [org.bituf.clj-miscutil  :as mu]
    [org.bituf.clj-dbcp      :as cp]
    [org.bituf.clj-dbspec    :as sp]
    [org.bituf.clj-liquibase :as lb]
    [org.bituf.clj-liquibase.change :as ch])
  (:use
    [leiningen.compile   :only [eval-in-project]]))


(def ^{:doc "Version of Lein-LB plugin"}
      version [0 2])


(defn help
  []
  (println "The following commands are available
help       - Shows this help screen
version    - Shows version information
dbcp-props - Prints a sample `clj-dbcp.properties` file
update     - Updates the database
rollback   - Rolls back database
tag        - Tags the database
dbdoc      - Generates documentation for database/changelogs
diff       - Reports differences between two database instances

For help on individual command, append with `--help`, e.g.:
lein lb update --help

If this is the first time you are running Lein-LB for the project
you will want to run `lein lb dbcp-props` and save the output to a
file called `clj-dbcp.properties` in current directory or in the
classpath root (e.g. together with the source code) and modify it
to suit your environment (as and when required.)"))


(defn ^String as-string
  [s]
  (if (keyword? s) (name s)
    (str s)))


(defn opt?
  [^String s] {:pre [(string? s)]}
  (some #(re-matches % s) [(re-pattern "--.+")
                           (re-pattern "-.+")]))


(defn opt-string
  ([^String elem] {:post [(string? %)]
                   :pre  [(string? elem)]}
    (format (if (> (count elem) 1)
              "--%s"
              "-%s")
      elem))
  ([^String elem ^String value]
    (format (if (> (count elem) 1)
              "--%s=%s"
              "-%s%s")
      elem value)))


(defn opt-pattern
  [^String elem] {:post [(instance? Pattern %)]
                  :pre  [(string? elem)]}
  (re-pattern (opt-string elem "(.*)")))


(defn opt-value
  "Return option value
  Example:
    (opt-value (opt-pattern \"foo\") \"--foo=bar\")
    => returns \"bar\"
  See also: opt-pattern"
  [^Pattern re ^String arg]
  (second (re-matches re arg)))


(defn noarg-pattern
  [^String elem] {:pre [(string? elem)]}
  (re-pattern (format (if (> (count elem) 1)
                        "--%s"
                        "-%s")
                elem)))


(def arg-types #{:with-arg :opt-arg :no-arg})


(defn print-usage
  "Print command usage"
  [cmd-prefix spec]
  (println "Usage: " cmd-prefix "<options>\n")
  (mu/print-table
    ["Option" "Must" "Description"]
    (map (fn [row]
           (let [[desc opt-type & keywds] row
                  takes-arg (contains? #{:with-arg :opt-arg} opt-type)
                  ks (map #(if takes-arg
                             (opt-string (as-string %) "<Val>")
                             (opt-string (as-string %)))
                       keywds)]
              [(mu/comma-sep-str ks)
               (if (= :with-arg opt-type) "Yes" "...")
               desc]))
      spec))
  (println))


(defn parse-opts
  "Spec can be:
    [[docstring :opt-arg :profile  :p]
     [docstring :no-arg  :sql-only :s]
     [docstring :with-arg :a]]
  `args` is a collection of argument bodies:
    \"--foo=bar\" \"-fbar\" \"--simulate\" \"-s\"
  Note: Evaluated every time"
  [cmd-prefix args & spec]
  {:post [(map? %)]
   :pre  [(coll? spec)                   ; spec is a collection
          (every? coll? spec)            ; spec is a collection of collections
          (every? #(> (count %) 2) spec) ; each sub-coll must be 2 elements or more
          (every? #(string? (first %)) spec)              ; 1st elem is a docstring
          (every? #(contains? arg-types (second %)) spec) ; 2nd elem is a valid arg-type
          ]}
  (let [spec-opts  (map #(map as-string (drop 2 %)) spec)
        rev-opts   (->> spec-opts
                     (map (fn [opt-row]
                            (let [sentinel (keyword (first opt-row))]
                              (map #(array-map % sentinel) opt-row))))
                     flatten
                     (reduce into))
        ;;
        with-arg (map (partial drop 2)    (filter #(= (second %) :with-arg) spec))
        opt-arg  (map (partial drop 2)    (filter #(= (second %) :opt-arg)  spec))
        no-arg   (map (partial drop 2)    (filter #(= (second %) :no-arg)   spec))
        ;; fn to convert arg into map entries
        get-opts (fn [acc arg] {:post [(map? %)] :pre  [(map? acc)
                                                        (string? arg)]}
                   (or
                     ;; with-arg and opt-arg
                     (some (fn [row]
                             (some #(let [v (-> %
                                              as-string
                                              opt-pattern
                                              (opt-value arg))]
                                      (and v
                                        (into acc
                                          {(get rev-opts (as-string %)) v})))
                               row))
                       (into with-arg opt-arg))
                     ;; no-arg
                     (some (fn [row]
                             (some (fn [opt]
                                     (if (opt? arg)
                                       (if (re-matches (noarg-pattern
                                                         (as-string opt)) arg)
                                         (into acc
                                           {(get rev-opts (as-string opt)) nil}))
                                       (if (contains? acc :more)
                                         {:more [arg]})))
                               row))
                       no-arg)
                     ;; special or bad args
                     (if (some #(= arg %) ["--help" "-h" "/?"])
                       (do (print-usage cmd-prefix spec)
                         {:help nil})
                       (into acc :more (cons arg (:more acc))))
                     (throw (IllegalArgumentException.
                              (str "Illegal option: " arg)))))]
    (let [opt-map   (reduce get-opts {} args)
          with-arg? (fn []
                      (every? (fn [row]
                                (some (fn [opt]
                                        (some #(re-matches
                                                 (opt-pattern (as-string opt))
                                                 (as-string %))
                                          args))
                                  row))
                        with-arg))]
      (cond
        ;; ignore validations if help was sought
        (contains?
          opt-map :help)  opt-map
        ;; ensure that `with-arg` options are supplied
        (not (with-arg?)) (let [optfn #(let [x (as-string %)]
                                         (if (> (count x) 1)
                                           (str "--" x) (str "-" x)))
                                optsr #(format "Either of %s\n"
                                         (mu/comma-sep-str (map optfn %)))]
                            (throw (IllegalArgumentException.
                                     (str "Must supply the following:\n"
                                       (apply str (map optsr with-arg))))))
        :else             opt-map))))


(defn resolve-var
  "Given a qualified/un-qualified var name (string), resolve and return value.
  Throw NullPointerException if var cannot be resolved."
  [^String var-name] {:pre [(string? var-name)]}
  @(let [tokens (sr/split var-name #"/")
         var-ns (first tokens)]
     (when (and (> (count tokens) 1)
             (not (find-ns (symbol var-ns))))
       (require (symbol var-ns)))
     (resolve (symbol var-name))))


(defn make-datasource
  "Given profile name (which could be nil for default), return DataSource"
  [profile] {:post [(instance? DataSource %)]
             :pre  [(or (nil? profile)
                      (string? profile))]}
  (if profile
    (cp/make-datasource-from-properties
      (cp/load-datasource-args profile))
    (cp/make-datasource-from-properties)))


(defn ctx-list
  "Generate context list from a given comma-separated context list (string)"
  [contexts] {:post [(vector? %)]
              :pre  [(or (nil? contexts)
                       (string? contexts))]}
  (if contexts
    (sr/split contexts #",")
    []))


(defn parse-update-args
  [& args]
  (parse-opts "lein lb update"
    args
    ["Changelog var name to apply update on"  :with-arg :changelog :c]
    ["Clj-DBCP profile name (or default)"     :opt-arg  :profile   :p]
    ["How many Changesets to apply update on" :opt-arg  :chs-count :n]
    ["Contexts (comma separated)"             :opt-arg  :contexts  :t]
    ["Only generate SQL, do not commit"       :no-arg   :sql-only  :s]))


(defn update
  [& args]
  (let [opt (apply parse-update-args args)]
    (when-not (contains? opt :help)
      (let [changelog  (resolve-var (:changelog opt))
            profile    (:profile   opt)
            chs-count  (:chs-count opt)
            contexts   (:contexts  opt)
            sql-only   (contains? opt :sql-only)]
        (sp/with-dbspec (cp/db-spec (make-datasource profile))
          (lb/with-lb
            (if chs-count
              (let [chs-num (Integer/parseInt chs-count)]
                (if sql-only
                  (lb/update-by-count changelog chs-num (ctx-list contexts) *out*)
                  (lb/update-by-count changelog chs-num (ctx-list contexts))))
              (if sql-only
                (lb/update changelog (ctx-list contexts) *out*)
                (lb/update changelog (ctx-list contexts))))))))))


(defn parse-rollback-args
  [& args]
  (parse-opts "lein lb rollback"
    args
    ["Changelog var name to apply rollback on"   :with-arg :changelog :c]
    ["Clj-DBCP profile name (or default)"        :opt-arg  :profile   :p]
    ["How many Changesets to rollback"           :opt-arg  :chs-count :n]
    ["Which tag to rollback to"                  :opt-arg  :tag       :g]
    ["Rollback ISO-date (yyyy-MM-dd'T'HH:mm:ss)" :opt-arg  :date      :d]
    ["Contexts (comma separated)"                :opt-arg  :contexts  :t]
    ["Only generate SQL, do not commit"          :no-arg   :sql-only  :s]))


(defn rollback
  [& args]
  (let [opt (apply parse-rollback-args args)]
    (when-not (contains? opt :help)
      (let [changelog  (resolve-var (:changelog opt))
            profile    (:profile   opt)
            chs-count  (:chs-count opt)
            tag        (:tag       opt)
            date       (:date      opt)
            c-t-d      [chs-count tag date] ; either of 3 is required
            contexts   (:contexts  opt)
            sql-only   (contains? opt :sql-only)]
        (when (not (= 1 (count (filter identity c-t-d))))
          (throw
            (IllegalArgumentException.
              (format
                "Expected only either of --chs-count/-n, --tag/-g and --date/-d
arguments, but found %s"
                (with-out-str (pp/pprint args))))))
        (sp/with-dbspec (cp/db-spec (make-datasource profile))
          (lb/with-lb
            (cond
              chs-count (let [chs-num (Integer/parseInt chs-count)]
                          (if sql-only
                            (lb/rollback-by-count changelog chs-num (ctx-list contexts) *out*)
                            (lb/rollback-by-count changelog chs-num (ctx-list contexts))))
              tag       (if sql-only
                          (lb/rollback-to-tag changelog tag (ctx-list contexts) *out*)
                          (lb/rollback-to-tag changelog tag (ctx-list contexts)))
              date      (if sql-only
                          (lb/rollback-to-date changelog (ch/iso-date date) (ctx-list contexts) *out*)
                          (lb/rollback-to-date changelog (ch/iso-date date) (ctx-list contexts)))
              :else     (throw
                          (IllegalStateException.
                            (format
                              "Neither of changeset-count, tag and date found to
roll back to: %s"
                              (with-out-str (pp/pprint args))))))))))))


(defn parse-tag-args
  [& args]
  (parse-opts "lein lb tag"
    args
    ["Clj-DBCP profile name (or default)" :opt-arg  :profile   :p]
    ["Tag name to apply"                  :with-arg :tag       :g]))


(defn tag
  "Tag the database manually (recommended: create a Change object of type tag)"
  [& args]
  (let [opt (apply parse-tag-args args)]
    (when-not (contains? opt :help)
      (let [profile   (:profile opt)
            tag       (:tag     opt)]
        (sp/with-dbspec (cp/db-spec (make-datasource profile))
          (lb/with-lb
            (lb/tag tag)))))))


(defn parse-dbdoc-args
  "Parse arguments for `dbdoc` command."
  [& args]
  (parse-opts "lein lb dbdoc"
    args
    ["Changelog var name to apply tag on"             :with-arg :changelog  :c]
    ["Clj-DBCP profile name (default if unspecified)" :opt-arg  :profile    :p]
    ["Output directory to generate doc files into"    :with-arg :output-dir :o]
    ["Contexts (comma separated)"                     :opt-arg  :contexts   :t]))


(defn dbdoc
  "Generate database/changelog documentation"
  [& args]
  (let [opt (apply parse-dbdoc-args args)]
    (when-not (contains? opt :help)
      (let [changelog (resolve-var (:changelog opt))
            profile   (:profile    opt)
            out-dir   (:output-dir opt)
            contexts  (:contexts   opt)]
        (sp/with-dbspec (cp/db-spec (make-datasource profile))
          (lb/with-lb
            (lb/generate-doc changelog out-dir (ctx-list contexts))))))))


(defn parse-diff-args
  "Parse arguments for `diff` command."
  [& args]
  (parse-opts "lein lb diff"
    args
    ["Clj-DBCP profile name (default if unspecified)" :opt-arg  :profile     :p]
    ["Reference Clj-DBCP profile name"                :with-arg :ref-profile :r]))


(defn diff
  "Report differences between two database instances"
  [& args]
  (let [opt (apply parse-diff-args args)]
    (when-not (contains? opt :help)
      (let [profile     (:profile     opt)
            ref-profile (:ref-profile opt)]
        ;; begin with reference DB profile
        (sp/with-dbspec
          (cp/db-spec (make-datasource ref-profile))
          (sp/with-connection
            sp/*dbspec*
            (let [ref-db (lb/make-db-instance (:connection sp/*dbspec*))]
              ;; go on to target DB profile
              (sp/with-dbspec (cp/db-spec (make-datasource profile))
                              (lb/with-lb
                                (lb/diff ref-db))))))))))


;; ----- Leiningen plugin command -----


(defn prepare-args
  [project ks sub-args] {:post [(vector? %)]
                         :pre  [(map? project)
                                (coll? sub-args)
                                (not (map? sub-args))]}
  (if (contains? project :lein-lb)
    (let [lein-lb (:lein-lb project)]
      (when (not (map? lein-lb))
        (throw (IllegalArgumentException.
                 "The :lein-lb key in project.clj must point to a map.")))
      (when (not (every? keyword? (keys lein-lb)))
        (throw (IllegalArgumentException.
                 "All keys in the map under :lein-lb must be keywords")))
      (when (not (every? #(or (string? %) (nil? %)) (vals lein-lb)))
        (throw (IllegalArgumentException.
                 "All values in the map under :lein-lb must be nil or string")))
      (into (vec (map (fn [[k v]]
                        (opt-string (as-string k) v))
                   (select-keys lein-lb ks)))
        sub-args))
    sub-args))


(defmacro eip
  [project & body]
  `(eval-in-project ~project
     (mu/! ~@body) (fn [& args#] (pp/pprint args#))))


(defn eip-fn
  [project f args ks] {:pre [(map? project)
                             (fn? f)
                             (coll? ks)
                             (coll? args)]}
  (mu/!
    (eip project (apply f (prepare-args project ks args)))))


(defn lb
  "Entry point for the Lein-LB plugin."
  [project & args]
  (let [argc (count args)
        cmd  (or (first args) "")]
    ;; check for lein-lb commands
    (case (sr/lower-case cmd)
      ""           (help)
      "help"       (help)
      "version"    (println (format "Lein-LB version %s"
                              (apply str (interpose "." version))))
      "dbcp-props" (println (slurp (io/resource "sample-clj-dbcp.properties")))
      "update"     (eip-fn project update   (rest args)
                           [:changelog :profile :chs-count :contexts :sql-only])
      "rollback"   (eip-fn project rollback (rest args)
                           [:changelog :profile :chs-count :tag :date :contexts :sql-only])
      "tag"        (eip-fn project tag      (rest args)
                           [:profile :tag])
      "dbdoc"      (eip-fn project dbdoc    (rest args)
                           [:changelog :profile :output-dir :contexts])
      "diff"       (eip-fn project diff     (rest args)
                           [:profile :ref-profile])
      (do
        (println (format "Invalid command: %s" cmd))
        (lb project "help")))))