#!/usr/bin/perl

=pod

=head1 NAME

git-deploy - Client for push notification deployment

=head1 DESCRIPTION

git-deploy runs as a git client daemon
to pull the changes from the git server
instantly after a push is triggered.

=head1 SYNOPSIS

  git deploy
    [ [--branch] <branch> ]
    [ { --chdir | -C } <dir> ]
    [ --umask <umask> ]
    [ -O <option> ]
    [ --build <command> ]
    [ --fix-nasty ]
    [ --background ]
    [ --max-delay <seconds> ]
    [ { --identity | -i } <identitykeyfile> ]
    [ { -v | --version } ]

=head2 --branch <branch>

If a <branch> is specified, then it will update to that branch.
By default, the current branch is used.

  Example: git deploy --branch main

  --OR--

  Example: git deploy main

=head2 --chdir <dir>

Jump to <dir> prior to running "git pull".
If this option is used multiple times,
then it will chdir in the order speficied.
By default, the current directory is used.

  Example: git deploy --chdir ~/projectx

  --OR--

  Example: git deploy -C ~/projectx

=head2 --umask <umask>

Set umask to <umask> in octal representation.
This is useful when you need to set the umask prior to running any git commands.

  Example: git deploy --umask 0022

=head2 -O <OPTION>

This -O may be used multiple times from commandline
in order to pass multiple options to the server hooks.
This has the same functionality as "git-client -O <OPTION>".
Populates GIT_OPTION_* environment variables on server side.
These ENV settings will be available to all the server side
hooks, including the pre-* hooks.

=head2 --build <COMMAND>

The --build argument is any command you want to execute
after any files are pulled or updated from git.
By default, no command is run.

  Example: git deploy --build='make -C src/.'

=head2 --fix-nasty

The --fix-nasty argument will automatically remove the offending
SSH host entry for the git server from known_hosts. Only use this
flag if you've changed the SSH server key on the git server host.
By default, this option is disabled for better security.

  Example: git deploy --fix-nasty

=head2 --background

The --background option will cause the deploy process to detach
from its invoker and run in the background.
This is useful when invoked from a cron
since there is nobody around to see the output anyways.
By default, this option is disabled so runs in the foreground.

  Example: echo '7 * * * * git deploy --chdir ~/projectz --background' | crontab -

=head2 --max-delay <seconds>

The --max-delay specifies the maximum number of seconds to wait
for each push notification.

If you have git-client installed, then you can run "git-client pull" to
immediately release a previously deploying "git fetch" and force all pull
updates without hanging your commandline for two hours waiting for the
next push. By default, max-delay is 7200 seconds (or 2 hours).

If the repo is NOT run through git-server, then --max-delay specifies
the interval in between each "git pull" operation in a loop. If no
--max-delay is specified for this case, then the default is a random
interval between 5 and 7 minutes.

  Example: git deploy --max-delay 10

=head2 --identity <identitykeyfile>

Specify identity keyfile to be used for SSH repos.

  Example: git-deploy -i ~/.ssh/id_ed25519-repodeploy

  sshCommand = ssh -i ~/.ssh/id_ed25519-repodeploykey -o IdentitiesOnly=yes

=head2 --version

Show git-deploy version.

=head1 INSTALL

As super user:

  [root@deploy-host ~]# wget -N -P /usr/bin https://raw.githubusercontent.com/hookbot/git-server/master/git-deploy
  [root@deploy-host ~]# chmod 755 /usr/bin/git-deploy
  [root@deploy-host ~]#

As deploy user:

  [puller@deploy-host projectz]$ git deploy --branch=main
  [puller@deploy-host projectz]$ echo '0 * * * * git deploy --chdir ~/projectz </dev/null >/dev/null 2>/dev/null' | crontab -
  [puller@deploy-host projectz]$

=head1 AUTHOR

Rob Brown <bbb@cpan.org>

=head1 COPYRIGHT AND LICENSE

