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
179
180
|
(* Co-installability tools
* http://coinst.irill.org/
* Copyright (C) 2012 Jérôme Vouillon
* Laboratoire PPS - CNRS Université Paris Diderot
*
* These programs are free software; you can redistribute them and/or
* modify them under the terms of the GNU General Public License as
* published by the Free Software Foundation; either version 2 of the
* License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
(*
- incremental update using Packages.diff?
*)
let src = "http://ftp.debian.org/debian/dists/"
let hint_src = "https://release.debian.org/britney/hints/"
let britney_src = "https://release.debian.org/britney/data-b2/"
let britney_files =
[("Dates", `Testing, "Dates");
("Urgency", `Testing, "Urgency");
("testing_BugsV", `Testing, "BugsV");
("unstable_BugsV", `Unstable, "BugsV")]
let sects = ["main"; "contrib"; "non-free"]
let ext = "gz"
let decompress_tool = "zcat"
(****)
let download dst url =
let tmp = dst ^ ".tmp" in
begin try Sys.remove tmp with Sys_error _ -> () end;
let cmd =
if Sys.file_exists dst then
Format.sprintf
"curl -L -f -z %s --create-dirs -o %s %s 2>/dev/null" dst tmp url
else
Format.sprintf "curl -L -f --create-dirs -o %s %s 2>/dev/null" tmp url
in
Format.eprintf "Fetching %s...@." url;
(*
Format.printf "> %s@." cmd;
*)
if Sys.command cmd = 0 && Sys.file_exists tmp then
ignore (Sys.rename tmp dst)
let rec make_directories f =
let f = Filename.dirname f in
if not (Sys.file_exists f) then begin
try
Unix.mkdir f (0o755)
with Unix.Unix_error (Unix.ENOENT, _, _) ->
make_directories f;
Unix.mkdir f (0o755)
end
let par_iter f l =
let l = List.map (fun s -> (s, Task.spawn (fun () -> ()))) l in
Task.iter l (fun (x, st) -> f st x) (fun () -> ());
List.iter (fun (_, st) -> Task.kill st) l
(****)
let uncompress cache_dir target_dir suite arch_tmp arch_dst =
let srcs =
List.map
(fun sect ->
Filename.concat cache_dir (Format.sprintf "%s/%s" sect arch_tmp))
sects
@
List.map
(fun sect ->
Filename.concat cache_dir
(Format.sprintf "%s/debian-installer/%s" sect arch_tmp))
sects
in
let dst = Filename.concat target_dir arch_dst in
let should_update =
try
let t = (Unix.stat dst).Unix.st_mtime in
List.exists
(fun src ->
try
(Unix.stat src).Unix.st_mtime > t
with Unix.Unix_error (Unix.ENOENT, _, _) ->
false)
srcs
with Unix.Unix_error (Unix.ENOENT, _, _) ->
true
in
if should_update then begin
make_directories dst;
let tmp = dst ^ ".tmp" in
let cmd = decompress_tool ^ " " ^ String.concat " " srcs ^ " > " ^ tmp in
Format.eprintf "> %s@." cmd;
ignore (Sys.command cmd);
ignore (Sys.rename tmp dst)
end
let update_suite suite archs target_dir =
let cache_dir = Filename.concat target_dir ".coinst_cache" in
List.iter
(fun (arch_tmp, arch_dst) ->
List.iter
(fun sect ->
let file1 = Format.sprintf "%s/%s" sect arch_tmp in
let url = Format.sprintf "%s%s/%s" src suite file1 in
let dst = Filename.concat cache_dir file1 in
download dst url;
let file2 =
Format.sprintf "%s/debian-installer/%s" sect arch_tmp in
let url = Format.sprintf "%s%s/%s" src suite file2 in
let dst = Filename.concat cache_dir file2 in
download dst url)
sects;
uncompress cache_dir target_dir suite arch_tmp arch_dst)
((Format.sprintf "source/Sources.%s" ext, "Sources") ::
List.map
(fun s -> (Format.sprintf "binary-%s/Packages.%s" s ext,
Format.sprintf "Packages_%s" s))
archs)
let update_suites suites archs =
let f =
Task.funct
(fun _ (suite, archs, target_dir) -> update_suite suite archs target_dir)
in
par_iter (fun st (suite, dir) -> f st (suite, archs, dir))
suites
(****)
let update_britney_files testing_dir unstable_dir =
let f =
Task.funct
(fun _ (src_file, suite, dst_file) ->
let dir =
match suite with
`Testing -> testing_dir
| `Unstable -> unstable_dir
in
let url = Format.sprintf "%s%s" britney_src src_file in
let dst = Filename.concat dir dst_file in
make_directories dst;
ignore (download dst url))
in
par_iter f britney_files
(****)
let update_hints hint_dir hint_files =
let f =
Task.funct
(fun _ file ->
let url = Format.sprintf "%s%s" hint_src file in
let dst = Filename.concat hint_dir file in
ignore (download dst url))
in
par_iter f hint_files
(****)
let f testing_dir unstable_dir archs hint_dir hint_files =
if Sys.command "curl -L -V > /dev/null" <> 0 then begin
Format.eprintf "Could not execute 'curl' command.@.";
exit 1
end;
update_suites [("testing", testing_dir); ("unstable", unstable_dir)] archs;
update_britney_files testing_dir unstable_dir;
update_hints hint_dir hint_files
|
