The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use URI;

use IO::Async::Loop;
use Net::Async::HTTP;

use POSIX qw( floor );
use Time::HiRes qw( time );
use Getopt::Long;

sub usage
{
   my ( $exitcode ) = @_;

   print STDERR <<"EOF";
Net::Async::HTTP PUT client example.

Usage:

 $0 [-u user:pass] https://example.com/file-to-put.bin /tmp/file-to-read.bin

If -u options are given, these will be sent as Basic auth credentials.
Different ports can be specified in the URL, e.g.

  http://example.com:12314/file.txt

EOF
}

# Basic commandline parameter support - -u user:password
my $userpass;
my $url;
my $src;
my $contenttype = "application/octet-stream";

GetOptions(
   'userpass|u=s' => \$userpass,
   'src=s'        => \$src,
   'type|t=s'     => \$contenttype,

   'help|h' => sub { usage(0) },
) or usage(1);

my $loop = IO::Async::Loop->new;

$url = shift @ARGV or usage(1);
$src = shift @ARGV or usage(1) if !defined $src;

my $ua = Net::Async::HTTP->new;
$loop->add( $ua );

# We'll send the size as the Content-Length, and get the filehandle ready for reading
my $size = (stat $src)[7];
open my $fh, '<', $src or die "Failed to open source file $src - $!\n";
binmode $fh;

# Prepare our request object
my $uri = URI->new($url) or die "Invalid URL?\n";
my $req = HTTP::Request->new(
   PUT => $uri->path, [
      'Host'         => $uri->host,
      'Content-Type' => $contenttype,
   ]
);

# Default is no protocol, we insist on HTTP/1.1 here, PUT probably requires that as a minimum anyway
$req->protocol( 'HTTP/1.1' );
$req->authorization_basic( split m/:/, $userpass, 2 ) if defined $userpass;
$req->content_length( $size );

# For stats
my $total = 0;
my $last = -1;
my $start;

$ua->do_request(
   request    => $req,
   host       => $uri->host,
   port       => $uri->port,
   SSL        => $uri->scheme eq 'https' ? 1 : 0,

   # We override the default behaviour (pulling content from HTTP::Request) by passing a callback explicitly
   # Originall had "content_callback", not really sure what the best thing to call this would be though.
   request_body => sub {
      my ($stream) = @_;
      unless (defined $start) {
         $start = time;
         $| = 1;
      }

      # This part is the important one - read some data, and eventually return it
      my $read = sysread $fh, my $buffer, 1048576;

      # Just for stats display, update every mbyte
      $total += $read;
      my $step = floor($total / 1048576);
      if($step > $last) {
         $last = $step;
         my $elapsed = (time - $start) || 1;
         printf("Total: %14d of %14d bytes, %5.2f%% complete, %9.3fkbyte/s   \r", $total, $size, (100 * $total) / $size, ($total) / ($elapsed * 1024));
      }

      return $buffer if $read;

      # Return undef when we're done
      print "\n\nComplete.\n";
      return;
   },
   on_response => sub {
      my ( $response ) = @_;

      close $fh or die $!;
      print $response->as_string;
   },

   on_error => sub {
      my ( $message ) = @_;

      print STDERR "Failed - $message\n";
   }
)->get;