Copyright 2015-2026 by Rob Brown <bbb@cpan.org>

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut

use strict;
use Cwd qw(getcwd abs_path);
use FindBin qw($Script $Bin);
use Getopt::Long qw(GetOptions);
use Fcntl qw(LOCK_EX LOCK_NB);

our $VERSION = "0.040";

my @invoked = ($0, @ARGV);
my %initial_ENV = %ENV;
my $origin = "";
my $cwd = getcwd();
my $opts = [];
my $build = undef;
my $force_branch = undef;
my $chdir = [];
my $umask = undef;
my $fix_nasty = undef;
my $background = undef;
our $maxpatience = undef;
my $identities = [];
my $ver = undef;
my $deploying_version = 0;
my $maxdelayrecommended = 0;
Getopt::Long::Configure("no_ignore_case");
GetOptions
    "O|o=s@" => $opts,
    "build=s" => \$build,
    "umask=s" => \$umask,
    "branch=s" => \$force_branch,
    "chdir|C=s" => $chdir,
    "version|v" => \$ver,
    "fix-nasty" => \$fix_nasty,
    "background" => \$background,
    "max-delay=i" => \$maxpatience,
    "identity|i=s@" => $identities,
    or exec perldoc => $0;

if ($ver) {
    print "[git-deploy v$VERSION] ".`git --version`;
    exit;
}

sub run_how_cmd {
    my $stderr = shift;
    my @cmd = @_;
    if (my $pid = open my $fh_out, "-|") {
        # Parent process waiting for kid to say something
        my $output = join "", <$fh_out>;
        waitpid $pid, 0;
        my $exit_status = $?;
        close $fh_out;
        $? = $exit_status;
        return $output;
    }
    # Child process
    open STDERR, $stderr;
    exec @cmd or die "$cmd[0]: Failed to spawn? $!\n";
}

sub run_output_ignore_err {
    return run_how_cmd ">/dev/null", @_;
}

sub run_output_include_err {
    return run_how_cmd ">&STDOUT", @_;
}

sub getps {
    return (run_output_ignore_err qw[ps fauwwx] or run_output_include_err qw[ps auwwx]);
}

sub rebuild {
    if (defined $build) {
        $0 = "$Script - $cwd: Waiting for build to finish ...";
        my $lock_file = "$ENV{GIT_DIR}/config";
        my $lock;
        print run_output_include_err $build if open $lock, "+<", $lock_file and flock $lock, LOCK_NB | LOCK_EX;
        close $lock;
    }
}

sub current_origin {
    (my $r = run_output_ignore_err qw(git remote)) =~ s/\n.*$//s;
    return $r || "origin";
}

sub current_branch {
    my $scan = run_output_ignore_err qw(git branch -a);
    return $1 if $scan =~ m{^\* ([\w/\-.@]+)}m;
    if ($scan =~ m{^\* .*detached at (\w+)}m) {
        $scan = run_output_ignore_err("git", "branch", "-a", "--contains", $1).$scan;
    }
    return $1 if $scan =~ m{^\s+([\w/\-.@]+)}m;
    die localtime().": [$$] $Script: Unable to determine which branch to deploy.\n$scan\n";
}

# checkout_branch()
# Which branch to checkout and remain on for the pull to update
sub checkout_branch {
    return $force_branch || current_branch;
}

