A naive database migration library for Korma.

migration.clj

(ns example.migration
  (:require [example.table-util :as u]
            [korma.core :as k]))

;; We need a table to help us keep track of the schema version so
;; whenever we migrate or rollback we know where we are before
;; executing any migration code. 
;;
;; The `create-schema-migrations-table` function is called whenever a
;; migration or rollback is executed to make sure we have something to
;; read from and write to. 

(defn- create-schema-migrations-table
  "Create a schema_migrations table."
  [conn]
  (u/create-table :schema_migrations
    (k/database conn)
    (u/column :version :varchar {:width 255 :null true})))

;; While we could use Korma's defentity macro to create an entity for
;; our schema_migrations table, but we might run in to problems if there
;; are several connections open. By creating a function which takes a
;; connection as one of it's arguments we can ensure we create the
;; right entity for the right connection.
;;
;;   (get-schema-migrations-entity :e db/dev)
;;
;; There is one catch to this however. When binding the result of
;; `get-schema-migrations-entity` to a symbol we must make sure this
;; symbol is the same as the name we give the entity. This is because
;; the `select` and `insert` macros use their first argument, the
;; entity, to look up the table information. So the given the
;; expression: 
;;
;;   (let [m (get-schema-migrations-entity :foo db/dev)]
;;     (insert m (values {:version "10"}))
;;
;; will fail, or worse execute a query on the wrong table if it
;; exists.

(defn- get-schema-migrations-entity
  [name-k conn]
  (-> (k/create-entity name-k)
      (k/database conn)
      (k/table :schema_migrations)))

;; We then provide ourselves two functions which allow us to retrieve
;; and set the current schema version.

(defn- get-current-version
  [conn]
  (let [e (get-schema-migrations-entity :e conn)]
    (-> (k/select e) last :version)))

(defn- set-current-version
  [v conn]
  (let [e (get-schema-migrations-entity :e conn)]
    (k/insert e
      (k/values {:version v}))))

;; And finally we need a little boiler plate for creating, finding,
;; and adding migrations.

(def empty-migration
  {:db nil
   :version nil
   :up '()
   :down '()})

(defn make-migration
  "Create a migration."
  [version]
  (assoc empty-migration :version (name version)))

(def migrations (atom []))

(defn find-migration
  [{:keys [version db]}]
  (let [f #(and (= version (:version %))
                (= db (:db %)))]
    (first (filter f @migrations))))

(defn add-migration
  [migration]
  (let [m (find-migration migration)]
    (if m
      (let [i (.indexOf @migrations m)]
        (swap! migrations assoc-in [i] migration))
      (swap! migrations conj migration))))

;; ## The icing on the migrations cake

;; Migrations generally come in two pieces: "up" and "down". These
;; pieces contain the business logic for what to do when we migrate
;; the database "up" to the next version and "down" to a previous one.
;;
;; When we define a migration we want to ensure that we defer code
;; execution until the migration is actually run. To help us with this
;; we define two macros `up` and `down`. These macros store the
;; instructions in the migration map but ensure the code is not executed
;; when the macro is called by quoting it. 

(defmacro up
  "Add code to a migration to be executed during a forward (`migrate!`)
   migration."
  [migration & body]
  `(assoc ~migration :up '(do ~@body)))

(defmacro down
  "Add code to a migration to be executed during a backward (`rollback!`)
   migration."
  [migration & body]
  `(assoc ~migration :down '(do ~@body)))

;; With the `up` and `down` macros we can easily define `defmigration`
;; which basically creates a migration, associates the up and down
;; information, and then adds it to the set of migrations.
;;
;; It's important to note the order you define migrations in matters.
;; For this reason you should keep all of your migration code under
;; in the same namespace or, if you're placing them in separate
;; namespaces, pay close attention to the order you require/load them
;; in.

(defmacro defmigration
  "Create a new migration.

   ex: (defmigration version-1
         (up
          (u/create-table :bar))
         (down
          (u/drop-table :bar)))"
  [name up down]
  `(-> (make-migration (keyword '~name))
       ~up
       ~down
       add-migration))

(defn migrate!
  "Migrate the database to the lastest version."
  ([] (migrate! nil))
  ([conn] 
     (create-schema-migrations-table conn)
     (let [v (get-current-version conn)
           ms (if v
                (rest (drop-while #(not= (:version %) v) @migrations))
                @migrations)]
       (doseq [m ms]
         (eval (:up m))
         (set-current-version (:version m) conn)
         (println "Migrated to version" (:version m)))
       (get-current-version conn))))

(defn rollback!
  "Rollback the database to the previous version."
  ([] (rollback! nil))
  ([conn]
     (create-schema-migrations-table conn)
     (when-let [v (get-current-version conn)]
       (let [m (find-migration {:version v})]
         (do
           (eval (:down m))
           (if (= (:version m)
                  (:version (first @migrations)))
             (set-current-version nil conn)
             (let [m (last (take-while #(not= (:version %) v) @migrations))]
               (set-current-version (:version m) conn))))
         (println "Rolled back version" (:version m))))
     (get-current-version conn)))

(defn recreate!
  "Reset the database by rolling back to the null version and then
   migrating to the latest version."
  ([] (recreate! nil))
  ([conn]
     (let [ts (->> (k/exec-raw ["SHOW TABLES"] :results)
                   (mapcat vals))]
       (do
         (doseq [t ts] (u/drop-table t))
         (migrate!)))))

table.clj

(ns example.table-util
  (:require [clojure.string :as s]
            [korma.core :as k]))

;; # Column data types

(def ^{:doc "A set of numeric types recognized by MySQL."}
  numeric-types
  #{:bit :tinyint :bool :boolean :smallint :mediumint :int :integer
    :bigint :serial :float :double :double-precision :dec :decimal
    :fixed :numeric})

(def ^{:doc "A set of date types recognized by MySQL."}
  date-types
  #{:date :datetime :timestamp :time :year})

(def ^{:doc "A set of string types recognized by MySQL."}
  string-types
  #{:char :varchar :binary :varbinary :tinyblob :tinytext :blob :text
    :mediumblob :mediumtext :longblog :longtext :enum :set})

;; # Column flags

;; Given a column type and a value return an SQL column flag for use
;; with `create-table`. 
;; 
;; ex: (flag :order :asc)"
(defmulti flag (fn [t _] t))

(defmethod flag :width [_ v]
  (when v
    (format "(%s)" (if (sequential? v)
                     (if (some string? v)
                       (s/join "," (map #(format "\"%s\"" (str %)) v))
                       (s/join "," v))
                     (str v)))))

(defmethod flag :order [_ v]
  (condp = v
    :asc " ASC "
    :desc " DESC "
    ""))

(defmethod flag :null [_ v]
  (cond
   (nil? v) ""
   (false? v) " NOT NULL "
   :else " NULL "))

(defmethod flag :default [_ v]
  (when v
    (let [template (partial format " DEFAULT %s ")] 
      (if (string? v)
        (template (format "\"%s\"" v))
        (template (str v))))))

(defmethod flag :auto-increment [_ v]
  (when v " AUTO_INCREMENT "))

(defmethod flag :primary-key [_ v]
  (when v " PRIMARY KEY "))

(defmethod flag :uniqe-key [_ v]
  (when v " UNIQUE KEY "))

(defmethod flag :key [_ v]
  (when v " KEY "))

;; Numeric flags

(defmethod flag :unsigned [_ v]
  (when v " UNSIGNED "))

(defmethod flag :zerofill [_ v]
  (when v " ZEROFILL "))

;; String flags

(defmethod flag :binary [_ v]
  (when v " BINARY "))

(defmethod flag :ascii [_ v]
  (when v " ASCII "))

(defmethod flag :unicode [_ v]
  (when v " UNICODE "))

(defmethod flag :character-set [_ v]
  (when v (format " CHARACTER SET %s " (name v))))

(defmethod flag :collate [_ v]
  (when v (" COLLATE %s " (name v))))

(defmethod flag :default [_ _]
  "")

;; ## Table and column templates

(defn make-table
  [table action]
  {:table (name table)
   :action action
   :db nil
   :columns []
   :constraints []
   :options []})

(defn- parse-column-type
  [type opts]
  (condp = type
    :string      [:varchar (assoc opts :width 255)]
    :float       [:float (let [{:keys [precision scale]} opts]
                           (if (and precision scale)
                             (assoc opts :width [precision scale])
                             opts))]
    :primary-key [:integer (assoc opts :primary-key true)]
    :unique-key  [:integer (assoc opts :unique-key true)]
    :key         [:integer (assoc opts :key true)]
    [type opts]))

(defn- make-column
  [column type opts]
  (let [[type opts] (parse-column-type type opts)
        {:keys [width order null default auto-increment primary-key unique-key key
                unsigned zerofill
                binary ascii unicode character-set collate
                action]} opts]
    {:column column
     :type type 
     ;; The column action. Can be one of :add, :drop, or :change. A
     ;; value of nil is for rendering column syntax during a CREATE
     ;; TABLE statement.
     :action action
     ;; Data type flags
     :width width
     :order order 
     :null null
     ::default default ; Hack to work with multimethod
     :auto-increment auto-increment
     :primary-key primary-key
     :unique-key unique-key
     :key key
     ;; Numeric data type flags
     :unsigned unsigned
     :zerofill zerofill
     ;; String data type flags
     :binary binary
     :ascii ascii
     :unicode unicode
     :character-set character-set
     :collate collate
     }))

(defn- make-constraint
  [constraint opts]
  (let [{:keys [foreign-key references on-update on-delete action]} opts]
    {:constraint constraint
     :action action 
     :foreign-key foreign-key
     :references references
     :on-update on-update
     :on-delete on-delete}))

;; ## Table and column functions

(declare do-column
         render-table-statement
         render-statement-then-exec)

(defn- append-column [table name type opts]
  (update-in table [:columns] conj (make-column name type opts)))

(defn- append-constraint [table name opts]
  (update-in table [:constraints] conj (make-constraint name opts)))

(defn add-column
  ([table name type]
     (append-column table name type {}))
  ([table name type opts]
     (append-column table name type (assoc opts :action :add))))

(defn drop-column
  [table name]
  (append-column table name nil {:action :drop}))

(def remove-column drop-column)

;; TODO: Implement change-column

(defn add-constraint
  [table name opts]
  (append-constraint table name (assoc opts :action :add)))

(defn constraint
  [table name opts]
  (append-constraint table name opts))

(defn column
  "Given a table, column name, a column type, and a map of options
   return a vector column spec for use in a `CREATE TABLE` query.

   ex: (column table :score :float {:precision 4 :scale 2})"
  ([table name type]
     (append-column table name type {}))
  ([table name type opts]
     (append-column table name type opts)))

(defmacro create-table*
  "Given a table name and columns specs, render a `CREATE TABLE`
   statement but do not execute it."
  [table & columns]
  `(-> (make-table '~table :create) ~@columns render-table-statement))

(defmacro create-table
  "Given a table name and columns specs, render and run a `CREATE TABLE`
   statement.
 
   ex: (create-table :users
         (k/database db/dev)
         (column :id :primary-key)
         (column :email :string))"
  [table & columns]
  (if (seq columns)
    (render-statement-then-exec table columns :create)
    (throw (IllegalArgumentException. "At least one column must be given."))))

(defn drop-table*
  "Given a table render a `DROP TABLE` statement but do not execute it."
  [table]
  (format "DROP TABLE IF EXISTS %s" (name table)))

(defn drop-table
  "Given a table render and execute a `DROP TABLE` statement."
  [table]
  (k/exec-raw [(drop-table* table)]))

(defmacro alter-table*
  [table & columns]
  `(-> (make-table '~table :alter) ~@columns render-table-statement))

(defmacro alter-table
  [table & columns]
  (if (seq columns)
    (render-statement-then-exec table columns :alter)
    (throw (IllegalArgumentException. "At least one column must be given."))))

;; ## Rendering

(defn- column-action [a]
  (condp = a
    :add "ADD COLUMN "
    :drop "DROP COLUMN "
    :change "CHANGE COLUMN "
    ""))

(defn- column-flags [c]
  (let [num-flag (when (numeric-types (:type c))
                  [:unsigned :zerofill])
        str-flag (when (string-types (:type c))
                   (cond 
                    (:binary c)  :binary 
                    (:ascii c)   :ascii 
                    (:unicode c) :unicode))
        key-flag (cond
                  (:primary-key c) :primary-key
                  (:uniqe-key c)   :uniqe-key
                  (:key c)         :key)
        flags `[:width ~str-flag ~@num-flag :order :null ::default :auto-increment ~key-flag]]
    (s/join (map #(flag % (c %)) flags))))

;; Column rendering

(defn- ->column [c]
  (let [action (:action c)
        column-name (name (:column c))
        column-type (-> (:type c)
                        (name)
                        (s/upper-case)
                        (s/replace "-" " "))
        base (partial str (column-action action) column-name)] 
    (if (= :drop action)
      (base)
      (base " " column-type (column-flags c)))))

;; Constraint rendering

(defn- constraint-action [c]
  (let [constraint (-> c :constraint name)
        action (if (= :add (:action c))
                 "ADD CONSTRAINT" 
                 "CONSTRAINT")]
    (format "%s %s " action constraint)))

(defn- constraint-fk [c]
  (when-let [fk (:foreign-key c)]
    (format "FOREIGN KEY (%s) " (name fk))))

(defn- constraint-ref [c]
  (when-let [[table column] (:references c)]
    (format "REFERENCES %s(%s) " (name table) (name column))))

(defn- constraint-on-flags [c]
  (let [on-flag (fn [v]
                  (condp = v
                    :restrict "RESTRICT"
                    :cascade "CASCADE"
                    :set-null "SET NULL"
                    "NO ACTION"))
        update-flag (on-flag (:on-update c))
        delete-flag (on-flag (:on-delete c))]
    (format "ON UPDATE %s ON DELETE %s" update-flag delete-flag)))

(defn- ->constraint [c]
  (let [f (juxt constraint-action
                constraint-fk
                constraint-ref
                constraint-on-flags)]
    (apply str (f c))))

(defn render-table-statement [{:keys [table action columns constraints]}]
  (letfn [(columns-and-constraints []
            (let [cs-1 (map ->column columns)
                  cs-2 (map ->constraint constraints)]
              (s/join ", " (concat cs-1 cs-2))))]
    (case action
      :create (format "CREATE TABLE IF NOT EXISTS %s (%s)" table (columns-and-constraints))
      :alter (format "ALTER TABLE %s %s" table (columns-and-constraints))
      :drop (format "DROP TABLE IF EXISTS %s" table))))

(defn render-statement-then-exec [table columns action]
  `(let [table-spec# (-> (make-table '~table ~action)
                         ~@columns)
         conn# (:db table-spec#)
         query# [(render-table-statement table-spec#)]]
     (if conn#
       (k/exec-raw conn# query#)
       (k/exec-raw query#))))

usage.clj

;; Example useage

(defmigration version-1
  (up
   (create-table :sport
     (database db/dev)
     (column :id :primary-key {:null false, :auto-increment true})
     (column :name :string)
     (column :slug :string)))
  (down
   (drop-table :sport)))

(defmigration version-2
  (up
   (create-table :position
     (database db/dev)
     (column :id :primary-key {:null false, :auto-increment true})
     (column :sport_id :integer)
     (column :name :string)
     (column :abbreviation :string)
     (constraint :FK_position_sport_id
                 {:foreign-key :sport_id, :references [:sport :id]})))
  (down
   (drop-table :position)))

(migrate!)