perl/Git/SVN/Prompt.pm

   1 package Git::SVN::Prompt;
   2 use strict;
   3 use warnings;
   4 require SVN::Core;
   5 use vars qw/$_no_auth_cache $_username/;
   6
   7 sub simple {
   8         my ($cred, $realm, $default_username, $may_save, $pool) = @_;
   9         $may_save = undef if $_no_auth_cache;
  10         $default_username = $_username if defined $_username;
  11         if (defined $default_username && length $default_username) {
  12                 if (defined $realm && length $realm) {
  13                         print STDERR "Authentication realm: $realm\n";
  14                         STDERR->flush;
  15                 }
  16                 $cred->username($default_username);
  17         } else {
  18                 username($cred, $realm, $may_save, $pool);
  19         }
  20         $cred->password(_read_password("Password for '" .
  21                                        $cred->username . "': ", $realm));
  22         $cred->may_save($may_save);
  23         $SVN::_Core::SVN_NO_ERROR;
  24 }
  25
  26 sub ssl_server_trust {
  27         my ($cred, $realm, $failures, $cert_info, $may_save, $pool) = @_;
  28         $may_save = undef if $_no_auth_cache;
  29         print STDERR "Error validating server certificate for '$realm':\n";
  30         {
  31                 no warnings 'once';
  32                 # All variables SVN::Auth::SSL::* are used only once,
  33                 # so we're shutting up Perl warnings about this.
  34                 if ($failures & $SVN::Auth::SSL::UNKNOWNCA) {
  35                         print STDERR " - The certificate is not issued ",
  36                             "by a trusted authority. Use the\n",
  37                             "   fingerprint to validate ",
  38                             "the certificate manually!\n";
  39                 }
  40                 if ($failures & $SVN::Auth::SSL::CNMISMATCH) {
  41                         print STDERR " - The certificate hostname ",
  42                             "does not match.\n";
  43                 }
  44                 if ($failures & $SVN::Auth::SSL::NOTYETVALID) {
  45                         print STDERR " - The certificate is not yet valid.\n";
  46                 }
  47                 if ($failures & $SVN::Auth::SSL::EXPIRED) {
  48                         print STDERR " - The certificate has expired.\n";
  49                 }
  50                 if ($failures & $SVN::Auth::SSL::OTHER) {
  51                         print STDERR " - The certificate has ",
  52                             "an unknown error.\n";
  53                 }
  54         } # no warnings 'once'
  55         printf STDERR
  56                 "Certificate information:\n".
  57                 " - Hostname: %s\n".
  58                 " - Valid: from %s until %s\n".
  59                 " - Issuer: %s\n".
  60                 " - Fingerprint: %s\n",
  61                 map $cert_info->$_, qw(hostname valid_from valid_until
  62                                        issuer_dname fingerprint);
  63         my $choice;
  64 prompt:
  65         print STDERR $may_save ?
  66               "(R)eject, accept (t)emporarily or accept (p)ermanently? " :
  67               "(R)eject or accept (t)emporarily? ";
  68         STDERR->flush;
  69         $choice = lc(substr(<STDIN> || 'R', 0, 1));
  70         if ($choice =~ /^t$/i) {
  71                 $cred->may_save(undef);
  72         } elsif ($choice =~ /^r$/i) {
  73                 return -1;
  74         } elsif ($may_save && $choice =~ /^p$/i) {
  75                 $cred->may_save($may_save);
  76         } else {
  77                 goto prompt;
  78         }
  79         $cred->accepted_failures($failures);
  80         $SVN::_Core::SVN_NO_ERROR;
  81 }
  82
  83 sub ssl_client_cert {
  84         my ($cred, $realm, $may_save, $pool) = @_;
  85         $may_save = undef if $_no_auth_cache;
  86         print STDERR "Client certificate filename: ";
  87         STDERR->flush;
  88         chomp(my $filename = <STDIN>);
  89         $cred->cert_file($filename);
  90         $cred->may_save($may_save);
  91         $SVN::_Core::SVN_NO_ERROR;
  92 }
  93
  94 sub ssl_client_cert_pw {
  95         my ($cred, $realm, $may_save, $pool) = @_;
  96         $may_save = undef if $_no_auth_cache;
  97         $cred->password(_read_password("Password: ", $realm));
  98         $cred->may_save($may_save);
  99         $SVN::_Core::SVN_NO_ERROR;
 100 }
 101
 102 sub username {
 103         my ($cred, $realm, $may_save, $pool) = @_;
 104         $may_save = undef if $_no_auth_cache;
 105         if (defined $realm && length $realm) {
 106                 print STDERR "Authentication realm: $realm\n";
 107         }
 108         my $username;
 109         if (defined $_username) {
 110                 $username = $_username;
 111         } else {
 112                 print STDERR "Username: ";
 113                 STDERR->flush;
 114                 chomp($username = <STDIN>);
 115         }
 116         $cred->username($username);
 117         $cred->may_save($may_save);
 118         $SVN::_Core::SVN_NO_ERROR;
 119 }
 120
 121 sub _read_password {
 122         my ($prompt, $realm) = @_;
 123         my $password = '';
 124         if (exists $ENV{GIT_ASKPASS}) {
 125                 open(PH, "-|", $ENV{GIT_ASKPASS}, $prompt);
 126                 $password = <PH>;
 127                 $password =~ s/[\012\015]//; # \n\r
 128                 close(PH);
 129         } else {
 130                 print STDERR $prompt;
 131                 STDERR->flush;
 132                 require Term::ReadKey;
 133                 Term::ReadKey::ReadMode('noecho');
 134                 while (defined(my $key = Term::ReadKey::ReadKey(0))) {
 135                         last if $key =~ /[\012\015]/; # \n\r
 136                         $password .= $key;
 137                 }
 138                 Term::ReadKey::ReadMode('restore');
 139                 print STDERR "\n";
 140                 STDERR->flush;
 141         }
 142         $password;
 143 }
 144
 145 1;
 146 __END__
 147
 148 Git::SVN::Prompt - authentication callbacks for git-svn
 149
 150 =head1 SYNOPSIS
 151
 152     use Git::SVN::Prompt qw(simple ssl_client_cert ssl_client_cert_pw
 153                             ssl_server_trust username);
 154     use SVN::Client ();
 155
 156     my $cached_simple = SVN::Client::get_simple_provider();
 157     my $git_simple = SVN::Client::get_simple_prompt_provider(\&simple, 2);
 158     my $cached_ssl = SVN::Client::get_ssl_server_trust_file_provider();
 159     my $git_ssl = SVN::Client::get_ssl_server_trust_prompt_provider(
 160         \&ssl_server_trust);
 161     my $cached_cert = SVN::Client::get_ssl_client_cert_file_provider();
 162     my $git_cert = SVN::Client::get_ssl_client_cert_prompt_provider(
 163         \&ssl_client_cert, 2);
 164     my $cached_cert_pw = SVN::Client::get_ssl_client_cert_pw_file_provider();
 165     my $git_cert_pw = SVN::Client::get_ssl_client_cert_pw_prompt_provider(
 166         \&ssl_client_cert_pw, 2);
 167     my $cached_username = SVN::Client::get_username_provider();
 168     my $git_username = SVN::Client::get_username_prompt_provider(
 169         \&username, 2);
 170
 171     my $ctx = new SVN::Client(
 172         auth => [
 173             $cached_simple, $git_simple,
 174             $cached_ssl, $git_ssl,
 175             $cached_cert, $git_cert,
 176             $cached_cert_pw, $git_cert_pw,
 177             $cached_username, $git_username
 178         ]);
 179
 180 =head1 DESCRIPTION
 181
 182 This module is an implementation detail of the "git svn" command.
 183 It implements git-svn's authentication policy.  Do not use it unless
 184 you are developing git-svn.
 185
 186 The interface will change as git-svn evolves.
 187
 188 =head1 DEPENDENCIES
 189
 190 L<SVN::Core>.
 191
 192 =head1 SEE ALSO
 193
 194 L<SVN::Client>.
 195
 196 =head1 INCOMPATIBILITIES
 197
 198 None reported.
 199
 200 =head1 BUGS
 201
 202 None.