File Coverage

blib/lib/LWP/Protocol/rsync.pm

Criterion	Covered	Total	%
statement	99	182	54.4
branch	28	102	27.4
condition	6	33	18.1
subroutine	16	20	80.0
pod	1	1	100.0
total	150	338	44.3

# Copyright 2012, 2013, 2014, 2018, 2019 Kevin Ryde

# This file is part of LWP-Protocol-rsync.
#
# LWP-Protocol-rsync is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# LWP-Protocol-rsync is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with LWP-Protocol-rsync.  If not, see .


# RFC 5781 rsync schema
# RFC 3986 URI general
# RFC 2518 WebDAV
# RFC 2068 HTTP 1.1
#    - reason phrase in status line can be changed without affecting protocol
# RFC 2616 HTTP 1.1
#
# cf LWP::Protocol::ftp
#    LWP::Protocol::http
#    LWP::Protocol::file


package LWP::Protocol::rsync;
use strict;
use 5.005;  # for \z
use File::Spec;
use HTTP::Date ();
use HTTP::Response;
use HTTP::Status ();
use IPC::Run;
use LWP::MediaTypes ();
use URI::Escape ();

use vars '$VERSION','@ISA';
$VERSION = 2;

use LWP::Protocol;
@ISA = ('LWP::Protocol');

# uncomment this to run the ### lines
# use Smart::Comments;


