View source with raw comments or as raw
    1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@cs.vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (C): 2013, VU University Amsterdam
    7
    8    This program is free software; you can redistribute it and/or
    9    modify it under the terms of the GNU General Public License
   10    as published by the Free Software Foundation; either version 2
   11    of the License, or (at your option) any later version.
   12
   13    This program is distributed in the hope that it will be useful,
   14    but WITHOUT ANY WARRANTY; without even the implied warranty of
   15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16    GNU General Public License for more details.
   17
   18    You should have received a copy of the GNU General Public
   19    License along with this library; if not, write to the Free Software
   20    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   21
   22    As a special exception, if you link this library with other files,
   23    compiled with a Free Software compiler, to produce an executable, this
   24    library does not by itself cause the resulting executable to be covered
   25    by the GNU General Public License. This exception does not however
   26    invalidate any other reasons why the executable file might be covered by
   27    the GNU General Public License.
   28*/
   29
   30:- module(pack_mirror,
   31	  [ pack_mirror/3,		% +Pack, -MirrorArchive, -Hash
   32	    pack_unmirror/1,		% +Pack
   33	    pack_mirror_directory/1	% -Dir
   34	  ]).   35:- use_module(pack).   36:- use_module(library(sha)).   37:- use_module(library(git)).   38:- use_module(library(http/http_open)).   39:- use_module(library(http/http_ssl_plugin)).   40:- use_module(library(filesex)).   41:- use_module(library(lists)).   42:- use_module(library(debug)).   43
   44:- debug(pack(mirror)).

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. */

   53pack_mirror_dir('pack/mirror').
 pack_mirror_directory(-Dir)
True when Dir is the absolute file name for the mirrors.
   59:- dynamic
   60	cached_pack_mirror_dir/1.   61
   62pack_mirror_directory(Dir) :-
   63	cached_pack_mirror_dir(Dir), !.
   64pack_mirror_directory(Dir) :-
   65	pack_mirror_dir(Dir0),
   66	absolute_file_name(Dir0, Dir,
   67			   [ access(read),
   68			     file_type(directory),
   69			     file_errors(fail)
   70			   ]),
   71	asserta(cached_pack_mirror_dir(Dir)).
 pack_mirror(+Pack, -File, -Hash) is semidet
Try to mirror the latest version of Pack into File. Hash is the SHA1 hash of the pack archive. If the hash of the downloaded file does not match, the download file is deleted.
   80pack_mirror(Pack, Mirror, Hash) :-
   81	pack_version_hashes(Pack, [_Latest-Hashes|_Older]),
   82	pack_mirror(Pack, Hashes, Mirror, Hash).
   83
   84pack_mirror(Pack, Hashes, MirrorDir, Hash) :-
   85	setof(GitURL, hashes_git_url(Hashes, GitURL), GitURLs),
   86	pack_git_mirror(Pack, MirrorDir),
   87	GitOptions = [directory(MirrorDir), askpass(path(echo))],
   88	(   exists_directory(MirrorDir)
   89	->  (   Hashes = [Hash],
   90		git_hash(Hash, GitOptions)
   91	    ->	true
   92	    ;	forall(member(Hash, Hashes),
   93		       git_has_commit(MirrorDir, Hash))
   94	    ->	git_hash(Hash, GitOptions)
   95	    ;	member(URL, GitURLs),
   96	        git_remote_url(origin, URL, GitOptions),
   97		debug(pack(mirror), 'git pull in ~q', [MirrorDir]),
   98		catch(git([pull], GitOptions), E,
   99		      ( print_message(warning, E), fail))
  100	    ->	git_hash(Hash, GitOptions)
  101	    ;	print_message(warning, pack_mirror(Pack)), % TBD
  102		fail
  103	    )
  104	;   member(URL, GitURLs),
  105	    debug(pack(mirror), 'git clone ~q into ~q', [URL, MirrorDir]),
  106	    catch(git([clone, URL, MirrorDir], [askpass(path(echo))]), E,
  107		  ( print_message(warning, E), fail))
  108	->  git_hash(Hash, GitOptions)
  109	), !.
  110pack_mirror(_Pack, Hashes, File, Hash) :-
  111	member(Hash, Hashes),
  112	hash_file_url(Hash, URL),
  113	hash_file(Hash, File),
  114	(   exists_file(File)
  115	;   pack_url_hash(URL, Hash),
  116	    debug(pack(mirror), 'Downloading ~q into ~q', [URL, File]),
  117	    catch(setup_call_cleanup(
  118		      http_open(URL, In,
  119				[ cert_verify_hook(ssl_verify)
  120				]),
  121		      setup_call_cleanup(
  122			  open(File, write, Out, [type(binary)]),
  123			  copy_stream_data(In, Out),
  124			  close(Out)),
  125		      close(In)),
  126		  E,
  127		  ( print_message(warning, E),
  128		    fail
  129		  )),
  130	    file_sha1(File, FileSHA1),
  131	    (	Hash == FileSHA1
  132	    ->	true
  133	    ;	print_message(warning,
  134			      pack(hash_mismatch(URL, Hash, FileSHA1))),
  135		delete_file(File),
  136		fail
  137	    )
  138	), !.
  139
  140hashes_git_url(Hashes, URL) :-
  141	member(Hash, Hashes),
  142	hash_git_url(Hash, URL).
 git_has_commit(+Repo, +Commit)
