home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 December / PCpro_2006_12.ISO / ossdvd / server / Perl2 / site / lib / lwp / Protocol / ftp.pm < prev    next >
Encoding:
Perl POD Document  |  2001-10-26  |  17.1 KB  |  544 lines
  1. #
  2. # $Id: ftp.pm,v 1.31 2001/10/26 20:13:20 gisle Exp $
  3.  
  4. # Implementation of the ftp protocol (RFC 959). We let the Net::FTP
  5. # package do all the dirty work.
  6.  
  7. package LWP::Protocol::ftp;
  8.  
  9. use Carp ();
  10.  
  11. use HTTP::Status ();
  12. use HTTP::Negotiate ();
  13. use HTTP::Response ();
  14. use LWP::MediaTypes ();
  15. use File::Listing ();
  16.  
  17. require LWP::Protocol;
  18. @ISA = qw(LWP::Protocol);
  19.  
  20. use strict;
  21. eval {
  22.     package LWP::Protocol::MyFTP;
  23.  
  24.     require Net::FTP;
  25.     Net::FTP->require_version(2.00);
  26.  
  27.     use vars qw(@ISA);
  28.     @ISA=qw(Net::FTP);
  29.  
  30.     sub new {
  31.     my $class = shift;
  32.     LWP::Debug::trace('()');
  33.  
  34.     my $self = $class->SUPER::new(@_) || return undef;
  35.  
  36.     my $mess = $self->message;  # welcome message
  37.     LWP::Debug::debug($mess);
  38.     $mess =~ s|\n.*||s; # only first line left
  39.     $mess =~ s|\s*ready\.?$||;
  40.     # Make the version number more HTTP like
  41.     $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
  42.     ${*$self}{myftp_server} = $mess;
  43.     #$response->header("Server", $mess);
  44.  
  45.     $self;
  46.     }
  47.  
  48.     sub http_server {
  49.     my $self = shift;
  50.     ${*$self}{myftp_server};
  51.     }
  52.  
  53.     sub home {
  54.     my $self = shift;
  55.     my $old = ${*$self}{myftp_home};
  56.     if (@_) {
  57.         ${*$self}{myftp_home} = shift;
  58.     }
  59.     $old;
  60.     }
  61.  
  62.     sub go_home {
  63.     LWP::Debug::trace('');
  64.     my $self = shift;
  65.     $self->cwd(${*$self}{myftp_home});
  66.     }
  67.  
  68.     sub request_count {
  69.     my $self = shift;
  70.     ++${*$self}{myftp_reqcount};
  71.     }
  72.  
  73.     sub ping {
  74.     LWP::Debug::trace('');
  75.     my $self = shift;
  76.     return $self->go_home;
  77.     }
  78.  
  79. };
  80. my $init_failed = $@;
  81.  
  82.  
  83. sub _connect {
  84.     my($self, $host, $port, $user, $account, $password, $timeout) = @_;
  85.  
  86.     my $key;
  87.     my $conn_cache = $self->{ua}{conn_cache};
  88.     if ($conn_cache) {
  89.     $key = "$host:$port:$user";
  90.     $key .= ":$account" if defined($account);
  91.     if (my $ftp = $conn_cache->withdraw("ftp", $key)) {
  92.         if ($ftp->ping) {
  93.         LWP::Debug::debug('Reusing old connection');
  94.         # save it again
  95.         $conn_cache->deposit("ftp", $key, $ftp);
  96.         return $ftp;
  97.         }
  98.     }
  99.     }
  100.  
  101.     # try to make a connection
  102.     my $ftp = LWP::Protocol::MyFTP->new($host,
  103.                     Port => $port,
  104.                     Timeout => $timeout,
  105.                        );
  106.     # XXX Should be some what to pass on 'Passive' (header??)
  107.     unless ($ftp) {
  108.     $@ =~ s/^Net::FTP: //;
  109.     return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
  110.     }
  111.  
  112.     LWP::Debug::debug("Logging in as $user (password $password)...");
  113.     unless ($ftp->login($user, $password, $account)) {
  114.     # Unauthorized.  Let's fake a RC_UNAUTHORIZED response
  115.     my $mess = scalar($ftp->message);
  116.     LWP::Debug::debug($mess);
  117.     $mess =~ s/\n$//;
  118.     my $res =  HTTP::Response->new(&HTTP::Status::RC_UNAUTHORIZED, $mess);
  119.     $res->header("Server", $ftp->http_server);
  120.     $res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
  121.     return $res;
  122.     }
  123.     LWP::Debug::debug($ftp->message);
  124.  
  125.     my $home = $ftp->pwd;
  126.     LWP::Debug::debug("home: '$home'");
  127.     $ftp->home($home);
  128.  
  129.     $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache;
  130.  
  131.     return $ftp;
  132. }
  133.  
  134.  
  135. sub request
  136. {
  137.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  138.  
  139.     $size = 4096 unless $size;
  140.  
  141.     LWP::Debug::trace('()');
  142.  
  143.     # check proxy
  144.     if (defined $proxy)
  145.     {
  146.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  147.                    'You can not proxy through the ftp');
  148.     }
  149.  
  150.     my $url = $request->url;
  151.     if ($url->scheme ne 'ftp') {
  152.     my $scheme = $url->scheme;
  153.     return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  154.                "LWP::Protocol::ftp::request called for '$scheme'");
  155.     }
  156.  
  157.     # check method
  158.     my $method = $request->method;
  159.  
  160.     unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
  161.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  162.                    'Library does not allow method ' .
  163.                    "$method for 'ftp:' URLs");
  164.     }
  165.  
  166.     if ($init_failed) {
  167.     return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  168.                    $init_failed);
  169.     }
  170.  
  171.     my $host     = $url->host;
  172.     my $port     = $url->port;
  173.     my $user     = $url->user;
  174.     my $password = $url->password;
  175.  
  176.     # If a basic autorization header is present than we prefer these over
  177.     # the username/password specified in the URL.
  178.     {
  179.     my($u,$p) = $request->authorization_basic;
  180.     if (defined $u) {
  181.         $user = $u;
  182.         $password = $p;
  183.     }
  184.     }
  185.  
  186.     # We allow the account to be specified in the "Account" header
  187.     my $account = $request->header('Account');
  188.  
  189.     my $ftp = $self->_connect($host, $port, $user, $account, $password, $timeout);
  190.     return $ftp if ref($ftp) eq "HTTP::Response"; # ugh!
  191.  
  192.     # Create an initial response object
  193.     my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  194.     $response->header(Server => $ftp->http_server);
  195.     $response->header('Client-Request-Num' => $ftp->request_count);
  196.     $response->request($request);
  197.  
  198.     # Get & fix the path
  199.     my @path =  grep { length } $url->path_segments;
  200.     my $remote_file = pop(@path);
  201.     $remote_file = '' unless defined $remote_file;
  202.  
  203.     my $type;
  204.     if (ref $remote_file) {
  205.     my @params;
  206.     ($remote_file, @params) = @$remote_file;
  207.     for (@params) {
  208.         $type = $_ if s/^type=//;
  209.     }
  210.     }
  211.  
  212.     if ($type && $type eq 'a') {
  213.     $ftp->ascii;
  214.     } else {
  215.     $ftp->binary;
  216.     }
  217.  
  218.     for (@path) {
  219.     LWP::Debug::debug("CWD $_");
  220.     unless ($ftp->cwd($_)) {
  221.         return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  222.                        "Can't chdir to $_");
  223.     }
  224.     }
  225.  
  226.     if ($method eq 'GET' || $method eq 'HEAD') {
  227.     LWP::Debug::debug("MDTM");
  228.     if (my $mod_time = $ftp->mdtm($remote_file)) {
  229.         $response->last_modified($mod_time);
  230.         if (my $ims = $request->if_modified_since) {
  231.         if ($mod_time <= $ims) {
  232.             $response->code(&HTTP::Status::RC_NOT_MODIFIED);
  233.             $response->message("Not modified");
  234.             return $response;
  235.         }
  236.         }
  237.     }
  238.  
  239.     # We'll use this later to abort the transfer if necessary. 
  240.     # if $max_size is defined, we need to abort early. Otherwise, it's
  241.       # a normal transfer
  242.     my $max_size = undef;
  243.  
  244.     # Set resume location, if the client requested it
  245.     if ($request->header('Range') && $ftp->supported('REST'))
  246.     {
  247.         my $range_info = $request->header('Range');
  248.  
  249.         # Change bytes=2772992-6781209 to just 2772992
  250.         my ($start_byte,$end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)/;
  251.  
  252.         if (!defined $start_byte || !defined $end_byte ||
  253.           ($start_byte < 0) || ($start_byte > $end_byte) || ($end_byte < 0))
  254.         {
  255.           return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  256.              'Incorrect syntax for Range request');
  257.         }
  258.  
  259.         $max_size = $end_byte-$start_byte;
  260.  
  261.         $ftp->restart($start_byte);
  262.     }
  263.     elsif ($request->header('Range') && !$ftp->supported('REST'))
  264.     {
  265.         return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  266.              "Server does not support resume.");
  267.     }
  268.  
  269.     my $data;  # the data handle
  270.     LWP::Debug::debug("retrieve file?");
  271.     if (length($remote_file) and $data = $ftp->retr($remote_file)) {
  272.         my($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
  273.         $response->header('Content-Type',   $type) if $type;
  274.         for (@enc) {
  275.         $response->push_header('Content-Encoding', $_);
  276.         }
  277.         my $mess = $ftp->message;
  278.         LWP::Debug::debug($mess);
  279.         if ($mess =~ /\((\d+)\s+bytes\)/) {
  280.         $response->header('Content-Length', "$1");
  281.         }
  282.  
  283.         if ($method ne 'HEAD') {
  284.         # Read data from server
  285.         $response = $self->collect($arg, $response, sub {
  286.             my $content = '';
  287.             my $result = $data->read($content, $size);
  288.  
  289.                     # Stop early if we need to.
  290.                     if (defined $max_size)
  291.                     {
  292.                       # We need an interface to Net::FTP::dataconn for getting
  293.                       # the number of bytes already read
  294.                       my $bytes_received = $data->bytes_read();
  295.  
  296.                       # We were already over the limit. (Should only happen
  297.                       # once at the end.)
  298.                       if ($bytes_received - length($content) > $max_size)
  299.                       {
  300.                         $content = '';
  301.                       }
  302.                       # We just went over the limit
  303.                       elsif ($bytes_received  > $max_size)
  304.                       {
  305.                         # Trim content
  306.                         $content = substr($content, 0,
  307.                           $max_size - ($bytes_received - length($content)) );
  308.                       }
  309.                       # We're under the limit
  310.                       else
  311.                       {
  312.                       }
  313.                     }
  314.  
  315.             return \$content;
  316.         } );
  317.         }
  318.         unless ($data->close) {
  319.         # Something did not work too well
  320.         if ($method ne 'HEAD') {
  321.             $response->code(&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
  322.             $response->message("FTP close response: " . $ftp->code .
  323.                        " " . $ftp->message);
  324.         }
  325.         }
  326.     } elsif (!length($remote_file) || $ftp->code == 550) {
  327.         # 550 not a plain file, try to list instead
  328.         if (length($remote_file) && !$ftp->cwd($remote_file)) {
  329.         LWP::Debug::debug("chdir before listing failed");
  330.         return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  331.                        "File '$remote_file' not found");
  332.         }
  333.  
  334.         # It should now be safe to try to list the directory
  335.         LWP::Debug::debug("dir");
  336.         my @lsl = $ftp->dir;
  337.  
  338.         # Try to figure out if the user want us to convert the
  339.         # directory listing to HTML.
  340.         my @variants =
  341.           (
  342.            ['html',  0.60, 'text/html'            ],
  343.            ['dir',   1.00, 'text/ftp-dir-listing' ]
  344.           );
  345.         #$HTTP::Negotiate::DEBUG=1;
  346.         my $prefer = HTTP::Negotiate::choose(\@variants, $request);
  347.  
  348.         my $content = '';
  349.  
  350.         if (!defined($prefer)) {
  351.         return HTTP::Response->new(&HTTP::Status::RC_NOT_ACCEPTABLE,
  352.                    "Neither HTML nor directory listing wanted");
  353.         } elsif ($prefer eq 'html') {
  354.         $response->header('Content-Type' => 'text/html');
  355.         $content = "<HEAD><TITLE>File Listing</TITLE>\n";
  356.         my $base = $request->url->clone;
  357.         my $path = $base->path;
  358.         $base->path("$path/") unless $path =~ m|/$|;
  359.         $content .= qq(<BASE HREF="$base">\n</HEAD>\n);
  360.         $content .= "<BODY>\n<UL>\n";
  361.         for (File::Listing::parse_dir(\@lsl, 'GMT')) {
  362.             my($name, $type, $size, $mtime, $mode) = @$_;
  363.             $content .= qq(  <LI> <a href="$name">$name</a>);
  364.             $content .= " $size bytes" if $type eq 'f';
  365.             $content .= "\n";
  366.         }
  367.         $content .= "</UL></body>\n";
  368.         } else {
  369.         $response->header('Content-Type', 'text/ftp-dir-listing');
  370.         $content = join("\n", @lsl, '');
  371.         }
  372.  
  373.         $response->header('Content-Length', length($content));
  374.  
  375.         if ($method ne 'HEAD') {
  376.         $response = $self->collect_once($arg, $response, $content);
  377.         }
  378.     } else {
  379.         my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  380.               "FTP return code " . $ftp->code);
  381.         $res->content_type("text/plain");
  382.         $res->content($ftp->message);
  383.         return $res;
  384.     }
  385.     } elsif ($method eq 'PUT') {
  386.     # method must be PUT
  387.     unless (length($remote_file)) {
  388.         return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  389.                        "Must have a file name to PUT to");
  390.     }
  391.     my $data;
  392.     if ($data = $ftp->stor($remote_file)) {
  393.         LWP::Debug::debug($ftp->message);
  394.         LWP::Debug::debug("$data");
  395.         my $content = $request->content;
  396.         my $bytes = 0;
  397.         if (defined $content) {
  398.         if (ref($content) eq 'SCALAR') {
  399.             $bytes = $data->write($$content, length($$content));
  400.         } elsif (ref($content) eq 'CODE') {
  401.             my($buf, $n);
  402.             while (length($buf = &$content)) {
  403.             $n = $data->write($buf, length($buf));
  404.             last unless $n;
  405.             $bytes += $n;
  406.             }
  407.         } elsif (!ref($content)) {
  408.             if (defined $content && length($content)) {
  409.             $bytes = $data->write($content, length($content));
  410.             }
  411.         } else {
  412.             die "Bad content";
  413.         }
  414.         }
  415.         $data->close;
  416.         LWP::Debug::debug($ftp->message);
  417.  
  418.         $response->code(&HTTP::Status::RC_CREATED);
  419.         $response->header('Content-Type', 'text/plain');
  420.         $response->content("$bytes bytes stored as $remote_file on $host\n")
  421.  
  422.     } else {
  423.         my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  424.                       "FTP return code " . $ftp->code);
  425.         $res->content_type("text/plain");
  426.         $res->content($ftp->message);
  427.         return $res;
  428.     }
  429.     } else {
  430.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  431.                    "Illegal method $method");
  432.     }
  433.  
  434.     $response;
  435. }
  436.  
  437. 1;
  438.  
  439. __END__
  440.  
  441. # This is what RFC 1738 has to say about FTP access:
  442. # --------------------------------------------------
  443. #
  444. # 3.2. FTP
  445. #
  446. #    The FTP URL scheme is used to designate files and directories on
  447. #    Internet hosts accessible using the FTP protocol (RFC959).
  448. #
  449. #    A FTP URL follow the syntax described in Section 3.1.  If :<port> is
  450. #    omitted, the port defaults to 21.
  451. #
  452. # 3.2.1. FTP Name and Password
  453. #
  454. #    A user name and password may be supplied; they are used in the ftp
  455. #    "USER" and "PASS" commands after first making the connection to the
  456. #    FTP server.  If no user name or password is supplied and one is
  457. #    requested by the FTP server, the conventions for "anonymous" FTP are
  458. #    to be used, as follows:
  459. #
  460. #         The user name "anonymous" is supplied.
  461. #
  462. #         The password is supplied as the Internet e-mail address
  463. #         of the end user accessing the resource.
  464. #
  465. #    If the URL supplies a user name but no password, and the remote
  466. #    server requests a password, the program interpreting the FTP URL
  467. #    should request one from the user.
  468. #
  469. # 3.2.2. FTP url-path
  470. #
  471. #    The url-path of a FTP URL has the following syntax:
  472. #
  473. #         <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode>
  474. #
  475. #    Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings
  476. #    and <typecode> is one of the characters "a", "i", or "d".  The part
  477. #    ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be
  478. #    empty. The whole url-path may be omitted, including the "/"
  479. #    delimiting it from the prefix containing user, password, host, and
  480. #    port.
  481. #
  482. #    The url-path is interpreted as a series of FTP commands as follows:
  483. #
  484. #       Each of the <cwd> elements is to be supplied, sequentially, as the
  485. #       argument to a CWD (change working directory) command.
  486. #
  487. #       If the typecode is "d", perform a NLST (name list) command with
  488. #       <name> as the argument, and interpret the results as a file
  489. #       directory listing.
  490. #
  491. #       Otherwise, perform a TYPE command with <typecode> as the argument,
  492. #       and then access the file whose name is <name> (for example, using
  493. #       the RETR command.)
  494. #
  495. #    Within a name or CWD component, the characters "/" and ";" are
  496. #    reserved and must be encoded. The components are decoded prior to
  497. #    their use in the FTP protocol.  In particular, if the appropriate FTP
  498. #    sequence to access a particular file requires supplying a string
  499. #    containing a "/" as an argument to a CWD or RETR command, it is
  500. #    necessary to encode each "/".
  501. #
  502. #    For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is
  503. #    interpreted by FTP-ing to "host.dom", logging in as "myname"
  504. #    (prompting for a password if it is asked for), and then executing
  505. #    "CWD /etc" and then "RETR motd". This has a different meaning from
  506. #    <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then
  507. #    "RETR motd"; the initial "CWD" might be executed relative to the
  508. #    default directory for "myname". On the other hand,
  509. #    <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null
  510. #    argument, then "CWD etc", and then "RETR motd".
  511. #
  512. #    FTP URLs may also be used for other operations; for example, it is
  513. #    possible to update a file on a remote file server, or infer
  514. #    information about it from the directory listings. The mechanism for
  515. #    doing so is not spelled out here.
  516. #
  517. # 3.2.3. FTP Typecode is Optional
  518. #
  519. #    The entire ;type=<typecode> part of a FTP URL is optional. If it is
  520. #    omitted, the client program interpreting the URL must guess the
  521. #    appropriate mode to use. In general, the data content type of a file
  522. #    can only be guessed from the name, e.g., from the suffix of the name;
  523. #    the appropriate type code to be used for transfer of the file can
  524. #    then be deduced from the data content of the file.
  525. #
  526. # 3.2.4 Hierarchy
  527. #
  528. #    For some file systems, the "/" used to denote the hierarchical
  529. #    structure of the URL corresponds to the delimiter used to construct a
  530. #    file name hierarchy, and thus, the filename will look similar to the
  531. #    URL path. This does NOT mean that the URL is a Unix filename.
  532. #
  533. # 3.2.5. Optimization
  534. #
  535. #    Clients accessing resources via FTP may employ additional heuristics
  536. #    to optimize the interaction. For some FTP servers, for example, it
  537. #    may be reasonable to keep the control connection open while accessing
  538. #    multiple URLs from the same server. However, there is no common
  539. #    hierarchical model to the FTP protocol, so if a directory change
  540. #    command has been given, it is impossible in general to deduce what
  541. #    sequence should be given to navigate to another directory for a
  542. #    second retrieval, if the paths are different.  The only reliable
  543. #    algorithm is to disconnect and reestablish the control connection.
  544.