File Coverage

blib/lib/App/Padadoy.pm

Criterion	Covered	Total	%
statement	127	296	42.9
branch	8	90	8.8
condition	12	65	18.4
subroutine	24	42	57.1
pod	15	17	88.2
total	186	510	36.4

use strict;
use warnings;
package App::Padadoy;
{
  $App::Padadoy::VERSION = '0.123_6';
}
#ABSTRACT: Simply deploy PSGI applications

use 5.010;
use autodie;
use Try::Tiny;
use IPC::System::Simple qw(run capture $EXITVAL);
use File::Slurp;
use List::Util qw(max);
use File::ShareDir qw(dist_file);
use File::Path qw(make_path);
use File::Basename qw(dirname);
use File::Spec::Functions qw(catdir catfile rel2abs);
use Git::Repository;
use Sys::Hostname;
use Cwd;

# required for deployment
use Plack::Handler::Starman qw();
use Carton qw(0.9.4);

# required for testing
use Plack::Test qw();
use HTTP::Request::Common qw();

our @commands = qw(init start stop restart config status create checkout
        deplist cartontest remote version update enable);
our @configs = qw(user base repository port pidfile logs errrorlog accesslog
        quiet remote);

# _msg( $fh, [\$caller], $msg [@args] )
sub _msg (@) {
    my $fh = shift;
    my $caller = ref($_[0]) ? ${(shift)} :
            ((caller(2))[3] =~ /^App::Padadoy::(.+)/ ? $1 : '');
    my $text  = shift;
    say $fh (($caller ? "[$caller] " : "")
        . (@_ ? sprintf($text, @_) : $text));
}

sub fail (@) {
    _msg(*STDERR, @_);
    exit 1;
}

sub msg {
    my $self = shift;
    _msg( *STDOUT, @_ ) unless $self->{quiet};
}