# pull_push_notification()
# Pull new changes or else block waiting until the next push before updating.
sub pull_push_notification {
    my $deploy_branch = checkout_branch();
    # Generate XMODIFIERS based on checkout_branch and $maxpatience and $opts:
    $ENV{XMODIFIERS} = join "\n", @$opts,
        "pull_branch=$deploy_branch",
        "client=".abs_path($invoked[0])."\@v$VERSION",
        ($maxpatience ? ("deploy_patience=$maxpatience") : ()),
        ($initial_ENV{XMODIFIERS} ? ($initial_ENV{XMODIFIERS}) : ()),
        ;
    # Generate GIT_SSH_COMMAND to ensure XMODIFIERS is provided to the git server:
    $ENV{GIT_SSH_COMMAND} = ($initial_ENV{GIT_SSH_COMMAND} || (run_output_include_err(qw[git config core.sshCommand]) =~ /^(.+)/ ? $1 : "ssh"))." -o SendEnv=XMODIFIERS";
    if (@$identities) {
        # Inject --identity files into GIT_SSH_COMMAND:
        $ENV{GIT_SSH_COMMAND} .= " -o IdentitiesOnly=yes";
        $ENV{GIT_SSH_COMMAND} .= " -i $_" foreach @$identities;
    }
    $0 = "$Script - $cwd: Waiting for push notification [$deploy_branch]";
    # Run "fetch" to call "git-upload-pack" causing the git-server to wait for the "push_notification" to release the update:
    return run_output_include_err(qw[git fetch]);
}

if ($force_branch and @ARGV) {
    warn "$0: Don't specify both --branch and commandline argument.\n";
    sleep 1;
    exec perldoc => $0 or die "$0: help menu unavailable\n";
}
$force_branch ||= shift;

# Handle [ -C <dir> ] first
if (@$chdir) {
    chdir $_ or die "fatal: cannot change to '$_': $!\n" foreach @$chdir;
    if (grep {/^[^\/]/} @$chdir) {
        # Relative chdir may fail if re-invoked, so clear it from @invoked
        for (my $i = 1; $i < @invoked; $i++) {
            splice @invoked, --$i, ($2?1:2) if $invoked[$i-1] =~ /^(-C|--chdir)\b(=?).*$/;
        }
    }
    $cwd = getcwd();
}

$ENV{GIT_DIR} ||= abs_path(`git rev-parse --git-dir 2>/dev/null` =~ /^(.+)/ && $1 || ".git");

umask oct $1 if $umask and $umask =~ /^(\d+)$/;

if (@$identities) {
    # Sanity check to verify identity files are ready to go.
    foreach (@$identities) {
        s/\.pub$//;
        -e && -r _ && -s _ or die "$Script: --identity $_: Unable to find key\n";
        my $pub = run_output_ignore_err "ssh-keygen", "-y", "-P", "", "-f", $_;
        if ($pub) {
            warn localtime().": [$$] $Script: Using identity: $pub";
        }
        else {
            die localtime().": [$$] $Script: Unable to read identity file without using a passphrase: $_\n";
        }
    }
}

$origin = current_origin();
$0 = "$Script - $cwd: Initial checkout [".checkout_branch()."]";
run_output_ignore_err "git", "checkout", checkout_branch;
sleep 1;
rebuild;

if (!$maxpatience) {
    $0 = "$Script - $cwd: Searching for other deployers ...";
    if (getps =~ /(.*\Q$Script - $cwd\E: Waiting.*)/) {
        my $found = $1;
        my $stagger = 5+int(rand()*115);
        $0 = "$Script - $cwd: Waiting $stagger seconds for random stagger ...";
        warn localtime().": [$$] $Script: Since no --max-delay option was provided, waiting $stagger seconds random stagger delay before taking over for other deployer:\n$found\n";
        print run_output_include_err(sleep => $stagger);
    }
}

if (sleep 1) {
    # Run quick pre-flight sanity test before entering loop
    local $maxpatience = 1;
    my $update = pull_push_notification;
    $0 = "$Script - $cwd: Scanning updates";
    die localtime().": [$$] $Script: Fatal crash while attempting to pull from ".run_output_ignore_err("git","config","remote.$origin.url")."\n$update\n\n".localtime().": [$$] $Script: Manual intervention required.\n" if $update =~ /^fatal:/m;
}

if ($background) {
    exit if fork;
    require POSIX;
    POSIX::setsid();
    open STDIN,  "<", "/dev/null";
    open STDOUT, ">", "/dev/null";
    open STDERR, ">", "/dev/null";
}

sleep 1;

