Support configurable ALGORITHM and LOCK in generated migrations

doc/_cli-options.md

@@ -19,10 +19,12 @@
   -now <YYYYMMDDHHMMSS>                            Pin the migration id timestamp (default: current clock); ids are <timestamp>_<descriptive_name>
   -max-migration-id-length <N>                     Limit generated migration ids to N characters (default: no limit)
   -ddl-as-migration                                Write new tables as CREATE TABLE migrations instead of plain schema DDL
+  -alter-algorithm default|instant|inplace|copy    Add ALGORITHM policy to generated ALTER TABLE statements (MySQL and TiDB only)
+  -alter-lock default|none|shared|exclusive        Add LOCK policy to generated ALTER TABLE statements (MySQL only)
 
  Dialect and checks:
   -dialect mysql|postgresql|sqlite|tidb            Set SQL dialect. Queries can only use its features
-  -no-check {all|<feature>{,<feature>}+}           Disable dialect feature checks (possible features: collation|join_on_subquery|create_table_as_select|on_duplicate_key|on_conflict|straight_join|lock_in_share_mode|fulltext_index|unsigned_types|autoincrement|replace_into|row_locking|default_expr|ttl|cached_table|alter_column|user_defined_type|extension)
+  -no-check {all|<feature>{,<feature>}+}           Disable dialect feature checks (possible features: collation|join_on_subquery|create_table_as_select|on_duplicate_key|on_conflict|straight_join|lock_in_share_mode|fulltext_index|unsigned_types|autoincrement|replace_into|row_locking|default_expr|ttl|cached_table|alter_column|alter_algorithm|alter_lock|user_defined_type|extension)
   -allow-write-notnull-null                        Accept writing a nullable value into a NOT NULL column, instead of failing (MySQL, TiDB and SQLite only)
 
  Generated header:

lib/dialect.ml

@@ -32,6 +32,8 @@ type feature =
   | Ttl [@as "ttl"]
   | CachedTable [@as "cached_table"]
   | AlterColumn [@as "alter_column"]
+  | AlterAlgorithm [@as "alter_algorithm"]
+  | AlterLock [@as "alter_lock"]
   | UserDefinedType [@as "user_defined_type"]
   | Extension [@as "extension"]
 [@@deriving show { with_path = false }, enumerate, to_string, of_string]
@@ -152,6 +154,11 @@ let get_alter_column (change : Sql.Alter_column_pg.t) pos =
   | Set_type _ | Set_not_null | Drop_not_null -> only AlterColumn [PostgreSQL] pos
   | Set_default | Drop_default -> only AlterColumn [MySQL; PostgreSQL; TiDB] pos
 
+let get_alter_option ({ Sql.value; pos } : Sql.alter_option Sql.located) =
+  match value with
+  | Alter_algorithm _ -> only AlterAlgorithm [MySQL; TiDB] pos
+  | Alter_lock _ -> only AlterLock [MySQL] pos
+
 let get_user_defined_type pos = only UserDefinedType [PostgreSQL] pos
 
 let get_extension pos = only Extension [PostgreSQL] pos
@@ -438,7 +445,8 @@ let rec analyze stmt =
       let acc = get_create_table_as_select pos :: acc in
       analyze_select_full acc [select] List.rev
   | Drop _ -> []
-  | Alter (_, actions) ->
+  | Alter { alter_actions = actions; alter_options = options; _ } ->
+      let acc = List.rev_append (List.map get_alter_option options) acc in
       analyze_alter_action acc actions List.rev
   | Rename _ -> []
   | CreateIndex { ci_cols; _ } -> List.concat_map check_collated ci_cols

lib/sql.ml

@@ -1079,14 +1079,40 @@ type alter_action = [
     | `NoCache of Pos.t
     | `AlterColumnPG of string * Alter_column_pg.t located ] [@@deriving show {with_path=false}]
 
+type alter_algorithm =
+  | Algorithm_default [@as "default"]
+  | Algorithm_instant [@as "instant"]
+  | Algorithm_inplace [@as "inplace"]
+  | Algorithm_copy [@as "copy"]
+  [@@deriving show {with_path=false}, enumerate, to_string, of_string]
+
+type alter_lock =
+  | Lock_default [@as "default"]
+  | Lock_none [@as "none"]
+  | Lock_shared [@as "shared"]
+  | Lock_exclusive [@as "exclusive"]
+  [@@deriving show {with_path=false}, enumerate, to_string, of_string]
+
+type alter_option =
+  | Alter_algorithm of alter_algorithm
+  | Alter_lock of alter_lock
+  [@@deriving show {with_path=false}]
+
+type alter = {
+  alter_table : table_name;
+  alter_actions : alter_action list;
+  alter_options : alter_option located list;
+}
+[@@deriving show]
+
 type create_type_target =
   | TypeEnum of string list
   [@@deriving show {with_path=false}]
 
 type stmt =
   | Create of table_name located * create_target
   | Drop of table_name