sub new {
    my ($class, $config, %values) = @_;

    my $self = bless { }, $class;

    if ($config) {
        # $self->msg("Reading configuration from $config");
        open (my $fh, "<", $config);
        while(<$fh>) {
            next if /^\s*$/;
            if (/^\s*([a-z]+)\s*[:=]\s*(.*?)\s*$/) {
                $self->{$1} = ($2 // '');
            } elsif ($_ !~ /^\s*#/) {
                fail "syntax error in config file: $_";
            }
        }
        close $fh;
        $self->{base} = rel2abs(dirname($config));
    }

    foreach (@configs) {
        $self->{$_} = $values{$_} if defined $values{$_};
    }

    $self->{user}       ||= getlogin || getpwuid($<);
    $self->{base}       ||= cwd; # '/base/'.$self->{user};
    $self->{repository} ||= catdir($self->{base},'repository');
    $self->{port}       ||= 6000;
    $self->{pidfile}    ||= catfile($self->{base},'starman.pid');
    $self->{logs}       ||= catdir( $self->{base},'logs');
    $self->{errorlog}   ||= catfile($self->{logs},'error.log');
    $self->{accesslog}  ||= catfile($self->{logs},'access.log');

    # config file
    $self->{config} = $config;

    # TODO: validate config values

    fail "Invalid remote value: ".$self->{remote}
        if $self->{remote} and $self->{remote} !~ qr{^[^@]+@[^:]+:[~/].*$};

    $self;
}


sub create {
    my $self   = shift;
    my $module = shift;

    $self->{module} = $module;
    fail("Invalid module name: $module")
        if $module and $module !~ /^([a-z][a-z0-9]*(::[a-z][a-z0-9]*)*)$/i;

    $self->_provide_config('create');

    $self->msg('Using base directory '.$self->{base});
    chdir $self->{base};

    $self->msg('app/');
    mkdir 'app';

    $self->msg('app/Makefile.PL');
    write_file('app/Makefile.PL',{no_clobber => 1},
        read_file(dist_file('App-Padadoy','Makefile.PL')));

    if ( $module ) {
        $self->msg("app/app.psgi (calling $module)");
        my $content = read_file(dist_file('App-Padadoy','app2.psgi'));
        $content =~ s/YOUR_MODULE/$module/mg;
        write_file('app/app.psgi',{no_clobber => 1},$content);

        my @parts = ('app', 'lib', split('::', $module));
        my $name = pop @parts;

        my $path = join '/', @parts;
        $self->msg("$path/");
        make_path ($path);

        $self->msg("$path/$name.pm");
        $content = read_file(dist_file('App-Padadoy','Module.pm.tpl'));
        $content =~ s/YOUR_MODULE/$module/mg;
        write_file( "$path/$name.pm", {no_clobber => 1}, $content );

        $self->msg('app/t/');
        make_path('app/t');

        $self->msg('app/t/basic.t');
        my $test = read_file(dist_file('App-Padadoy','basic.t'));
        $test =~ s/YOUR_MODULE/$module/mg;
        write_file('app/t/basic.t',{no_clobber => 1},$test);
    } else {
        $self->msg('app/app.psgi');
        write_file('app/app.psgi',{no_clobber => 1},
            read_file(dist_file('App-Padadoy','app1.psgi')));

        $self->msg('app/lib/');
        mkdir 'app/lib';
        write_file('app/lib/.gitkeep',{no_clobber => 1},''); # TODO: required?

        $self->msg('app/t/');
        mkdir 'app/t';
        write_file('app/t/.gitkeep',{no_clobber => 1},''); # TODO: required?
    }

    $self->msg('data/');
    mkdir 'data';

    $self->msg('dotcloud.yml');
    write_file( 'dotcloud.yml',{no_clobber => 1},
         "www:\n  type: perl\n  approot: app" );

    my $content = read_file(dist_file('App-Padadoy','index.pl.tpl'));
    $self->msg("perl/index.pl");
    make_path("perl");
    write_file('perl/index.pl',{no_clobber => 1},$content);

    my %symlinks = (libs => 'app/lib','app/deplist.txt' => 'deplist.txt');
    while (my ($from,$to) = each %symlinks) {
        $self->msg("$from -> $to");
        symlink $to, $from;
    }

    # TODO:
    # .openshift/      - hooks for OpenShift (o)
    #   action_hooks/  - scripts that get run every git push (o)
}


sub deplist {
    my $self = shift;

    eval "use Perl::PrereqScanner";
    fail "Perl::PrereqScanner required" if $@;

    fail "not implemented yet";

    # TODO: dependencies should be detectable automatically
    # with Perl::PrereqScanner::App

    $self->msg("You must initialize a git repository and add remotes");
}


sub init {
    my $self = shift;
    $self->msg("Initializing environment");

    fail "Expected to run in ".$self->{base}
        unless cwd eq $self->{base};
    fail 'Expected to run in an EMPTY base directory'
        if grep { $_ ne $0 and $_ ne 'padadoy.conf' } <*>;

    $self->_provide_config('init');

    try {
        my $out = capture('git', 'init', '--bare', $self->{repository});
        $self->msg(\'init',$_) for split "\n", $out;
    } catch {
        fail 'Failed to init git repository in ' . $self->{repository};
    };

    my $file = $self->{repository}.'/hooks/update';
    $self->msg("$file as executable");
    write_file($file, read_file(dist_file('App-Padadoy','update')));
    chmod 0755,$file;

    $file = $self->{repository}.'/hooks/post-receive';
    $self->msg("$file as executable");
    write_file($file, read_file(dist_file('App-Padadoy','post-receive')));
    chmod 0755,$file;

    $self->msg("logs/");
    mkdir 'logs';

    $self->msg("app -> current/app");
    symlink 'current/app','app';

    $self->msg("Pushing to git repository %s@%s:%s will update",
        $self->{user}, hostname, $self->{repository});
}


sub config {
    say shift->_config;
}

sub _config {
    my $self = shift;
    my $max = max map { length } keys %$self;
    join "\n", map { sprintf( "%-${max}s = %s", $_, $self->{$_} // '' ) }
        sort keys %$self;
}


sub restart {
    my $self = shift;

    my $pid = $self->_pid;
    if ($pid) {
        $self->msg("Gracefully restarting starman as deamon on port %d (pid in %s)",
            $self->{port}, $self->{pidfile});
        run('kill','-HUP',$pid);
    } else {
        $self->start;
    }
}


sub start {
    my $self = shift;

    fail "No configuration file found" unless $self->{config};

    chdir $self->{base}.'/app';


if (0) { # FIXME
    # check whether dependencies are satisfied
    my @out = split "\n", capture('carton check --nocolor 2>&1');
    if (@out > 1) { # carton check always seems to exit with zero (?!)
        $out[0] =
        _msg( *STDERR, \'start', $_) for @out;
        exit 1;
    }
}

    # make sure log files exist
    foreach my $log (qw(errorlog accesslog)) {
        my $path = dirname($self->{$log});
        make_path($path) unless -d $path;
        if (! -e $self->{$log} ) {
            open (my $fh, '>>', $self->{$log});
            close $fh;
        }
    }

    $self->msg("Starting starman as deamon on port %d (pid in %s)",
        $self->{port}, $self->{pidfile});

    # TODO: refactor after release of carton 1.0
    $ENV{PLACK_ENV} = 'production';
    my @opt = (
        'starman','--port' => $self->{port},
        '-D','--pid'   => $self->{pidfile},
        '--error-log'  => $self->{errorlog},
        '--access-log' => $self->{accesslog},
    );
    run('carton','exec','-Ilib','--',@opt);
}


sub stop {
    my $self = shift;

    my $pid = $self->_pid;
    if ( $pid ) {
        $self->msg("killing old process");
        run('kill',$pid);
    } else {
        $self->msg("no PID file found");
    }
}

sub _pid {
    my $self = shift;
    return unless $self->{pidfile} and -f $self->{pidfile};
    my $pid = read_file($self->{pidfile}) || 0;
    return ($pid =~ s/^(\d+).*$/$1/sm ? $pid : 0);
}


sub status {
    my $self = shift;

    fail "No configuration file found" unless $self->{config};
    $self->msg("Configuration from ".$self->{config});

    # PID file?
    my $pid = $self->_pid;
    if ($pid) {
        $self->msg("Process running: $pid (PID in %s)", $self->{pidfile});
    } else {
        $self->msg("PID file %s not found or broken", $self->{pidfile});
    }

    my $port = $self->{port};

    # something listening on the port?
    my $sock = IO::Socket::INET->new( PeerAddr => "localhost:$port" );
    $self->msg("Port is $port - " . ($sock ? "currently used" : "not used"));

    # find out whether this users owns the socket (there should be a better way!)
    my ($command,$pid2,$user);
    my @lsof = eval { grep /LISTEN/, ( capture('lsof','-i',":$port") ) };
    if (@lsof) {
        foreach (@lsof) { # there may be multiple processes
            my @f = split /\s+/, $_;
            ($command,$pid2,$user) = @f if !$pid2 or $f[1] < $pid2;
        }
    } else {
        $self->msg("Not listening at port $port");
    }

    if ($sock or $pid2) {
        if ($pid and $pid eq $pid2) {
            $self->msg("Port $port is used by process $pid as given in ".$self->{pidfile});
        } elsif (!$pid and $user and $user eq $self->{user}) {
            $self->msg("Looks like " . $self->{pidfile} . " is missing (should contain PID $pid2) ".
                "maybe you run another instance as same user ".$self->{user});
        } else {
            $self->msg("Looks like the port $port is used by someone else!");
        }
    }
}

sub _provide_config {
    my ($self, $caller) = @_;
    return if $self->{config};

    $self->{config} = cwd.'/padadoy.conf';
    $self->msg(\$caller,"Writing default configuration to ".$self->{config});
    # TODO: better use template with comments instead
    write_file( $self->{config}, $self->_config );
}


sub checkout {
    my ($self, $revision, $directory, $current) = @_;
    $revision  ||= 'master';
    $directory ||= catdir($self->{base},$revision);

    my $git_dir = $self->{repository};
    fail("git repository directory not found: $git_dir") unless -d $git_dir;

    $self->msg("checking out $revision to $directory");
    fail("Working directory already exists: $directory")
        if -e $directory;

    if ( $current ) {
        fail("Current working directory not found") unless -d $current;
    } else {
        $current =  catdir($self->{base},'current');
    }

    mkdir $directory;
    my $local = catdir( $current, 'app', 'local' );
    if (-d $local) {
        my $newlocal = catdir($directory,'app');
        $self->msg("rsyncing $local into $newlocal");
        mkdir $newlocal;
        run('rsync', '-a', $local, catdir($directory,'app') );
    }

    $self->msg("repository is $git_dir");
    my $r = Git::Repository->new(
        work_tree => $directory,
        git_dir   => $git_dir,
    );
    $r->run( checkout => '-q', '-f', $revision );
}


sub cartontest {
    my $self = shift;

    chdir $self->{base}.'/app';
    $self->msg("installing dependencies and testing");

    run('carton install');
    run('perl Makefile.PL');
    run('carton exec -Ilib -- make test');
    run('carton exec -Ilib -- make clean > /dev/null');
}


sub update {
    my $self = shift;
    my $revision = shift || 'master';

    $self->msg("updating to revision $revision");

    # check out to $newdir
    $self->checkout($revision);
    my $revdir = catdir($self->{base},$revision);
    my $newdir = catdir($self->{base},'new');

    # TODO: call directly
    run('padadoy','cartontest',"base=$revdir");

    chdir $self->{base};
    run('rm','-f','new');
    symlink $revision, 'new';

    $self->msg("revision $revision checked out and tested at $newdir");
}


sub enable {
    my $self = shift;

    fail "Missing directory ".$self->{base} unless -d $self->{base};
    chdir $self->{base};

    my $new     = catdir($self->{base},'new');
    my $current = catdir($self->{base},'current');

    fail "Missing directory $new" unless -d $new;

    $self->msg("$new -> current");
    run('rm','-f','current');
    run('mv','new','current');

    chdir $current;

    # TODO: re-read full configuration (?)
    $self->{base} = $current;

    # graceful restart seems broken
    $self->stop;
    $self->start;

    # TODO: cleanup old revisions?
}


sub remote {
    my $self = shift;
    my $command = shift;

    fail 'no remote configured' unless $self->{remote};
    fail 'missing remote command' unless $command;

    fail "command $command not supported on remote"
        unless grep { $_ eq $command } qw(init start stop restart config status version);
        # TODO: create deplist checkout cartontest

    $self->{remote} =~ /^(.+):(.+)$/ or fail 'invalid remote value: '.$self->{remote};
    my ($userhost,$dir) = ($1,$2);
    fail 'remote directory should not contain spaces' if $dir =~ /\s/;

    $self->msg("running padadoy on ".$self->{remote});

    run('ssh',$userhost,"cd $dir && padadoy $command ".join ' ', @_);
}


sub version {
    say 'This is padadoy version '.($App::Padadoy::VERSION || '??');
    exit;
}

1;


__END__