while (1) {
    my $update = pull_push_notification;
    $deploying_version ||= $update =~ / git-server(?: v([\d.]+):)?.*waiting for notification/ ? $1 || "OLD" : 0 or
        $maxpatience or $maxdelayrecommended ||= warn localtime().": [$$] $Script: Warning: Missing recommended [ --max-delay <INTERVAL_SECONDS> ] for NON-deploy repo: ".run_output_ignore_err("git","config","remote.$origin.url");
    my $branch = checkout_branch;
    $update .= run_output_include_err "git", "checkout", $branch;
    $update .= run_output_include_err "git", "rebase", "$origin/$branch";
    $0 = "$Script - $cwd: Scanning updates";
    $update .= run_output_include_err "git", "rebase", "--abort" if $update =~ /fix conflicts|git rebase.*--continue|you need to resolve your|stop rebasing/;
    if (-M "$Bin/$Script" < 0) {
        # Myself update detected so need to respawn
        warn localtime().": [$$] $Script: Auto-update $Script respawning ...\n";
        sleep 1;
        %ENV = %initial_ENV;
        exec @invoked or die localtime().": [$$] $Bin/$Script: RESPAWN FATAL CRASH\n";
    }
    if ($update =~ /POSSIBLE.*SOMEONE.*DOING.*NASTY/) {
        warn $update;
        if ($fix_nasty && $update =~ /host key for (\S+) has changed and you have requested strict checking/) {
            my $nasty = $1;
            warn "--fix-nasty: $nasty: Clearing known_hosts ...\n";
            my $wipe = run_output_include_err "ssh-keygen", "-R", $nasty;
            if (!$?) {
                $wipe =~ s/\s*$/\n/;
                warn $wipe;
                require Socket;
                if (my $ip = Socket::inet_ntoa(Socket::inet_aton($nasty))) {
                    $nasty .= ",$ip";
                }
                if (my $real_ssh_server_key = run_output_ignore_err "ssh-keyscan", $nasty) {
                    $real_ssh_server_key =~ s/^#.*\n//gm;
                    open my $fh_known, ">>", "$ENV{HOME}/.ssh/known_hosts";
                    print $fh_known $real_ssh_server_key;
                    close $fh_known;
                }
            }
        }
        else {
            warn "To force deploy to continue anyway, run this: $Script --fix-nasty\n";
        }
        last;
    }
    if ($update =~ /Your branch.*diverged/) {
        # Rebase can't work if there are local divergents.
        warn $update;
        warn localtime().": [$$] $Script: Detected local divergence off [$branch] so doing HARD RESET ...\n";
        my $hard = "";
        $hard .= run_output_include_err "git", "checkout", $branch;
        $hard .= run_output_include_err "git", "reset", "--hard", "$origin/$branch";
        my $running = getps;
        last if $running =~ /\Q$Script - $cwd\E: Waiting/;
        $0 = "$Script - $cwd: Waiting because of local divergence";
        print run_output_include_err qw(sleep 60);
    }
    elsif ($update =~ /You have unstaged changes/) {
        # Rebase can't work if there are local changes.
        # Make sure there aren't multiple pullers choking on the repo
        warn $update;
        my $running = getps;
        last if $running =~ /\Q$Script - $cwd\E: Waiting/;
        my $monkey = "";
        $monkey = ": $1" if $update =~ /^M\s+(\S+)/m;
        $0 = "$Script - $cwd: Waiting because of local modifications$monkey";
        print run_output_ignore_err qw(sleep 10);
        $0 = "$Script - $cwd: Checking if changes still exist$monkey";
    }
    elsif ($update =~ /untracked.*files would be overwritten/) {
        # Can't create a file if it's already there.
        warn $update;
        my $running = getps;
        last if $running =~ /\Q$Script - $cwd\E: Waiting/;
        my $monkey = "";
        $monkey = ": $1" if $update =~ /would be overwritten.*\n\s*(\S.*?)\s*\n/;
        $0 = "$Script - $cwd: Waiting because someone created file locally$monkey";
        print run_output_ignore_err qw(sleep 20);
        $monkey =~ s/:\s+// and system "mv","-v","-n",$monkey,"$monkey-PLEASE-REMOVE-MANUALLY-CREATED-FILE-FOR-DEPLOY-$$";
        $0 = "$Script - $cwd: Checking if file still exist$monkey";
    }
    elsif ($update =~ m{fatal: Unable to create '(.+?)': File exists.}) {
        # Updates cannot work while lock file exists
        warn $update;
        my $broken_lock = $1;
        $0 = "$Script - Choking Locked: $broken_lock";
        my $running = getps;
        last if $running =~ /\Q$Script - $cwd\E: Waiting/;
        if ($running !~ /git rebase/) {
            # No other conflicting git process running
            # So lock file is safe enough to be removed
            unlink $broken_lock;
        }
        else {
            print run_output_include_err qw(sleep 60);
        }
    }
    elsif ($update =~ m{cannot create.*rebase-apply[\s\S]*?please\s+rm -fr (/.*\.git/rebase-apply)\s}) {
        # Duplicate rebase choking
        warn $update;
        my $choked_rebase = $1;
        $0 = "$Script - $cwd: Choking Rebase: $choked_rebase";
        last if 0.0416 > -M $choked_rebase; # Leave rebase progress alone if still too fresh
        my $running = getps;
        last if $running =~ /\Q$Script - $cwd\E: Waiting/;
        if ($running !~ /git rebase/) {
            # No other conflicting git process running
            # So rebase progress is safe to be removed
            print run_output_include_err "rm","-rfv",$choked_rebase;
        }
        else {
            print run_output_include_err qw(sleep 60);
        }
    }
    elsif ($update =~ /^(fatal:.*)/m) {
        my $fatal = substr $1, 0, 30;
        chomp (my $url = run_output_ignore_err("git","config","remote.$origin.url"));
        warn localtime().": [$$] $Script: Fatal crash during update: $url\n";
        warn $update;
        warn localtime().": [$$] $Script: Manual intervention required. Please repair the problem now!\n";
        $0 = "$Script - $cwd: Found fatal crash [$fatal] $url";
        my $running = getps;
        last if $running =~ /\Q$Script - $cwd\E: Waiting/;
        $0 = "$Script - $cwd: Waiting for fix [$fatal] $url";
        print run_output_ignore_err qw(sleep 65);
        next;
    }
    # If repo isn't via git-server, then we can't rely on the server to regulate any other git-deploy running, so we have to take care of everything ourselves. So either he goes, or I go.
    warn localtime().": [$$] $Script: Aborting other git-deploy process still running on NON-deploy repo:\n$1\n" and kill TERM => $2 or last if !$deploying_version and getps() =~ /^(\w+\s+(\d+).*\Q$Script - $cwd\E: Waiting.*)/m;
    # Get out of here if someone is monkeying a local file "error: cannot rebase: You have unstaged changes."
    warn localtime().": [$$] $Script: Deployable git-server v$deploying_version wants me to leave.\n$update" and last if $deploying_version and $update !~ /rewinding head to replay|fast-forward|but expected|Unpacking objects|Cannot rebase|ecent commit/;
    if ($update =~ /Current branch.*is up to date/) {
        my $pause_because_done = $deploying_version ? 5 + int(55 * rand()) : ($maxpatience || (305 + int(115 * rand())));
        my $why_wait = $deploying_version ? "since everything had already been deployed ..." : "for NON-deploy repo ...";
        $0 = "$Script - $cwd: Waiting $pause_because_done seconds $why_wait";
        print "Everything was already updated. Sleeping $pause_because_done seconds $why_wait\n";
        print run_output_ignore_err sleep => $pause_because_done;
    }
    $0 = "$Script - $cwd: Update complete";
    sleep 1;
    rebuild;
}

rebuild;
