30
31:- module(pack_mirror,
32 [ pack_mirror/3, 33 pack_unmirror/1, 34 pack_mirror_directory/1 35 ]). 36:- use_module(pack). 37:- use_module(library(sha)). 38:- use_module(library(git)). 39:- use_module(library(http/http_open)). 40:- use_module(library(http/http_ssl_plugin)). 41:- use_module(library(filesex)). 42:- use_module(library(lists)). 43:- use_module(library(debug)). 44
45:- debug(pack(mirror)).
54pack_mirror_dir(data('pack/mirror')).
60:- dynamic
61 cached_pack_mirror_dir/1. 62
63pack_mirror_directory(Dir) :-
64 cached_pack_mirror_dir(Dir), !.
65pack_mirror_directory(Dir) :-
66 pack_mirror_dir(Dir0),
67 absolute_file_name(Dir0, Dir,
68 [ access(read),
69 file_type(directory),
70 file_errors(fail)
71 ]),
72 asserta(cached_pack_mirror_dir(Dir)).
81pack_mirror(Pack, Mirror, Hash) :-
82 pack_version_hashes(Pack, [_Latest-Hashes|_Older]),
83 pack_mirror(Pack, Hashes, Mirror, Hash).
84
85pack_mirror(Pack, Hashes, MirrorDir, Hash) :-
86 setof(GitURL, hashes_git_url(Hashes, GitURL), GitURLs),
87 pack_git_mirror(Pack, MirrorDir),
88 GitOptions = [directory(MirrorDir), askpass(path(echo))],
89 ( exists_directory(MirrorDir)
90 -> ( Hashes = [Hash],
91 git_hash(Hash, GitOptions)
92 -> true
93 ; forall(member(Hash, Hashes),
94 git_has_commit(MirrorDir, Hash))
95 -> git_hash(Hash, GitOptions)
96 ; member(URL, GitURLs),
97 git_remote_url(origin, URL, GitOptions),
98 debug(pack(mirror), 'git pull in ~p', [MirrorDir]),
99 ( catch(git([pull], GitOptions), E,
100 ( print_message(warning, E), fail))
101 -> true
102 ; debug(pack(mirror), 'pull ~p failed; retrying with fetch', [MirrorDir]),
103 catch(git([reset, '--hard'], GitOptions), E,
104 ( print_message(warning, E), fail)),
105 catch(git([remote, prune, origin], GitOptions), E,
106 ( print_message(warning, E), fail)),
107 catch(git([fetch], GitOptions), E,
108 ( print_message(warning, E), fail)),
109 switch_to_main(Branch, GitOptions),
110 atom_concat('origin/', Branch, Origin),
111 catch(git([reset, '--hard', Origin], GitOptions), E,
112 ( print_message(warning, E), fail))
113 )
114 -> git_hash(Hash, GitOptions)
115 ; print_message(warning, pack_mirror(Pack)), 116 fail
117 )
118 ; member(URL, GitURLs),
119 debug(pack(mirror), 'git clone ~q into ~q', [URL, MirrorDir]),
120 catch(git([clone, URL, MirrorDir], [askpass(path(echo))]), E,
121 ( print_message(warning, E), fail))
122 -> git_hash(Hash, GitOptions)
123 ), !.
124pack_mirror(_Pack, Hashes, File, Hash) :-
125 member(Hash, Hashes),
126 hash_file_url(Hash, URL),
127 hash_file(Hash, File),
128 ( exists_file(File)
129 ; pack_url_hash(URL, Hash),
130 debug(pack(mirror), 'Downloading ~q into ~q', [URL, File]),
131 catch(setup_call_cleanup(
132 http_open(URL, In,
133 [ cert_verify_hook(ssl_verify)
134 ]),
135 setup_call_cleanup(
136 open(File, write, Out, [type(binary)]),
137 copy_stream_data(In, Out),
138 close(Out)),
139 close(In)),
140 E,
141 ( print_message(warning, E),
142 fail
143 )),
144 file_sha1(File, FileSHA1),
145 ( Hash == FileSHA1
146 -> true
147 ; print_message(warning,
148 pack(hash_mismatch(URL, Hash, FileSHA1))),
149 delete_file(File),
150 fail
151 )
152 ), !.
153
154switch_to_main(Branch, GitOptions) :-
155 git_current_branch(BranchName, GitOptions),
156 atom_concat('origin/', BranchName, Ref),
157 git_branches(Branches, [remote(true)|GitOptions]),
158 \+ memberchk(Ref, Branches),
159 default_branch(Branch),
160 atom_concat('origin/', Branch, NewRef),
161 memberchk(NewRef, Branches),
162 !,
163 catch(git([checkout, Branch], GitOptions), E,
164 ( print_message(warning, E), fail)).
165switch_to_main(Branch, GitOptions) :-
166 git_current_branch(Branch, GitOptions).
167
168default_branch(main).
169default_branch(master).
170
171
172hashes_git_url(Hashes, URL) :-
173 member(Hash, Hashes),
174 hash_git_url(Hash, URL).
181:- dynamic
182 git_commit_in_repo/2. 183
184git_has_commit(Repo, Commit) :-
185 git_commit_in_repo(Commit, Repo), !.
186git_has_commit(Repo, Commit) :-
187 catch(git_branches(_,
188 [ commit(Commit),
189 error(_),
190 directory(Repo)
191 ]), _, fail),
192 assertz(git_commit_in_repo(Commit, Repo)).
198pack_unmirror(Pack) :-
199 ( pack_git_mirror(Pack, MirrorDir),
200 exists_directory(MirrorDir)
201 -> print_message(informational, pack(unmirror(dir(MirrorDir)))),
202 catch(delete_directory_and_contents(MirrorDir), E,
203 print_message(warning, E))
204 ; true
205 ),
206 pack_version_hashes(Pack, VersionHashes),
207 forall(member(_Version-Hashes, VersionHashes),
208 forall(member(Hash, Hashes),
209 delete_mirror_hash(Hash))).
210
211delete_mirror_hash(Hash) :-
212 hash_file(Hash, File),
213 ( exists_file(File)
214 -> print_message(informational, pack(unmirror(file(File)))),
215 catch(delete_file(File), E, print_message(warning, E))
216 ; true
217 ).
218
219:- public ssl_verify/5.
227ssl_verify(_SSL,
228 _ProblemCertificate, _AllCertificates, _FirstCertificate,
229 _Error).
235hash_file(Hash, File) :-
236 pack_mirror_directory(Root),
237 sub_atom(Hash, 0, 2, _, Dir0),
238 sub_atom(Hash, 2, 2, _, Dir1),
239 atomic_list_concat([Root, Dir0, Dir1], /, Dir),
240 make_directory_path(Dir),
241 directory_file_path(Dir, Hash, File).
247pack_git_mirror(Pack, GitDir) :-
248 pack_mirror_directory(Root),
249 directory_file_path(Root, 'GIT', GitRoot),
250 make_directory_path(GitRoot),
251 directory_file_path(GitRoot, Pack, GitDir).
252
253
254 257
258:- multifile
259 prolog:message//1. 260
261prolog:message(pack(hash_mismatch(URL, Hash, FileSHA1))) -->
262 [ '~q: Hash mismatch'-[URL], nl,
263 ' Got ~w'-[FileSHA1], nl,
264 ' Expected ~w'-[Hash]
265 ].
266prolog:message(pack(mirror_failed(Pack))) -->
267 [ 'Mirror for pack ~q failed'-[Pack] ].
268prolog:message(pack(unmirror(dir(MirrorDir)))) -->
269 [ 'Deleting GIT mirror directory ~p'-[MirrorDir] ].
270prolog:message(pack(unmirror(file(Hash)))) -->
271 [ 'Deleting mirror archive ~p'-[Hash] ]
Mirror pack archives
This module maintains mirrors of the latest versions of pack archives as they are registered. This data will be used to maintain a database of meta-information on packs. */