/t/22-chunked-put.t

  1#!/usr/bin/perl
  2
  3use strict;
  4use Perlbal::Test;
  5use IO::Socket::INET;
  6use Test::More 'no_plan';
  7
  8my $port = new_port();
  9my $dir = tempdir();
 10
 11my $conf = qq{
 12SERVER aio_mode = none
 13
 14CREATE SERVICE test
 15SET test.role = web_server
 16SET test.listen = 127.0.0.1:$port
 17SET test.docroot = $dir
 18SET test.dirindexing = 0
 19SET test.enable_put = 1
 20SET test.enable_delete = 1
 21SET test.min_put_directory = 0
 22SET test.persist_client = 1
 23ENABLE test
 24};
 25
 26my $msock = start_server($conf);
 27
 28my $ua = ua();
 29ok($ua);
 30
 31require HTTP::Request;
 32
 33my $url = "http://127.0.0.1:$port/foo.txt";
 34my $disk_file = "$dir/foo.txt";
 35my $contentlen = 0;
 36my $written_content = "";
 37
 38sub buffer_file_exists {
 39    -e $disk_file;
 40}
 41
 42# cmds can be:
 43#    write:<length>     writes <length> bytes
 44#    sleep:<duration>   sleeps <duration> seconds, may be fractional
 45#    finish             (sends any final writes and/or reads response)
 46#    close              close socket
 47#    sub {}             coderef to run.  gets passed response object
 48#    no-reason          response has no reason
 49#    reason:<reason>    did buffering for either "size", "rate", or "time"
 50#    empty              No files in temp buffer location
 51#    exists             Yes, a temporary file exists
 52sub request {
 53    my $testname = shift;
 54    my $len = shift || 0;
 55    my @cmds = @_;
 56
 57    my $curpos = 0;
 58    my $remain = $len;
 59
 60    $contentlen = 0;
 61    $written_content = "";
 62
 63    my $hdr = "PUT /foo.txt HTTP/1.0\r\nTransfer-Encoding: chunked\r\nExpect: 100-continue\r\n\r\n";
 64    my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port" )
 65        or return undef;
 66    my $rv = syswrite($sock, $hdr);
 67    die unless $rv == length($hdr);
 68
 69    # wanting HTTP/1.1 100 Continue\r\n...\r\n lines
 70    {
 71        my $contline = <$sock>;
 72        die "didn't get 100 Continue line, got: $contline"
 73            unless $contline =~ m!^HTTP/1.1 100!;
 74        my $gotempty = 0;
 75        while (defined(my $line = <$sock>)) {
 76            if ($line eq "\r\n") {
 77                $gotempty = 1;
 78                last;
 79            }
 80        }
 81        die "didn't get empty line after 100 Continue" unless $gotempty;
 82    }
 83
 84    my $res = undef;  # no response yet
 85
 86    foreach my $cmd (@cmds) {
 87        my $writelen;
 88
 89        if ($cmd =~ /^write:([\d_]+)/) {
 90            $writelen = $1;
 91            $writelen =~ s/_//g;
 92        } elsif ($cmd =~ /^(\d+)/) {
 93            $writelen = $1;
 94        } elsif ($cmd eq "finish") {
 95            $writelen = $remain;
 96        }
 97
 98        if ($cmd =~ /^sleep:([\d\.]+)/) {
 99            select undef, undef, undef, $1;
100            next;
101        }
102
103        if ($cmd eq "close") {
104            close($sock);
105            next;
106        }
107
108        if ($cmd eq "exists") {
109            ok(buffer_file_exists(), "$testname: buffer file exists");
110            next;
111        }
112
113        if ($writelen) {
114            diag("Writing: $writelen");
115            die "Too long" if $writelen > $remain;
116            my $buf = chr(int(rand(26)) + 65) x $writelen;
117
118            # update what we'll be checking for later,
119            $contentlen += $writelen;
120            $written_content .= $buf;
121
122            $buf = sprintf("%x\r\n", $writelen) . $buf . "\r\n";
123            $remain -= $writelen;
124            if ($remain == 0) {
125                # one \r\n for chunk ending, one for chunked-body ending,
126                # after (our empty) trailer...
127                $buf .= "0\r\n\r\n";
128            }
129            my $bufsize = length($buf);
130            my $off = 0;
131            while ($off < $bufsize) {
132                my $rv = syswrite($sock, $buf, $bufsize-$off, $off);
133                die "Error writing: $!, we had finished $off of $bufsize" unless defined $rv;
134                die "Got rv=0 from syswrite" unless $rv;
135                $off += $rv;
136            }
137
138            next unless $cmd eq "finish";
139        }
140
141        if ($cmd eq "finish") {
142            $res = resp_from_sock($sock);
143            my $clen = $res ? $res->header('Content-Length') : 0;
144            ok($res && length($res->content) == $clen, "$testname: good response");
145            next;
146        }
147
148        if (ref $cmd eq "CODE") {
149            $cmd->($res, $testname);
150            next;
151        }
152
153        die "Invalid command: $cmd\n";
154    }
155}
156
157sub delete_file {
158    my $req = HTTP::Request->new(DELETE => $url);
159    my $res = $ua->request($req);
160    return $res->is_success;
161}
162
163sub verify_put {
164    open(my $fh, $disk_file) or die;
165    my $slurp = do { local $/; <$fh>; };
166    ok(-s $disk_file == $contentlen && $slurp eq $written_content, "verified put");
167}
168
169# disable all of it
170request("buffer_off", 500_000,
171        "write:500",
172        "write:5",
173        "write:5",
174        "write:5",
175        "sleep:0.25",
176        "exists",
177        "write:100000",
178        "write:60000",
179        "write:1000",
180        "finish",
181        sub {
182            verify_put();
183        },
184        );
185
1861;