view release on metacpan or  search on metacpan

lib/CPAN/Mirror/Server/HTTP.pm  view on Meta::CPAN

    my $child = fork();
    unless ( defined $child ) {
      die "Cannot fork child: $!\n";
    }
    if ( $child == 0 ) {
      _handle_request( $conn, $root );
      exit(0);
    }
    $conn->close();
  }

}

sub _handle_request {
  my $conn = shift;
  my $root = shift;
  REQ: while (my $req = $conn->get_request) {
    if ($req->method eq 'GET' or $req->method eq 'HEAD') {
      # Special case /icons
      if ( my ($icon) = $req->uri->path =~ m#^/icons/(back|blank|compressed|folder|unknown)\.gif$# ) {
        my $resp = _gen_icon( $icon );
        $conn->send_response( $resp );
        next REQ;
      }
      my @path = $req->uri->path_segments;
      my $path = File::Spec->catfile( $root, @path );
      if ( -d $path and $req->uri->path !~ m#/$# ) {
        my $resp = _gen_301( $req->uri );
        $conn->send_response( $resp );
        next REQ;
      }
      if ( -d $path and -e File::Spec->catfile( $path, $index ) ) {
        $path = File::Spec->catfile( $path, $index );
      }
      if ( -d $path ) {
        my $resp = _gen_dir( $req->uri, $path );
        $conn->send_response( $resp );
        next REQ;
      }
      unless ( -e $path ) {
        $conn->send_error(RC_NOT_FOUND);
        next REQ;
      }
      $conn->send_file_response( $path );
    }
    else {
      $conn->send_error(RC_FORBIDDEN)
    }
  }
}

sub _gen_dir {
  my $uri  = shift;
  my $path = shift;
  my $resp = HTTP::Response->new( 200 );
  my %dir;

  {
    opendir my $DIR, $path or die "$!\n";
  
    $dir{ $_ } = [ ( stat( File::Spec->catfile( $path, $_ ) ) )[7,9],
                   ( -d File::Spec->catfile( $path, $_ ) ? 1 : 0 ),
                 ] for grep { !/^\./ } readdir $DIR;
  }

  my $h = HTML::Tiny->new;

  my @data;
  foreach my $item ( sort keys %dir ) {
    my $data = $dir{$item};
    push @data, [ 
      $h->td( { valign => 'top' }, 
        [ $h->img({ src => '/icons/' . _guess_type( $data->[2], $item ), 
            alt => ( $data->[2] ? '[DIR]' : '[   ]' ) }) ],
        [ $h->a( { href => ( $data->[2] ? "$item/" : $item ) }, $item ) ],
        { align => 'right' },
        strftime("%d-%b-%Y %H:%M",localtime($data->[1])),
        { align => 'right' },
        format_bytes( $data->[0] ),
      ),
    ];
  }

  my $parent;

  {
    my @segs = split m#/#, $uri->path;
    if ( scalar @segs ) {
      pop @segs;
      if ( grep { $_ } @segs ) {
        $parent = join('/', @segs);
      }
      $parent .= '/';
    }
  }

  unshift @data, 
    [ $h->td( { valign => 'top' }, 
      [ $h->img({ src => '/icons/back.gif', alt => '[DIR]' }) ], 
      [ $h->a( { href => $parent }, 'Parent Directory' ) ],
      ' ',
      '  - ', )
    ]
    if $parent;

  my $html = $h->html(
    [
      $h->head( $h->title( 'Index of ' . $uri->path ) ),
      $h->body( 
        [
          $h->h1( 'Index of ' . $uri->path ),
          $h->table(
            [
              $h->tr(
                [ $h->th( [ $h->img({ src => '/icons/blank.gif', alt => '[ICO]' }) ], 
                                'Name', 'Last modified', 'Size' ) ],
                [ $h->th( { colspan => 4 }, [ $h->hr() ] ) ],
                @data,
                [ $h->th( { colspan => 4 }, [ $h->hr() ] ) ],
              ),
            ],