Something went wrong. Try again.
Odoc docs forked from jon.recoil.org/odd
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156module SS = Set.Make (String)
type outcome = { built : string list; failed : string list }
let summary o = Printf.sprintf "%d built, %d failed" (List.length o.built) (List.length o.failed)
let timestamp () = let tm = Unix.localtime (Unix.gettimeofday ()) in Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
let log sw msg = let write () = ignore (Bos.OS.Dir.create ~path:true (Switch.state_dir sw)); let fd = Unix.openfile (Fpath.to_string (Switch.log_file sw)) [ O_WRONLY; O_APPEND; O_CREAT ] 0o644 in Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> let line = Printf.sprintf "[%s] %s\n" (timestamp ()) msg in ignore (Unix.write_substring fd line 0 (String.length line))) in try write () with _ -> ()
let with_lock sw f = Result.bind (Bos.OS.Dir.create ~path:true (Switch.state_dir sw)) @@ fun (_ : bool) -> match Unix.openfile (Fpath.to_string (Switch.lock_file sw)) [ O_WRONLY; O_CREAT ] 0o644 with | exception Unix.Unix_error (e, _, _) -> Error (`Msg (Unix.error_message e)) | fd -> Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> Unix.lockf fd Unix.F_LOCK 0; f ())
(* Package names are [A-Za-z0-9_+-]; refuse to delete anything else so a corrupt pending file can never escape the doc tree. *)let valid_pkg_name n = n <> "" && String.for_all (fun c -> match c with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '+' -> true | _ -> false) n
let erase_doc sw name = if valid_pkg_name name then ignore (Bos.OS.Dir.delete ~recurse:true Fpath.(Switch.odoc_dir sw / name))
(* The driver locates the switch by running `opam switch show`; make sure that resolves to ours even when sync is invoked with an explicit --prefix. *)let driver_env sw = let prefix = Switch.prefix sw in let switch_id = if Fpath.basename prefix = "_opam" then Fpath.to_string (Fpath.parent prefix) else Fpath.basename prefix in let env = Bos.OS.Env.current () |> Result.value ~default:Astring.String.Map.empty in env |> Astring.String.Map.add "OPAM_SWITCH_PREFIX" (Fpath.to_string prefix) |> Astring.String.Map.add "OPAMSWITCH" switch_id
let run_driver sw ~driver ~env name = let cmd = Bos.Cmd.(driver % name % "--actions" % "all") in log sw (Printf.sprintf "running: %s" (Bos.Cmd.to_string cmd)); let result = Bos.OS.Dir.with_current (Switch.work_dir sw) (fun () -> Bos.OS.Cmd.(run_out ~env ~err:err_run_out cmd |> out_string ~trim:true)) () in match result with | Error (`Msg m) | Ok (Error (`Msg m)) -> log sw (Printf.sprintf "%s: failed to run driver: %s" name m); Error () | Ok (Ok (output, (_, status))) -> ( if output <> "" then log sw output; match status with | `Exited 0 -> log sw (Printf.sprintf "%s: ok" name); Ok () | `Exited n -> log sw (Printf.sprintf "%s: driver exited with %d" name n); Error () | `Signaled n -> log sw (Printf.sprintf "%s: driver killed by signal %d" name n); Error ())
let sync ?(driver = Bos.Cmd.v "odd-driver") sw = with_lock sw @@ fun () -> let installed = SS.of_list (List.map fst (Switch.installed sw)) in let marked = Pending.read sw in let stale = List.filter (fun n -> SS.mem n installed) marked in (* A marker for a package that is no longer installed can only be left over from an install+remove in the same session (the remove hook's [rm -rf] normally clears it). Tidy it away. *) List.iter (fun n -> if not (SS.mem n installed) then erase_doc sw n) marked; (* Always regenerate the landing page (skipping the write when unchanged), so a session that only removed packages still drops them from the list. *) let finish outcome = Result.bind (Index_page.write sw) @@ fun () -> if outcome.built <> [] || outcome.failed <> [] then log sw (summary outcome); Ok outcome in match stale with | [] -> finish { built = []; failed = [] } | _ -> let driver_exists = match Bos.OS.Cmd.resolve driver with Ok _ -> true | Error _ -> false in if not driver_exists then ( log sw (Printf.sprintf "driver %s not found; leaving %d package(s) pending" (Bos.Cmd.to_string driver) (List.length stale)); (* Markers left intact, so the next session retries. *) finish { built = []; failed = stale }) else Result.bind (Result.map (fun (_ : bool) -> ()) (Bos.OS.Dir.create ~path:true (Switch.work_dir sw))) @@ fun () -> let env = driver_env sw in let ordered = Deps.order ~warn:(log sw) sw stale in let built, failed = List.fold_left (fun (built, failed) name -> (* Erase first (removing the marker) for a clean build; on failure re-mark so the package is retried next session. *) erase_doc sw name; match run_driver sw ~driver ~env name with | Ok () -> (name :: built, failed) | Error () -> ignore (Pending.mark sw name); (built, name :: failed)) ([], []) ordered in finish { built = List.rev built; failed = List.rev failed }