# $arg is
#    undef -- use HTTP::Request / HTTP::Response ->content()
#    scalar -- filename
#    coderef -- func to call with data blocks of $size bytes
#
sub request {
  my($self, $request, $proxy, $arg, $size) = @_;
  $size = 4096 unless defined $size and $size > 0;

  if (defined $proxy) {
    return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST(),
                               'No proxy support for rsync');
  }

  # URI::rsync documented in URI.pm
  my $uri = $request->uri;
  ### $uri

  my $scheme = $uri->scheme;
  if ($scheme ne 'rsync') {
    return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR(),
                               "URI scheme not rsync");
  }

  my $hostport = $uri->host_port;  # eg "localhost:9999"
  my $user = $uri->user;           # or undef if no "fred@" part present
  my $password = $uri->password;
  my $path = $uri->path;
  ### $path

  foreach ($hostport, $user, $password, $path) {
    if (defined $_) {
      $_ = URI::Escape::uri_unescape($_);   # mutate to undo %20 etc
    }
  }
  ### path unescaped: $path

  # wildcards bad in $path (but ok in $hostport as "[::1]" etc IPv6)
  if ($path =~ /[*?[]/) {
    return HTTP::Response->new(HTTP::Status::HTTP_NOT_IMPLEMENTED(),
                               "Characters * ? [ not allowed in path");
  }

  my $uri_str = "rsync://".(defined $user ? "$user@" : "").$hostport.$path;
  ### $uri_str

  my $method = $request->method;
  ### $method

  my $dir_listing = ($uri_str =~ m{/\z}
                     || _path_is_modules_or_root($path));
  my $content_type;
  if ($dir_listing) {
    $content_type = 'text/plain';
  }
  ### $dir_listing
  ### $content_type

  if ($method eq 'HEAD') {
    # With --no-dirs a directory sets $listing to either
    #     skipping directory foo         # no trailing /
    #     skipping directory .           # if trailing /
    # Without --no-dirs and without trailing slash is
    #     drwxrwxrwt         69,632 2014/03/26 19:18:01 tmp
    #
    # For the root directory "rsync://hostname/module/" or
    # "rsync://hostname/module" both give the full listing of the root
    # directory, not just the root "/" itself.  Use --quiet to suppress that
    # so as to check just the existence.  Likewise the module listing is
    # suppressed with --quiet.

    $uri_str =~ s{/+\z}{}; # strip trailing slashes
    ### uri strip trailing slashes: $uri_str

    my $listing;
    if (my $resp = _run_rsync($password,
                              [ 'rsync',
                                '--no-dirs',
                                (_path_is_modules_or_root($path)
                                 ? '--quiet'
                                 : ()),
                                $uri_str,   # single arg means --list-only
                              ],
                              \$listing)) {
      return $resp;
    }

    my ($perms, $length, $mtime) = _parse_listing($listing);
    ### $perms
    ### $length
    ### $mtime

    # No Content-Length for directory.  The size in the listing is the
    # directory size on disk and is not the length the GET listing will
    # give.  Could fetch the whole listing like GET to find the size, but
    # the reason for HEAD is not to do a full fetch like that.
    my $dir_listing ||= ($listing =~ /^(d|skipping directory)/);
    if ($dir_listing) {
      undef $length;
      $content_type = 'text/plain';
    }
    my $resp = HTTP::Response->new(HTTP::Status::RC_OK(),
                                   undef,
                                   [ _content_headers($length, $mtime, $content_type) ]);
    unless ($content_type) {
      LWP::MediaTypes::guess_media_type($uri, $resp->headers);
    }
    return $resp;
  }

  # If :content_file then rsync directly to or from it, otherwise a temp
  # file.
  my $temp_fh;   # if a temp file is used
  my $filename;  # either $arg or $temp_fh->filename()
  if ($arg && ! ref $arg) {
    ### arg is content_file ...
    $filename = $arg;
    # $arg = \&_content_cb_noop;
  } else {
    ### arg not a file, make a temp file ...
    require File::Temp;
    $temp_fh = File::Temp->new;
    $filename = $temp_fh->filename;
    binmode($temp_fh)
      or return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR(),
                                    "Cannot binmode on $filename: $!");
  }
  ### $filename

  if ($method eq 'GET') {
    ### _path_is_modules_or_root: _path_is_modules_or_root($path)

    # No If-Modified-Since check on a directory or on the modules listing
    # "rsync://hostname/module".
    #
    if (! $dir_listing
        && defined (my $ims_str = $request->header('If-Modified-Since'))) {
      if (defined (my $ims_time = HTTP::Date::str2time($ims_str))) {
        my $listing;
        _run_rsync($password,
                   [ 'rsync', $uri_str ],   # same as HEAD above
                   \$listing);
        if (defined $listing) {  # if rsync ran successfully
          my ($perms, $length, $mtime) = _parse_listing($listing);
          ### mtime   : $mtime
          ### ims_time: $ims_time
          if (! (defined $perms && $perms =~ /^d/)  # no check of directory listing
              && defined $mtime && $mtime <= $ims_time) {
            my $resp = HTTP::Response->new (HTTP::Status::RC_NOT_MODIFIED(),
                                            undef,
                                            [ _content_headers($length, $mtime) ]);
            LWP::MediaTypes::guess_media_type($uri, $resp->headers);
            return $resp;
          }
        }
      }
    }

    my $mtime;

    if (! $dir_listing) {
      my $stdout;
      if (my $resp = _run_rsync($password,
                                [ 'rsync',
                                  '--checksum',  # no date/size quick check
                                  '-t',          # -t set destination $filename modtime
                                  '--inplace',   # write into $filename rather than renaming
                                  $uri_str,
                                  $filename ],
                                \$stdout)) {
        return $resp;
      }
      # if the path was in fact a directory then re-run to get its listing
      $dir_listing = ($stdout =~ /^skipping directory/mi);
    }

    # For non-root directory listing must have trailing slash like
    # "rsync://hostname/module/dirname/" otherwise the listing is just the
    # directory itself like
    #     "drwxrwxrwt         69,632 2014/03/26 19:38:01 tmp"
    #
    if ($dir_listing) {
      unless ($uri_str =~ m{/\z}) { $uri_str .= '/'; }
      if (my $resp = _run_rsync($password,
                                [ 'rsync', $uri_str ],
                                $filename)) {
        return $resp;
      }
      $content_type = 'text/plain';
    } else {
      $mtime = _stat_mtime($filename)
    }

    my $resp = HTTP::Response->new(HTTP::Status::RC_OK(),
                                   undef,
                                   [ _content_headers(-s $filename, $mtime, $content_type) ]);
    unless ($content_type) {
      LWP::MediaTypes::guess_media_type($uri, $resp->headers);
    }

    # If not read directly into :content_file $arg filename then collect
    # from $temp_fh into $resp.  collect() enforces max_size and has
    # some callbacks.
    #
    # FIXME: Should we worry about those for the :content_file case?  For
    # the max_size we already have the full content, would there be any
    # merit in truncating it?
    #
    if ($temp_fh) {
      my $readerr;
      $self->collect($arg, $resp, sub {
                       my $content = "";
                       my $bytes = sysread($temp_fh, $content, $size);
                       ### $bytes
                       if (! defined $bytes) {
                         $readerr = "$!";
                         return '';
                       }
                       return \$content;
                     });
      if (defined $readerr) {
        return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR(),
                                   "Error reading $filename: $readerr");
      }
    }

    return $resp;
  }

  if ($method eq 'PUT') {
    ### PUT ...

    # ENHANCE-ME: Does "Content-Range" mean ->content() is only that part of
    # the data?

    if ($temp_fh) {
      if (defined (my $err = _http_message_content_to_fh($request, $temp_fh,
                                                         $filename))) {
        return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR(),
                                   "Error writing $filename: $err");
      }
    }
    ### ls: system("ls -d $filename")

    if (my $resp = _run_rsync($password,
                              [ 'rsync',
                                '--checksum', # full check, not date/size quick
                                '--inplace',  # write into file, not rename
                                $filename,
                                $uri_str ])) {
      return $resp;
    }

    # Per RFC 2616 and webdav RFC 2518
    # "201 Created" is for newly created destination resource.
    # ENHANCE-ME: Supposed to be "200 OK" for existing destination modified.
    #
    return HTTP::Response->new(HTTP::Status::RC_CREATED());
  }

  return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED(),
                             "Unrecognised rsync method: $method");
}

