jon.recoil.org
this repo has no description
1(* TODO: Add content-addressed output paths (like day10's jtw_gen.ml) so that
2 worker.js, .cma.js, and .cmi files are served from paths containing a
3 content hash. This prevents stale browser caches after rebuilds.
4 See day10/bin/jtw_gen.ml for the reference implementation:
5 - compiler/<version>/<hash>/worker.js
6 - p/<pkg>/<version>/<hash>/lib/<name>/...
7 - findlib_index.json references hashed paths *)
8
9open Bos
10
11let opam = Cmd.v "opam"
12let switch = ref None
13let prefix = ref None
14
15type package = { name : string; version : string }
16
17let pp fmt p = Format.fprintf fmt "%s.%s" p.name p.version
18
19let rec get_switch () =
20 match !switch with
21 | None ->
22 let cur_switch =
23 Util.lines_of_process Cmd.(opam % "switch" % "show") |> List.hd
24 in
25 switch := Some cur_switch;
26 get_switch ()
27 | Some s -> s
28
29let prefix () =
30 match !prefix with
31 | Some p -> p
32 | None ->
33 let p =
34 Util.lines_of_process
35 Cmd.(opam % "var" % "--switch" % get_switch () % "prefix")
36 |> List.hd
37 in
38 prefix := Some p;
39 p
40
41let deps_of_opam_result line =
42 match Astring.String.fields ~empty:false line with
43 | [ name; version ] -> [ { name; version } ]
44 | _ -> []
45
46let all_opam_packages () =
47 Util.lines_of_process
48 Cmd.(
49 opam % "list" % "--switch" % get_switch () % "--columns=name,version"
50 % "--color=never" % "--short")
51 |> List.map deps_of_opam_result
52 |> List.flatten
53
54let pkg_contents { name; _ } =
55 let prefix = Fpath.v (prefix ()) in
56 let changes_file =
57 Format.asprintf "%a/.opam-switch/install/%s.changes" Fpath.pp prefix name
58 in
59 let file = OpamFilename.raw changes_file in
60 let filename =
61 OpamFile.make @@ OpamFilename.raw @@ Filename.basename changes_file
62 in
63 let changed =
64 OpamFilename.with_contents
65 (fun str ->
66 OpamFile.Changes.read_from_string ~filename
67 @@
68 (* Field [opam-version] is invalid in [*.changes] files, displaying a warning. *)
69 if String.starts_with ~prefix:"opam-version" str then
70 match OpamStd.String.cut_at str '\n' with
71 | Some (_, str) -> str
72 | None -> assert false
73 else str)
74 file
75 in
76 let added =
77 OpamStd.String.Map.fold
78 (fun file x acc ->
79 match x with
80 | OpamDirTrack.Added _ -> (
81 try
82 if not @@ Sys.is_directory Fpath.(to_string (prefix // v file))
83 then file :: acc
84 else acc
85 with _ ->
86 acc
87 (* dose (and maybe others) sometimes creates a symlink to something that doesn't exist *)
88 )
89 | _ -> acc)
90 changed []
91 in
92 List.map Fpath.v added
93
94(* let opam_file { name; version } = *)
95(* let prefix = Fpath.v (prefix ()) in *)
96(* let opam_file = *)
97(* Format.asprintf "%a/.opam-switch/packages/%s.%s/opam" Fpath.pp prefix name *)
98(* version *)
99(* in *)
100(* let ic = open_in opam_file in *)
101(* try *)
102(* let lines = Util.lines_of_channel ic in *)
103(* close_in ic; *)
104(* Some lines *)
105(* with _ -> *)
106(* close_in ic; *)
107(* None *)
108
109type installed_files = {
110 libs : Fpath.set;
111 odoc_pages : Fpath.set;
112 other_docs : Fpath.set;
113}
114
115type package_of_fpath = package Fpath.map
116
117(* Here we use an associative list *)
118type fpaths_of_package = (package * installed_files) list
119
120let pkg_to_dir_map () =
121 let pkgs = all_opam_packages () in
122 let prefix = prefix () in
123 let pkg_content =
124 List.map
125 (fun p ->
126 let contents = pkg_contents p in
127 let libs =
128 List.fold_left
129 (fun set fpath ->
130 match Fpath.segs fpath with
131 | "lib" :: "stublibs" :: _ -> set
132 | "lib" :: _ :: _ :: _ when Fpath.has_ext ".cmi" fpath ->
133 Fpath.Set.add
134 Fpath.(v prefix // fpath |> split_base |> fst)
135 set
136 | _ -> set)
137 Fpath.Set.empty contents
138 in
139 let odoc_pages, other_docs =
140 List.fold_left
141 (fun (odoc_pages, others) fpath ->
142 match Fpath.segs fpath with
143 | "doc" :: _pkg :: "odoc-pages" :: _ ->
144 Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
145
146 (Fpath.Set.add Fpath.(v prefix // fpath) odoc_pages, others)
147 | "doc" :: _ ->
148 Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);
149 (odoc_pages, Fpath.Set.add Fpath.(v prefix // fpath) others)
150 | _ -> (odoc_pages, others))
151 Fpath.Set.(empty, empty)
152 contents
153 in
154 Logs.debug (fun m ->
155 m "Found %d odoc pages, %d other docs"
156 (Fpath.Set.cardinal odoc_pages)
157 (Fpath.Set.cardinal other_docs));
158 (p, { libs; odoc_pages; other_docs }))
159 pkgs
160 in
161 let map =
162 List.fold_left
163 (fun map (p, { libs; _ }) ->
164 Fpath.Set.fold
165 (fun dir map ->
166 Fpath.Map.update dir
167 (function
168 | None -> Some p
169 | Some x ->
170 Logs.debug (fun m ->
171 m "Multiple packages (%a,%a) found for dir %a" pp x pp p
172 Fpath.pp dir);
173 Some p)
174 map)
175 libs map)
176 Fpath.Map.empty pkg_content
177 in
178 (pkg_content, map)