True if Repo contains Commit. Cashed, which is safe because objects to not vanish in GIT.
  149:- dynamic
  150	git_commit_in_repo/2.  151
  152git_has_commit(Repo, Commit) :-
  153	git_commit_in_repo(Commit, Repo), !.
  154git_has_commit(Repo, Commit) :-
  155	catch(git_branches(_,
  156			   [ commit(Commit),
  157			     error(_),
  158			     directory(Repo)
  159			   ]), _, fail),
  160	assertz(git_commit_in_repo(Commit, Repo)).
 pack_unmirror(+Pack)
Delete all mirrors we have for Pack
  166pack_unmirror(Pack) :-
  167	(   pack_git_mirror(Pack, MirrorDir),
  168	    exists_directory(MirrorDir)
  169	->  print_message(informational, pack(unmirror(dir(MirrorDir)))),
  170	    catch(delete_directory_and_contents(MirrorDir), E,
  171		  print_message(warning, E))
  172	;   true
  173	),
  174	pack_version_hashes(Pack, VersionHashes),
  175	forall(member(_Version-Hashes, VersionHashes),
  176	       forall(member(Hash, Hashes),
  177		      delete_mirror_hash(Hash))).
  178
  179delete_mirror_hash(Hash) :-
  180	hash_file(Hash, File),
  181	(   exists_file(File)
  182	->  print_message(informational, pack(unmirror(file(File)))),
  183	    catch(delete_file(File), E, print_message(warning, E))
  184	;   true
  185	).
  186
  187:- public ssl_verify/5.
 ssl_verify(+SSL, +ProblemCert, +AllCerts, +FirstCert, +Error)
Currently we accept all certificates. We organise our own security using SHA1 signatures, so we do not care about the source of the data.
  195ssl_verify(_SSL,
  196	   _ProblemCertificate, _AllCertificates, _FirstCertificate,
  197	   _Error).
 hash_file(+Hash, -File) is det
True when File is the location for storing Hash
  203hash_file(Hash, File) :-
  204	pack_mirror_dir(Root),
  205	sub_atom(Hash, 0, 2, _, Dir0),
  206	sub_atom(Hash, 2, 2, _, Dir1),
  207	atomic_list_concat([Root, Dir0, Dir1], /, Dir),
  208	make_directory_path(Dir),
  209	directory_file_path(Dir, Hash, File).
 pack_git_mirror(+Pack, -GitDir)
True when MirrorDir is the directory in which we mirror Pack.
  215pack_git_mirror(Pack, GitDir) :-
  216	pack_mirror_dir(Root),
  217	directory_file_path(Root, 'GIT', GitRoot),
  218	make_directory_path(GitRoot),
  219	directory_file_path(GitRoot, Pack, GitDir).
  220
  221
  222		 /*******************************
  223		 *	      MESSAGES		*
  224		 *******************************/
  225
  226:- multifile
  227	prolog:message//1.  228
  229prolog:message(pack(hash_mismatch(URL, Hash, FileSHA1))) -->
  230	[ '~q: Hash mismatch'-[URL], nl,
  231	  '   Got      ~w'-[FileSHA1], nl,
  232	  '   Expected ~w'-[Hash]
  233	].
  234prolog:message(pack(mirror_failed(Pack))) -->
  235	[ 'Mirror for pack ~q failed'-[Pack] ].
  236prolog:message(pack(unmirror(dir(MirrorDir)))) -->
  237	[ 'Deleting GIT mirror directory ~p'-[MirrorDir] ].
  238prolog:message(pack(unmirror(file(Hash)))) -->
  239	[ 'Deleting mirror archive ~p'-[Hash] ]