1/*  Part of SWISH
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@cs.vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (C): 2004-2018, VU University Amsterdam
    7                              CWI Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(swish_version,
   37          [ check_prolog_version/1,     % +NumericVersion
   38            prolog_version_atom/1,      % -Atom
   39            register_git_module/2,      % +Name, +Options
   40            git_module_property/2,      % ?Name, ?Property
   41            git_update_versions/1       % ?Name
   42          ]).   43:- use_module(library(option)).   44:- use_module(library(lists)).   45:- use_module(library(git)).   46
   47
   48/** <module> Manage software versions
   49
   50The module deals with software  versions.   It  currently implements two
   51features:  test  whether   SWI-Prolog   is    sufficiently   new   using
   52check_prolog_version/1 and find GIT version   signatures for the running
   53server. Modules that want  their  version   info  available  through the
   54web-page can do so using a call to register_git_module/2.
   55*/
   56
   57:- multifile
   58    git_module_hook/3.              % Name, Dir, Options
   59
   60%!  check_prolog_version(+Required) is det.
   61%
   62%   Validate the program is running under Prolog version Required or
   63%   newer. Required is in numeric notation (e.g. 70718 for 7.7.18)
   64%
   65%   @error prolog_version_error(Required) if Prolog does not have
   66%   the required version.
   67
   68check_prolog_version(Required) :-
   69    prolog_version_ok(Required),
   70    !.
   71check_prolog_version(Required) :-
   72    throw(error(prolog_version_error(Required), _)).
   73
   74prolog_version_ok(or(V1, V2)) :-
   75    !,
   76    (   prolog_version_ok(V1)
   77    ->  true
   78    ;   prolog_version_ok(V2)
   79    ).
   80prolog_version_ok(Required) :-
   81    current_prolog_flag(version, MyVersion),
   82    MyVersion >= Required.
   83
   84%!  prolog_version_atom(-Atom) is det.
   85%
   86%   Atom describes the current Prolog version
   87
   88prolog_version_atom(Version) :-
   89    current_prolog_flag(version_git, Version),
   90    !.
   91prolog_version_atom(Version) :-
   92    current_prolog_flag(version_data, swi(Major,Minor,Patch,Options)),
   93    (   memberchk(tag(Tag), Options)
   94    ->  format(atom(Version), '~w.~w.~w-~w', [Major, Minor, Patch, Tag])
   95    ;   format(atom(Version), '~w.~w.~w',    [Major, Minor, Patch])
   96    ).
   97
   98
   99
  100:- multifile
  101    prolog:message//1,
  102    prolog:error_message//1.  103
  104prolog:error_message(prolog_version_error(Required)) -->
  105    { current_prolog_flag(version, MyVersion),
  106      user_version(MyVersion, MyV),
  107      user_version(Required, Req)
  108    },
  109    [ 'This program requires SWI-Prolog ~w'-[Req], nl,
  110      'while you are running version ~w.'-[MyV], nl,
  111      'Please visit http://www.swi-prolog.org and', nl,
  112      'upgrade your version of SWI-Prolog.'
  113    ].
  114prolog:message(git(no_version)) -->
  115    [ 'Sorry, cannot retrieve version stamp from GIT.' ].
  116prolog:message(git(update_versions)) -->
  117    [ 'Updating GIT version stamps in the background.' ].
  118
  119
  120user_version(or(V1,V2), Version) :-
  121    !,
  122    user_version(V1, A1),
  123    user_version(V2, A2),
  124    format(atom(Version), '~w or ~w', [A1, A2]).
  125user_version(N, Version) :-
  126    Major is N // 10000,
  127    Minor is (N // 100) mod 100,
  128    Patch is N mod 100,
  129    atomic_list_concat([Major, Minor, Patch], '.', Version).
  130
  131
  132                 /*******************************
  133                 *         REGISTRATION         *
  134                 *******************************/
  135
  136:- dynamic
  137    git_module/3,           % Name, Dir, Options
  138    git_module_prop/3.      % Name, Property, Value
  139
  140%!  register_git_module(+Name, +Options)
  141%
  142%   Register the directory from which the  Prolog file was loaded as
  143%   a GIT component about which to  report version information. This
  144%   should be used as a directive.  Defined options:
  145%
  146%       * directory(Dir)
  147%       Use Dir as the location of the GIT repository instead of the
  148%       directory of the file from which this directive was called.
  149%       If Dir is not absolute, it is taken relative to the
  150%       directory holding the file from which this directive was called.
  151%
  152%       * home_url(URL)
  153%       Used to create a link to the components home-page.
  154
  155register_git_module(Name, Options) :-
  156    (   prolog_load_context(directory, BaseDir)
  157    ->  true
  158    ;   working_directory(BaseDir, BaseDir)
  159    ),
  160    select_option(directory(Dir), Options, RestOptions, '.'),
  161    absolute_file_name(Dir, AbsDir,
  162                       [ file_type(directory),
  163                         relative_to(BaseDir),
  164                         access(read)
  165                       ]),
  166    retractall(git_module(Name, _, _)),
  167    assert(git_module(Name, AbsDir, RestOptions)).
  168
  169git_update_versions(Name) :-
  170    catch(forall(current_git_module(Name, _, _),
  171                 update_version(Name)),
  172          _,
  173          print_message(warning, git(no_version))).
  174
  175update_version(Name) :-
  176    current_git_module(Name, Dir, Options),
  177    (   catch(git_describe(GitVersion, [directory(Dir)|Options]), _, fail)
  178    ->  true
  179    ;   GitVersion = unknown
  180    ),
  181    retractall(git_module_prop(Name, version, _)),
  182    assert(git_module_prop(Name, version, GitVersion)).
  183
  184current_git_module(Name, Dir, Options) :-
  185    git_module(Name, Dir, Options).
  186current_git_module(Name, Dir, Options) :-
  187    git_module_hook(Name, Dir, Options).
  188
  189
  190%!  git_module_property(?Name, ?Property) is nondet.
  191%
  192%   Property is a property of the named git-component. Defined
  193%   properties are:
  194%
  195%       - version(Version)
  196%         git-describe like version information
  197%       - directory(Dir)
  198%         Base directory of the component
  199%       - remote(URL)
  200%         Location we are cloned from
  201%       - home_url(URL)
  202%         Project home
  203
  204git_module_property(Name, Property) :-
  205    (   var(Name)
  206    ->  current_git_module(Name, _, _),
  207        git_module_property(Name, Property)
  208    ;   compound(Property)
  209    ->  once(gen_module_property(Name, Property))
  210    ;   gen_module_property(Name, Property)
  211    ).
  212
  213gen_module_property(Name, version(Version)) :-
  214    (   git_module_prop(Name, version, Version0)
  215    ->  true
  216    ;   git_update_versions(Name),
  217        git_module_prop(Name, version, Version0)
  218    ),
  219    Version0 \== unknown,
  220    Version = Version0.
  221gen_module_property(Name, directory(Dir)) :-
  222    current_git_module(Name, Dir, _).
  223gen_module_property(Name, remote(Alias, Remote)) :-
  224    (   ground(Alias)
  225    ->  true
  226    ;   Alias = origin
  227    ),
  228    current_git_module(Name, Dir, _),
  229    (   git_module_prop(Name, remote, Alias-Remote)
  230    ->  true
  231    ;   git_remote_url(Alias, Remote, [directory(Dir)]),
  232        asserta(git_module_prop(Name, remote, Alias-Remote))
  233    ).
  234gen_module_property(Name, Term) :-
  235    current_git_module(Name, _, Options),
  236    member(Term, Options).
  237
  238
  239
  240                 /*******************************
  241                 *        KEEP UP-TO-DATE       *
  242                 *******************************/
  243
  244bg_git_update_versions :-
  245    print_message(informational, git(update_versions)),
  246    thread_create(git_update_versions(_), _,
  247                  [ detached(true)
  248                  ]).
  249
  250:- multifile
  251    user:message_hook/3.  252
  253user:message_hook(make(done(_)), _, _) :-
  254    bg_git_update_versions,
  255    fail.
  256
  257% do not update versions in background because we need to fork
  258:- if(current_predicate(http_unix_daemon:http_daemon/0)).  259:- initialization git_update_versions(_).  260:- else.  261:- initialization bg_git_update_versions.  262:- endif.