jon.recoil.org
A fork of mtelver's day10 project
1let dir_size path =
2 let rec aux acc dir =
3 let entries = try Sys.readdir dir with _ -> [||] in
4 Array.fold_left (fun acc name ->
5 let full = Filename.concat dir name in
6 try
7 let stat = Unix.lstat full in
8 if stat.Unix.st_kind = Unix.S_DIR then aux (acc + stat.Unix.st_size) full
9 else acc + stat.Unix.st_size
10 with _ -> acc
11 ) (acc + (try (Unix.lstat dir).Unix.st_size with _ -> 0)) entries
12 in
13 aux 0 path
14
15let read_from_file filename = In_channel.with_open_text filename @@ fun ic -> In_channel.input_all ic
16let write_to_file filename str = Out_channel.with_open_text filename @@ fun oc -> Out_channel.output_string oc str
17let append_to_file filename str = Out_channel.with_open_gen [ Open_text; Open_append; Open_creat ] 0o644 filename @@ fun oc -> Out_channel.output_string oc str
18
19(* Per-PID logging *)
20let log_dir = ref None
21
22let set_log_dir dir =
23 log_dir := Some dir;
24 if not (Sys.file_exists dir) then
25 try Sys.mkdir dir 0o755 with _ -> ()
26
27let log fmt =
28 Printf.ksprintf (fun msg ->
29 match !log_dir with
30 | None -> () (* logging disabled *)
31 | Some dir ->
32 let pid = Unix.getpid () in
33 let timestamp = Unix.gettimeofday () in
34 let time_str =
35 let tm = Unix.localtime timestamp in
36 Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d.%03d"
37 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
38 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
39 (int_of_float ((timestamp -. floor timestamp) *. 1000.))
40 in
41 let log_file = Filename.concat dir (Printf.sprintf "%d.log" pid) in
42 let line = Printf.sprintf "[%s] %s\n" time_str msg in
43 append_to_file log_file line
44 ) fmt
45
46let sudo ?stdout ?stderr cmd =
47 log "exec: sudo %s" (String.concat " " cmd);
48 let r = Sys.command (Filename.quote_command ?stdout ?stderr "sudo" cmd) in
49 if r <> 0 then log "exec: sudo %s -> exit %d" (String.concat " " (List.filteri (fun i _ -> i < 3) cmd)) r;
50 r
51
52let exec ?stdout ?stderr cmd =
53 log "exec: %s" (String.concat " " cmd);
54 let r = Sys.command (Filename.quote_command ?stdout ?stderr (List.hd cmd) (List.tl cmd)) in
55 if r <> 0 then log "exec: %s -> exit %d" (String.concat " " (List.filteri (fun i _ -> i < 3) cmd)) r;
56 r
57
58let retry_exec ?stdout ?stderr ?(tries = 10) cmd =
59 let rec loop n =
60 match (exec ?stdout ?stderr cmd, n) with
61 | 0, _ -> 0
62 | r, 0 -> r
63 | _, n ->
64 OpamConsole.note "retry %i: %s" (tries - n + 1) (String.concat " " cmd);
65 Unix.sleepf (Random.float 2.0);
66 loop (n - 1)
67 in
68 loop tries
69
70let retry_rename ?(tries = 10) src dst =
71 let rec loop n =
72 try Unix.rename src dst with
73 | Unix.Unix_error (Unix.EACCES, x, y) ->
74 let d = tries - n + 1 in
75 OpamConsole.note "retry_rename %i: %s -> %s" d src dst;
76 Unix.sleep ((d * d) + Random.int d);
77 if n = 1 then raise (Unix.Unix_error (Unix.EACCES, x, y)) else loop (n - 1)
78 in
79 loop tries
80
81let run cmd =
82 let inp = Unix.open_process_in cmd in
83 let r = In_channel.input_all inp in
84 In_channel.close inp;
85 r
86
87let nproc () = run "nproc" |> String.trim |> int_of_string
88
89let rec mkdir ?(parents = false) dir =
90 if not (Sys.file_exists dir) then (
91 (if parents then
92 let parent_dir = Filename.dirname dir in
93 if parent_dir <> dir then mkdir ~parents:true parent_dir);
94 try Sys.mkdir dir 0o755
95 with Sys_error _ when Sys.file_exists dir && Sys.is_directory dir -> ())
96
97(** Create a unique temporary directory. Unlike Filename.temp_dir, this includes
98 the PID in the name to guarantee uniqueness across forked processes. *)
99let temp_dir ?(perms = 0o700) ~parent_dir prefix suffix =
100 let pid = Unix.getpid () in
101 let rec try_create attempts =
102 let rand = Random.int 0xFFFFFF in
103 let name = Printf.sprintf "%s%d-%06x%s" prefix pid rand suffix in
104 let path = Filename.concat parent_dir name in
105 try
106 Unix.mkdir path perms;
107 path
108 with Unix.Unix_error (Unix.EEXIST, _, _) ->
109 if attempts > 0 then try_create (attempts - 1)
110 else raise (Sys_error (path ^ ": File exists"))
111 in
112 try_create 100
113
114let rec rm ?(recursive = false) path =
115 try
116 let stat = Unix.lstat path in
117 match stat.st_kind with
118 | S_REG
119 | S_LNK
120 | S_CHR
121 | S_BLK
122 | S_FIFO
123 | S_SOCK -> (
124 try Unix.unlink path with
125 | Unix.Unix_error (Unix.EACCES, _, _) ->
126 Unix.chmod path (stat.st_perm lor 0o222);
127 Unix.unlink path)
128 | S_DIR ->
129 if recursive then Sys.readdir path |> Array.iter (fun f -> rm ~recursive (Filename.concat path f));
130 Unix.rmdir path
131 with
132 | Unix.Unix_error (Unix.ENOENT, _, _) -> (
133 try
134 match Sys.is_directory path with
135 | true -> Sys.rmdir path
136 | false -> Sys.remove path
137 with
138 | _ -> ())
139
140(** Remove a directory, using sudo if needed for root-owned files. *)
141let sudo_rm_rf path =
142 try rm ~recursive:true path with
143 | Unix.Unix_error (Unix.EACCES, _, _)
144 | Unix.Unix_error (Unix.EPERM, _, _) ->
145 (* Files owned by root from container builds - use sudo *)
146 ignore (sudo [ "rm"; "-rf"; path ])
147
148(** Safely rename a temp directory to a target directory.
149 Handles ENOTEMPTY which can occur if:
150 1. Another worker already completed the target (marker_file exists) - just clean up src
151 2. A previous crashed run left a stale target (no marker_file) - delete target and retry
152
153 [marker_file] is the path to check if the target is complete (e.g., layer.json) *)
154let safe_rename_dir ~marker_file src dst =
155 try Unix.rename src dst with
156 | Unix.Unix_error (Unix.ENOTEMPTY, _, _)
157 | Unix.Unix_error (Unix.EEXIST, _, _) ->
158 let dst_basename = Filename.basename dst in
159 if Sys.file_exists marker_file then begin
160 (* Target already complete by another worker - clean up our temp dir *)
161 log "Target already exists, cleaning up temp: %s" dst_basename;
162 sudo_rm_rf src
163 end else begin
164 (* Stale target from crashed run - remove it and retry *)
165 log "Removing stale target: %s" dst_basename;
166 sudo_rm_rf dst;
167 Unix.rename src dst
168 end
169
170module IntSet = Set.Make (Int)
171
172let fork ?np f lst =
173 let nproc = Option.value ~default:(nproc ()) np in
174 List.fold_left
175 (fun acc x ->
176 let acc =
177 let rec loop acc =
178 if IntSet.cardinal acc <= nproc then acc
179 else
180 let running, finished =
181 IntSet.partition
182 (fun pid ->
183 (try let c, _ = Unix.waitpid [ WNOHANG ] pid in pid <> c
184 with Unix.Unix_error (Unix.EINTR, _, _) -> true))
185 acc
186 in
187 let () = if IntSet.is_empty finished then Unix.sleepf 0.1 in
188 loop running
189 in
190 loop acc
191 in
192 match Unix.fork () with
193 | 0 ->
194 (* Reseed RNG after fork using PID to avoid temp directory collisions *)
195 Random.init (Unix.getpid () lxor int_of_float (Unix.gettimeofday () *. 1000000.));
196 f x;
197 exit 0
198 | child -> IntSet.add child acc)
199 IntSet.empty lst
200 |> IntSet.iter (fun pid -> ignore (Unix.waitpid [] pid))
201
202(** Fork with progress callback. [on_complete status] is called each time a worker finishes.
203 [status] is the exit code (0 = success, non-zero = failure). *)
204let fork_with_progress ?np ~on_complete f lst =
205 let nproc = Option.value ~default:(nproc ()) np in
206 let status_of_wait = function
207 | Unix.WEXITED c -> c
208 | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> -1
209 in
210 (* Try to reap finished processes, returning (still_running, exit_codes) *)
211 let reap_finished pids =
212 IntSet.fold (fun pid (running, codes) ->
213 match Unix.waitpid [ WNOHANG ] pid with
214 | c, status when c = pid -> (running, status_of_wait status :: codes)
215 | _ -> (IntSet.add pid running, codes)
216 | exception Unix.Unix_error (Unix.EINTR, _, _) -> (IntSet.add pid running, codes)
217 ) pids (IntSet.empty, [])
218 in
219 List.fold_left
220 (fun acc x ->
221 let acc =
222 let rec loop acc =
223 if IntSet.cardinal acc <= nproc then acc
224 else
225 let running, codes = reap_finished acc in
226 List.iter on_complete codes;
227 let () = if codes = [] then Unix.sleepf 0.1 in
228 loop running
229 in
230 loop acc
231 in
232 match Unix.fork () with
233 | 0 ->
234 (* Reseed RNG after fork using PID to avoid temp directory collisions *)
235 Random.init (Unix.getpid () lxor int_of_float (Unix.gettimeofday () *. 1000000.));
236 (try f x with exn ->
237 Printf.eprintf "Worker exception: %s\n%!" (Printexc.to_string exn);
238 exit 1);
239 exit 0
240 | child -> IntSet.add child acc)
241 IntSet.empty lst
242 |> fun remaining ->
243 (* Wait for all remaining processes *)
244 IntSet.iter (fun pid ->
245 let _, status = Unix.waitpid [] pid in
246 on_complete (status_of_wait status)
247 ) remaining
248
249(** Fork processes to run function on list items in parallel, collecting results.
250 Each process writes its result to a temp file, parent collects after all complete.
251 Returns list of (input, result option) pairs in original order. *)
252let fork_map ?np ~temp_dir ~serialize ~deserialize f lst =
253 let nproc = Option.value ~default:(nproc ()) np in
254 let indexed = List.mapi (fun i x -> (i, x)) lst in
255 (* Fork processes *)
256 let pids = List.fold_left
257 (fun acc (i, x) ->
258 let acc =
259 let rec loop acc =
260 if IntSet.cardinal acc <= nproc then acc
261 else
262 let running, finished =
263 IntSet.partition
264 (fun pid ->
265 (try let c, _ = Unix.waitpid [ WNOHANG ] pid in pid <> c
266 with Unix.Unix_error (Unix.EINTR, _, _) -> true))
267 acc
268 in
269 let () = if IntSet.is_empty finished then Unix.sleepf 0.1 in
270 loop running
271 in
272 loop acc
273 in
274 match Unix.fork () with
275 | 0 ->
276 (* Reseed RNG after fork using PID to avoid temp directory collisions *)
277 Random.init (Unix.getpid () lxor int_of_float (Unix.gettimeofday () *. 1000000.));
278 let result = f x in
279 let result_file = Filename.concat temp_dir (string_of_int i) in
280 (match result with
281 | Some r -> write_to_file result_file (serialize r)
282 | None -> ());
283 exit 0
284 | child -> IntSet.add child acc)
285 IntSet.empty indexed
286 in
287 IntSet.iter (fun pid ->
288 let rec wait () =
289 try ignore (Unix.waitpid [] pid)
290 with Unix.Unix_error (Unix.EINTR, _, _) -> wait ()
291 in
292 wait ()
293 ) pids;
294 (* Collect results *)
295 List.map (fun (i, x) ->
296 let result_file = Filename.concat temp_dir (string_of_int i) in
297 let result =
298 if Sys.file_exists result_file then
299 Some (deserialize (read_from_file result_file))
300 else
301 None
302 in
303 (x, result)
304 ) indexed
305
306(** Lock info for tracking active builds/docs/tools.
307 When provided, locks are created in a central directory with descriptive names. *)
308type lock_info = {
309 cache_dir : string;
310 stage : [`Build | `Doc | `Tool];
311 package : string;
312 version : string;
313 universe : string option; (* For Build/Doc: dependency hash. For Tool: OCaml version if applicable *)
314 layer_name : string option; (* The final layer directory name, for finding logs after completion *)
315}
316
317(** Generate lock filename from lock info *)
318let lock_filename info =
319 match info.stage, info.universe with
320 | `Build, Some u -> Printf.sprintf "build-%s.%s-%s.lock" info.package info.version u
321 | `Build, None -> Printf.sprintf "build-%s.%s.lock" info.package info.version
322 | `Doc, Some u -> Printf.sprintf "doc-%s.%s-%s.lock" info.package info.version u
323 | `Doc, None -> Printf.sprintf "doc-%s.%s.lock" info.package info.version
324 | `Tool, Some ocaml_ver -> Printf.sprintf "tool-%s-%s.lock" info.package ocaml_ver
325 | `Tool, None -> Printf.sprintf "tool-%s.lock" info.package
326
327(** Get or create locks directory *)
328let locks_dir cache_dir =
329 let dir = Path.(cache_dir / "locks") in
330 if not (Sys.file_exists dir) then
331 (try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
332 dir
333
334let create_directory_exclusively ?marker_file ?lock_info dir_name write_function =
335 (* Determine lock file location based on whether lock_info is provided *)
336 let lock_file = match lock_info with
337 | Some info -> Path.(locks_dir info.cache_dir / lock_filename info)
338 | None -> dir_name ^ ".lock"
339 in
340 let lock_fd = Unix.openfile lock_file [ O_CREAT; O_RDWR ] 0o644 in
341 let dir_basename = Filename.basename dir_name in
342 (* Try non-blocking lock first to detect contention *)
343 let got_lock_immediately =
344 try Unix.lockf lock_fd F_TLOCK 0; true with
345 | Unix.Unix_error (Unix.EAGAIN, _, _)
346 | Unix.Unix_error (Unix.EACCES, _, _) -> false
347 | Unix.Unix_error (Unix.EINTR, _, _) -> false
348 in
349 if not got_lock_immediately then begin
350 log "Waiting for lock: %s" dir_basename;
351 (* Retry lockf on EINTR (interrupted by signal) *)
352 let rec lock_with_retry () =
353 try Unix.lockf lock_fd F_LOCK 0 with
354 | Unix.Unix_error (Unix.EINTR, _, _) -> lock_with_retry ()
355 in
356 lock_with_retry ();
357 log "Acquired lock: %s" dir_basename
358 end;
359 (* Write lock metadata for monitoring:
360 Line 1: PID
361 Line 2: start time
362 Line 3: layer name (for finding logs after completion)
363 Line 4: temp log path (updated by write_function for live logs) *)
364 let layer_name = match lock_info with
365 | Some info -> Option.value ~default:"" info.layer_name
366 | None -> ""
367 in
368 let write_metadata ?temp_log_path () =
369 match lock_info with
370 | Some _ ->
371 let temp_log = Option.value ~default:"" temp_log_path in
372 let metadata = Printf.sprintf "%d\n%.0f\n%s\n%s\n" (Unix.getpid ()) (Unix.time ()) layer_name temp_log in
373 ignore (Unix.lseek lock_fd 0 Unix.SEEK_SET);
374 ignore (Unix.ftruncate lock_fd 0);
375 ignore (Unix.write_substring lock_fd metadata 0 (String.length metadata))
376 | None -> ()
377 in
378 write_metadata ();
379 (* Callback for write_function to update the temp log path for live viewing *)
380 let set_temp_log_path path = write_metadata ~temp_log_path:path () in
381 (* Check marker_file if provided, otherwise check directory existence *)
382 let already_complete = match marker_file with
383 | Some f -> Sys.file_exists f
384 | None -> Sys.file_exists dir_name
385 in
386 if not already_complete then begin
387 log "Building: %s" dir_basename;
388 write_function ~set_temp_log_path dir_name;
389 log "Completed: %s" dir_basename
390 end;
391 Unix.close lock_fd;
392 (* Only delete lock file if no lock_info (old behavior) -
393 with lock_info, we keep the file for stale cleanup later *)
394 (match lock_info with
395 | None -> (try Unix.unlink lock_file with _ -> ())
396 | Some _ -> ())
397
398exception Copy_error of string
399
400let cp ?(buffer_size = 65536) ?(preserve_permissions = true) ?(preserve_times = true) src dst =
401 let safe_close fd =
402 try Unix.close fd with
403 | _ -> ()
404 in
405 let src_stats =
406 try Unix.stat src with
407 | Unix.Unix_error (err, _, _) -> raise (Copy_error (Printf.sprintf "Cannot stat source file '%s': %s" src (Unix.error_message err)))
408 in
409 if src_stats.st_kind <> S_REG then raise (Copy_error (Printf.sprintf "Source '%s' is not a regular file" src));
410 let src_fd =
411 try Unix.openfile src [ O_RDONLY ] 0 with
412 | Unix.Unix_error (err, _, _) -> raise (Copy_error (Printf.sprintf "Cannot open source file '%s': %s" src (Unix.error_message err)))
413 in
414 let dst_fd =
415 try Unix.openfile dst [ O_WRONLY; O_CREAT; O_TRUNC ] src_stats.st_perm with
416 | Unix.Unix_error (err, _, _) ->
417 safe_close src_fd;
418 raise (Copy_error (Printf.sprintf "Cannot open destination file '%s': %s" dst (Unix.error_message err)))
419 in
420 let buffer = Bytes.create buffer_size in
421 let rec copy_loop () =
422 try
423 match Unix.read src_fd buffer 0 buffer_size with
424 | 0 -> ()
425 | bytes_read ->
426 let rec write_all pos remaining =
427 if remaining > 0 then
428 let bytes_written = Unix.write dst_fd buffer pos remaining in
429 write_all (pos + bytes_written) (remaining - bytes_written)
430 in
431 write_all 0 bytes_read;
432 copy_loop ()
433 with
434 | Unix.Unix_error (err, _, _) ->
435 safe_close src_fd;
436 safe_close dst_fd;
437 raise (Copy_error (Printf.sprintf "Error during copy: %s" (Unix.error_message err)))
438 in
439 copy_loop ();
440 safe_close src_fd;
441 safe_close dst_fd;
442 (if preserve_permissions then
443 try Unix.chmod dst src_stats.st_perm with
444 | Unix.Unix_error (err, _, _) -> Printf.eprintf "Warning: Could not preserve permissions: %s\n" (Unix.error_message err));
445 if preserve_times then
446 try Unix.utimes dst src_stats.st_atime src_stats.st_mtime with
447 | Unix.Unix_error (err, _, _) -> Printf.eprintf "Warning: Could not preserve timestamps: %s\n" (Unix.error_message err)
448
449let hardlink_tree ~source ~target =
450 let rec process_directory current_source current_target =
451 let entries = Sys.readdir current_source in
452 Array.iter
453 (fun entry ->
454 let source = Filename.concat current_source entry in
455 let target = Filename.concat current_target entry in
456 try
457 let stat = Unix.lstat source in
458 match stat.st_kind with
459 | S_LNK -> if not (Sys.file_exists target) then Unix.symlink (Unix.readlink source) target
460 | S_REG -> if not (Sys.file_exists target) then Unix.link source target
461 | S_DIR ->
462 mkdir target;
463 process_directory source target
464 | S_CHR
465 | S_BLK
466 | S_FIFO
467 | S_SOCK ->
468 ()
469 with
470 | Unix.Unix_error (Unix.EMLINK, _, _) -> cp source target
471 | Unix.Unix_error (err, _, _) -> Printf.eprintf "Warning: %s -> %s = %s\n" source target (Unix.error_message err))
472 entries
473 in
474 process_directory source target
475
476let clense_tree ~source ~target =
477 let rec process_directory current_source current_target =
478 let entries = Sys.readdir current_source in
479 Array.iter
480 (fun entry ->
481 let source = Filename.concat current_source entry in
482 let target = Filename.concat current_target entry in
483 try
484 let src_stat = Unix.lstat source in
485 match src_stat.st_kind with
486 | Unix.S_LNK -> if Sys.file_exists target then if Unix.readlink source = Unix.readlink target then Unix.unlink target
487 | Unix.S_REG ->
488 if Sys.file_exists target then
489 let tgt_stat = Unix.lstat target in
490 if src_stat.st_mtime = tgt_stat.st_mtime then (
491 try Unix.unlink target with
492 | Unix.Unix_error (Unix.EACCES, _, _) ->
493 Unix.chmod target (src_stat.st_perm lor 0o222);
494 Unix.unlink target)
495 | Unix.S_DIR -> (
496 process_directory source target;
497 try
498 if Sys.file_exists target then
499 let target_entries = Sys.readdir target in
500 if Array.length target_entries = 0 then Unix.rmdir target
501 with
502 | Unix.Unix_error (err, _, _) -> Printf.eprintf "Warning: rmdir %s = %s\n" target (Unix.error_message err))
503 | S_CHR
504 | S_BLK
505 | S_FIFO
506 | S_SOCK ->
507 ()
508 with
509 | Unix.Unix_error (err, _, _) -> Printf.eprintf "Warning: unlink %s = %s\n" target (Unix.error_message err))
510 entries
511 in
512 process_directory source target
513
514let copy_tree ~source ~target =
515 let rec process_directory current_source current_target =
516 let entries = Sys.readdir current_source in
517 Array.iter
518 (fun entry ->
519 let source = Filename.concat current_source entry in
520 let target = Filename.concat current_target entry in
521 try
522 let stat = Unix.lstat source in
523 match stat.st_kind with
524 | S_LNK -> if not (Sys.file_exists target) then Unix.symlink (Unix.readlink source) target
525 | S_REG -> if not (Sys.file_exists target) then cp source target
526 | S_DIR ->
527 mkdir target;
528 process_directory source target
529 | S_CHR
530 | S_BLK
531 | S_FIFO
532 | S_SOCK ->
533 ()
534 with
535 | Copy_error _ ->
536 Printf.eprintf "Warning: hard linking %s -> %s\n" source target;
537 Unix.link source target
538 | Unix.Unix_error (err, _, _) -> Printf.eprintf "Warning: %s -> %s = %s\n" source target (Unix.error_message err))
539 entries
540 in
541 process_directory source target
542
543let ls ?extn dir =
544 try
545 let files = Sys.readdir dir |> Array.to_list |> List.map (Filename.concat dir) in
546 match extn with
547 | None -> files
548 | Some ext ->
549 let ext = if ext <> "" && ext.[0] = '.' then ext else "." ^ ext in
550 List.filter (fun f -> Filename.check_suffix f ext) files
551 with
552 | Sys_error _ -> []
553
554(** Atomic directory swap for graceful degradation.
555
556 This module provides atomic swap operations for documentation directories,
557 implementing the "fresh docs with graceful degradation" pattern:
558 - Write new docs to a staging directory ([dir.new])
559 - On success, atomically swap: old -> [.old], new -> current, remove [.old]
560 - On failure, leave original docs untouched
561
562 Recovery: On startup, clean up any stale .new or .old directories left
563 from interrupted swaps. *)
564
565module Atomic_swap = struct
566 (** Clean up stale .new and .old directories from interrupted swaps.
567 Call this on startup before processing packages. *)
568 let cleanup_stale_dirs ~html_dir =
569 let p_dir = Filename.concat html_dir "p" in
570 if Sys.file_exists p_dir && Sys.is_directory p_dir then begin
571 try
572 Sys.readdir p_dir |> Array.iter (fun pkg_name ->
573 let pkg_dir = Filename.concat p_dir pkg_name in
574 if Sys.is_directory pkg_dir then begin
575 try
576 Sys.readdir pkg_dir |> Array.iter (fun version_dir ->
577 (* Clean up .new directories - incomplete writes *)
578 if Filename.check_suffix version_dir ".new" then begin
579 let stale_new = Filename.concat pkg_dir version_dir in
580 log "Cleaning up stale .new directory: %s" stale_new;
581 sudo_rm_rf stale_new
582 end
583 (* Clean up .old directories - incomplete swap *)
584 else if Filename.check_suffix version_dir ".old" then begin
585 let stale_old = Filename.concat pkg_dir version_dir in
586 log "Cleaning up stale .old directory: %s" stale_old;
587 sudo_rm_rf stale_old
588 end
589 )
590 with _ -> ()
591 end
592 )
593 with _ -> ()
594 end;
595 (* Also clean up universe directories *)
596 let u_dir = Filename.concat html_dir "u" in
597 if Sys.file_exists u_dir && Sys.is_directory u_dir then begin
598 try
599 Sys.readdir u_dir |> Array.iter (fun universe_hash ->
600 let universe_dir = Filename.concat u_dir universe_hash in
601 if Sys.is_directory universe_dir then begin
602 try
603 Sys.readdir universe_dir |> Array.iter (fun pkg_name ->
604 let pkg_dir = Filename.concat universe_dir pkg_name in
605 if Sys.is_directory pkg_dir then begin
606 try
607 Sys.readdir pkg_dir |> Array.iter (fun version_dir ->
608 if Filename.check_suffix version_dir ".new" then begin
609 let stale_new = Filename.concat pkg_dir version_dir in
610 log "Cleaning up stale .new directory: %s" stale_new;
611 sudo_rm_rf stale_new
612 end
613 else if Filename.check_suffix version_dir ".old" then begin
614 let stale_old = Filename.concat pkg_dir version_dir in
615 log "Cleaning up stale .old directory: %s" stale_old;
616 sudo_rm_rf stale_old
617 end
618 )
619 with _ -> ()
620 end
621 )
622 with _ -> ()
623 end
624 )
625 with _ -> ()
626 end
627
628 (** Get paths for atomic swap operations.
629 Returns (staging_dir, final_dir, old_dir) where:
630 - staging_dir: {version}.new - where new docs are written
631 - final_dir: {version} - the live docs location
632 - old_dir: {version}.old - backup during swap *)
633 let get_swap_paths ~html_dir ~pkg ~version ~blessed ~universe =
634 let base_dir =
635 if blessed then
636 Filename.concat (Filename.concat html_dir "p") pkg
637 else
638 Filename.concat (Filename.concat (Filename.concat html_dir "u") universe) pkg
639 in
640 let final_dir = Filename.concat base_dir version in
641 let staging_dir = final_dir ^ ".new" in
642 let old_dir = final_dir ^ ".old" in
643 (staging_dir, final_dir, old_dir)
644
645 (** Prepare staging directory for a package.
646 Creates the .new directory for doc generation.
647 Returns the staging path. *)
648 let prepare_staging ~html_dir ~pkg ~version ~blessed ~universe =
649 let staging_dir, _, _ = get_swap_paths ~html_dir ~pkg ~version ~blessed ~universe in
650 (* Remove any existing .new directory from failed previous attempt *)
651 if Sys.file_exists staging_dir then sudo_rm_rf staging_dir;
652 (* Create the staging directory structure *)
653 mkdir ~parents:true staging_dir;
654 staging_dir
655
656 (** Commit staging to final location atomically.
657 Performs the swap: final -> .old, staging -> final, remove .old
658 Returns true on success, false on failure. *)
659 let commit ~html_dir ~pkg ~version ~blessed ~universe =
660 let staging_dir, final_dir, old_dir = get_swap_paths ~html_dir ~pkg ~version ~blessed ~universe in
661 if not (Sys.file_exists staging_dir) then begin
662 log "commit: staging directory does not exist: %s" staging_dir;
663 false
664 end else begin
665 log "commit: swapping %s -> %s" staging_dir final_dir;
666 (* Step 1: If final exists, move to .old *)
667 let has_existing = Sys.file_exists final_dir in
668 (if has_existing then begin
669 (* Remove any stale .old first *)
670 if Sys.file_exists old_dir then sudo_rm_rf old_dir;
671 try Unix.rename final_dir old_dir with
672 | Unix.Unix_error (err, _, _) ->
673 log "commit: failed to rename %s to %s: %s" final_dir old_dir (Unix.error_message err);
674 raise Exit
675 end);
676 (* Step 2: Move staging to final *)
677 (try Unix.rename staging_dir final_dir with
678 | Unix.Unix_error (err, _, _) ->
679 log "commit: failed to rename %s to %s: %s" staging_dir final_dir (Unix.error_message err);
680 (* Try to restore old if we moved it *)
681 if has_existing && Sys.file_exists old_dir then begin
682 try Unix.rename old_dir final_dir with _ -> ()
683 end;
684 raise Exit);
685 (* Step 3: Remove .old backup *)
686 if has_existing && Sys.file_exists old_dir then
687 sudo_rm_rf old_dir;
688 log "commit: successfully swapped docs for %s/%s" pkg version;
689 true
690 end
691
692 (** Rollback staging on failure.
693 Removes the .new directory, leaving original docs intact. *)
694 let rollback ~html_dir ~pkg ~version ~blessed ~universe =
695 let staging_dir, _, _ = get_swap_paths ~html_dir ~pkg ~version ~blessed ~universe in
696 if Sys.file_exists staging_dir then begin
697 log "rollback: removing staging directory %s" staging_dir;
698 sudo_rm_rf staging_dir
699 end
700end