Source file opamRepositoryBackend.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
open OpamTypes
let log ?level fmt = OpamConsole.log "REPO_BACKEND" ?level fmt
let slog = OpamConsole.slog
type update =
| Update_full of dirname
| Update_patch of filename
| Update_empty
| Update_err of exn
module type S = sig
val name: OpamUrl.backend
val pull_url:
?full_fetch:bool ->
?cache_dir:dirname -> ?subpath:subpath -> dirname -> OpamHash.t option -> url ->
filename option download OpamProcess.job
val fetch_repo_update:
repository_name -> ?cache_dir:dirname -> dirname -> url ->
update OpamProcess.job
val repo_update_complete: dirname -> url -> unit OpamProcess.job
val revision: dirname -> string option OpamProcess.job
val sync_dirty:
?subpath:subpath -> dirname -> url -> filename option download OpamProcess.job
val get_remote_url:
?hash:string -> dirname ->
url option OpamProcess.job
end
let compare r1 r2 = compare r1.repo_name r2.repo_name
let to_string r =
Printf.sprintf "%s from %s"
(OpamRepositoryName.to_string r.repo_name)
(OpamUrl.to_string r.repo_url)
let to_json r =
`O [ ("name", OpamRepositoryName.to_json r.repo_name);
("kind", `String (OpamUrl.string_of_backend r.repo_url.OpamUrl.backend));
]
let check_digest filename = function
| Some expected
when OpamRepositoryConfig.(!r.force_checksums) <> Some false ->
(match OpamHash.mismatch (OpamFilename.to_string filename) expected with
| None -> true
| Some bad_hash ->
OpamConsole.error
"Bad checksum for %s: expected %s\n\
\ got %s\n\
Metadata might be out of date, in this case use `opam update`."
(OpamFilename.to_string filename)
(OpamHash.to_string expected)
(OpamHash.to_string bad_hash);
false)
| _ -> true
let job_text name label =
OpamProcess.Job.with_text
(Printf.sprintf "[%s: %s]"
(OpamConsole.colorise `green (OpamRepositoryName.to_string name))
label)
let get_files_for_diff parent_dir dir1 dir2 =
let getfiles parent_dir dir =
let dir = Filename.concat (OpamFilename.Dir.to_string parent_dir) dir in
OpamSystem.get_files_except_vcs dir
in
match dir1, dir2 with
| None, None -> assert false
| Some dir, None ->
List.map (fun file -> (Some (dir^"/"^file), None))
(getfiles parent_dir dir)
| None, Some dir ->
List.map (fun file -> (None, Some (dir^"/"^file)))
(getfiles parent_dir dir)
| Some dir1, Some dir2 ->
let files1 = List.fast_sort String.compare (getfiles parent_dir dir1) in
let files2 = List.fast_sort String.compare (getfiles parent_dir dir2) in
let rec aux acc files1 files2 = match files1, files2 with
| (file1::files1 as orig1), (file2::files2 as orig2) ->
let cmp = String.compare file1 file2 in
if cmp = 0 then
aux ((Some (dir1^"/"^file1), Some (dir2^"/"^file2)) :: acc)
files1 files2
else if cmp < 0 then
aux ((Some (dir1^"/"^file1), None) :: acc) files1 orig2
else
aux ((None, Some (dir2^"/"^file2)) :: acc) orig1 files2
| file1::files1, [] ->
aux ((Some (dir1^"/"^file1), None) :: acc) files1 []
| [], file2::files2 ->
aux ((None, Some (dir2^"/"^file2)) :: acc) [] files2
| [], [] ->
acc
in
aux [] files1 files2
let get_diff parent_dir dir1 dir2 =
let chrono = OpamConsole.timer () in
log "diff: %a/{%a,%a}"
(slog OpamFilename.Dir.to_string) parent_dir
(slog OpamFilename.Base.to_string) dir1
(slog OpamFilename.Base.to_string) dir2;
let readfile parent_dir file =
let real_file =
Filename.concat (OpamFilename.Dir.to_string parent_dir) file
in
(file, OpamSystem.read real_file)
in
let lstat_opt parent_dir = function
| None -> None
| Some file ->
let file = Filename.concat (OpamFilename.Dir.to_string parent_dir) file in
Some (Unix.lstat file)
in
let rec aux diffs dir1 dir2 =
let files = get_files_for_diff parent_dir dir1 dir2 in
let diffs =
List.fold_left (fun diffs (file1, file2) ->
let add_to_diffs content1 content2 diffs =
match Patch.diff content1 content2 with
| None -> diffs
| Some diff -> diff :: diffs
in
match lstat_opt parent_dir file1, lstat_opt parent_dir file2 with
| Some {st_kind = S_REG; _}, None
| None, Some {st_kind = S_REG; _}
| Some {st_kind = S_REG; _}, Some {st_kind = S_REG; _} ->
let content1 = Option.map (readfile parent_dir) file1 in
let content2 = Option.map (readfile parent_dir) file2 in
add_to_diffs content1 content2 diffs
| Some {st_kind = S_DIR; _}, None | None, Some {st_kind = S_DIR; _}
| Some {st_kind = S_DIR; _}, Some {st_kind = S_DIR; _} ->
aux diffs file1 file2
| Some {st_kind = S_DIR; _}, Some {st_kind = S_REG; _} ->
failwith "Change from a directory to a regular file is unsupported"
| Some {st_kind = S_REG; _}, Some {st_kind = S_DIR; _} ->
failwith "Change from a regular file to a directory is unsupported"
| Some {st_kind = S_LNK; _}, _ | _, Some {st_kind = S_LNK; _} ->
failwith "Symlinks are unsupported"
| Some {st_kind = S_CHR; _}, _ | _, Some {st_kind = S_CHR; _} ->
failwith "Character devices are unsupported"
| Some {st_kind = S_BLK; _}, _ | _, Some {st_kind = S_BLK; _} ->
failwith "Block devices are unsupported"
| Some {st_kind = S_FIFO; _}, _ | _, Some {st_kind = S_FIFO; _} ->
failwith "Named pipes are unsupported"
| Some {st_kind = S_SOCK; _}, _ | _, Some {st_kind = S_SOCK; _} ->
failwith "Sockets are unsupported"
| None, None -> assert false)
diffs files
in
diffs
in
match
aux []
(Some (OpamFilename.Base.to_string dir1))
(Some (OpamFilename.Base.to_string dir2))
with
| [] ->
log "Internal diff (empty) done in %.2fs." (chrono ());
None
| diffs ->
log "Internal diff (non-empty) done in %.2fs." (chrono ());
let patch = OpamSystem.temp_file ~auto_clean:false "patch" in
let patch_file = OpamFilename.of_string patch in
OpamFilename.write patch_file (Format.asprintf "%a" Patch.pp_list diffs);
Some patch_file