lib_gitimport.pl

% Purpose: acquire unpinned runtime imports and pinned declarative Git
%   dependencies into isolated local checkout directories.
% Guarantees:
%   - git-import! refuses an unbound URL under its own MeTTa name before any
%     filesystem or process work [tested:
%     test_the_residual_positions_refuse_by_their_own_names].
%   - an existing target must itself be a Git worktree root; being nested in
%     another checkout is not enough [tested: tests/shell/test_git_import.sh;
%     commit=60b4e5a39f2274ad5d207dd9ce7b948b74a299ab].
%   - on a build with no library(process) every git route refuses under the
%     MeTTa name that reached it, naming the absent library and its cost,
%     rather than raising existence_error(procedure, process_create/3)
%     [tested: platform_capabilities_reduced:git_import_refuses_by_name_when_subprocess_is_absent;
%     commit=87d998c24278fc7f020ccb0e408ebcd9332b63eb].
%   - git_pinned_dependency/2 answers every revision this process pinned, by
%     either route, so a lockfile cannot name the declared pins and omit the
%     imported ones; an UNPINNED import records nothing, because a revision it
%     never chose is not a pin [tested: tests/shell/test_git_import.sh, the two
%     pin checks after the arity family; commit=ff4257005f562786e3ef7a5a37ce94b7d80e782d].


:- module(lib_gitimport,
          [ 'git-import!'/2,
            'git-import!'/3,
            'git-import!'/4,
            'git-import!'/5,
            acquire_declared_dependencies/1,
            git_pinned_dependency/2,
            % git_library_path/2 is read by engine/metta.pl's library/3, which resolves a
            % (library <alias> <file>) spec against a fetched dependency's directory.
            git_library_path/2
          ]).

% Guarantees: private helpers and autoload declarations belong to this module.
% [tested: engine_modules; commit=ede2ac57e213a0d4502c6bbbca6227f97015b720]
% Assumes: engine operations resolve through metta_engine's published exports.
% [source: engine/metta.pl:metta_engine_reexport/2; commit=ede2ac57e213a0d4502c6bbbca6227f97015b720]
:- set_module(base(metta_engine)).

:- use_module(library(filesex)).
%This file loads at BOOT, from engine/metta.pl's own ensure_loaded list, so it
%cannot use the pre-load declaration lib/lib_thread/lib_thread.pl carries: nothing is
%reading its manifest. It reads the census instead, which engine/metta.pl has
%already decided by the time this file loads, and refuses at the one place
%every route reaches a program (git_process_output/6 below) rather than at
%load, because a build that cannot start a process can still read every other
%thing this file does
%[tested: platform_capabilities_reduced:git_import_refuses_by_name_when_subprocess_is_absent].
:- ( metta_platform(subprocess, present, _, _)
   -> use_module(library(process))
   ;  true
   ).
:- use_module(library(random)).

:- dynamic git_dependency/2.
:- dynamic git_library_path/2.

% Runtime git-import! is a core primitive.  Declarative git-dependency forms use
% the same acquisition machinery before the file's runnable forms execute.
'git-import!'(Url, _) :-
    var(Url),
    !,
    refuse_unbound_input('git-import!', 1).
'git-import!'(Url, true) :-
    'git-import!'(Url, '', './repos', _).
'git-import!'(Url, Build, true) :-
    'git-import!'(Url, Build, './repos', _).
'git-import!'(Url0, Build0, Base0, true) :-
    maplist(git_atom, [Url0, Build0, Base0], [Url, Build, Base]),
    %The revision needs no such check: git_validate_sha/3 already
    %requires exactly 40 hexadecimal characters, which no hyphen passes.
    git_refuse_option_like(url, Url),
    git_refuse_option_like(build, Build),
    acquire_unpinned_repository('git-import!', Url, Build, Base,
                                Name, LocalDir),
    register_git_library_path(Name, LocalDir).