sub _run_rsync {
  my ($password, $command_line, $stdout_ref) = @_;
  ### _run_rsync() ...
  # ### diagnostic -ivvvv: splice @$command_line, 1,0, '-ivv'

  if (! $stdout_ref) {
    my $stdout;
    $stdout_ref = \$stdout;
  }
  my $stderr;
  my $eval;
  {
    # Always set $ENV{RSYNC_PASSWORD}, to an empty string if nothing else.
    # Otherwise rsync will prompt for a password with getpass() or similar
    # (which opens and read /dev/tty).
    #
    # Does --protect-args do anything when talking to the daemon?  Turn it
    # on since certainly don't want space splitting etc.  Do this by
    # $ENV{'RSYNC_PROTECT_ARGS'} since the option is only in rsync 3.1 up.
    #
    # $ENV{'TZ'} set to GMT so that the date/time in the listing output will
    # be in GMT.  If the local timezone has any daylight savings then when
    # the clocks go back times are duplicated and so are ambiguous.
    #
    if (! defined $password) { $password = ''; }
    local %ENV = (%ENV,
                  RSYNC_PROTECT_ARGS => 1,
                  RSYNC_PASSWORD => $password,
                  TZ => 'GMT+0');

    ### $command_line
    ### RSYNC_PASSWORD: $ENV{'RSYNC_PASSWORD'}
    $eval = eval {
      IPC::Run::run ($command_line,
                     '<', File::Spec->devnull,
                     (defined $stdout_ref
                      ? ('>', $stdout_ref, '2>', \$stderr)
                      : ('>', \$stderr, '2>&1')));
      1 };
  }
  if (! $eval) {
    my $err = $@;
    return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR(),
                               "Cannot run rsync program",
                               [ 'Content-Type' => 'text/plain' ],
                               $err);
  }

  # "401 Unauthorized" here applies to all rsync runs, GET, HEAD and PUT.
  my $wstat = $?;
  ### wstat: sprintf '0x%X', $wstat
  ### $stdout_ref
  ### $stderr
  if ($wstat != 0) {
    return HTTP::Response->new(($stderr =~ /\@ERROR: auth failed/
                                ? HTTP::Status::RC_UNAUTHORIZED()
                                : HTTP::Status::RC_NOT_FOUND()),
                               undef,
                               [ 'Content-Type' => 'text/plain' ],
                               join ('',
                                     "rsync program ", _wstat_str($wstat), "\n",
                                     (ref $stdout_ref && defined $$stdout_ref ? ($$stdout_ref, "\n") : ()),
                                     $stderr, "\n"));
  }

  return;
}