-  | Alter of table_name * alter_action list
+  | Alter of alter
   | Rename of (table_name * table_name) list
   | CreateIndex of create_index_def
   | Insert of insert_action

lib/sql_parser.mly

@@ -144,7 +144,16 @@ statement: CREATE ioption(temporary) TABLE ioption(if_not_exists) name=located(t
               }
          | ALTER TABLE name=table_name actions=commas(alter_action_or_ignored)
               {
-                Alter (name, List.filter_map (fun x -> x) actions)
+                let actions, options =
+                  List.fold_right
+                    (fun item (actions, options) ->
+                      match item with
+                      | `Action action -> action :: actions, options
+                      | `Option option -> actions, option :: options
+                      | `Ignored -> actions, options)
+                    actions ([], [])
+                in
+                Alter { alter_table = name; alter_actions = actions; alter_options = options }
               }
          | RENAME TABLE l=separated_nonempty_list(COMMA, separated_pair(table_name,TO,table_name)) { Rename l }
          | DROP either(TABLE,VIEW) if_exists? name=table_name
@@ -422,11 +431,13 @@ alter_action: ADD COLUMN? col=maybe_parenth(column_def) pos=alter_pos { `Add (co
             | NOCACHE { `NoCache ($startofs, $endofs) }
             | either(DEFAULT,pair(CONVERT,TO))? cs=charset c=collate? { `Default_or_convert_to (cs, c) }
 
-(* clauses sqlgg parses but does not act on: kept out of the action list *)
-alter_action_or_ignored: a=alter_action { Some a }
-            | SET IDENT IDENT { None }
-            | ALGORITHM EQUAL algorithm { None }
-            | LOCK EQUAL lock { None }
+alter_action_or_ignored: a=alter_action { `Action a }
+            | SET IDENT IDENT { `Ignored }
+            | option=located(alter_option) { `Option option }
+
+alter_option:
+            | ALGORITHM EQUAL algorithm=algorithm { Alter_algorithm algorithm }
+            | LOCK EQUAL lock=lock { Alter_lock lock }
 
 ttl_option: TTL EQUAL col=ident PLUS INTERVAL n=INTEGER unit=INTERVAL_UNIT
               { `TtlSet (col, n, unit) }
@@ -856,14 +867,15 @@ manual_type:
     | T_DATETIME NULL        { Source_type.nullable Datetime }
 
 algorithm:
- | INPLACE { }
- | COPY { }
- | INSTANT { }
+ | DEFAULT { Algorithm_default }
+ | INPLACE { Algorithm_inplace }
+ | COPY { Algorithm_copy }
+ | INSTANT { Algorithm_instant }
 
 lock:
- | NONE {}
- | EXCLUSIVE {}
- | DEFAULT {}
- | SHARED {}
+ | NONE { Lock_none }
+ | EXCLUSIVE { Lock_exclusive }
+ | DEFAULT { Lock_default }
+ | SHARED { Lock_shared }
 
 %inline located(X): X { make_located ~value:$1 ~pos:($startofs, $endofs) }

lib/syntax.ml

@@ -1830,7 +1830,7 @@ let rec eval (stmt:Sql.stmt) =
       Tables.add (name, to_schema schema);
       [], params, Create name,
       { annotations with table_defs = (located_name, []) :: annotations.table_defs }
-  | Alter (name,actions) ->
+  | Alter { alter_table = name; alter_actions = actions; _ } ->
       List.iter (function
       | `Add (col,pos) ->
         let source_kind = Option.map (fun k -> k.value) col.Alter_action_attr.kind in

src/cli.ml

@@ -210,6 +210,27 @@ let set_dialect s =
       | Dialect.MySQL | Dialect.TiDB | Dialect.SQLite -> Some Gen.Unnamed  (* ? syntax *)
       | Dialect.PostgreSQL -> Some Gen.PostgreSQL  (* $1, $2, etc. *)
 
+let enum_values to_string values =
+  String.concat "|" (List.map to_string values)
+
+let alter_lock_values =
+  enum_values Sql.alter_lock_to_string Sql.all_of_alter_lock
+
+let alter_algorithm_values =
+  enum_values Sql.alter_algorithm_to_string Sql.all_of_alter_algorithm
+
+let parse_alter_option kind values of_string s =
+  match of_string s with
+  | Some option -> option
+  | None -> fatal "unknown ALTER TABLE %s %S (expected %s)" kind s values
+
+let parse_alter_lock =
+  parse_alter_option "lock" alter_lock_values Sql.alter_lock_of_string
+
+let parse_alter_algorithm =
+  parse_alter_option "algorithm" alter_algorithm_values
+    Sql.alter_algorithm_of_string
+
 let set_no_check = function
   | "all" -> Sqlgg_config.set_no_check_features Dialect.all_of_feature
   | s ->
@@ -246,9 +267,9 @@ let schema_of_sources sources =
 
 let load_schema files = schema_of_sources (to_file_sources files)
 
-let diff_schema ~naming ~ddl_as_migration ~from_ ~to_ =
+let diff_schema ~naming ~alter_options ~ddl_as_migration ~from_ ~to_ =
   let migs =
-    try Schema_diff.generate ~naming ~ddl_as_migration ~from_ ~to_
+    try Schema_diff.generate ~naming ~alter_options ~ddl_as_migration ~from_ ~to_
     with Gen_migrations.Migration_error msg ->
       fatal "cannot generate migration (write this step manually):\n%s" msg
   in
@@ -272,6 +293,7 @@ type delta_args = {
   now : int option;
   max_id_length : int option;
   ddl_as_migration : bool;
+  alter_options : Sql.alter_option list;
 }
 
 type diff_args = {
@@ -310,6 +332,8 @@ let parse_args () =
   let now = ref None in
   let max_id_length = ref None in
   let ddl_as_migration = ref false in
+  let alter_lock = ref None in
+  let alter_algorithm = ref None in
   let files : (string, [ `Open of Gen.stmt list | `Positional ]) Hashtbl.t = Hashtbl.create 4 in
   let canonical = function
     | "-" -> "-"
@@ -356,14 +380,22 @@ let parse_args () =
       "-max-migration-id-length", Arg.Int (fun n -> max_id_length := Some n),
         "<N> Limit generated migration ids to N characters (default: no limit)";
       "-ddl-as-migration", Arg.Set ddl_as_migration, " Write new tables as CREATE TABLE migrations instead of plain schema DDL";
+      "-alter-algorithm", Arg.String (fun s -> alter_algorithm := Some (parse_alter_algorithm s)),
+        sprintf "%s Add ALGORITHM policy to generated ALTER TABLE statements (MySQL and TiDB only)"
+          alter_algorithm_values;
+      "-alter-lock", Arg.String (fun s -> alter_lock := Some (parse_alter_lock s)),
+        sprintf "%s Add LOCK policy to generated ALTER TABLE statements (MySQL only)"
+          alter_lock_values;
     ] };
 
     { title = "Dialect and checks"; opts =
     [
-      "-dialect", Arg.String set_dialect, sprintf "%s Set SQL dialect. Queries can only use its features" (Dialect.all |> List.map Dialect.to_string |> String.concat "|");
+      "-dialect", Arg.String set_dialect,
+        sprintf "%s Set SQL dialect. Queries can only use its features"
+          (enum_values Dialect.to_string Dialect.all);
       "-no-check", Arg.String set_no_check,
         sprintf "{all|<feature>{,<feature>}+} Disable dialect feature checks (possible features: %s)"
-          (Dialect.all_of_feature |> List.map Dialect.feature_to_string |> String.concat "|");
+          (enum_values Dialect.feature_to_string Dialect.all_of_feature);
       "-allow-write-notnull-null", Arg.Unit (fun () -> Sqlgg_config.allow_write_notnull_null true), " Accept writing a nullable value into a NOT NULL column, instead of failing (MySQL, TiDB and SQLite only)";
     ] };
 
@@ -404,12 +436,29 @@ let parse_args () =
   in
   Arg.parse args work usage_msg;
   if Array.length Sys.argv = 1 then show_help ();
+  begin match !alter_lock, !Dialect.selected with
+  | Some _, (Dialect.PostgreSQL | Dialect.SQLite | Dialect.TiDB) ->
+    fatal "-alter-lock is only supported for dialect mysql"
+  | None, _ | Some _, Dialect.MySQL -> ()
+  end;
+  begin match !alter_algorithm, !Dialect.selected with
+  | Some _, (Dialect.PostgreSQL | Dialect.SQLite) ->
+    fatal "-alter-algorithm is only supported for dialects mysql and tidb"
+  | None, _ | Some _, (Dialect.MySQL | Dialect.TiDB) -> ()
+  end;
+  let alter_options =
+    Stdlib.Option.to_list
+      (Option.map (fun algorithm -> Sql.Alter_algorithm algorithm) !alter_algorithm)
+    @ Stdlib.Option.to_list
+        (Option.map (fun lock -> Sql.Alter_lock lock) !alter_lock)
+  in
   let delta =
     { name = !name;
       target_files = List.rev !target_files;
       now = !now;
       max_id_length = !max_id_length;
-      ddl_as_migration = !ddl_as_migration }
+      ddl_as_migration = !ddl_as_migration;
+      alter_options }
   in
   (* these modes reset the schema and rebuild it from -base/-target/-initial,
      silently discarding whatever -open loaded *)
@@ -451,7 +500,8 @@ let parse_migrations blocks =
   abort_on_errors ();
   migs
 
-let run_migrate ({ delta = { name; target_files; now; max_id_length; ddl_as_migration };
+let run_migrate ({ delta = { name; target_files; now; max_id_length;
+                             ddl_as_migration; alter_options };
                    gen_lang; initial_files; migrations_file; extends_file } : migrate_args) =
   let initial = to_file_sources initial_files in
   let ext = Option.map_default read_blocks [] extends_file in
@@ -468,7 +518,7 @@ let run_migrate ({ delta = { name; target_files; now; max_id_length; ddl_as_migr
   in
   let base = next_base now before in
   let naming = Migration_id.naming ~max_length:max_id_length base in
-  match diff_schema ~naming ~ddl_as_migration ~from_:current ~to_:target with
+  match diff_schema ~naming ~alter_options ~ddl_as_migration ~from_:current ~to_:target with
   | [] ->
     regenerate ();
     (match before with
@@ -508,13 +558,14 @@ let run_materialize_schema ({ base_files } : materialize_args) =
   end;
   print_endline ddl
 
-let run_diff ({ delta = { name; target_files; now; max_id_length; ddl_as_migration };
+let run_diff ({ delta = { name; target_files; now; max_id_length;
+                          ddl_as_migration; alter_options };
                 base_files; output } : diff_args) =
   let from_ = load_schema base_files in
   let to_   = load_schema target_files in
   let base = next_base now [] in
   let naming = Migration_id.naming ~max_length:max_id_length base in
-  let migs = diff_schema ~naming ~ddl_as_migration ~from_ ~to_ in
+  let migs = diff_schema ~naming ~alter_options ~ddl_as_migration ~from_ ~to_ in
   Tables.restore from_;
   match output with
   | None -> ()

src/gen_migrations.ml

@@ -219,6 +219,12 @@ type alter_clause =
   | Default_charset of ddl_charset
   | Ttl_options of Sql.ttl_option list
 
+let alter_option_to_sql = function
+  | Sql.Alter_algorithm algorithm ->
+    "ALGORITHM=" ^ String.uppercase_ascii (Sql.alter_algorithm_to_string algorithm)
+  | Sql.Alter_lock lock ->
+    "LOCK=" ^ String.uppercase_ascii (Sql.alter_lock_to_string lock)
+
 let alter_clause_body ~default_sql_lookup = function
   | Columns actions ->
     (match List.map (action_to_sql_fragment ~default_sql_lookup) actions with
@@ -236,8 +242,14 @@ let alter_clause_body ~default_sql_lookup = function
   | Ttl_options opts ->
     Some (action_to_sql_fragment ~default_sql_lookup (`TtlOptions (opts, (0, 0))))
 
-let alter_table_sql ~default_sql_lookup table clause =
-  Option.map (sprintf "ALTER TABLE %s %s" (quote_table_name table))
+let alter_table_sql ~default_sql_lookup ?(options = []) table clause =
+  let suffix =
+    match options with
+    | [] -> ""
+    | options -> ", " ^ String.concat ", " (List.map alter_option_to_sql options)
+  in
+  Option.map
+    (fun body -> sprintf "ALTER TABLE %s %s%s" (quote_table_name table) body suffix)
     (alter_clause_body ~default_sql_lookup clause)
 
 let drop_table_sql name =

src/main.ml

@@ -152,7 +152,9 @@ let get_statements ch =
         Printf.eprintf "Warning: this SQL statement will produce rowset with duplicate column names:\n%s\n" stmt.text;
       stmts)
 
-let replay_statement stmt = ignore (executable stmt)
+let replay_statement stmt =
+  let (_ : Gen.stmt option) = executable stmt in
+  ()
 
 let replay_sql sql = List.iter replay_statement (prepare_statements sql)