%The result slot is `[]`, the unit every effectful builtin in this engine
%answers with: 'import!'/3 (engine/metta/interop.pl), 'println!'/2
%(engine/metta/runtime.pl), and the three git-import! clauses above. This one
%alone answered `true`, so a program that imported a pinned dependency and then
%imported a library printed `True` for one and `()` for the other, and a caller
%passing the unit explicitly -- which is what the shell suite did -- simply
%FAILED to match this head, with no error, because a failed goal is not an
%error. That suite now checks all four arities answer the same unit, so the
%four cannot drift apart again
%[tested: tests/shell/test_git_import.sh].
'git-import!'(Url0, Build0, Base0, Rev0, true) :-
    maplist(git_atom, [Url0, Build0, Base0], [Url, Build, Base]),
    %The revision needs no such check: git_validate_sha/3 already
    %requires exactly 40 hexadecimal characters, which no hyphen passes.
    git_refuse_option_like(url, Url),
    git_refuse_option_like(build, Build),
    git_validate_sha('git-import!', Rev0, Rev),
    acquire_pinned_repository('git-import!', Url, Build, Base, Rev,
                              Name, LocalDir),
    acquire_manifest_dependencies(LocalDir),
    register_git_library_path(Name, LocalDir),
    record_git_pin(Url, Rev, Build, Base).

%The runtime form records what it pinned, in the SAME table the declarative
%form keeps, so a reader asking what revisions this process is running gets
%both routes from one place. Without it a lockfile could name the pins a
%manifest declared and silently omit the ones a program imported by hand,
%which is the half a reader would never think to check
%[tested: tests/shell/test_git_import.sh, the pin a runtime import records].
%
%Recorded AFTER the checkout succeeds, because it is a record of what happened
%rather than a claim about what will: a refused or failed acquisition leaves
%no row, exactly as the declarative form's marker is erased when its body
%raises. The row replaces any earlier one for the same URL, which is what
%keeps it true when one process imports the same repository twice; the
%declarative form's own conflict check is unchanged and now sees a runtime
%pin as the standing specification, which is what it is.
record_git_pin(Url, Rev, Build, Base) :-
    with_mutex(git_dependencies,
               (   absolute_file_name(Base, CanonBase, [file_errors(fail)])
               ->  normalize_git_url(Url, IdentityUrl),
                   retractall(git_dependency(IdentityUrl, _)),
                   assertz(git_dependency(IdentityUrl,
                                          dependency(Rev, Build, CanonBase)))
               ;   true
               )).

%Every pinned repository this process acquired, by either route: the URL as
%the identity the table keys on, and the full 40-character revision.
git_pinned_dependency(Url, Rev) :-
    git_dependency(Url, dependency(Rev, _, _)).

% Collect and satisfy the pinned dependencies declared by one parsed file.
acquire_declared_dependencies(ParsedForms) :-
    forall(member(parsed(expression, _, ['git-dependency'|Args]), ParsedForms),
           acquire_git_declaration(Args)).

acquire_git_declaration([Url, Rev]) :- !,
    acquire_git_declaration([Url, Rev, ""]).
acquire_git_declaration([Url, Rev, Build]) :- !,
    acquire_git_declaration([Url, Rev, Build, "./repos"]).
acquire_git_declaration([Url0, Rev0, Build0, Base0]) :- !,
    maplist(git_atom, [Url0, Build0, Base0], [Url, Build, Base]),
    %The revision needs no such check: git_validate_sha/3 already
    %requires exactly 40 hexadecimal characters, which no hyphen passes.
    git_refuse_option_like(url, Url),
    git_refuse_option_like(build, Build),
    git_validate_sha('git-dependency', Rev0, Rev),
    acquire_git_dependency(Url, Rev, Build, Base).
acquire_git_declaration(Args) :-
    throw(error(domain_error(git_dependency_declaration, Args),
                context('git-dependency',
                        'expected (git-dependency url rev [build [basedir]])'))).

