jon.recoil.org
Odoc docs
1module SS = Set.Make (String)
2
3type outcome = { built : string list; failed : string list }
4
5let summary o =
6 Printf.sprintf "%d built, %d failed" (List.length o.built)
7 (List.length o.failed)
8
9let timestamp () =
10 let tm = Unix.localtime (Unix.gettimeofday ()) in
11 Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.Unix.tm_year + 1900)
12 (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
13 tm.Unix.tm_sec
14
15let log sw msg =
16 let write () =
17 ignore (Bos.OS.Dir.create ~path:true (Switch.state_dir sw));
18 let fd =
19 Unix.openfile
20 (Fpath.to_string (Switch.log_file sw))
21 [ O_WRONLY; O_APPEND; O_CREAT ]
22 0o644
23 in
24 Fun.protect
25 ~finally:(fun () -> Unix.close fd)
26 (fun () ->
27 let line = Printf.sprintf "[%s] %s\n" (timestamp ()) msg in
28 ignore (Unix.write_substring fd line 0 (String.length line)))
29 in
30 try write () with _ -> ()
31
32let with_lock sw f =
33 Result.bind (Bos.OS.Dir.create ~path:true (Switch.state_dir sw))
34 @@ fun (_ : bool) ->
35 match
36 Unix.openfile
37 (Fpath.to_string (Switch.lock_file sw))
38 [ O_WRONLY; O_CREAT ] 0o644
39 with
40 | exception Unix.Unix_error (e, _, _) -> Error (`Msg (Unix.error_message e))
41 | fd ->
42 Fun.protect
43 ~finally:(fun () -> Unix.close fd)
44 (fun () ->
45 Unix.lockf fd Unix.F_LOCK 0;
46 f ())
47
48(* Package names are [A-Za-z0-9_+-]; refuse to delete anything else so a
49 corrupt pending file can never escape the doc tree. *)
50let valid_pkg_name n =
51 n <> ""
52 && String.for_all
53 (fun c ->
54 match c with
55 | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '+' -> true
56 | _ -> false)
57 n
58
59let erase_doc sw name =
60 if valid_pkg_name name then
61 ignore (Bos.OS.Dir.delete ~recurse:true Fpath.(Switch.odoc_dir sw / name))
62
63(* The driver locates the switch by running `opam switch show`; make sure
64 that resolves to ours even when sync is invoked with an explicit
65 --prefix. *)
66let driver_env sw =
67 let prefix = Switch.prefix sw in
68 let switch_id =
69 if Fpath.basename prefix = "_opam" then
70 Fpath.to_string (Fpath.parent prefix)
71 else Fpath.basename prefix
72 in
73 let env =
74 Bos.OS.Env.current () |> Result.value ~default:Astring.String.Map.empty
75 in
76 env
77 |> Astring.String.Map.add "OPAM_SWITCH_PREFIX" (Fpath.to_string prefix)
78 |> Astring.String.Map.add "OPAMSWITCH" switch_id
79
80let run_driver sw ~driver ~env name =
81 let cmd = Bos.Cmd.(driver % name % "--actions" % "all") in
82 log sw (Printf.sprintf "running: %s" (Bos.Cmd.to_string cmd));
83 let result =
84 Bos.OS.Dir.with_current (Switch.work_dir sw)
85 (fun () ->
86 Bos.OS.Cmd.(run_out ~env ~err:err_run_out cmd |> out_string ~trim:true))
87 ()
88 in
89 match result with
90 | Error (`Msg m) | Ok (Error (`Msg m)) ->
91 log sw (Printf.sprintf "%s: failed to run driver: %s" name m);
92 Error ()
93 | Ok (Ok (output, (_, status))) -> (
94 if output <> "" then log sw output;
95 match status with
96 | `Exited 0 ->
97 log sw (Printf.sprintf "%s: ok" name);
98 Ok ()
99 | `Exited n ->
100 log sw (Printf.sprintf "%s: driver exited with %d" name n);
101 Error ()
102 | `Signaled n ->
103 log sw (Printf.sprintf "%s: driver killed by signal %d" name n);
104 Error ())
105
106let sync ?(driver = Bos.Cmd.v "odd-driver") sw =
107 with_lock sw @@ fun () ->
108 let installed = SS.of_list (List.map fst (Switch.installed sw)) in
109 let marked = Pending.read sw in
110 let stale = List.filter (fun n -> SS.mem n installed) marked in
111 (* A marker for a package that is no longer installed can only be left over
112 from an install+remove in the same session (the remove hook's [rm -rf]
113 normally clears it). Tidy it away. *)
114 List.iter (fun n -> if not (SS.mem n installed) then erase_doc sw n) marked;
115 (* Always regenerate the landing page (skipping the write when unchanged), so
116 a session that only removed packages still drops them from the list. *)
117 let finish outcome =
118 Result.bind (Index_page.write sw) @@ fun () ->
119 if outcome.built <> [] || outcome.failed <> [] then log sw (summary outcome);
120 Ok outcome
121 in
122 match stale with
123 | [] -> finish { built = []; failed = [] }
124 | _ ->
125 let driver_exists =
126 match Bos.OS.Cmd.resolve driver with Ok _ -> true | Error _ -> false
127 in
128 if not driver_exists then (
129 log sw
130 (Printf.sprintf "driver %s not found; leaving %d package(s) pending"
131 (Bos.Cmd.to_string driver) (List.length stale));
132 (* Markers left intact, so the next session retries. *)
133 finish { built = []; failed = stale })
134 else
135 Result.bind
136 (Result.map
137 (fun (_ : bool) -> ())
138 (Bos.OS.Dir.create ~path:true (Switch.work_dir sw)))
139 @@ fun () ->
140 let env = driver_env sw in
141 let ordered = Deps.order ~warn:(log sw) sw stale in
142 let built, failed =
143 List.fold_left
144 (fun (built, failed) name ->
145 (* Erase first (removing the marker) for a clean build; on failure
146 re-mark so the package is retried next session. *)
147 erase_doc sw name;
148 match run_driver sw ~driver ~env name with
149 | Ok () -> (name :: built, failed)
150 | Error () ->
151 ignore (Pending.mark sw name);
152 (built, name :: failed))
153 ([], []) ordered
154 in
155 finish { built = List.rev built; failed = List.rev failed }