tools/copy_host.ml

   1 (* Copy a whole host (site).  This can also copy between databases and
   2  * servers.
   3  *
   4  * Use 'copy_host --help' for usage.
   5  *
   6  * $Id: copy_host.ml,v 1.2 2006/09/11 09:58:43 rich Exp $
   7  *)
   8
   9 open Printf
  10 open ExtList
  11 open ExtString
  12
  13 let usage =
  14   "copy_host can be used to copy/duplicate a whole host (site).
  15 It can also copy hosts between databases and database server.
  16
  17   Please read the instructions below carefully before attempting
  18   to use this program!
  19
  20 BASIC USAGE
  21
  22   Duplicate a host on the same (local) database server:
  23
  24     copy_host -shost mysite.example.com -dhost mycopy.example.com
  25
  26   Copy a host from the local database server to another.  The copy
  27   will have the same canonical and alternate hostnames:
  28
  29     copy_host -short mysite.example.com -ddbhost anotherdb.example.com
  30
  31 TERMINOLOGY
  32
  33 'host': The term used by COCANWIKI to mean a site.  Each host has
  34   a single row in the 'hosts' table in the database, and a single
  35   unique hostid.  A single COCANWIKI database instance can handle
  36   an unlimited number of hosts.
  37
  38 'canonical hostname': The standard hostname for a host.  See the
  39   hosts.canonical_hostname column.
  40
  41 'hostname': Any of the hostnames permitted for a host.  Most sites
  42   will only have one, the canonical_hostname, but some will have
  43   several names, eg. 'example.com' and 'www.example.com'.  See
  44   the 'hostnames' table.
  45
  46 'source ***', 'destination ***': When copying hosts, you copy
  47   from the source whatever to the destination whatever.
  48
  49 'database hostname': The name of the server running the PostgreSQL
  50   database.  When copying a host between databases, you have a
  51   source database hostname and a destination database hostname.
  52
  53 'database name': The name of the PostgreSQL database (not the
  54   name of the server, but the name of the database).  Usually
  55   'cocanwiki'.  Use the command 'psql -l' to list database
  56   names.
  57
  58 SELECTING THE SOURCE AND DESTINATION HOSTS
  59
  60 In general, any parameter beginning with '-s***' refers to the
  61 source and with '-d***' to the destination.
  62
  63 The '-shost hostname' parameter is required, and it selects the
  64 particular host which you want to copy/duplicate.  You may give
  65 either the canonical hostname or one of the alternate hostnames,
  66 since either uniquely identifies the source host you want to
  67 copy.
  68
  69 '-dhost hostname[,...]' is an optional parameter which specifies
  70 the destination hostnames (canonical and alternates).
  71
  72   If not given, then the same hostname(s) are used as the source.
  73   This only makes sense when copying a host between database
  74   instances, since a single database instance cannot contain
  75   multiple hosts with the same hostnames.
  76
  77   If given with a single hostname, then that hostname is used
  78   as the canonical hostname for the copy.
  79
  80   If given with multiple (comma-separated) hostnames, then
  81   the first one is the canonical hostname and the subsequent
  82   ones are the alternate hostnames, eg:
  83
  84     -dhost www.example.com,example.com
  85
  86 SELECTING THE SOURCE AND DESTINATION DATABASE(S)
  87
  88 '-sdb***' and '-ddb***' parameters can be used to select
  89 different source and destination database instances.  The
  90 parameters in question are:
  91
  92   -sdbhost     -ddbhost      Database hostname.
  93   -sdbport     -ddbport      Database port number.
  94   -sdbuser     -ddbuser      Database username.
  95   -sdbpassword -ddbpassword  Database password.
  96   -sdbdatabase -ddbdatabase  Database name.
  97
  98 All except the last two, database name, default to nothing
  99 which means that the usual PostgreSQL method for find the value
 100 is used (ie. first use environment variables like $PGHOST, then
 101 use an internal default, usually the local database and user).
 102
 103 The database name defaults to 'cocanwiki'.
 104
 105 It is possible to duplicate a host on the same database instance.
 106 In this case it is probably better not to specify the '-sdb***'
 107 or '-ddb***' parameters, but instead use environment variables,
 108 or run this program on the database server itself.
 109
 110 OPTIONS
 111 "
 112
 113 let shost = ref ""
 114 let dhost = ref ""
 115 let sdbhost = ref ""
 116 let ddbhost = ref ""
 117 let sdbport = ref 0
 118 let ddbport = ref 0
 119 let sdbuser = ref ""
 120 let ddbuser = ref ""
 121 let sdbpassword = ref ""
 122 let ddbpassword = ref ""
 123 let sdbdatabase = ref "cocanwiki"
 124 let ddbdatabase = ref "cocanwiki"
 125 let dryrun = ref false
 126
 127 let argspec = [
 128   "-shost", Arg.Set_string shost,
 129     "Source hostname (required).";
 130   "-dhost", Arg.Set_string dhost,
 131     "Destination hostname(s) (optional).";
 132   "-sdbhost", Arg.Set_string sdbhost,
 133     "Source database hostname (optional).";
 134   "-ddbhost", Arg.Set_string ddbhost,
 135     "Destination database hostname (optional).";
 136   "-sdbport", Arg.Set_int sdbport,
 137     "Source database port (optional).";
 138   "-ddbport", Arg.Set_int ddbport,
 139     "Destination database port (optional).";
 140   "-sdbuser", Arg.Set_string sdbuser,
 141     "Source database user (optional).";
 142   "-ddbuser", Arg.Set_string ddbuser,
 143     "Destination database user (optional).";
 144   "-sdbpassword", Arg.Set_string sdbpassword,
 145     "Source database password (optional).";
 146   "-ddbpassword", Arg.Set_string ddbpassword,
 147     "Destination database password (optional).";
 148   "-sdbdatabase", Arg.Set_string sdbdatabase,
 149     "Source database name (default: cocanwiki).";
 150   "-ddbdatabase", Arg.Set_string ddbdatabase,
 151     "Destination database name (default: cocanwiki).";
 152   "-dryrun", Arg.Set dryrun,
 153     "Rollback database changes at the end.";
 154 ]
 155
 156 let error _ = raise (Arg.Bad "Use --help for help.")
 157
 158 let () = Arg.parse argspec error usage
 159
 160 let shost =
 161   match !shost with
 162   | "" -> failwith "-shost is required.  Use --help for help."
 163   | s -> s
 164 let dhost =
 165   match !dhost with
 166   | "" -> []
 167   | s -> String.nsplit s ","
 168 let sdbhost = match !sdbhost with "" -> None | s -> Some s
 169 let ddbhost = match !ddbhost with "" -> None | s -> Some s
 170 let sdbport = match !sdbport with 0 -> None | p -> Some p
 171 let ddbport = match !ddbport with 0 -> None | p -> Some p
 172 let sdbuser = match !sdbuser with "" -> None | s -> Some s
 173 let ddbuser = match !ddbuser with "" -> None | s -> Some s
 174 let sdbpassword = match !sdbpassword with "" -> None | s -> Some s
 175 let ddbpassword = match !ddbpassword with "" -> None | s -> Some s
 176 let sdbdatabase = match !sdbdatabase with "" -> None | s -> Some s
 177 let ddbdatabase = match !ddbdatabase with "" -> None | s -> Some s
 178 let dryrun = !dryrun
 179
 180 (* Get column names from a table. *)
 181 let columns dbh table_name =
 182   let query = "select * from " ^ table_name ^ " order by 1" in
 183   let name = "columns" in
 184   PGOCaml.prepare dbh ~query ~name ();
 185   let columns =
 186     match PGOCaml.describe_statement dbh ~name () with
 187     | _, Some results ->
 188         List.map (fun { PGOCaml.name = name } -> name) results
 189     | _, None -> assert false in
 190   PGOCaml.close_statement dbh ~name ();
 191   columns
 192
 193 (* 'select * on table where ...' using the low level interface. *)
 194 let select_all dbh table_name where_clause =
 195   let query = "select * from " ^ table_name ^
 196     (match where_clause with
 197      | "" -> ""
 198      | where_clause -> " where " ^ where_clause) ^
 199     " order by 1" in
 200   let name = "selectall" in
 201   PGOCaml.prepare dbh ~query ~name ();
 202   let columns =
 203     match PGOCaml.describe_statement dbh ~name () with
 204     | _, Some results ->
 205         List.map (fun { PGOCaml.name = name } -> name) results
 206     | _, None -> assert false in
 207   let rows = PGOCaml.execute dbh ~name ~params:[] () in
 208   PGOCaml.close_statement dbh ~name ();
 209   columns, rows
 210
 211 (* Functions to remove or update the value in a column. *)
 212 let rec remove_column columns rows col_name =
 213   List.filter (
 214     fun col_name' -> col_name <> col_name'
 215   ) columns,
 216   List.map (
 217     fun row ->
 218       List.filter_map (
 219         fun (col_name', value) ->
 220           if col_name <> col_name' then Some value else None
 221       ) (List.combine columns row)
 222   ) rows
 223
 224 and update_column columns rows col_name new_value =
 225   columns,
 226   List.map (
 227     fun row ->
 228       List.map (
 229         fun (col_name', old_value) ->
 230           if col_name <> col_name' then old_value else new_value
 231       ) (List.combine columns row)
 232   ) rows
 233
 234 and update_apply_column columns rows col_name f =
 235   columns,
 236   List.map (
 237     fun row ->
 238       List.map (
 239         fun (col_name', old_value) ->
 240           if col_name <> col_name' then old_value else f old_value
 241       ) (List.combine columns row)
 242   ) rows
 243
 244 (* Insert rows into the database table. *)
 245 let insert dbh table_name columns rows =
 246   let query = "insert into " ^ table_name ^ " (" ^
 247     String.concat ", " columns
 248     ^ ") values (" ^
 249     String.concat ", " (List.mapi (fun i _ -> sprintf "$%d" (i+1)) columns)
 250     ^ ")" in
 251   let name = "insertinto" in
 252   PGOCaml.prepare dbh ~query ~name ();
 253   List.iter (fun params -> ignore (PGOCaml.execute dbh ~name ~params ())) rows;
 254   PGOCaml.close_statement dbh ~name ()
 255
 256 (* Insert rows into the database table, returning serial numbers. *)
 257 let insert_serial dbh table_name columns rows serial_col =
 258   let query = "insert into " ^ table_name ^ " (" ^
 259     String.concat ", " columns
 260     ^ ") values (" ^
 261     String.concat ", " (List.mapi (fun i _ -> sprintf "$%d" (i+1)) columns)
 262     ^ ")" in
 263   let name = "insertserial" in
 264   PGOCaml.prepare dbh ~query ~name ();
 265   let seq = table_name ^ "_" ^ serial_col ^ "_seq" in
 266   let serials =
 267     List.map (
 268       fun params ->
 269         ignore (PGOCaml.execute dbh ~name ~params ());
 270         PGOCaml.serial4 dbh seq
 271     ) rows in
 272   PGOCaml.close_statement dbh ~name ();
 273   serials
 274
 275 let int32_of_value value =
 276   let value = Option.get value in
 277   Int32.of_string value
 278
 279 let value_of_int32 i =
 280   let i = Int32.to_string i in
 281   Some i
 282
 283 let () =
 284   print_endline "Connecting to databases ...";
 285   print_endline "  Source ...";
 286   let sdbh =
 287     let host = sdbhost in
 288     let port = sdbport in
 289     let user = sdbuser in
 290     let password = sdbpassword in
 291     let database = sdbdatabase in
 292     PGOCaml.connect ?host ?port ?user ?password ?database () in
 293   print_endline "  Destination ...";
 294   let ddbh =
 295     let host = ddbhost in
 296     let port = ddbport in
 297     let user = ddbuser in
 298     let password = ddbpassword in
 299     let database = ddbdatabase in
 300     PGOCaml.connect ?host ?port ?user ?password ?database () in
 301   print_endline "Locate source host ...";
 302   let shostid = List.hd (
 303     PGSQL(sdbh) "select hostid from hostnames where name = $shost"
 304   ) in
 305   let scanonical_hostname = List.hd (
 306     PGSQL(sdbh) "select canonical_hostname from hosts where id = $shostid"
 307   ) in
 308   let shostnames =
 309     PGSQL(sdbh)
 310       "select name from hostnames where hostid = $shostid order by 1" in
 311   printf "  shostid = %ld\n" shostid;
 312   printf "  scanonical_hostname = %s\n" scanonical_hostname;
 313   printf "  shostnames = [ %s ]\n" (String.concat "; " shostnames);
 314
 315   print_endline "Begin transaction on destination database ...";
 316   PGOCaml.begin_work ddbh;
 317   PGSQL(ddbh) "set constraints hosts_hostname_cn, pages_redirect_cn deferred";
 318
 319   (* Also start a transaction on the source database.  We are not
 320    * intending to make any changes, but this transaction ensures that we
 321    * can't because the disconnect at the end of the program will roll any
 322    * we make back.
 323    *)
 324   PGOCaml.begin_work sdbh;
 325
 326   (* Tables hosts and hostnames are the most complex to copy because
 327    * we may want to update the hostname.
 328    *)
 329   let dcanonical_hostname, dhostnames =
 330     match dhost with
 331     | [] -> scanonical_hostname, shostnames
 332     | x :: xs -> x, xs in
 333
 334   print_endline "Create new host ...";
 335
 336   let columns, rows =
 337     select_all sdbh "hosts" (sprintf "id = %ld" shostid) in
 338   let nr_columns = List.length columns in
 339   assert (nr_columns >= 19);
 340   assert (List.length rows = 1);
 341   let columns, rows = remove_column columns rows "id" in
 342   assert (List.length columns = nr_columns - 1);
 343   assert (List.length rows = 1);
 344   let columns, rows =
 345     update_column columns rows "canonical_hostname"
 346       (Some dcanonical_hostname) in
 347   assert (List.length columns = nr_columns - 1);
 348   assert (List.length rows = 1);
 349   let serials = insert_serial ddbh "hosts" columns rows "id" in
 350   assert (List.length serials = 1);
 351   let dhostid = List.hd serials in
 352   printf "  dhostid = %ld\n" dhostid;
 353
 354   print_endline "Create table hostnames ...";
 355   List.iter (
 356     fun hostname ->
 357       printf "  adding hostname %s\n" hostname;
 358       PGSQL(ddbh)
 359         "insert into hostnames (hostid, name) values ($dhostid, $hostname)"
 360   ) dhostnames;
 361
 362   (* Now start copying the tables.
 363    * Not entirely trivial because where a table references another,
 364    * we will need to update the IDs to match the corrected serial
 365    * numbers.
 366    *)
 367   print_endline "Copying table users ...";
 368   let columns, rows =
 369     select_all sdbh "users" (sprintf "hostid = %ld" shostid) in
 370   assert (List.hd columns = "id");
 371   let old_ids = List.map int32_of_value (List.map List.hd rows) in
 372   let columns, rows =
 373     remove_column columns rows "id" in
 374   let columns, rows =
 375     update_column columns rows "hostid" (value_of_int32 dhostid) in
 376   let new_ids =
 377     insert_serial ddbh "users" columns rows "id" in
 378
 379   let userid_map = List.combine old_ids new_ids in
 380
 381   print_endline "Copying tables contacts, contact_emails ...";
 382   let columns, rows =
 383     select_all sdbh "contacts" (sprintf "hostid = %ld" shostid) in
 384   assert (List.hd columns = "id");
 385   let old_ids = List.map int32_of_value (List.map List.hd rows) in
 386   let columns, rows =
 387     remove_column columns rows "id" in
 388   let columns, rows =
 389     update_column columns rows "hostid" (value_of_int32 dhostid) in
 390   let new_ids =
 391     insert_serial ddbh "contacts" columns rows "id" in
 392
 393   let map = List.combine old_ids new_ids in
 394
 395   if old_ids <> [] then (
 396     let columns, rows =
 397       select_all sdbh "contact_emails"
 398         ("contactid in (" ^
 399            String.concat ", " (List.map Int32.to_string old_ids) ^
 400            ")") in
 401     let columns, rows =
 402       update_apply_column columns rows "contactid"
 403         (fun old_id ->
 404            let old_id = int32_of_value old_id in
 405            value_of_int32 (List.assoc old_id map)) in
 406     insert ddbh "contact_emails" columns rows
 407   );
 408
 409   print_endline "Copying tables pages, contents ...";
 410   let columns, rows =
 411     select_all sdbh "pages" (sprintf "hostid = %ld" shostid) in
 412   assert (List.hd columns = "id");
 413   let old_ids = List.map int32_of_value (List.map List.hd rows) in
 414   let columns, rows =
 415     remove_column columns rows "id" in
 416   let columns, rows =
 417     remove_column columns rows "title_description_fti" in
 418   let columns, rows =
 419     update_column columns rows "hostid" (value_of_int32 dhostid) in
 420   let columns, rows =
 421     update_apply_column columns rows "logged_user"
 422       (function
 423        | None -> None
 424        | (Some _) as old_id ->
 425            let old_id = int32_of_value old_id in
 426            value_of_int32 (List.assoc old_id userid_map)) in
 427   let new_ids =
 428     insert_serial ddbh "pages" columns rows "id" in
 429
 430   let map = List.combine old_ids new_ids in
 431
 432   if old_ids <> [] then (
 433     let columns, rows =
 434       select_all sdbh "contents"
 435         ("pageid in (" ^
 436            String.concat ", " (List.map Int32.to_string old_ids) ^
 437            ")") in
 438     let columns, rows = remove_column columns rows "id" in
 439     let columns, rows = remove_column columns rows "content_fti" in
 440     let columns, rows =
 441       update_apply_column columns rows "pageid"
 442         (fun old_id ->
 443            let old_id = int32_of_value old_id in
 444            value_of_int32 (List.assoc old_id map)) in
 445     insert ddbh "contents" columns rows
 446   );
 447
 448   print_endline "Copying tables messages, msg_references ...";
 449   let columns, rows =
 450     select_all sdbh "messages" (sprintf "hostid = %ld" shostid) in
 451   assert (List.hd columns = "id");
 452   let old_ids = List.map int32_of_value (List.map List.hd rows) in
 453   let columns, rows =
 454     remove_column columns rows "id" in
 455   let columns, rows =
 456     update_column columns rows "hostid" (value_of_int32 dhostid) in
 457   let new_ids =
 458     insert_serial ddbh "messages" columns rows "id" in
 459
 460   let map = List.combine old_ids new_ids in
 461
 462   if old_ids <> [] then (
 463     let columns, rows =
 464       select_all sdbh "msg_references"
 465         ("message_id in (" ^
 466            String.concat ", " (List.map Int32.to_string old_ids) ^
 467            ")") in
 468     let columns, rows =
 469       update_apply_column columns rows "message_id"
 470         (fun old_id ->
 471            let old_id = int32_of_value old_id in
 472            value_of_int32 (List.assoc old_id map)) in
 473     insert ddbh "msg_references" columns rows
 474   );
 475
 476   print_endline "Copying table files ...";
 477   let columns, rows =
 478     select_all sdbh "files" (sprintf "hostid = %ld" shostid) in
 479   let columns, rows =
 480     remove_column columns rows "id" in
 481   let columns, rows =
 482     update_column columns rows "hostid" (value_of_int32 dhostid) in
 483   insert ddbh "files" columns rows;
 484
 485   print_endline "Copying table images ...";
 486   let columns, rows =
 487     select_all sdbh "images" (sprintf "hostid = %ld" shostid) in
 488   let columns, rows =
 489     remove_column columns rows "id" in
 490   let columns, rows =
 491     update_column columns rows "hostid" (value_of_int32 dhostid) in
 492   insert ddbh "images" columns rows;
 493
 494   print_endline "Copying table sitemenu ...";
 495   let columns, rows =
 496     select_all sdbh "sitemenu" (sprintf "hostid = %ld" shostid) in
 497   let columns, rows =
 498     update_column columns rows "hostid" (value_of_int32 dhostid) in
 499   insert ddbh "sitemenu" columns rows;
 500
 501   print_endline "Copying table links ...";
 502   let columns, rows =
 503     select_all sdbh "links" (sprintf "hostid = %ld" shostid) in
 504   let columns, rows =
 505     update_column columns rows "hostid" (value_of_int32 dhostid) in
 506   insert ddbh "links" columns rows;
 507
 508   print_endline "Copying table macros ...";
 509   let columns, rows =
 510     select_all sdbh "macros" (sprintf "hostid = %ld" shostid) in
 511   let columns, rows =
 512     update_column columns rows "hostid" (value_of_int32 dhostid) in
 513   insert ddbh "macros" columns rows;
 514
 515   print_endline "Copying table page_emails ...";
 516   let columns, rows =
 517     select_all sdbh "page_emails" (sprintf "hostid = %ld" shostid) in
 518   let columns, rows =
 519     update_column columns rows "hostid" (value_of_int32 dhostid) in
 520   insert ddbh "page_emails" columns rows;
 521
 522   print_endline "Copying table mailing_lists ...";
 523   let columns, rows =
 524     select_all sdbh "mailing_lists" (sprintf "hostid = %ld" shostid) in
 525   let columns, rows =
 526     update_column columns rows "hostid" (value_of_int32 dhostid) in
 527   insert ddbh "mailing_lists" columns rows;
 528
 529   (* pending_email_changes and usercookies are only copied if the URL
 530    * will not change, because if the URL does change then there is
 531    * no point copying them because all cookies/email URLs will be
 532    * out of date.
 533    *)
 534   if scanonical_hostname = dcanonical_hostname && userid_map <> [] then (
 535     let where_clause =
 536       "userid in (" ^
 537         String.concat ", "
 538         (List.map Int32.to_string (List.map fst userid_map)) ^
 539         ")" in
 540
 541     print_endline "Copying table usercookies ...";
 542     let columns, rows = select_all sdbh "usercookies" where_clause in
 543     let columns, rows =
 544       update_apply_column columns rows "userid"
 545         (function
 546          | None -> None
 547          | (Some _) as old_id ->
 548              let old_id = int32_of_value old_id in
 549              value_of_int32 (List.assoc old_id userid_map)) in
 550     insert ddbh "usercookies" columns rows;
 551
 552     print_endline "Copying table pending_email_changes ...";
 553     let columns, rows = select_all sdbh "pending_email_changes" where_clause in
 554     let columns, rows =
 555       update_apply_column columns rows "userid"
 556         (function
 557          | None -> None
 558          | (Some _) as old_id ->
 559              let old_id = int32_of_value old_id in
 560              value_of_int32 (List.assoc old_id userid_map)) in
 561     insert ddbh "pending_email_changes" columns rows;
 562   );
 563
 564   (* Note: Tables which are NOT copied:
 565    *
 566    * pg_ts_cfg      -- Internal tables used by tsearch2
 567    * pg_ts_cfgmap   --   """"
 568    * pg_ts_dict     --   """"
 569    * pg_ts_parser   --   """"
 570    * powered_by     -- Fixed table.
 571    * recently_visited -- Not worth copying.
 572    * server_settings -- Global configuration table.
 573    * templates      -- Fixed table.
 574    * themes         -- Fixed table.
 575    *)
 576
 577   (* Commit or rollback. *)
 578   if dryrun then (
 579     print_endline "Rolling back database because -dryrun flag was given.";
 580     PGOCaml.rollback ddbh
 581   ) else (
 582     print_endline "Committing changes ...";
 583     PGOCaml.commit ddbh;
 584     print_endline "Done."
 585   )