% A declarative URL has one complete dependency specification per process.  This
% prevents manifests from silently changing revision, build, or checkout root
% beneath already-loaded code.
acquire_git_dependency(Url, Rev, Build, Base) :-
    with_mutex(git_dependencies,
               acquire_git_dependency_impl(Url, Rev, Build, Base)).

acquire_git_dependency_impl(Url, Rev, Build, Base) :-
    absolute_file_name(Base, CanonBase, [file_errors(fail)]),
    normalize_git_url(Url, IdentityUrl),
    Spec = dependency(Rev, Build, CanonBase),
    ( git_dependency(IdentityUrl, PreviousSpec)
      -> ( PreviousSpec == Spec
           -> true
            ; throw(error(domain_error(conflicting_git_dependency, Url),
                          context('git-dependency',
                                  conflicting_specs(PreviousSpec, Spec)))) )
       ; run_with_loading_marker(
             git_dependency(IdentityUrl, Spec),
             acquire_git_dependency_body(Url, Rev, Build, CanonBase)) ).

acquire_git_dependency_body(Url, Rev, Build, Base) :-
    acquire_pinned_repository('git-dependency', Url, Build, Base, Rev,
                              Name, LocalDir),
    acquire_manifest_dependencies(LocalDir),
    register_git_library_path(Name, LocalDir).

% A checkout can declare transitive pinned dependencies in deps.metta.
acquire_manifest_dependencies(LocalDir) :-
    directory_file_path(LocalDir, 'deps.metta', Manifest),
    ( exists_file(Manifest)
      -> read_file_to_string(Manifest, Source, []),
         parse_metta_source(Source, ParsedForms),
         acquire_declared_dependencies(ParsedForms)
       ; true ).

% The name is recorded explicitly with the canonical checkout root.  library/3
% can therefore perform an exact lookup instead of guessing from path suffixes.
register_git_library_path(Name0, LocalDir) :-
    git_atom(Name0, Name),
    absolute_file_name(LocalDir, CanonDir,
                       [file_type(directory), file_errors(fail)]),
    ( git_library_path(Name, CanonDir)
      -> true
       ; git_library_path(Name, Existing)
      -> throw(error(permission_error(register, git_library, Name),
                     context(register_git_library_path/2,
                             conflicting_paths(Existing, CanonDir))))
       ; assertz(git_library_path(Name, CanonDir)) ).

acquire_unpinned_repository(Context, Url, Build, Base, Name, LocalDir) :-
    make_directory_path(Base),
    git_repository_name(Url, Name),
    directory_file_path(Base, Name, LocalDir),
    atom_concat(LocalDir, '.lock', LockFile),
    setup_call_cleanup(
        open(LockFile, append, Lock, [lock(write)]),
        acquire_unpinned_locked(Context, Url, Build, Base, Name, LocalDir),
        close(Lock)).

acquire_unpinned_locked(Context, Url, Build, Base, Name, LocalDir) :-
    ( exists_directory(LocalDir)
      -> ensure_git_checkout(Context, LocalDir),
         ensure_git_origin(Context, LocalDir, Url),
         git_output(Context, 'resolve current HEAD', LocalDir,
                    ['rev-parse', '--verify', 'HEAD^{commit}'], Head),
         ensure_git_build(Context, LocalDir, Head, Build)
       ; exists_file(LocalDir)
      -> throw(error(permission_error(create, git_checkout, LocalDir),
                     context(Context, 'target exists and is not a directory')))
       ; create_staging_directory(Context, Base, Name, StagingRoot),
         directory_file_path(StagingRoot, Name, StagingDir),
         setup_call_cleanup(
             true,
             ( git_process(Context, 'clone repository', path(git),
                           [clone, '--depth', '1', '--', Url, StagingDir], []),
               git_output(Context, 'resolve current HEAD', StagingDir,
                          ['rev-parse', '--verify', 'HEAD^{commit}'], Head),
               ensure_git_build(Context, StagingDir, Head, Build),
               rename_file(StagingDir, LocalDir) ),
             delete_directory_and_contents(StagingRoot)) ).