# POSIX::WIFEXITED() and friends either croak (Perl 5.8 up) or don't exist
# at all (5.6.x and earlier) if not available from the system.
#
sub _wstat_str {
  my ($wstat) = @_;
  require POSIX;
  if (eval { POSIX::WIFEXITED($wstat) }
      && defined (my $exit_code = eval { POSIX::WEXITSTATUS($wstat) })) {
    return "exit code $exit_code";
  }
  if (eval { POSIX::WIFSIGNALED($wstat) }
      && defined (my $signal_number = eval { POSIX::WTERMSIG($wstat) })) {
    return "signal $signal_number";
  }
  return sprintf "exit status 0x%X", $wstat;
}

# $request is a HTTP::Message.
# Write its $request->content() bytes to file handle $fh.
# If successful return undef.
# If error then return a string describing the problem.
# $filename is used in the error message.
#
sub _http_message_content_to_fh {
  my ($request, $fh, $filename) = @_;
  ### _http_message_content_to_fh() ...

  my $content = $request->content;
  if (! defined $content) {
    return "no content in request";
  }

  if (ref($content) eq 'SCALAR') {
    ### scalar ref ...
    if (print $fh $$content) {
      return;  # good
    }
    # write error

  } elsif (ref($content) eq 'CODE') {
    ### coderef ...
    for (;;) {
      my $buf = &$content();
      if (length($buf) == 0) {
        return; # good
      }
      print $fh $buf
        or last; # write error
    }

  } elsif (! ref $content) {
    ### plain scalar ...
    if (print $fh $content) {
      return;  # good
    }
    # write error

  } else {
    return "unrecognised request content()";
  }

  return "Cannot write $filename: $!";
}

# sub _content_cb_noop {
# }

# Return the mtime modification time of a filename or file handle.
sub _stat_mtime {
  my ($fh_or_filename) = @_;
  my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
      $atime,$mtime,$ctime,$blksize,$blocks) = stat $fh_or_filename;
  return $mtime;
}

# $listing is a file info string from rsync.
# Return ($perms, $length, $mtime), possibly with undefs if parts not
# recognised.
#   $perms is a string
#   $length is an integer number
#   $mtime is a time_t number
#
# $listing is like
#   -rw-r--r--          1,260 2004/10/29 04:50:12 foo.txt
# or for a symlink
#   lrwxrwxrwx              3 2014/03/20 17:21:21 bar -> foo
#
# rsync 3.1 introduces commas as digit grouping for the size.  Or dots if
# the decimal point is not a dot in the locale.  The "k" etc abbreviations
# are confined to --human-readable so don't occur.  Code in rsync
# lib/compat.c.  Any dots or commas are removed for the returned $length.
#
# Date/time in the listing is in the client-side system timezone.
# _run_rsync() above forces it to GMT and that's how it's treated here when
# converting to time_t $mtime.
#
# rsync code in generator.c list_file_entry().
#
sub _parse_listing {
  my ($listing) = @_;
  ### $listing

  my ($perms, $length, $mtime);
  if (($perms, $length, my $mtime_str)
      = ($listing =~ m{\s*(\S+)\s+([0-9,.]+)\s+([0-9/]+ [0-9:]+)})) {
    $length =~ tr/.,//d;   # delete commas and dots
    $mtime = HTTP::Date::str2time($mtime_str, 'GMT');
  }
  return ($perms, $length, $mtime);
}

# return a list
sub _content_headers {
  my ($length, $mtime, $content_type) = @_;
  return ('Content-Length' => $length,
          (defined $mtime ? ('Last-Modified' => HTTP::Date::time2str($mtime)) : ()),
          'Content-Type' => $content_type,
          # 'X-Rsync-Perms'  => $perms,  # any good?
         );
}

# Return true if $path has no module part, hence giving a modules listing,
# or has a module part but only the root directory.
sub _path_is_modules_or_root {
  my ($path) = @_;
  return scalar($path !~ m{^/[^/]+  # module part
                           /.*
                           [^./]*   # some non-. or / means not root dir
                        }x);
}

1;
__END__