1 (* Copy a whole host (site). This can also copy between databases and
4 * Use 'copy_host --help' for usage.
6 * $Id: copy_host.ml,v 1.5 2006/12/11 15:34:36 rich Exp $
14 "copy_host can be used to copy/duplicate a whole host (site).
15 It can also copy hosts between databases and database server.
17 Please read the instructions below carefully before attempting
22 Duplicate a host on the same (local) database server:
24 copy_host -shost mysite.example.com -dhost mycopy.example.com
26 Copy a host from the local database server to another. The copy
27 will have the same canonical and alternate hostnames:
29 copy_host -shost mysite.example.com -ddbhost anotherdb.example.com
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.
38 'canonical hostname': The standard hostname for a host. See the
39 hosts.canonical_hostname column.
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.
46 'source ***', 'destination ***': When copying hosts, you copy
47 from the source whatever to the destination whatever.
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.
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
58 SELECTING THE SOURCE AND DESTINATION HOSTS
60 In general, any parameter beginning with '-s***' refers to the
61 source and with '-d***' to the destination.
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
69 '-dhost hostname[,...]' is an optional parameter which specifies
70 the destination hostnames (canonical and alternates).
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.
77 If given with a single hostname, then that hostname is used
78 as the canonical hostname for the copy.
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:
84 -dhost www.example.com,example.com
86 SELECTING THE SOURCE AND DESTINATION DATABASE(S)
88 '-sdb***' and '-ddb***' parameters can be used to select
89 different source and destination database instances. The
90 parameters in question are:
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.
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).
103 The database name defaults to 'cocanwiki'.
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.
112 Use -dryrun as a parameter to test the copy. This does everything
113 and then rolls back the database at the end.
117 It is possible to use this script to implement a staging server.
119 The basic setup is that you have two hosts (called for example
120 'staging.example.com' and 'www.example.com' where the latter
121 is the live site). Create the staging host first (or use
122 copy_host to duplicate it from the live host if you already
123 have one). Do all editing on the staging server.
125 When you are satisfied with the state of the staging server
126 and are ready to go live, use the following command:
128 copy_host -shost staging.example.com -dhost www.example.com,example.com \
129 -overwrite -disableedit -enableviewanon
131 The key options to take note of are:
133 -overwrite If the dhost already exists, it can be overwritten.
134 (In fact what happens is that the existing destination
135 host is renamed to a unique name like 'deleted-<timestamp>')
137 -disableedit This disables the editing capability of all users on
138 the destination host. This stops users from accidentally
139 editing the live site.
141 -enableviewanon This enables anonymous viewing on the destination
142 host (assuming that the staging server is configured to
143 only allow logged in users to view, which is usually the
157 let sdbpassword = ref ""
158 let ddbpassword = ref ""
159 let sdbdatabase = ref "cocanwiki"
160 let ddbdatabase = ref "cocanwiki"
161 let dryrun = ref false
162 let overwrite = ref false
163 let disableedit = ref false
164 let enableviewanon = ref false
167 "-shost", Arg.Set_string shost,
168 "Source hostname (required).";
169 "-dhost", Arg.Set_string dhost,
170 "Destination hostname(s) (optional).";
171 "-sdbhost", Arg.Set_string sdbhost,
172 "Source database hostname (optional).";
173 "-ddbhost", Arg.Set_string ddbhost,
174 "Destination database hostname (optional).";
175 "-sdbport", Arg.Set_int sdbport,
176 "Source database port (optional).";
177 "-ddbport", Arg.Set_int ddbport,
178 "Destination database port (optional).";
179 "-sdbuser", Arg.Set_string sdbuser,
180 "Source database user (optional).";
181 "-ddbuser", Arg.Set_string ddbuser,
182 "Destination database user (optional).";
183 "-sdbpassword", Arg.Set_string sdbpassword,
184 "Source database password (optional).";
185 "-ddbpassword", Arg.Set_string ddbpassword,
186 "Destination database password (optional).";
187 "-sdbdatabase", Arg.Set_string sdbdatabase,
188 "Source database name (default: cocanwiki).";
189 "-ddbdatabase", Arg.Set_string ddbdatabase,
190 "Destination database name (default: cocanwiki).";
191 "-dryrun", Arg.Set dryrun,
192 "Rollback database changes at the end.";
193 "-overwrite", Arg.Set overwrite,
194 "Allow the destination host to be overwritten.";
195 "-disableedit", Arg.Set disableedit,
196 "Disable users.can_edit on the destination host.";
197 "-enableviewanon", Arg.Set enableviewanon,
198 "Enable hosts.view_anon on the destination host.";
201 let error _ = raise (Arg.Bad "Use --help for help.")
203 let () = Arg.parse argspec error usage
207 | "" -> failwith "-shost is required. Use --help for help."
212 | s -> String.nsplit s ","
213 let sdbhost = match !sdbhost with "" -> None | s -> Some s
214 let ddbhost = match !ddbhost with "" -> None | s -> Some s
215 let sdbport = match !sdbport with 0 -> None | p -> Some p
216 let ddbport = match !ddbport with 0 -> None | p -> Some p
217 let sdbuser = match !sdbuser with "" -> None | s -> Some s
218 let ddbuser = match !ddbuser with "" -> None | s -> Some s
219 let sdbpassword = match !sdbpassword with "" -> None | s -> Some s
220 let ddbpassword = match !ddbpassword with "" -> None | s -> Some s
221 let sdbdatabase = match !sdbdatabase with "" -> None | s -> Some s
222 let ddbdatabase = match !ddbdatabase with "" -> None | s -> Some s
224 let overwrite = !overwrite
225 let disableedit = !disableedit
226 let enableviewanon = !enableviewanon
228 (* Get column names from a table. *)
229 let columns dbh table_name =
230 let query = "select * from " ^ table_name ^ " order by 1" in
231 let name = "columns" in
232 PGOCaml.prepare dbh ~query ~name ();
234 match PGOCaml.describe_statement dbh ~name () with
236 List.map (fun { PGOCaml.name = name } -> name) results
237 | _, None -> assert false in
238 PGOCaml.close_statement dbh ~name ();
241 (* 'select * on table where ...' using the low level interface. *)
242 let select_all dbh table_name where_clause =
243 let query = "select * from " ^ table_name ^
244 (match where_clause with
246 | where_clause -> " where " ^ where_clause) ^
248 let name = "selectall" in
249 PGOCaml.prepare dbh ~query ~name ();
251 match PGOCaml.describe_statement dbh ~name () with
253 List.map (fun { PGOCaml.name = name } -> name) results
254 | _, None -> assert false in
255 let rows = PGOCaml.execute dbh ~name ~params:[] () in
256 PGOCaml.close_statement dbh ~name ();
259 (* Functions to remove or update the value in a column. *)
260 let rec remove_column columns rows col_name =
262 fun col_name' -> col_name <> col_name'
267 fun (col_name', value) ->
268 if col_name <> col_name' then Some value else None
269 ) (List.combine columns row)
272 and update_column columns rows col_name new_value =
277 fun (col_name', old_value) ->
278 if col_name <> col_name' then old_value else new_value
279 ) (List.combine columns row)
282 and update_apply_column columns rows col_name f =
287 fun (col_name', old_value) ->
288 if col_name <> col_name' then old_value else f old_value
289 ) (List.combine columns row)
292 (* Insert rows into the database table. *)
293 let insert dbh table_name columns rows =
294 let query = "insert into " ^ table_name ^ " (" ^
295 String.concat ", " columns
297 String.concat ", " (List.mapi (fun i _ -> sprintf "$%d" (i+1)) columns)
299 let name = "insertinto" in
300 PGOCaml.prepare dbh ~query ~name ();
301 List.iter (fun params -> ignore (PGOCaml.execute dbh ~name ~params ())) rows;
302 PGOCaml.close_statement dbh ~name ()
304 (* Insert rows into the database table, returning serial numbers. *)
305 let insert_serial dbh table_name columns rows serial_col =
306 let query = "insert into " ^ table_name ^ " (" ^
307 String.concat ", " columns
309 String.concat ", " (List.mapi (fun i _ -> sprintf "$%d" (i+1)) columns)
311 let name = "insertserial" in
312 PGOCaml.prepare dbh ~query ~name ();
313 let seq = table_name ^ "_" ^ serial_col ^ "_seq" in
317 ignore (PGOCaml.execute dbh ~name ~params ());
318 PGOCaml.serial4 dbh seq
320 PGOCaml.close_statement dbh ~name ();
323 let int32_of_value value =
324 let value = Option.get value in
325 Int32.of_string value
327 let value_of_int32 i =
328 let i = Int32.to_string i in
331 let value_of_bool b =
332 let b = string_of_bool b in
336 print_endline "Connecting to databases ...";
337 print_endline " Source ...";
339 let host = sdbhost in
340 let port = sdbport in
341 let user = sdbuser in
342 let password = sdbpassword in
343 let database = sdbdatabase in
344 PGOCaml.connect ?host ?port ?user ?password ?database () in
345 print_endline " Destination ...";
347 let host = ddbhost in
348 let port = ddbport in
349 let user = ddbuser in
350 let password = ddbpassword in
351 let database = ddbdatabase in
352 PGOCaml.connect ?host ?port ?user ?password ?database () in
353 print_endline "Locate source host ...";
354 let shostid = List.hd (
355 PGSQL(sdbh) "select hostid from hostnames where name = $shost"
357 let scanonical_hostname = List.hd (
358 PGSQL(sdbh) "select canonical_hostname from hosts where id = $shostid"
362 "select name from hostnames where hostid = $shostid order by 1" in
363 printf " shostid = %ld\n" shostid;
364 printf " scanonical_hostname = %s\n" scanonical_hostname;
365 printf " shostnames = [ %s ]\n" (String.concat "; " shostnames);
367 print_endline "Begin transaction on destination database ...";
368 PGOCaml.begin_work ddbh;
369 PGSQL(ddbh) "set constraints hosts_hostname_cn, pages_redirect_cn deferred";
371 (* Also start a transaction on the source database. We are not
372 * intending to make any changes, but this transaction ensures that we
373 * can't because the disconnect at the end of the program will roll any
376 PGOCaml.begin_work sdbh;
378 (* Tables hosts and hostnames are the most complex to copy because
379 * we may want to update the hostname.
381 let dcanonical_hostname, dhostnames =
383 | [] -> scanonical_hostname, shostnames
384 | x :: xs -> x, (x :: xs) in
386 (* Does the destination host already exist? *)
387 let dhost_exists, old_dhostid =
390 "select hostid from hostnames where name = $dcanonical_hostname" in
392 | [dhostid] -> true, dhostid
393 | _ -> false, (-1_l) in
394 if dhost_exists then (
396 (* Rename the destination host. *)
397 let name = sprintf "deleted-%.0f" (Unix.time ()) in
399 printf "Renaming old host %s to %s\n%!" dcanonical_hostname name;
402 "update hosts set canonical_hostname = $name where id = $old_dhostid";
404 "delete from hostnames where hostid = $old_dhostid";
406 "insert into hostnames (hostid, name) values ($old_dhostid, $name)";
408 failwith "Destination host exists. Did you mean to use -overwrite?"
411 print_endline "Create new host ...";
414 select_all sdbh "hosts" (sprintf "id = %ld" shostid) in
415 let nr_columns = List.length columns in
416 assert (nr_columns >= 19);
417 assert (List.length rows = 1);
418 let columns, rows = remove_column columns rows "id" in
419 assert (List.length columns = nr_columns - 1);
420 assert (List.length rows = 1);
422 update_column columns rows "canonical_hostname"
423 (Some dcanonical_hostname) in
424 assert (List.length columns = nr_columns - 1);
425 assert (List.length rows = 1);
427 if enableviewanon then
428 update_column columns rows "view_anon" (value_of_bool true)
431 let serials = insert_serial ddbh "hosts" columns rows "id" in
432 assert (List.length serials = 1);
433 let dhostid = List.hd serials in
434 printf " dhostid = %ld\n" dhostid;
436 print_endline "Create table hostnames ...";
439 printf " adding hostname %s\n" hostname;
441 "insert into hostnames (hostid, name) values ($dhostid, $hostname)"
444 (* Now start copying the tables.
445 * Not entirely trivial because where a table references another,
446 * we will need to update the IDs to match the corrected serial
449 print_endline "Copying table users ...";
451 select_all sdbh "users" (sprintf "hostid = %ld" shostid) in
452 assert (List.hd columns = "id");
453 let old_ids = List.map int32_of_value (List.map List.hd rows) in
455 remove_column columns rows "id" in
457 update_column columns rows "hostid" (value_of_int32 dhostid) in
460 update_column columns rows "can_edit" (value_of_bool false)
464 insert_serial ddbh "users" columns rows "id" in
466 let userid_map = List.combine old_ids new_ids in
468 print_endline "Copying tables contacts, contact_emails ...";
470 select_all sdbh "contacts" (sprintf "hostid = %ld" shostid) in
471 assert (List.hd columns = "id");
472 let old_ids = List.map int32_of_value (List.map List.hd rows) in
474 remove_column columns rows "id" in
476 update_column columns rows "hostid" (value_of_int32 dhostid) in
478 insert_serial ddbh "contacts" columns rows "id" in
480 let map = List.combine old_ids new_ids in
482 if old_ids <> [] then (
484 select_all sdbh "contact_emails"
486 String.concat ", " (List.map Int32.to_string old_ids) ^
489 update_apply_column columns rows "contactid"
491 let old_id = int32_of_value old_id in
492 value_of_int32 (List.assoc old_id map)) in
493 insert ddbh "contact_emails" columns rows
496 print_endline "Copying tables pages, contents ...";
498 select_all sdbh "pages" (sprintf "hostid = %ld" shostid) in
499 assert (List.hd columns = "id");
500 let old_ids = List.map int32_of_value (List.map List.hd rows) in
502 remove_column columns rows "id" in
504 remove_column columns rows "title_description_fti" in
506 update_column columns rows "hostid" (value_of_int32 dhostid) in
508 update_apply_column columns rows "logged_user"
511 | (Some _) as old_id ->
512 let old_id = int32_of_value old_id in
513 value_of_int32 (List.assoc old_id userid_map)) in
515 insert_serial ddbh "pages" columns rows "id" in
517 let map = List.combine old_ids new_ids in
519 if old_ids <> [] then (
521 select_all sdbh "contents"
523 String.concat ", " (List.map Int32.to_string old_ids) ^
525 let columns, rows = remove_column columns rows "id" in
526 let columns, rows = remove_column columns rows "content_fti" in
528 update_apply_column columns rows "pageid"
530 let old_id = int32_of_value old_id in
531 value_of_int32 (List.assoc old_id map)) in
532 insert ddbh "contents" columns rows
535 print_endline "Copying tables messages, msg_references ...";
537 select_all sdbh "messages" (sprintf "hostid = %ld" shostid) in
538 assert (List.hd columns = "id");
539 let old_ids = List.map int32_of_value (List.map List.hd rows) in
541 remove_column columns rows "id" in
543 update_column columns rows "hostid" (value_of_int32 dhostid) in
545 insert_serial ddbh "messages" columns rows "id" in
547 let map = List.combine old_ids new_ids in
549 if old_ids <> [] then (
551 select_all sdbh "msg_references"
553 String.concat ", " (List.map Int32.to_string old_ids) ^
556 update_apply_column columns rows "message_id"
558 let old_id = int32_of_value old_id in
559 value_of_int32 (List.assoc old_id map)) in
560 insert ddbh "msg_references" columns rows
563 print_endline "Copying table files ...";
565 select_all sdbh "files" (sprintf "hostid = %ld" shostid) in
567 remove_column columns rows "id" in
569 update_column columns rows "hostid" (value_of_int32 dhostid) in
570 insert ddbh "files" columns rows;
572 print_endline "Copying table images ...";
574 select_all sdbh "images" (sprintf "hostid = %ld" shostid) in
576 remove_column columns rows "id" in
578 update_column columns rows "hostid" (value_of_int32 dhostid) in
579 insert ddbh "images" columns rows;
581 print_endline "Copying table sitemenu ...";
583 select_all sdbh "sitemenu" (sprintf "hostid = %ld" shostid) in
585 update_column columns rows "hostid" (value_of_int32 dhostid) in
586 insert ddbh "sitemenu" columns rows;
588 print_endline "Copying table links ...";
590 select_all sdbh "links" (sprintf "hostid = %ld" shostid) in
592 update_column columns rows "hostid" (value_of_int32 dhostid) in
593 insert ddbh "links" columns rows;
595 print_endline "Copying table macros ...";
597 select_all sdbh "macros" (sprintf "hostid = %ld" shostid) in
599 update_column columns rows "hostid" (value_of_int32 dhostid) in
600 insert ddbh "macros" columns rows;
602 print_endline "Copying table page_emails ...";
604 select_all sdbh "page_emails" (sprintf "hostid = %ld" shostid) in
606 update_column columns rows "hostid" (value_of_int32 dhostid) in
607 insert ddbh "page_emails" columns rows;
609 print_endline "Copying table mailing_lists ...";
611 select_all sdbh "mailing_lists" (sprintf "hostid = %ld" shostid) in
613 update_column columns rows "hostid" (value_of_int32 dhostid) in
614 insert ddbh "mailing_lists" columns rows;
616 (* pending_email_changes and usercookies are only copied if the URL
617 * will not change, because if the URL does change then there is
618 * no point copying them because all cookies/email URLs will be
621 if scanonical_hostname = dcanonical_hostname && userid_map <> [] then (
625 (List.map Int32.to_string (List.map fst userid_map)) ^
628 print_endline "Copying table usercookies ...";
629 let columns, rows = select_all sdbh "usercookies" where_clause in
631 update_apply_column columns rows "userid"
634 | (Some _) as old_id ->
635 let old_id = int32_of_value old_id in
636 value_of_int32 (List.assoc old_id userid_map)) in
637 insert ddbh "usercookies" columns rows;
639 print_endline "Copying table pending_email_changes ...";
640 let columns, rows = select_all sdbh "pending_email_changes" where_clause in
642 update_apply_column columns rows "userid"
645 | (Some _) as old_id ->
646 let old_id = int32_of_value old_id in
647 value_of_int32 (List.assoc old_id userid_map)) in
648 insert ddbh "pending_email_changes" columns rows;
651 (* Note: Tables which are NOT copied:
653 * pg_ts_cfg -- Internal tables used by tsearch2
654 * pg_ts_cfgmap -- """"
656 * pg_ts_parser -- """"
657 * powered_by -- Fixed table.
658 * recently_visited -- Not worth copying.
659 * server_settings -- Global configuration table.
660 * templates -- Fixed table.
661 * themes -- Fixed table.
664 (* Commit or rollback. *)
666 print_endline "Rolling back database because -dryrun flag was given.";
667 PGOCaml.rollback ddbh
669 print_endline "Committing changes ...";
671 print_endline "Done."