acquire_pinned_repository(Context, Url, Build, Base, Rev, Name, LocalDir) :-
    make_directory_path(Base),
    git_repository_name(Url, Name),
    directory_file_path(Base, Name, LocalDir),
    atom_concat(LocalDir, '.lock', LockFile),
    setup_call_cleanup(
        open(LockFile, append, Lock, [lock(write)]),
        acquire_pinned_locked(Context, Url, Build, Base, Name, LocalDir, Rev),
        close(Lock)).

acquire_pinned_locked(Context, Url, Build, Base, Name, LocalDir, Rev) :-
    ( exists_directory(LocalDir)
      -> ensure_git_checkout(Context, LocalDir),
         ensure_git_origin(Context, LocalDir, Url),
         git_output(Context, 'resolve current HEAD', LocalDir,
                    ['rev-parse', '--verify', 'HEAD^{commit}'], Head),
         ( Head == Rev
           -> ensure_tracked_checkout_clean(Context, LocalDir)
            ; ensure_clean_checkout(Context, LocalDir),
              fetch_git_commit(Context, LocalDir, Rev),
              checkout_git_commit(Context, LocalDir, Rev),
              verify_git_head(Context, LocalDir, Rev) ),
         ensure_git_build(Context, LocalDir, Rev, Build)
       ; exists_file(LocalDir)
      -> throw(error(permission_error(create, git_checkout, LocalDir),
                     context(Context, 'target exists and is not a directory')))
       ; create_staging_directory(Context, Base, Name, StagingRoot),
         directory_file_path(StagingRoot, Name, StagingDir),
         setup_call_cleanup(
             true,
             ( git_process(Context, 'clone repository', path(git),
                           [clone, '--no-checkout', '--', Url, StagingDir], []),
               fetch_git_commit(Context, StagingDir, Rev),
               checkout_git_commit(Context, StagingDir, Rev),
               verify_git_head(Context, StagingDir, Rev),
               ensure_git_build(Context, StagingDir, Rev, Build),
               rename_file(StagingDir, LocalDir) ),
             delete_directory_and_contents(StagingRoot)) ).

git_repository_name(Url, Name) :-
    atom_string(Url, UrlString),
    split_string(UrlString, "/:", "/:", Parts0),
    exclude(==(""), Parts0, Parts),
    last(Parts, Last),
    ( string_concat(NameString, ".git", Last) -> true ; NameString = Last ),
    atom_string(Name, NameString).

git_validate_sha(_Context, Rev0, Rev) :-
    git_atom(Rev0, Candidate),
    atom_codes(Candidate, Codes),
    length(Codes, 40),
    maplist(git_hex_code, Codes), !,
    downcase_atom(Candidate, Rev).
git_validate_sha(Context, Rev, _) :-
    throw(error(domain_error(full_git_commit_sha, Rev),
                context(Context,
                        'commit must be exactly 40 hexadecimal characters'))).

git_hex_code(Code) :- between(0'0, 0'9, Code), !.
git_hex_code(Code) :- between(0'a, 0'f, Code), !.
git_hex_code(Code) :- between(0'A, 0'F, Code).

git_atom(Value, Atom) :- atom(Value), !, Atom = Value.
git_atom(Value, Atom) :- string(Value), !, atom_string(Atom, Value).
git_atom(Value, _) :- throw(error(type_error(text, Value), none)).

%A value beginning with `-` is parsed by git as an OPTION rather than as the
%repository or revision it stands in for. Measured against git's own parser:
%`git clone --depth 1 --no-such-option d` answers "unknown option", and fetch,
%checkout and cat-file answer the same for a dash-leading positional.
%
%The `--` terminator is the documented remedy and it is applied below where git
%accepts it, in `clone` and `fetch`, but it CANNOT be the whole answer: for
%`git checkout` the same token introduces PATHS rather than ending options, so
%adding it there would change what the command means. Refusing the leading dash
%covers every subcommand and does not depend on which of them terminates.
%
%Nothing legitimate is excluded. A repository URL is a scheme, a host or a
%path; a revision is a hash, a ref or a name; a build script is a filename.
%None of the three begins with a hyphen.
git_refuse_option_like(Position, Value) :-
    (   atom(Value),
        atom_concat('-', _, Value)
    ->  throw(error(domain_error(git_option_like_argument, Value),
                    context(Position,
                            'a leading hyphen makes this parse as a git \c
                             option rather than as the value; give the value \c
                             without it, or write ./NAME for a local path')))
    ;   true
    ).

create_staging_directory(_Context, Base, Name, StagingRoot) :-
    between(1, 100, _),
    random_between(100000000, 999999999, Suffix),
    format(atom(TempName), '.~w.git-acquire-~d', [Name, Suffix]),
    directory_file_path(Base, TempName, Candidate),
    catch(make_directory(Candidate), error(existence_error(_, _), _), fail), !,
    StagingRoot = Candidate.
create_staging_directory(Context, _, Name, _) :-
    throw(error(resource_error(temporary_directory), context(Context, Name))).

ensure_git_checkout(Context, LocalDir) :-
    catch(git_output(Context, 'validate Git checkout', LocalDir,
                     ['rev-parse', '--show-toplevel'], WorktreeRoot), _, fail),
    catch(same_file(LocalDir, WorktreeRoot), _, fail),
    !.
ensure_git_checkout(Context, LocalDir) :-
    throw(error(domain_error(git_checkout, LocalDir),
                context(Context, 'existing target is not a Git checkout'))).

ensure_git_origin(Context, LocalDir, Url) :-
    git_output(Context, 'read origin URL', LocalDir,
               [remote, 'get-url', origin], Actual),
    normalize_git_url(Actual, NormalActual),
    normalize_git_url(Url, NormalUrl),
    ( NormalActual == NormalUrl
      -> true
       ; throw(error(domain_error(git_origin, Actual),
                     context(Context, expected(Url)))) ).

normalize_git_url(Url, Normal) :-
    ( atom_concat(Base, '.git', Url)
      -> Normal = Base
       ; Normal = Url
    ).

ensure_clean_checkout(Context, LocalDir) :-
    git_output(Context, 'check checkout cleanliness', LocalDir,
               [status, '--porcelain', '--untracked-files=all'], Status),
    ( Status == ''
      -> true
       ; throw(error(permission_error(modify, dirty_git_checkout, LocalDir),
                     context(Context, Status))) ).

ensure_tracked_checkout_clean(Context, LocalDir) :-
    git_output(Context, 'check tracked checkout cleanliness', LocalDir,
               [status, '--porcelain', '--untracked-files=no'], Status),
    ( Status == ''
      -> true
       ; throw(error(permission_error(modify, dirty_git_checkout, LocalDir),
                     context(Context, Status))) ).

fetch_git_commit(Context, LocalDir, Rev) :-
    git_process(Context, 'fetch requested commit', path(git),
                [fetch, '--no-tags', '--', origin, Rev], [cwd(LocalDir)]),
    atom_concat(Rev, '^{commit}', CommitObject),
    git_process(Context, 'resolve requested commit object', path(git),
                ['cat-file', '-e', CommitObject], [cwd(LocalDir)]).

checkout_git_commit(Context, LocalDir, Rev) :-
    git_process(Context, 'checkout requested commit', path(git),
                [checkout, '--detach', Rev], [cwd(LocalDir)]).

verify_git_head(Context, LocalDir, Rev) :-
    git_output(Context, 'verify checked out HEAD', LocalDir,
               ['rev-parse', '--verify', 'HEAD^{commit}'], Head),
    ( Head == Rev
      -> true
       ; throw(error(consistency_error(git_head, Rev, Head),
                     context(Context, LocalDir))) ).

run_git_build(Context, LocalDir, Build) :-
    format("Running build: ~w in ~w~n", [Build, LocalDir]),
    git_process(Context, 'build imported repository', path(sh),
                [Build], [cwd(LocalDir)]).

ensure_git_build(_, _, _, Build) :- Build == '', !.
ensure_git_build(Context, LocalDir, Rev, Build) :-
    ( valid_git_build_stamp(Context, LocalDir, Rev, Build)
      -> true
       ; run_git_build(Context, LocalDir, Build),
         write_git_build_stamp(Context, LocalDir, Rev, Build) ).

git_build_stamp_file(Context, LocalDir, StampFile) :-
    git_output(Context, 'resolve Git metadata directory', LocalDir,
               ['rev-parse', '--absolute-git-dir'], GitDir),
    directory_file_path(GitDir, 'metta-build-stamp', StampFile).

valid_git_build_stamp(Context, LocalDir, Rev, Build) :-
    git_build_stamp_file(Context, LocalDir, StampFile),
    exists_file(StampFile),
    catch(setup_call_cleanup(
              open(StampFile, read, Stream),
              read_term(Stream, Stamp, []),
              close(Stream)),
          _,
          fail),
    Stamp == git_build(Rev, Build).

write_git_build_stamp(Context, LocalDir, Rev, Build) :-
    git_build_stamp_file(Context, LocalDir, StampFile),
    atom_concat(StampFile, '.tmp', TempFile),
    setup_call_cleanup(
        open(TempFile, write, Stream),
        write_term(Stream, git_build(Rev, Build),
                   [quoted(true), fullstop(true), nl(true)]),
        close(Stream)),
    rename_file(TempFile, StampFile).

git_output(Context, Operation, LocalDir, Args, OutputAtom) :-
    git_process_output(Context, Operation, path(git), Args,
                       [cwd(LocalDir)], Output),
    split_string(Output, "", "\r\n", [TrimmedOutput]),
    atom_string(OutputAtom, TrimmedOutput).

git_process(Context, Operation, Executable, Args, Options) :-
    git_process_output(Context, Operation, Executable, Args, Options, _).

git_process_output(Context, Operation, Executable, Args, Options, Output) :-
    metta_require_platform(Context, subprocess),
    tmp_file(git_acquire_stdout, OutFile),
    tmp_file(git_acquire_stderr, ErrFile),
    open(OutFile, write, Out),
    open(ErrFile, write, Err),
    setup_call_cleanup(
        true,
        ( setup_call_cleanup(
              true,
              run_logged_git_process(Context, Operation, Executable, Args,
                                     Options, Out, Err, Status),
              (close(Out), close(Err))),
          read_git_process_log(OutFile, Stdout),
          read_git_process_log(ErrFile, Stderr) ),
        cleanup_git_process_logs(OutFile, ErrFile)),
    string_concat(Stdout, Stderr, Output),
    ( Status == exit(0)
      -> true
       ; throw(error(process_error(Operation, Status, Output),
                     context(Context, Args))) ).

run_logged_git_process(Context, Operation, Executable, Args, Options,
                       Out, Err, Status) :-
    append(Options,
           [stdout(stream(Out)), stderr(stream(Err)), process(PID)],
           ProcessOptions),
    catch(process_create(Executable, Args, ProcessOptions), Error,
          throw(error(process_error(Operation, Error),
                      context(Context, Args)))),
    process_wait(PID, Status).

read_git_process_log(File, Output) :-
    setup_call_cleanup(open(File, read, In),
                       read_string(In, _, Output),
                       close(In)).

cleanup_git_process_logs(OutFile, ErrFile) :-
    ( exists_file(OutFile) -> delete_file(OutFile) ; true ),
    ( exists_file(ErrFile) -> delete_file(ErrFile) ; true ).