├── .gitattributes ├── .github └── workflows │ ├── linux.yml │ └── macos.yml ├── .gitignore ├── Changes ├── LICENSE ├── META6.json ├── README.md ├── TODO.md ├── dist.ini ├── doc └── HTTP-UserAgent.rakudoc ├── examples ├── crawler.raku ├── ex_readme.raku ├── http-download.raku ├── http-dump.raku └── http-request.raku ├── lib └── HTTP │ ├── Cookie.rakumod │ ├── Cookies.rakumod │ ├── Header.rakumod │ ├── Header │ └── Field.rakumod │ ├── MediaType.rakumod │ ├── Message.rakumod │ ├── Request.rakumod │ ├── Request │ └── Common.rakumod │ ├── Response.rakumod │ ├── UserAgent.rakumod │ └── UserAgent │ ├── Common.rakumod │ └── Exception.rakumod ├── run-tests ├── t ├── 001-meta.rakutest ├── 010-headers.rakutest ├── 020-message.rakutest ├── 030-cookies.rakutest ├── 040-request.rakutest ├── 041-form-urlencoded.rakutest ├── 050-response.rakutest ├── 060-ua-common.rakutest ├── 070-ua-simple.rakutest ├── 080-ua.rakutest ├── 082-exceptions.rakutest ├── 085-auth.rakutest ├── 090-ua-ssl.rakutest ├── 100-redirect-ssl.rakutest ├── 110-redirect-cookies.rakutest ├── 150-issue-64.rakutest ├── 160-issue-67.rakutest ├── 170-request-common.rakutest ├── 180-mediatype.rakutest ├── 190-issue-116.rakutest ├── 200-w3-test-encodings.rakutest ├── 210-content-encoding.rakutest ├── 220-binary-content.rakutest ├── 230-binary-request.rakutest ├── 250-issue-144.rakutest ├── 260-no-proxy.rakutest ├── 270-issue-212.rakutest ├── dat │ ├── foo.txt │ └── multipart-1.dat └── lib │ └── TestServer.rakumod └── xt └── coverage.rakutest /.gitattributes: -------------------------------------------------------------------------------- 1 | t/dat/foo.txt eol=lf 2 | -------------------------------------------------------------------------------- /.github/workflows/linux.yml: -------------------------------------------------------------------------------- 1 | name: Linux 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | jobs: 12 | raku: 13 | strategy: 14 | matrix: 15 | os: 16 | - ubuntu-latest 17 | raku-version: 18 | - 'latest' 19 | runs-on: ${{ matrix.os }} 20 | steps: 21 | - uses: actions/checkout@v2 22 | - uses: Raku/setup-raku@v1 23 | with: 24 | raku-version: ${{ matrix.raku-version }} 25 | - name: Install Dependencies 26 | run: zef install --/test --test-depends --deps-only . 27 | - name: Run Special Tests 28 | run: raku run-tests -i 29 | -------------------------------------------------------------------------------- /.github/workflows/macos.yml: -------------------------------------------------------------------------------- 1 | name: MacOS 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | jobs: 12 | raku: 13 | strategy: 14 | matrix: 15 | os: 16 | - macos-latest 17 | raku-version: 18 | - 'latest' 19 | runs-on: ${{ matrix.os }} 20 | steps: 21 | - uses: actions/checkout@v2 22 | - uses: Raku/setup-raku@v1 23 | with: 24 | raku-version: ${{ matrix.raku-version }} 25 | - name: Install Libraries (MacOS) 26 | run: brew install openssl 27 | - name: Install Dependencies 28 | run: zef install --/test --test-depends --deps-only . 29 | - name: Run Special Tests 30 | run: raku run-tests -i 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .precomp/ 2 | /HTTP-UserAgent-* 3 | cookies.dat 4 | *.rakucov 5 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for HTTP::UserAgent 2 | 3 | {{$NEXT}} 4 | 5 | 1.2.0 2025-05-04T00:27:49+02:00 6 | - Initial version as a Raku Community module 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2014-2022 Filip Sergot 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "auth": "zef:raku-community-modules", 3 | "authors": [ 4 | "Filip Sergot" 5 | ], 6 | "build-depends": [ 7 | ], 8 | "depends": [ 9 | "HTTP::Status", 10 | "File::Temp", 11 | "DateTime::Parse", 12 | "Encode", 13 | "MIME::Base64", 14 | "URI", 15 | "IO::Socket::SSL:ver:<0.0.4+>:auth" 16 | ], 17 | "description": "Web user agent", 18 | "license": "MIT", 19 | "name": "HTTP::UserAgent", 20 | "perl": "6.*", 21 | "provides": { 22 | "HTTP::Cookie": "lib/HTTP/Cookie.rakumod", 23 | "HTTP::Cookies": "lib/HTTP/Cookies.rakumod", 24 | "HTTP::Header": "lib/HTTP/Header.rakumod", 25 | "HTTP::Header::Field": "lib/HTTP/Header/Field.rakumod", 26 | "HTTP::MediaType": "lib/HTTP/MediaType.rakumod", 27 | "HTTP::Message": "lib/HTTP/Message.rakumod", 28 | "HTTP::Request": "lib/HTTP/Request.rakumod", 29 | "HTTP::Request::Common": "lib/HTTP/Request/Common.rakumod", 30 | "HTTP::Response": "lib/HTTP/Response.rakumod", 31 | "HTTP::UserAgent": "lib/HTTP/UserAgent.rakumod", 32 | "HTTP::UserAgent::Common": "lib/HTTP/UserAgent/Common.rakumod", 33 | "HTTP::UserAgent::Exception": "lib/HTTP/UserAgent/Exception.rakumod" 34 | }, 35 | "raku": "6.*", 36 | "resources": [ 37 | ], 38 | "source-url": "https://github.com/raku-community-modules/HTTP-UserAgent.git", 39 | "tags": [ 40 | "HTTP", 41 | "USERAGENT", 42 | "CLIENT" 43 | ], 44 | "test-depends": [ 45 | "IO::Capture::Simple", 46 | "Test::Util::ServerPort", 47 | "JSON::Fast" 48 | ], 49 | "version": "1.2.0" 50 | } 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Actions Status](https://github.com/raku-community-modules/HTTP-UserAgent/actions/workflows/linux.yml/badge.svg)](https://github.com/raku-community-modules/HTTP-UserAgent/actions) [![Actions Status](https://github.com/raku-community-modules/HTTP-UserAgent/actions/workflows/macos.yml/badge.svg)](https://github.com/raku-community-modules/HTTP-UserAgent/actions) 2 | 3 | NAME 4 | ==== 5 | 6 | HTTP::UserAgent - Web user agent class 7 | 8 | SYNOPSIS 9 | ======== 10 | 11 | ```raku 12 | use HTTP::UserAgent; 13 | 14 | my $ua = HTTP::UserAgent.new; 15 | $ua.timeout = 10; 16 | 17 | my $response = $ua.get("URL"); 18 | 19 | if $response.is-success { 20 | say $response.content; 21 | } 22 | else { 23 | die $response.status-line; 24 | } 25 | ``` 26 | 27 | DESCRIPTION 28 | =========== 29 | 30 | This module provides functionality to crawling the web witha handling cookies and correct User-Agent value. 31 | 32 | It has TLS/SSL support. 33 | 34 | METHODS 35 | ======= 36 | 37 | method new 38 | ---------- 39 | 40 | ```raku 41 | method new(HTTP::UserAgent:U: :$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug) 42 | ``` 43 | 44 | Default constructor. 45 | 46 | There are four optional named arguments: 47 | 48 | * useragent 49 | 50 | A string that specifies what will be provided in the `User-Agent` header in the request. A number of standard user agents are described in [HTTP::UserAgent::Common](HTTP::UserAgent::Common), but a string that is not specified there will be used verbatim. 51 | 52 | * throw-exceptions 53 | 54 | By default the `request` method will not throw an exception if the response from the server indicates that the request was unsuccesful, in this case you should check `is-success` to determine the status of the [HTTP::Response](HTTP::Response) returned. If this is specified then an exception will be thrown if the request was not a success, however you can still retrieve the response from the `response` attribute of the exception object. 55 | 56 | * max-redirects 57 | 58 | This is the maximum number of redirects allowed for a single request, if this is exceeded then an exception will be thrown (this is not covered by `no-exceptions` above and will always be throw,) the default value is 5. 59 | 60 | * debug 61 | 62 | It can etheir be a Bool like simply `:debug` or you can pass it a IO::Handle or a file name. Eg `:debug($*ERR)` will ouput on stderr `:debug("mylog.txt")` will ouput on the file. 63 | 64 | method auth 65 | ----------- 66 | 67 | ```raku 68 | method auth(HTTP::UserAgent:, Str $login, Str $password) 69 | ``` 70 | 71 | Sets username and password needed to HTTP Auth. 72 | 73 | method get 74 | ---------- 75 | 76 | ```raku 77 | multi method get(Str $url is copy, :bin?, *%headers) 78 | multi method get(URI $uri, :bin?, *%headers) 79 | ``` 80 | 81 | Requests the $url site, returns HTTP::Response, except if throw-exceptions is set as described above whereby an exception will be thrown if the response indicates that the request wasn't successfull. 82 | 83 | If the Content-Type of the response indicates that the content is text the `content` of the Response will be a decoded string, otherwise it will be left as a [Blob](Blob). 84 | 85 | If the ':bin' adverb is supplied this will force the response `content` to always be an undecoded [Blob](Blob) 86 | 87 | Any additional named arguments will be applied as headers in the request. 88 | 89 | method post 90 | ----------- 91 | 92 | ```raku 93 | multi method post(URI $uri, %form, *%header ) -> HTTP::Response 94 | multi method post(Str $uri, %form, *%header ) -> HTTP::Response 95 | ``` 96 | 97 | Make a POST request to the specified uri, with the provided Hash of %form data in the body encoded as "application/x-www-form-urlencoded" content. Any additional named style arguments will be applied as headers in the request. 98 | 99 | An [HTTP::Response](HTTP::Response) will be returned, except if throw-exceptions has been set and the response indicates the request was not successfull. 100 | 101 | If the Content-Type of the response indicates that the content is text the `content` of the Response will be a decoded string, otherwise it will be left as a [Blob](Blob). 102 | 103 | If the ':bin' adverb is supplied this will force the response `content` to always be an undecoded [Blob](Blob) 104 | 105 | If greater control over the content of the request is required you should create an [HTTP::Request](HTTP::Request) directly and populate it as needed, 106 | 107 | method request 108 | -------------- 109 | 110 | ```raku 111 | method request(HTTP::Request $request, :bin?) 112 | ``` 113 | 114 | Performs the request described by the supplied [HTTP::Request](HTTP::Request), returns a [HTTP::Response](HTTP::Response), except if throw-exceptions is set as described above whereby an exception will be thrown if the response indicates that the request wasn't successful. 115 | 116 | If the response has a 'Content-Encoding' header that indicates that the content was compressed, then it will attempt to inflate the data using [Compress::Zlib](Compress::Zlib), if the module is not installed then an exception will be thrown. If you do not have or do not want to install [Compress::Zlib](Compress::Zlib) then you should be able to send an 'Accept-Encoding' header with a value of 'identity' which should cause a well behaved server to send the content verbatim if it is able to. 117 | 118 | If the Content-Type of the response indicates that the content is text the `content` of the Response will be a decoded string, otherwise it will be left as a [Blob](Blob). The content-types that are always considered to be binary (and thus left as a [Blob](Blob) ) are those with the major-types of 'image','audio' and 'video', certain 'application' types are considered to be 'text' (e.g. 'xml', 'javascript', 'json'). 119 | 120 | If the ':bin' adverb is supplied this will force the response `content` to always be an undecoded [Blob](Blob) 121 | 122 | You can use the helper subroutines defined in [HTTP::Request::Common](HTTP::Request::Common) to create the [HTTP::Request](HTTP::Request) for you or create it yourself if you have more complex requirements. 123 | 124 | routine get :simple 125 | ------------------- 126 | 127 | ```raku 128 | sub get(Str $url) returns Str is export(:simple) 129 | ``` 130 | 131 | Like method get, but returns decoded content of the response. 132 | 133 | routine head :simple 134 | -------------------- 135 | 136 | ```raku 137 | sub head(Str $url) returns Parcel is export(:simple) 138 | ``` 139 | 140 | Returns values of following header fields: 141 | 142 | * Content-Type 143 | 144 | * Content-Length 145 | 146 | * Last-Modified 147 | 148 | * Expires 149 | 150 | * Server 151 | 152 | routine getstore :simple 153 | ------------------------ 154 | 155 | ```raku 156 | sub getstore(Str $url, Str $file) is export(:simple) 157 | ``` 158 | 159 | Like routine get but writes the content to a file. 160 | 161 | routine getprint :simple 162 | ------------------------ 163 | 164 | ```raku 165 | sub getprint(Str $url) is export(:simple) 166 | ``` 167 | 168 | Like routine get but prints the content and returns the response code. 169 | 170 | SUPPORT MODULES 171 | =============== 172 | 173 | HTTP::Cookie - HTTP cookie class 174 | -------------------------------- 175 | 176 | This module encapsulates single HTTP Cookie. 177 | 178 | ```raku 179 | use HTTP::Cookie; 180 | 181 | my $cookie = HTTP::Cookie.new(:name, :value); 182 | say ~$cookie; 183 | ``` 184 | 185 | The following methods are provided: 186 | 187 | ### method new 188 | 189 | ```raku 190 | my $c = HTTP::Cookie.new(:name, :value, :secure, fields => (a => b)); 191 | ``` 192 | 193 | A constructor, it takes these named arguments: 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 |
key description
name name of a cookie
value value of a cookie
secure Secure param
httponly HttpOnly param
fields list of field Pairs (field => value)
203 | 204 | ### method Str 205 | 206 | Returns a cookie as a string in readable (RFC2109) form. 207 | 208 | HTTP::Cookies - HTTP cookie jars 209 | -------------------------------- 210 | 211 | This module provides a bunch of methods to manage HTTP cookies. 212 | 213 | ```raku 214 | use HTTP::Cookies; 215 | my $cookies = HTTP::Cookies.new( 216 | :file<./cookies>, 217 | :autosave 218 | ); 219 | $cookies.load; 220 | ``` 221 | 222 | ### method new 223 | 224 | ```raku 225 | my $cookies = HTTP::Cookies.new( 226 | :file<./cookies.here> 227 | :autosave, 228 | ); 229 | 230 | Constructor, takes named arguments: 231 | ``` 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 |
key description
file where to write cookies
autosave save automatically after every operation on cookies or not
241 | 242 | ### method set-cookie 243 | 244 | ```raku 245 | my $cookies = HTTP::Cookies.new; 246 | $cookies.set-cookie('Set-Cookie: name1=value1; HttpOnly'); 247 | ``` 248 | 249 | Adds a cookie (passed as an argument $str of type Str) to the list of cookies. 250 | 251 | ### method save 252 | 253 | ```raku 254 | my $cookies = HTTP::Cookies.new; 255 | $cookies.set-cookie('Set-Cookie: name1=value1; HttpOnly'); 256 | $cookies.save; 257 | ``` 258 | 259 | Saves cookies to the file ($.file). 260 | 261 | ### method load 262 | 263 | ```raku 264 | my $cookies = HTTP::Cookies.new; 265 | $cookies.load; 266 | ``` 267 | 268 | Loads cookies from file specified at instantiation ($.file). 269 | 270 | ### method extract-cookies 271 | 272 | ```raku 273 | my $cookies = HTTP::Cookies.new; 274 | my $response = HTTP::Response.new(Set-Cookie => "name1=value; Secure"); 275 | $cookies.extract-cookies($response); 276 | ``` 277 | 278 | Gets cookies ('Set-Cookie: ' lines) from the HTTP Response and adds it to the list of cookies. 279 | 280 | ### method add-cookie-header 281 | 282 | ```raku 283 | my $cookies = HTTP::Cookies.new; 284 | my $request = HTTP::Request.new; 285 | $cookies.load; 286 | $cookies.add-cookie-header($request); 287 | ``` 288 | 289 | Adds cookies fields ('Cookie: ' lines) to the HTTP Request. 290 | 291 | ### method clear-expired 292 | 293 | ```raku 294 | my $cookies = HTTP::Cookies.new; 295 | $cookies.set-cookie('Set-Cookie: name1=value1; Secure'); 296 | $cookies.set-cookie('Set-Cookie: name2=value2; Expires=Wed, 09 Jun 2021 10:18:14 GMT'); 297 | $cookies.clear-expired; # contains 'name1' cookie only 298 | ``` 299 | 300 | Removes expired cookies. 301 | 302 | ### method clear 303 | 304 | ```raku 305 | my $cookies = HTTP::Cookies.new; 306 | $cookies.load; # contains something 307 | $cookies.clear; # will be empty after this action 308 | ``` 309 | 310 | Removes all cookies. 311 | 312 | ### method push-cookie 313 | 314 | ```raku 315 | my $c = HTTP::Cookie.new(:name, :value, :httponly); 316 | my $cookies = HTTP::Cookies.new; 317 | $cookies.push-cookie: $c; 318 | ``` 319 | 320 | Pushes cookies (passed as an argument $c of type HTTP::Cookie) to the list of cookies. 321 | 322 | ### method Str 323 | 324 | Returns all cookies in human (and server) readable form. 325 | 326 | HTTP::UserAgent::Common - the most commonly used User-Agents 327 | ------------------------------------------------------------ 328 | 329 | This module provides a list of the most commonly used User-Agents. 330 | 331 | ```raku 332 | use HTTP::UserAgent::Common; 333 | say get-ua('chrome_linux'); 334 | ``` 335 | 336 | ### routine get-ua 337 | 338 | ```raku 339 | say get-ua('chrome_linux'); 340 | ``` 341 | 342 | Returns correct UserAgent or unchaged passed argument if UserAgent could not be found. 343 | 344 | Available UserAgents: 345 | 346 | chrome_w7_64 firefox_w7_64 ie_w7_64 chrome_w81_64 firefox_w81_64 mob_safari_osx 347 | safari_osx chrome_osx firefox_linux chrome_linux 348 | 349 | HTTP::Header - class encapsulating HTTP message header 350 | ------------------------------------------------------ 351 | 352 | This module provides a class with a set of methods making us able to easily handle HTTP message headers. 353 | 354 | ```raku 355 | use HTTP::Header; 356 | my $h = HTTP::Header.new; 357 | $h.field(Accept => 'text/plain'); 358 | say $h.field('Accept'); 359 | $h.remove-field('Accept'); 360 | ``` 361 | 362 | ### method new 363 | 364 | ```raku 365 | my $head = HTTP::Header.new(:h1, :h2); 366 | ``` 367 | 368 | A constructor. Takes name => value pairs as arguments. 369 | 370 | ### method header 371 | 372 | ```raku 373 | my $head = HTTP::Header.new(:h1, :h2); 374 | say $head.header('h1'); 375 | 376 | my $head = HTTP::Header.new(:h1, :h2); 377 | $head.header(:h3); 378 | ``` 379 | 380 | Gets/sets header field. 381 | 382 | ### method init-field 383 | 384 | ```raku 385 | my $head = HTTP::Header.new; 386 | $head.header(:h1); 387 | $head.init-header(:h1, :h2); # it doesn't change the value of 'h1' 388 | say ~$head; 389 | ``` 390 | 391 | Initializes a header field: adds a field only if it does not exist yet. 392 | 393 | ### method push-header 394 | 395 | ```raku 396 | my $head = HTTP::Header.new; 397 | $head.push-header( HTTP::Header::Field.new(:name, :value) ); 398 | say ~$head; 399 | ``` 400 | 401 | Pushes a new field. Does not check if exists. 402 | 403 | ### method remove-header 404 | 405 | ```raku 406 | my $head = HTTP::Header.new; 407 | $head.header(:h1); 408 | $head.remove-header('h1'); 409 | ``` 410 | 411 | Removes a field of name $field. 412 | 413 | ### method header-field-names 414 | 415 | ```raku 416 | my $head = HTTP::Header.new(:h1, :h2); 417 | my @names = $head.header-field-names; 418 | say @names; # h1, h2 419 | ``` 420 | 421 | Returns a list of names of all fields. 422 | 423 | ### method clear 424 | 425 | ```raku 426 | my $head = HTTP::Header.new(:h1, :h2); 427 | $head.clear; 428 | ``` 429 | 430 | Removes all fields. 431 | 432 | ### method Str 433 | 434 | Returns readable form of the whole header section. 435 | 436 | ### method parse 437 | 438 | ```raku 439 | my $head = HTTP::Header.new.parse("h1: v1\r\nh2: v2\r\n"); 440 | say $head.raku; 441 | ``` 442 | 443 | Parses the whole header section. 444 | 445 | HTTP::Header::Field 446 | ------------------- 447 | 448 | This module provides a class encapsulating HTTP Message header field. 449 | 450 | ```raku 451 | use HTTP::Header::Field; 452 | my $header = HTTP::Header::Field.new(:name, values => (123, 456)); 453 | ``` 454 | 455 | ### method new 456 | 457 | Constructor. Takes these named arguments: 458 | 459 | 460 | 461 | 462 | 463 | 464 | 465 | 466 |
key description
name name of a header field
values array of values of a header field
467 | 468 | ### method Str 469 | 470 | Stringifies an HTTP::Header::Field object. Returns a header field in a human (and server) readable form. 471 | 472 | HTTP::Request - class encapsulating HTTP request message 473 | -------------------------------------------------------- 474 | 475 | Module provides functionality to easily manage HTTP requests. 476 | 477 | ```raku 478 | use HTTP::Request; 479 | my $request = HTTP::Request.new(GET => 'http://www.example.com/'); 480 | ``` 481 | 482 | ### method new 483 | 484 | A constructor, the first form takes parameters like: 485 | 486 | * method => URL, where method can be POST, GET ... etc. 487 | 488 | * field => values, header fields 489 | 490 | ```raku 491 | my $req = HTTP::Request.new(:GET, :h1); 492 | ``` 493 | 494 | The second form takes the key arguments as simple positional parameters and is designed for use in places where for example the request method may be calculated and the headers pre-populated. 495 | 496 | ### method set-method 497 | 498 | ```raku 499 | my $req = HTTP::Request.new; 500 | $req.set-method: 'POST'; 501 | ``` 502 | 503 | Sets a method of the request. 504 | 505 | ### method uri 506 | 507 | ```raku 508 | my $req = HTTP::Request.new; 509 | $req.uri: 'example.com'; 510 | ``` 511 | 512 | Sets URL to request. 513 | 514 | ### method add-cookies 515 | 516 | ```raku 517 | method add-cookies(HTTP::Cookies $cookies) 518 | ``` 519 | 520 | This will cause the appropriate cookie headers to be added from the supplied HTTP::Cookies object. 521 | 522 | ### method add-form-data 523 | 524 | ```raku 525 | multi method add-form-data(%data, :$multipart) 526 | multi method add-form-data(:$multipart, *%data); 527 | multi method add-form-data(Array $data, :$multipart) 528 | ``` 529 | 530 | Adds the form data, supplied either as a `Hash`, an `Array` of `Pair`s, or in a named parameter style, to the POST request (it doesn't make sense on most other request types). 531 | 532 | The default is to use 'application/x-www-form-urlencoded' and 'multipart/form-data' can be used by providing the ':multipart' named argument. Alternatively a previously applied "content-type" header of either 'application/x-www-form-urlencoded' or 'multipart/form-data' will be respected and in the latter case any applied boundary marker will be retained. 533 | 534 | As a special case for multipart data if the value for some key in the data is an `Array` of at least one item then it is taken to be a description of a file to be "uploaded" where the first item is the path to the file to be inserted, the second (optional) an alternative name to be used in the content disposition header and the third an optional `Array` of `Pair`s that will provide additional header lines for the part. 535 | 536 | ### method Str 537 | 538 | Returns stringified object. 539 | 540 | ### method parse 541 | 542 | ```raku 543 | method parse(Str $raw_request --> HTTP::Request:D) 544 | ``` 545 | 546 | Parses raw HTTP request. See `HTTP::Message` 547 | 548 | HTTP::Request::Common - Construct common HTTP::Request objects 549 | -------------------------------------------------------------- 550 | 551 | ```raku 552 | use HTTP::Request::Common; 553 | 554 | my $ua = HTTP::UserAgent.new; 555 | my $response = $ua.request(GET 'http://google.com/'); 556 | ``` 557 | 558 | This module provide functions that return newly created `HTTP::Request` objects. These functions are usually more convenient to use than the standard `HTTP::Request` constructor for the most common requests. The following functions are provided: 559 | 560 | ### GET $url, Header => Value... 561 | 562 | The `GET` function returns an `HTTP::Request` object initialized with the "GET" method and the specified URL. 563 | 564 | ### HEAD $url, Header => Value,... 565 | 566 | Like `GET` but the method in the request is "HEAD". 567 | 568 | ### DELETE $url, Header => Value,... 569 | 570 | Like `GET` but the method in the request is "DELETE". 571 | 572 | ### `PUT $url, Header =` Value,..., content => $content> 573 | 574 | Like `GET` but the method in the request is "PUT". 575 | 576 | HTTP::Response - class encapsulating HTTP response message 577 | ---------------------------------------------------------- 578 | 579 | ```raku 580 | use HTTP::Response; 581 | my $response = HTTP::Response.new(200); 582 | say $response.is-success; # it is 583 | ``` 584 | 585 | Module provides functionality to easily manage HTTP responses. 586 | 587 | Response object is returned by the .get() method of [HTTP::UserAgent](HTTP::UserAgent). 588 | 589 | ### method new 590 | 591 | ```raku 592 | my $response = HTTP::Response.new(200, :h1); 593 | ``` 594 | 595 | A constructor, takes named arguments: 596 | 597 | 598 | 599 | 600 | 601 | 602 | 603 | 604 |
key description
code code of the response
fields header fields (field_name => values)
605 | 606 | ### method is-success 607 | 608 | ```raku 609 | my $response = HTTP::Response.new(200); 610 | say 'YAY' if $response.is-success; 611 | ``` 612 | 613 | Returns True if response is successful (status == 2xx), False otherwise. 614 | 615 | method set-code 616 | --------------- 617 | 618 | ```raku 619 | my $response = HTTP::Response.new; 620 | $response.set-code: 200; 621 | ``` 622 | 623 | Sets code of the response. 624 | 625 | ### method Str 626 | 627 | Returns stringified object. 628 | 629 | ### method parse 630 | 631 | See `HTTP::Message`. 632 | 633 | HTTP::Message - class encapsulating HTTP message 634 | ------------------------------------------------ 635 | 636 | ```raku 637 | use HTTP::Message; 638 | my $raw_msg = "GET / HTTP/1.1\r\nHost: somehost\r\n\r\n"; 639 | my $mess = HTTP::Message.new.parse($raw_msg); 640 | say $mess; 641 | ``` 642 | 643 | This module provides a bunch of methods to easily manage HTTP message. 644 | 645 | ### method new 646 | 647 | ```raku 648 | my $msg = HTTP::Message.new('content', :field); 649 | ``` 650 | 651 | A constructor, takes these named arguments: 652 | 653 | 654 | 655 | 656 | 657 | 658 | 659 | 660 |
key description
content content of the message (optional)
fields fields of the header section
661 | 662 | ### method add-content 663 | 664 | ```raku 665 | my $msg = HTTP::Message.new('content', :field); 666 | $msg.add-content: 's'; 667 | say $msg.content; # says 'contents' 668 | ``` 669 | 670 | Adds HTTP message content. It does not remove the existing value, it concats to the existing content. 671 | 672 | ### method decoded-content 673 | 674 | ```raku 675 | my $msg = HTTP::Message.new(); 676 | say $msg.decoded-content; 677 | ``` 678 | 679 | Returns decoded content of the message (using [Encode](Encode) module to decode). 680 | 681 | ### method field 682 | 683 | See `HTTP::Header`. 684 | 685 | ### method init-field 686 | 687 | See `HTTP::Header`. 688 | 689 | ### method push-field 690 | 691 | See `HTTP::Header`. 692 | 693 | ### method remove-field 694 | 695 | See `HTTP::Header`. 696 | 697 | ### method clear 698 | 699 | ```raku 700 | my $msg = HTTP::Message.new('content', :field); 701 | $msg.clear; 702 | say ~$msg; # says nothing 703 | ``` 704 | 705 | Removes the whole message, both header and content section. 706 | 707 | ### method parse 708 | 709 | ```raku 710 | my $msg = HTTP::Message.new.parse("GET / HTTP/1.1\r\nHost: example\r\ncontent\r\n"); 711 | say $msg.raku; 712 | ``` 713 | 714 | Parses the whole HTTP message. 715 | 716 | It takes the HTTP message (with \r\n as a line separator) and obtains the header and content sections, creates a `HTTP::Header` object. 717 | 718 | ### method Str 719 | 720 | Returns HTTP message in a readable form. 721 | 722 | AUTHOR 723 | ====== 724 | 725 | * Filip Sergot 726 | 727 | Source can be located at: https://github.com/raku-community-modules/HTTP-UserAgent . Comments and Pull Requests are welcome. 728 | 729 | COPYRIGHT AND LICENSE 730 | ===================== 731 | 732 | Copyright 2014 - 2022 Filip Sergot 733 | 734 | Copyright 2023 - 2025 The Raku Community 735 | 736 | This library is free software; you can redistribute it and/or modify it under the MIT License. 737 | 738 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # To-do List and Future Ideas 2 | 3 | ~~strikethrough text~~ means **done**. 4 | 5 | - clean up 6 | - speed up 7 | 8 | ## HTTP::UserAgent 9 | - ~~HTTP Auth~~ 10 | - let user set his own cookie jar 11 | - ~~make getprint() return the code response~~ 12 | - ~~security fix - use File::Temp to create temporary cookie jar~~ 13 | - use Promises 14 | - ~~make SSL dependency as optional~~ 15 | 16 | ## HTTP::Cookies 17 | - path restriction 18 | 19 | ## OpenSSL 20 | - ~~fix NativeCall's int bug~~ 21 | - make it work on more platforms 22 | 23 | ## IO::Socket::SSL 24 | - make it work on more platforms 25 | - make SSL support more reliable 26 | - add throwing exception on failing SSL 27 | - more tests 28 | 29 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = HTTP::UserAgent 2 | 3 | [ReadmeFromPod] 4 | filename = doc/HTTP-UserAgent.rakudoc 5 | 6 | [UploadToZef] 7 | 8 | [Badges] 9 | provider = github-actions/linux.yml 10 | provider = github-actions/macos.yml 11 | #provider = github-actions/windows.yml 12 | -------------------------------------------------------------------------------- /doc/HTTP-UserAgent.rakudoc: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =head1 NAME 4 | 5 | HTTP::UserAgent - Web user agent class 6 | 7 | =head1 SYNOPSIS 8 | 9 | =begin code :lang 10 | 11 | use HTTP::UserAgent; 12 | 13 | my $ua = HTTP::UserAgent.new; 14 | $ua.timeout = 10; 15 | 16 | my $response = $ua.get("URL"); 17 | 18 | if $response.is-success { 19 | say $response.content; 20 | } 21 | else { 22 | die $response.status-line; 23 | } 24 | 25 | =end code 26 | 27 | =head1 DESCRIPTION 28 | 29 | This module provides functionality to crawling the web witha handling 30 | cookies and correct User-Agent value. 31 | 32 | It has TLS/SSL support. 33 | 34 | =head1 METHODS 35 | 36 | =head2 method new 37 | 38 | =begin code :lang 39 | 40 | method new(HTTP::UserAgent:U: :$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug) 41 | 42 | =end code 43 | 44 | Default constructor. 45 | 46 | There are four optional named arguments: 47 | 48 | =item useragent 49 | 50 | A string that specifies what will be provided in the C header in 51 | the request. A number of standard user agents are described in 52 | L, but a string that is not specified there will be 53 | used verbatim. 54 | 55 | =item throw-exceptions 56 | 57 | By default the C method will not throw an exception if the 58 | response from the server indicates that the request was unsuccesful, in 59 | this case you should check C to determine the status of the 60 | L returned. If this is specified then an exception will 61 | be thrown if the request was not a success, however you can still retrieve 62 | the response from the C attribute of the exception object. 63 | 64 | =item max-redirects 65 | 66 | This is the maximum number of redirects allowed for a single request, if 67 | this is exceeded then an exception will be thrown (this is not covered by 68 | C above and will always be throw,) the default value is 5. 69 | 70 | =item debug 71 | 72 | It can etheir be a Bool like simply C<:debug> or you can pass it a IO::Handle 73 | or a file name. Eg C<:debug($*ERR)> will ouput on stderr C<:debug("mylog.txt")> 74 | will ouput on the file. 75 | 76 | =head2 method auth 77 | 78 | =begin code :lang 79 | 80 | method auth(HTTP::UserAgent:, Str $login, Str $password) 81 | 82 | =end code 83 | 84 | Sets username and password needed to HTTP Auth. 85 | 86 | =head2 method get 87 | 88 | =begin code :lang 89 | 90 | multi method get(Str $url is copy, :bin?, *%headers) 91 | multi method get(URI $uri, :bin?, *%headers) 92 | 93 | =end code 94 | 95 | Requests the $url site, returns HTTP::Response, except if throw-exceptions 96 | is set as described above whereby an exception will be thrown if the 97 | response indicates that the request wasn't successfull. 98 | 99 | If the Content-Type of the response indicates that the content is text the 100 | C of the Response will be a decoded string, otherwise it will be 101 | left as a L. 102 | 103 | If the ':bin' adverb is supplied this will force the response C to 104 | always be an undecoded L 105 | 106 | Any additional named arguments will be applied as headers in the request. 107 | 108 | =head2 method post 109 | 110 | =begin code :lang 111 | 112 | multi method post(URI $uri, %form, *%header ) -> HTTP::Response 113 | multi method post(Str $uri, %form, *%header ) -> HTTP::Response 114 | 115 | =end code 116 | 117 | Make a POST request to the specified uri, with the provided Hash of %form 118 | data in the body encoded as "application/x-www-form-urlencoded" content. 119 | Any additional named style arguments will be applied as headers in the 120 | request. 121 | 122 | An L will be returned, except if throw-exceptions has been set 123 | and the response indicates the request was not successfull. 124 | 125 | If the Content-Type of the response indicates that the content is text the 126 | C of the Response will be a decoded string, otherwise it will be 127 | left as a L. 128 | 129 | If the ':bin' adverb is supplied this will force the response C to 130 | always be an undecoded L 131 | 132 | If greater control over the content of the request is required you should 133 | create an L directly and populate it as needed, 134 | 135 | =head2 method request 136 | 137 | =begin code :lang 138 | 139 | method request(HTTP::Request $request, :bin?) 140 | 141 | =end code 142 | 143 | Performs the request described by the supplied L, returns 144 | a L, except if throw-exceptions is set as described above 145 | whereby an exception will be thrown if the response indicates that the 146 | request wasn't successful. 147 | 148 | If the response has a 'Content-Encoding' header that indicates that the 149 | content was compressed, then it will attempt to inflate the data using 150 | L, if the module is not installed then an exception will 151 | be thrown. If you do not have or do not want to install L 152 | then you should be able to send an 'Accept-Encoding' header with a value 153 | of 'identity' which should cause a well behaved server to send the content 154 | verbatim if it is able to. 155 | 156 | If the Content-Type of the response indicates that the content is text the 157 | C of the Response will be a decoded string, otherwise it will be 158 | left as a L. The content-types that are always considered to be 159 | binary (and thus left as a L ) are those with the major-types of 160 | 'image','audio' and 'video', certain 'application' types are considered to 161 | be 'text' (e.g. 'xml', 'javascript', 'json'). 162 | 163 | If the ':bin' adverb is supplied this will force the response C to 164 | always be an undecoded L 165 | 166 | You can use the helper subroutines defined in L to 167 | create the L for you or create it yourself if you have more 168 | complex requirements. 169 | 170 | =head2 routine get :simple 171 | 172 | =begin code :lang 173 | 174 | sub get(Str $url) returns Str is export(:simple) 175 | 176 | =end code 177 | 178 | Like method get, but returns decoded content of the response. 179 | 180 | =head2 routine head :simple 181 | 182 | =begin code :lang 183 | 184 | sub head(Str $url) returns Parcel is export(:simple) 185 | 186 | =end code 187 | 188 | Returns values of following header fields: 189 | 190 | =item Content-Type 191 | =item Content-Length 192 | =item Last-Modified 193 | =item Expires 194 | =item Server 195 | 196 | =head2 routine getstore :simple 197 | 198 | =begin code :lang 199 | 200 | sub getstore(Str $url, Str $file) is export(:simple) 201 | 202 | =end code 203 | 204 | Like routine get but writes the content to a file. 205 | 206 | =head2 routine getprint :simple 207 | 208 | =begin code :lang 209 | 210 | sub getprint(Str $url) is export(:simple) 211 | 212 | =end code 213 | 214 | Like routine get but prints the content and returns the response code. 215 | 216 | =head1 SUPPORT MODULES 217 | 218 | =head2 HTTP::Cookie - HTTP cookie class 219 | 220 | This module encapsulates single HTTP Cookie. 221 | 222 | =begin code :lang 223 | 224 | use HTTP::Cookie; 225 | 226 | my $cookie = HTTP::Cookie.new(:name, :value); 227 | say ~$cookie; 228 | 229 | =end code 230 | 231 | The following methods are provided: 232 | 233 | =head3 method new 234 | 235 | =begin code :lang 236 | 237 | my $c = HTTP::Cookie.new(:name, :value, :secure, fields => (a => b)); 238 | 239 | =end code 240 | 241 | A constructor, it takes these named arguments: 242 | 243 | =table 244 | key | description 245 | ---------+------------ 246 | name | name of a cookie 247 | value | value of a cookie 248 | secure | Secure param 249 | httponly | HttpOnly param 250 | fields | list of field Pairs (field => value) 251 | 252 | =head3 method Str 253 | 254 | Returns a cookie as a string in readable (RFC2109) form. 255 | 256 | =head2 HTTP::Cookies - HTTP cookie jars 257 | 258 | This module provides a bunch of methods to manage HTTP cookies. 259 | 260 | =begin code :lang 261 | 262 | use HTTP::Cookies; 263 | my $cookies = HTTP::Cookies.new( 264 | :file<./cookies>, 265 | :autosave 266 | ); 267 | $cookies.load; 268 | 269 | =end code 270 | 271 | =head3 method new 272 | 273 | =begin code :lang 274 | 275 | my $cookies = HTTP::Cookies.new( 276 | :file<./cookies.here> 277 | :autosave, 278 | ); 279 | 280 | Constructor, takes named arguments: 281 | 282 | =end code 283 | 284 | =table 285 | key | description 286 | -------- +------------ 287 | file | where to write cookies 288 | autosave | save automatically after every operation on cookies or not 289 | 290 | =head3 method set-cookie 291 | 292 | =begin code :lang 293 | 294 | my $cookies = HTTP::Cookies.new; 295 | $cookies.set-cookie('Set-Cookie: name1=value1; HttpOnly'); 296 | 297 | =end code 298 | 299 | Adds a cookie (passed as an argument $str of type Str) to the list of cookies. 300 | 301 | =head3 method save 302 | 303 | =begin code :lang 304 | 305 | my $cookies = HTTP::Cookies.new; 306 | $cookies.set-cookie('Set-Cookie: name1=value1; HttpOnly'); 307 | $cookies.save; 308 | 309 | =end code 310 | 311 | Saves cookies to the file ($.file). 312 | 313 | =head3 method load 314 | 315 | =begin code :lang 316 | 317 | my $cookies = HTTP::Cookies.new; 318 | $cookies.load; 319 | 320 | =end code 321 | 322 | Loads cookies from file specified at instantiation ($.file). 323 | 324 | =head3 method extract-cookies 325 | 326 | =begin code :lang 327 | 328 | my $cookies = HTTP::Cookies.new; 329 | my $response = HTTP::Response.new(Set-Cookie => "name1=value; Secure"); 330 | $cookies.extract-cookies($response); 331 | 332 | =end code 333 | 334 | Gets cookies ('Set-Cookie: ' lines) from the HTTP Response and adds it to 335 | the list of cookies. 336 | 337 | =head3 method add-cookie-header 338 | 339 | =begin code :lang 340 | 341 | my $cookies = HTTP::Cookies.new; 342 | my $request = HTTP::Request.new; 343 | $cookies.load; 344 | $cookies.add-cookie-header($request); 345 | 346 | =end code 347 | 348 | Adds cookies fields ('Cookie: ' lines) to the HTTP Request. 349 | 350 | =head3 method clear-expired 351 | 352 | =begin code :lang 353 | 354 | my $cookies = HTTP::Cookies.new; 355 | $cookies.set-cookie('Set-Cookie: name1=value1; Secure'); 356 | $cookies.set-cookie('Set-Cookie: name2=value2; Expires=Wed, 09 Jun 2021 10:18:14 GMT'); 357 | $cookies.clear-expired; # contains 'name1' cookie only 358 | 359 | =end code 360 | 361 | Removes expired cookies. 362 | 363 | =head3 method clear 364 | 365 | =begin code :lang 366 | 367 | my $cookies = HTTP::Cookies.new; 368 | $cookies.load; # contains something 369 | $cookies.clear; # will be empty after this action 370 | 371 | =end code 372 | 373 | Removes all cookies. 374 | 375 | =head3 method push-cookie 376 | 377 | =begin code :lang 378 | 379 | my $c = HTTP::Cookie.new(:name, :value, :httponly); 380 | my $cookies = HTTP::Cookies.new; 381 | $cookies.push-cookie: $c; 382 | 383 | =end code 384 | 385 | Pushes cookies (passed as an argument $c of type HTTP::Cookie) to the 386 | list of cookies. 387 | 388 | =head3 method Str 389 | 390 | Returns all cookies in human (and server) readable form. 391 | 392 | =head2 HTTP::UserAgent::Common - the most commonly used User-Agents 393 | 394 | This module provides a list of the most commonly used User-Agents. 395 | 396 | =begin code :lang 397 | 398 | use HTTP::UserAgent::Common; 399 | say get-ua('chrome_linux'); 400 | 401 | =end code 402 | 403 | =head3 routine get-ua 404 | 405 | =begin code :lang 406 | 407 | say get-ua('chrome_linux'); 408 | 409 | =end code 410 | 411 | Returns correct UserAgent or unchaged passed argument if UserAgent could not be found. 412 | 413 | Available UserAgents: 414 | 415 | =begin output 416 | 417 | chrome_w7_64 firefox_w7_64 ie_w7_64 chrome_w81_64 firefox_w81_64 mob_safari_osx 418 | safari_osx chrome_osx firefox_linux chrome_linux 419 | 420 | =end output 421 | 422 | =head2 HTTP::Header - class encapsulating HTTP message header 423 | 424 | This module provides a class with a set of methods making us able to 425 | easily handle HTTP message headers. 426 | 427 | =begin code :lang 428 | 429 | use HTTP::Header; 430 | my $h = HTTP::Header.new; 431 | $h.field(Accept => 'text/plain'); 432 | say $h.field('Accept'); 433 | $h.remove-field('Accept'); 434 | 435 | =end code 436 | 437 | =head3 method new 438 | 439 | =begin code :lang 440 | 441 | my $head = HTTP::Header.new(:h1, :h2); 442 | 443 | =end code 444 | 445 | A constructor. Takes name => value pairs as arguments. 446 | 447 | =head3 method header 448 | 449 | =begin code :lang 450 | 451 | my $head = HTTP::Header.new(:h1, :h2); 452 | say $head.header('h1'); 453 | 454 | my $head = HTTP::Header.new(:h1, :h2); 455 | $head.header(:h3); 456 | 457 | =end code 458 | 459 | Gets/sets header field. 460 | 461 | =head3 method init-field 462 | 463 | =begin code :lang 464 | 465 | my $head = HTTP::Header.new; 466 | $head.header(:h1); 467 | $head.init-header(:h1, :h2); # it doesn't change the value of 'h1' 468 | say ~$head; 469 | 470 | =end code 471 | 472 | Initializes a header field: adds a field only if it does not exist yet. 473 | 474 | =head3 method push-header 475 | 476 | =begin code :lang 477 | 478 | my $head = HTTP::Header.new; 479 | $head.push-header( HTTP::Header::Field.new(:name, :value) ); 480 | say ~$head; 481 | 482 | =end code 483 | 484 | Pushes a new field. Does not check if exists. 485 | 486 | =head3 method remove-header 487 | 488 | =begin code :lang 489 | 490 | my $head = HTTP::Header.new; 491 | $head.header(:h1); 492 | $head.remove-header('h1'); 493 | 494 | =end code 495 | 496 | Removes a field of name $field. 497 | 498 | =head3 method header-field-names 499 | 500 | =begin code :lang 501 | 502 | my $head = HTTP::Header.new(:h1, :h2); 503 | my @names = $head.header-field-names; 504 | say @names; # h1, h2 505 | 506 | =end code 507 | 508 | Returns a list of names of all fields. 509 | 510 | =head3 method clear 511 | 512 | =begin code :lang 513 | 514 | my $head = HTTP::Header.new(:h1, :h2); 515 | $head.clear; 516 | 517 | =end code 518 | 519 | Removes all fields. 520 | 521 | =head3 method Str 522 | 523 | Returns readable form of the whole header section. 524 | 525 | =head3 method parse 526 | 527 | =begin code :lang 528 | 529 | my $head = HTTP::Header.new.parse("h1: v1\r\nh2: v2\r\n"); 530 | say $head.raku; 531 | 532 | =end code 533 | 534 | Parses the whole header section. 535 | 536 | =head2 HTTP::Header::Field 537 | 538 | This module provides a class encapsulating HTTP Message header field. 539 | 540 | =begin code :lang 541 | 542 | use HTTP::Header::Field; 543 | my $header = HTTP::Header::Field.new(:name, values => (123, 456)); 544 | 545 | =end code 546 | 547 | =head3 method new 548 | 549 | Constructor. Takes these named arguments: 550 | 551 | =table 552 | key | description 553 | -------+------------ 554 | name | name of a header field 555 | values | array of values of a header field 556 | 557 | =head3 method Str 558 | 559 | Stringifies an HTTP::Header::Field object. Returns a header field in a 560 | human (and server) readable form. 561 | 562 | =head2 HTTP::Request - class encapsulating HTTP request message 563 | 564 | Module provides functionality to easily manage HTTP requests. 565 | 566 | =begin code :lang 567 | 568 | use HTTP::Request; 569 | my $request = HTTP::Request.new(GET => 'http://www.example.com/'); 570 | 571 | =end code 572 | 573 | =head3 method new 574 | 575 | A constructor, the first form takes parameters like: 576 | 577 | =item method => URL, where method can be POST, GET ... etc. 578 | =item field => values, header fields 579 | 580 | =begin code :lang 581 | 582 | my $req = HTTP::Request.new(:GET, :h1); 583 | 584 | =end code 585 | 586 | The second form takes the key arguments as simple positional parameters and 587 | is designed for use in places where for example the request method may be 588 | calculated and the headers pre-populated. 589 | 590 | =head3 method set-method 591 | 592 | =begin code :lang 593 | 594 | my $req = HTTP::Request.new; 595 | $req.set-method: 'POST'; 596 | 597 | =end code 598 | 599 | Sets a method of the request. 600 | 601 | =head3 method uri 602 | 603 | =begin code :lang 604 | 605 | my $req = HTTP::Request.new; 606 | $req.uri: 'example.com'; 607 | 608 | =end code 609 | 610 | Sets URL to request. 611 | 612 | =head3 method add-cookies 613 | 614 | =begin code :lang 615 | 616 | method add-cookies(HTTP::Cookies $cookies) 617 | 618 | =end code 619 | 620 | This will cause the appropriate cookie headers to be added from the 621 | supplied HTTP::Cookies object. 622 | 623 | =head3 method add-form-data 624 | 625 | =begin code :lang 626 | 627 | multi method add-form-data(%data, :$multipart) 628 | multi method add-form-data(:$multipart, *%data); 629 | multi method add-form-data(Array $data, :$multipart) 630 | 631 | =end code 632 | 633 | Adds the form data, supplied either as a C, an C of Cs, 634 | or in a named parameter style, to the POST request (it doesn't 635 | make sense on most other request types). 636 | 637 | The default is to use 'application/x-www-form-urlencoded' and 638 | 'multipart/form-data' can be used by providing the ':multipart' named 639 | argument. Alternatively a previously applied "content-type" header of 640 | either 'application/x-www-form-urlencoded' or 'multipart/form-data' will 641 | be respected and in the latter case any applied boundary marker will be 642 | retained. 643 | 644 | As a special case for multipart data if the value for some key in the 645 | data is an C of at least one item then it is taken to be a 646 | description of a file to be "uploaded" where the first item is the path 647 | to the file to be inserted, the second (optional) an alternative name to 648 | be used in the content disposition header and the third an optional 649 | C of Cs that will provide additional header lines for the 650 | part. 651 | 652 | =head3 method Str 653 | 654 | Returns stringified object. 655 | 656 | =head3 method parse 657 | 658 | =begin code :lang 659 | 660 | method parse(Str $raw_request --> HTTP::Request:D) 661 | 662 | =end code 663 | 664 | Parses raw HTTP request. See C 665 | 666 | =head2 HTTP::Request::Common - Construct common HTTP::Request objects 667 | 668 | =begin code :lang 669 | 670 | use HTTP::Request::Common; 671 | 672 | my $ua = HTTP::UserAgent.new; 673 | my $response = $ua.request(GET 'http://google.com/'); 674 | 675 | =end code 676 | 677 | This module provide functions that return newly created C 678 | objects. These functions are usually more convenient to use than the 679 | standard C constructor for the most common requests. The 680 | following functions are provided: 681 | 682 | =head3 GET $url, Header => Value... 683 | 684 | The C function returns an C object initialized with 685 | the "GET" method and the specified URL. 686 | 687 | =head3 HEAD $url, Header => Value,... 688 | 689 | Like C but the method in the request is "HEAD". 690 | 691 | =head3 DELETE $url, Header => Value,... 692 | 693 | Like C but the method in the request is "DELETE". 694 | 695 | =head3 C Value,..., content => $content> 696 | 697 | Like C but the method in the request is "PUT". 698 | 699 | =head2 HTTP::Response - class encapsulating HTTP response message 700 | 701 | =begin code :lang 702 | 703 | use HTTP::Response; 704 | my $response = HTTP::Response.new(200); 705 | say $response.is-success; # it is 706 | 707 | =end code 708 | 709 | Module provides functionality to easily manage HTTP responses. 710 | 711 | Response object is returned by the .get() method of L. 712 | 713 | =head3 method new 714 | 715 | =begin code :lang 716 | 717 | my $response = HTTP::Response.new(200, :h1); 718 | 719 | =end code 720 | 721 | A constructor, takes named arguments: 722 | 723 | =table 724 | key | description 725 | -------+------------ 726 | code | code of the response 727 | fields | header fields (field_name => values) 728 | 729 | =head3 method is-success 730 | 731 | =begin code :lang 732 | 733 | my $response = HTTP::Response.new(200); 734 | say 'YAY' if $response.is-success; 735 | 736 | =end code 737 | 738 | Returns True if response is successful (status == 2xx), False otherwise. 739 | 740 | =head2 method set-code 741 | 742 | =begin code :lang 743 | 744 | my $response = HTTP::Response.new; 745 | $response.set-code: 200; 746 | 747 | =end code 748 | 749 | Sets code of the response. 750 | 751 | =head3 method Str 752 | 753 | Returns stringified object. 754 | 755 | =head3 method parse 756 | 757 | See C. 758 | 759 | =head2 HTTP::Message - class encapsulating HTTP message 760 | 761 | =begin code :lang 762 | 763 | use HTTP::Message; 764 | my $raw_msg = "GET / HTTP/1.1\r\nHost: somehost\r\n\r\n"; 765 | my $mess = HTTP::Message.new.parse($raw_msg); 766 | say $mess; 767 | 768 | =end code 769 | 770 | This module provides a bunch of methods to easily manage HTTP message. 771 | 772 | =head3 method new 773 | 774 | =begin code :lang 775 | 776 | my $msg = HTTP::Message.new('content', :field); 777 | 778 | =end code 779 | 780 | A constructor, takes these named arguments: 781 | 782 | =table 783 | key | description 784 | --------+------------ 785 | content | content of the message (optional) 786 | fields | fields of the header section 787 | 788 | =head3 method add-content 789 | 790 | =begin code :lang 791 | 792 | my $msg = HTTP::Message.new('content', :field); 793 | $msg.add-content: 's'; 794 | say $msg.content; # says 'contents' 795 | 796 | =end code 797 | 798 | Adds HTTP message content. It does not remove the existing value, 799 | it concats to the existing content. 800 | 801 | =head3 method decoded-content 802 | 803 | =begin code :lang 804 | 805 | my $msg = HTTP::Message.new(); 806 | say $msg.decoded-content; 807 | 808 | =end code 809 | 810 | Returns decoded content of the message (using L module to decode). 811 | 812 | =head3 method field 813 | 814 | See C. 815 | 816 | =head3 method init-field 817 | 818 | See C. 819 | 820 | =head3 method push-field 821 | 822 | See C. 823 | 824 | =head3 method remove-field 825 | 826 | See C. 827 | 828 | =head3 method clear 829 | 830 | =begin code :lang 831 | 832 | my $msg = HTTP::Message.new('content', :field); 833 | $msg.clear; 834 | say ~$msg; # says nothing 835 | 836 | =end code 837 | 838 | Removes the whole message, both header and content section. 839 | 840 | =head3 method parse 841 | 842 | =begin code :lang 843 | 844 | my $msg = HTTP::Message.new.parse("GET / HTTP/1.1\r\nHost: example\r\ncontent\r\n"); 845 | say $msg.raku; 846 | 847 | =end code 848 | 849 | Parses the whole HTTP message. 850 | 851 | It takes the HTTP message (with \r\n as a line separator) and obtains the header 852 | and content sections, creates a C object. 853 | 854 | =head3 method Str 855 | 856 | Returns HTTP message in a readable form. 857 | 858 | =head1 AUTHOR 859 | 860 | =item Filip Sergot 861 | 862 | Source can be located at: https://github.com/raku-community-modules/HTTP-UserAgent . 863 | Comments and Pull Requests are welcome. 864 | 865 | =head1 COPYRIGHT AND LICENSE 866 | 867 | Copyright 2014 - 2022 Filip Sergot 868 | 869 | Copyright 2023 - 2025 The Raku Community 870 | 871 | This library is free software; you can redistribute it and/or modify it under the MIT License. 872 | 873 | =end pod 874 | 875 | # vim: expandtab shiftwidth=4 876 | -------------------------------------------------------------------------------- /examples/crawler.raku: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env raku 2 | use HTTP::UserAgent; 3 | 4 | sub MAIN(Str $start_url) { 5 | my $c = HTTP::UserAgent.new(:useragent); 6 | 7 | my $content = $c.get($start_url).content; 8 | 9 | my @urls = get-urls($content); 10 | 11 | while my $url = @urls.shift { 12 | print "trying: $url ... "; 13 | try { 14 | my $r = $c.get(~$url); 15 | CATCH { 16 | when X::HTTP { 17 | say '[ALMOST OK - X::HTTP exception]'; 18 | } 19 | 20 | say '[NOT OK]'; 21 | } 22 | default { 23 | say '[OK]'; 24 | 25 | $content = $r.content; 26 | if $content ~~ Str { 27 | #say ~$r.header; 28 | #say $content; 29 | my @new_url = get-urls($content); 30 | @urls.push($_) unless $_ ~~ any(@urls) for @new_url; 31 | } 32 | } 33 | } 34 | } 35 | } 36 | 37 | sub get-urls($content) { 38 | $content.match(/ \s 'href="' (<-["]>+) '"' /, :g).map({ $_[0] }).grep( rx:i/^http/ ); 39 | } 40 | 41 | # vim: expandtab shiftwidth=4 42 | -------------------------------------------------------------------------------- /examples/ex_readme.raku: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env raku 2 | use HTTP::UserAgent; 3 | 4 | my $ua = HTTP::UserAgent.new; 5 | $ua.timeout = 1; 6 | 7 | my $response = $ua.get('https://github.com'); 8 | 9 | if $response.is-success { 10 | say $response.content; 11 | } 12 | else { 13 | die $response.status-line; 14 | } 15 | 16 | $response = $ua.get('https://github.com/404here'); 17 | 18 | # vim: expandtab shiftwidth=4 19 | -------------------------------------------------------------------------------- /examples/http-download.raku: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env raku 2 | use HTTP::UserAgent :simple; 3 | 4 | sub MAIN(Str $url, Str $filename?) { 5 | my $file = $filename.defined ?? $filename !! get-filename($url); 6 | 7 | say "Saving to '$file'..."; 8 | 9 | getstore($url, $file); 10 | 11 | say "{($file.path.s / 1024).fmt("%.1f")} KB received"; 12 | } 13 | 14 | sub get-filename($url is copy) { 15 | my $filename; 16 | 17 | $filename = $url.substr($url.chars - 1, 1) eq '/' ?? 18 | 'index.html' !! $url.substr($url.rindex('/') + 1); 19 | 20 | } 21 | 22 | # vim: expandtab shiftwidth=4 23 | -------------------------------------------------------------------------------- /examples/http-dump.raku: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env raku 2 | use HTTP::UserAgent; 3 | 4 | sub MAIN($url) { 5 | my $response = HTTP::UserAgent.new.get($url); 6 | say ~$response.header; 7 | my $content = $response.decoded-content; 8 | if $content.elems > 800 { 9 | say "{$content.substr(0, 800)}..."; 10 | $content .= substr(800); 11 | say "(+ {$content.encode('utf8').bytes} bytes not shown)"; 12 | } 13 | else { 14 | $content.say; 15 | } 16 | } 17 | 18 | # vim: expandtab shiftwidth=4 19 | -------------------------------------------------------------------------------- /examples/http-request.raku: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env raku 2 | use HTTP::UserAgent :simple; 3 | 4 | sub MAIN($url) { 5 | getprint($url); 6 | } 7 | 8 | # vim: expandtab shiftwidth=4 9 | -------------------------------------------------------------------------------- /lib/HTTP/Cookie.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::Cookie; 2 | 3 | has $.name is rw; 4 | has $.value is rw; 5 | has $.secure is rw; 6 | has $.httponly is rw; 7 | has $.path is rw; 8 | has $.domain is rw; 9 | has $.version is rw; 10 | has $.expires is rw; 11 | 12 | has %.fields; 13 | 14 | method Str { 15 | my $s = "$.name=$.value"; 16 | $s ~= "; Domain=$.domain" if $.domain; 17 | $s ~= "; Version=$.version" if $.version; 18 | $s ~= "; Path=$.path" if $.path; 19 | $s ~= "; Expires=$.expires" if $.expires; 20 | $s ~= ';' ~ (%.fields.map( *.fmt("%s=%s") )).flat.join('; ') if %.fields.elems > 1; 21 | $s ~= "; $.secure" if $.secure; 22 | $s ~= "; $.httponly" if $.httponly; 23 | $s 24 | } 25 | 26 | # vim: expandtab shiftwidth=4 27 | -------------------------------------------------------------------------------- /lib/HTTP/Cookies.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::Cookies; 2 | 3 | use HTTP::Cookie; 4 | use HTTP::Response:auth; 5 | use HTTP::Request:auth; 6 | use DateTime::Parse; 7 | 8 | has @.cookies; 9 | has $.file; 10 | has $.autosave is rw = 0; 11 | 12 | my grammar HTTP::Cookies::Grammar { 13 | token TOP { 14 | 'Set-Cookie:' [\s* ','?]* 15 | } 16 | 17 | token cookie { 18 | '=' ';'? \s* [ \s*]* ? ';'? \s* ? ';'? 19 | } 20 | token separator { <[()<>@,;:\"/\[\]?={}\s\t]> } 21 | token name { <[\S] - [()<>@,;:\"/\[\]?={}]>+ } 22 | token value { <-[;]>+ } 23 | token arg { '=' ';'? } 24 | token secure { Secure } 25 | token httponly { :i HttpOnly } 26 | } 27 | 28 | my class HTTP::Cookies::Actions { 29 | method cookie($/) { 30 | my $h = HTTP::Cookie.new; 31 | $h.name = ~$; 32 | $h.value = ~$; 33 | $h.secure = $.defined ?? ~$ !! False;; 34 | $h.httponly = $.defined ?? ~$ !! False; 35 | 36 | for $.list -> $a { 37 | if .grep($a.lc) { 38 | $h."{$a.lc}"() = ~$a; 39 | } else { 40 | $h.fields.push: $a => ~$a; 41 | } 42 | } 43 | $*OBJ.push-cookie($h); 44 | } 45 | } 46 | 47 | method extract-cookies(HTTP::Response $response) { 48 | self.set-cookie($_) for $response.field('Set-Cookie').grep({ $_.defined }).map({ "Set-Cookie: $_" }).flat; 49 | self.save if $.autosave; 50 | } 51 | 52 | method add-cookie-header(HTTP::Request $request) { 53 | for @.cookies -> $cookie { 54 | # TODO this check sucks, eq is not the right (should probably use uri) 55 | #next if $cookie.domain.defined 56 | # && $cookie.domain ne $request.field('Host'); 57 | # TODO : path/domain restrictions 58 | my $cookiestr = "{$cookie.name}={$cookie.value}; { ($cookie.fields.map( *.fmt("%s=%s") )).flat.join('; ') }"; 59 | if $cookie.version.defined and $cookie.version >= 1 { 60 | $cookiestr ~= ',$Version='~ $cookie.version; 61 | } else { 62 | $request.field(Cookie2 => '$Version="1"'); 63 | } 64 | if $request.field('Cookie').defined { 65 | $request.field( Cookie => $request.field("Cookie") ~ $cookiestr ); 66 | } else { 67 | $request.field( Cookie => $cookiestr ); 68 | } 69 | } 70 | } 71 | 72 | method save { 73 | my $fh = open $.file, :w; 74 | 75 | # TODO : add versioning 76 | $fh.say: "#LWP6-Cookies-0.1"; 77 | $fh.say: self.Str; 78 | 79 | $fh.close; 80 | } 81 | 82 | method load { 83 | for $.file.IO.lines -> $l { 84 | # we don't need #LWP6-Cookies-$VER 85 | self.set-cookie($l) unless $l.starts-with('#'); 86 | } 87 | } 88 | 89 | method clear-expired { 90 | @.cookies .= grep({ 91 | ! .expires.defined || .expires !~~ /\d\d/ || 92 | # we need more precision 93 | DateTime::Parse.new( .expires ).Date > Date.today 94 | }); 95 | self.save if $.autosave; 96 | } 97 | 98 | method clear { 99 | @.cookies = (); 100 | self.save if $.autosave; 101 | } 102 | 103 | method set-cookie($str) { 104 | my $*OBJ = self; 105 | HTTP::Cookies::Grammar.parse($str, :actions(HTTP::Cookies::Actions)); 106 | 107 | self.save if $.autosave; 108 | } 109 | 110 | method push-cookie(HTTP::Cookie $c) { 111 | @.cookies .= grep({ .name ne $c.name }); 112 | @.cookies.push: $c; 113 | 114 | self.save if $.autosave; 115 | } 116 | 117 | method Str { 118 | @.cookies.map({ "Set-Cookie: $_" }).join("\n"); 119 | } 120 | 121 | # vim: expandtab shiftwidth=4 122 | -------------------------------------------------------------------------------- /lib/HTTP/Header.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::Header; 2 | 3 | use HTTP::Header::Field; 4 | 5 | # headers container 6 | has @.fields; 7 | 8 | our grammar HTTP::Header::Grammar { 9 | token TOP { 10 | [ \r?\n ]* 11 | } 12 | 13 | token message-header { 14 | $=[ <-[:]>+ ] ':' 15 | } 16 | 17 | token field-value { 18 | [ ( ['W/' | 'w/'] )? ? 19 | $=[ <-[\r\n"]>+ ] || \h+ ]* 20 | ? 21 | } 22 | token quot { 23 | <['"]> 24 | } 25 | } 26 | 27 | our class HTTP::Header::Actions { 28 | method message-header($/) { 29 | my $value = $.made; 30 | my $k = ~$; 31 | my @v = $value.Array; 32 | 33 | @v[0] = $value ~ @v[0] if $value && $k.lc ne 'etag'; 34 | if $k && @v -> $v { 35 | if $*OBJ.field($k) { 36 | $*OBJ.push-field: |($k => $v); 37 | } else { 38 | $*OBJ.field: |($k => $v); 39 | } 40 | } 41 | } 42 | 43 | method field-value($/) { 44 | make { 45 | prefix => $0, 46 | content => $ ?? 47 | $.Str.split(',')>>.trim !! Nil 48 | } 49 | } 50 | } 51 | 52 | # we want to pass arguments like this: .new(a => 1, b => 2 ...) 53 | method new(*%fields) { 54 | my @fields = %fields.sort(*.key).map: { 55 | HTTP::Header::Field.new(:name(.key), :values(.value.list)); 56 | } 57 | 58 | self.bless(:@fields) 59 | } 60 | 61 | proto method field(|) {*} 62 | 63 | # set fields 64 | multi method field(*%fields) { 65 | for %fields.sort(*.key) -> (:key($k), :value($v)) { 66 | my $f = HTTP::Header::Field.new(:name($k), :values($v.list)); 67 | if @.fields.first({ .name.lc eq $k.lc }) { 68 | @.fields[@.fields.first({ .name.lc eq $k.lc }, :k)] = $f; 69 | } 70 | else { 71 | @.fields.push: $f; 72 | } 73 | } 74 | } 75 | 76 | # get fields 77 | multi method field($field) { 78 | my $field-lc := $field.lc; 79 | @.fields.first(*.name.lc eq $field-lc) 80 | } 81 | 82 | # initialize fields 83 | method init-field(*%fields) { 84 | for %fields.sort(*.key) -> (:key($k), :value($v)) { 85 | my $k-lc := $k.lc; 86 | @.fields.push: 87 | HTTP::Header::Field.new(:name($k), :values($v.list)) 88 | unless @.fields.first(*.name.lc eq $k-lc); 89 | } 90 | } 91 | 92 | # add value to existing fields 93 | method push-field(*%fields) { 94 | for %fields.sort(*.key) -> (:key($k), :value($v)) { 95 | my $k-lc := $k.lc; 96 | @.fields.first(*.name.lc eq $k-lc).values.append: $v.list; 97 | } 98 | } 99 | 100 | # remove a field 101 | method remove-field(Str $field) { 102 | my $field-lc := $field.lc; 103 | @.fields.splice($_, 1) 104 | with @.fields.first(*.name.lc eq $field-lc, :k); 105 | } 106 | 107 | # get fields names 108 | method header-field-names() { 109 | @.fields.map(*.name) 110 | } 111 | 112 | # return the headers as name -> value hash 113 | method hash(--> Hash:D) { 114 | @.fields.map({ $_.name => $_.values }).Hash 115 | } 116 | 117 | # remove all fields 118 | method clear() { 119 | @.fields = (); 120 | } 121 | 122 | # get header as string 123 | method Str($eol = "\n") { 124 | @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join 125 | } 126 | 127 | method parse($raw) { 128 | my $*OBJ = self; 129 | HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); 130 | } 131 | 132 | # vim: expandtab shiftwidth=4 133 | -------------------------------------------------------------------------------- /lib/HTTP/Header/Field.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::Header::Field; 2 | 3 | has $.name; 4 | has @.values; 5 | 6 | method Str { @.values.join(', ') } 7 | 8 | # vim: expandtab shiftwidth=4 9 | -------------------------------------------------------------------------------- /lib/HTTP/MediaType.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::MediaType; 2 | 3 | class X::MediaTypeParser::IllegalMediaType is Exception { 4 | has $.media-type; 5 | 6 | method message() { "Illegal media type: '$.media-type'" } 7 | } 8 | 9 | my grammar MediaTypeGrammar { 10 | token TOP { } 11 | 12 | # https://tools.ietf.org/html/rfc7231#section-3.1.1.1 13 | token media-type { "/" [ <.OWS> ";" <.OWS> ]* } 14 | token type { <._token> } 15 | token subtype { <._token> } 16 | 17 | token parameter { "=" } 18 | token parameter-key { <._token> } 19 | token parameter-value { <._token> || <.quoted-string> } 20 | 21 | # https://tools.ietf.org/html/rfc7230#section-3.2.3 22 | # optional white space 23 | token OWS { [ <.SP> || <.HTAB> ]* } 24 | 25 | # https://tools.ietf.org/html/rfc7230#section-3.2.6 26 | token _token { <.tchar>+ } 27 | token tchar { 28 | || < ! # $ % & ' * + - . ^ _ ` | ~ > 29 | || <.DIGIT> 30 | || <.ALPHA> 31 | } 32 | token quoted-string { <.DQUOTE> [<.qdtext> || <.quoted-pair>]* <.DQUOTE> } 33 | token qdtext { <.HTAB> || <.SP> || "\x21" || <[\x23 .. \x5B]> || <[\x5D .. \x7E]> || <.obs-text> } 34 | token obs-text { <[\x80..\xff]> } 35 | token quoted-pair { '\\' [ <.HTAB> || <.SP> || <.VCHAR> || <.obs-text> ] } 36 | 37 | # https://tools.ietf.org/html/rfc5234#appendix-B.1 38 | token DIGIT { <[ 0..9 ]> } 39 | token ALPHA { <[ A..Z a..z ]> } 40 | token SP { "\x20" } 41 | token HTAB { "\x09" } 42 | token DQUOTE { "\x22" } 43 | # visible (printing) characters 44 | token VCHAR { <[\x21..\x7E]> } 45 | } 46 | 47 | my class MediaTypeAction { 48 | method TOP($/) { $/.make: $.made() } 49 | method media-type($/) { 50 | $/.make: HTTP::MediaType.new( 51 | type => $.made ~ "/" ~ $.made, 52 | major-type => $.made, 53 | sub-type => $.made, 54 | parameters => $».made()) 55 | } 56 | method type($/) { $/.make: ~$/ } 57 | method subtype($/) { $/.make: ~$/ } 58 | method parameter($/) { $/.make: $.made() => $.made } 59 | method parameter-key($/) { $/.make: ~$/ } 60 | method parameter-value($/) { $/.make: ~$/ } 61 | } 62 | 63 | has Str $.type; 64 | has Str $.major-type; 65 | has Str $.sub-type; 66 | has %.parameters; 67 | 68 | method charset(HTTP::MediaType:D:) returns Str { 69 | (%!parameters // '').lc; 70 | } 71 | 72 | method parse(Str $media-type) { 73 | my $result = MediaTypeGrammar.parse($media-type, :actions(MediaTypeAction)); 74 | if $result { 75 | $result.made; 76 | } 77 | else { 78 | X::MediaTypeParser::IllegalMediaType.new(:$media-type).throw; 79 | } 80 | } 81 | 82 | proto method param(|) {*} 83 | 84 | multi method param(Str:D $name) { 85 | %!parameters{$name}; 86 | } 87 | 88 | multi method param(Str:D $name, Str:D $value) { 89 | %!parameters{$name} = $value 90 | } 91 | 92 | method Str(HTTP::MediaType:D:) { 93 | %!parameters 94 | ?? $.type ~ "; " ~ %!parameters.map({ .key ~ "=" ~ .value }).join(";") 95 | !! $.type 96 | } 97 | 98 | # vim: expandtab shiftwidth=4 99 | -------------------------------------------------------------------------------- /lib/HTTP/Message.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::Message; 2 | 3 | use HTTP::Header; 4 | use HTTP::MediaType; 5 | use Encode; 6 | 7 | has HTTP::Header $.header = HTTP::Header.new; 8 | has $.content is rw; 9 | 10 | has $.protocol is rw = 'HTTP/1.1'; 11 | 12 | has Bool $.binary = False; 13 | has Str @.text-types; 14 | 15 | my $CRLF = "\r\n"; 16 | 17 | method new($content?, *%fields) { 18 | my $header = HTTP::Header.new(|%fields); 19 | 20 | self.bless(:$header, :$content); 21 | } 22 | 23 | method add-content($content) { 24 | $.content ~= $content; 25 | } 26 | 27 | class X::Decoding is Exception { 28 | has HTTP::Message $.response; 29 | has Blob $.content; 30 | method message() { 31 | "Problem decoding content"; 32 | } 33 | } 34 | 35 | method content-type(--> Str:D) { 36 | $!header.field('Content-Type').values[0] || ''; 37 | } 38 | 39 | has HTTP::MediaType $!media-type; 40 | 41 | method media-type(--> HTTP::MediaType) { 42 | without $!media-type { 43 | if self.content-type() -> $ct { 44 | $!media-type = HTTP::MediaType.parse($ct); 45 | } 46 | } 47 | $!media-type 48 | } 49 | 50 | # Don't want to put the heuristic in the HTTP::MediaType 51 | # Also moving this here makes it much more easy to test 52 | 53 | method charset(--> Str:D) { 54 | if self.media-type -> $mt { 55 | $mt.charset || ( $mt.major-type eq 'text' ?? $mt.sub-type eq 'html' ?? 'utf-8' !! 'iso-8859-1' !! 'utf-8'); 56 | } 57 | else { 58 | # At this point we're probably screwed anyway 59 | 'iso-8859-1' 60 | } 61 | } 62 | 63 | # This is already a candidate for refactoring 64 | # Just want to get it working 65 | method is-text(--> Bool:D) { 66 | if $!binary { 67 | False 68 | } 69 | elsif self.media-type -> $mt { 70 | if $mt.type ~~ any(@!text-types) { 71 | True 72 | } 73 | else { 74 | given $mt.major-type { 75 | when 'text' { 76 | True 77 | } 78 | when any() { 79 | False 80 | } 81 | when 'application' { 82 | given $mt.sub-type { 83 | when /xml|javascript|json/ { 84 | True 85 | } 86 | default { 87 | False 88 | } 89 | } 90 | } 91 | default { 92 | # Not sure about this 93 | True 94 | } 95 | } 96 | } 97 | } 98 | else { 99 | # No content type, try and blow up 100 | True 101 | } 102 | } 103 | 104 | method is-binary(--> Bool:D) { !self.is-text } 105 | 106 | method content-encoding() { 107 | $!header.field('Content-Encoding'); 108 | } 109 | 110 | class X::Deflate is Exception { 111 | has Str $.message; 112 | } 113 | 114 | method inflate-content(--> Blob:D) { 115 | if self.content-encoding -> $v is copy { 116 | # This is a guess 117 | $v = 'zlib' if $v eq 'compress' ; 118 | $v = 'zlib' if $v eq 'deflate'; 119 | try require ::('Compress::Zlib'); 120 | if ::('Compress::Zlib::Stream') ~~ Failure { 121 | X::Deflate.new(message => "Please install 'Compress::Zlib' to uncompress '$v' encoded content").throw; 122 | } 123 | else { 124 | my $z = ::('Compress::Zlib::Stream').new( |{ $v => True }); 125 | $z.inflate($!content); 126 | } 127 | } 128 | else { 129 | $!content; 130 | } 131 | } 132 | 133 | method decoded-content(:$bin) { 134 | return $!content if $!content ~~ Str || $!content.bytes == 0; 135 | 136 | my $content = self.inflate-content; 137 | # [todo] 138 | # If charset is missing from Content-Type, then before defaulting 139 | # to anything it should attempt to extract it from $.content like (for HTML): 140 | # 141 | # 142 | 143 | my $decoded_content; 144 | 145 | if !$bin && self.is-text { 146 | my $charset = self.charset; 147 | $decoded_content = try { 148 | Encode::decode($charset, $content); 149 | } || try { 150 | $content.decode('iso-8859-1'); 151 | } || try { 152 | $content.unpack("A*") 153 | } || X::Decoding.new(content => $content, response => self).throw; 154 | } 155 | else { 156 | $decoded_content = $content; 157 | } 158 | 159 | $decoded_content 160 | } 161 | 162 | multi method field(Str $f) { 163 | $.header.field($f) 164 | } 165 | 166 | multi method field(*%fields) { 167 | $.header.field(|%fields) 168 | } 169 | 170 | method push-field(*%fields) { 171 | $.header.push-field(|%fields) 172 | } 173 | 174 | method remove-field(Str $field) { 175 | $.header.remove-field($field) 176 | } 177 | 178 | method clear { 179 | $.header.clear; 180 | $.content = '' 181 | } 182 | 183 | method parse($raw_message) { 184 | my @lines = $raw_message.split(/$CRLF/); 185 | 186 | my ($first, $second, $third) = @lines.shift.split(/\s+/); 187 | 188 | if $third.index('/') { # is a request 189 | $.protocol = $third; 190 | } 191 | else { # is a response 192 | $.protocol = $first; 193 | } 194 | 195 | loop { 196 | last until @lines; 197 | 198 | my $line = @lines.shift; 199 | if $line { 200 | my ($k, $v) = $line.split(/\:\s*/, 2); 201 | if $k and $v { 202 | if $.header.field($k) { 203 | $.header.push-field: |($k => $v.split(',')>>.trim); 204 | } else { 205 | $.header.field: |($k => $v.split(',')>>.trim); 206 | } 207 | } 208 | } else { 209 | $.content = @lines.grep({ $_ }).join("\n"); 210 | last; 211 | } 212 | } 213 | 214 | self 215 | } 216 | 217 | method Str($eol = "\n", :$debug, Bool :$bin) { 218 | my constant $max_size = 300; 219 | my $s = $.header.Str($eol); 220 | $s ~= $eol if $.content; 221 | 222 | # The :bin will be passed from the H::UA 223 | if not $bin { 224 | $s ~= $.content ~ $eol if $.content and !$debug; 225 | } 226 | if $.content and $debug { 227 | if $bin || self.is-binary { 228 | $s ~= $eol ~ "=Content size : " ~ $.content.elems ~ " bytes "; 229 | $s ~= "$eol ** Not showing binary content ** $eol"; 230 | } 231 | else { 232 | $s ~= $eol ~ "=Content size: "~$.content.Str.chars~" chars"; 233 | $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; 234 | $s ~= $eol ~ $.content.Str.substr(0, $max_size) ~ $eol; 235 | } 236 | } 237 | 238 | $s 239 | } 240 | 241 | # vim: expandtab shiftwidth=4 242 | -------------------------------------------------------------------------------- /lib/HTTP/Request.rakumod: -------------------------------------------------------------------------------- 1 | use HTTP::Message; 2 | use URI; 3 | use URI::Escape; 4 | use HTTP::MediaType; 5 | use MIME::Base64; 6 | 7 | unit class HTTP::Request is HTTP::Message; 8 | 9 | subset RequestMethod of Str where any(); 10 | 11 | has RequestMethod $.method is rw; 12 | has $.url is rw; 13 | has $.file is rw; 14 | has $.uri is rw; 15 | 16 | has Str $.host is rw; 17 | has Int $.port is rw; 18 | has Str $.scheme is rw; 19 | 20 | my $CRLF = "\r\n"; 21 | 22 | my $HRC_DEBUG = %*ENV.Bool; 23 | 24 | proto method new(|) {*} 25 | 26 | multi method new(Bool :$bin, *%args) { 27 | 28 | if %args { 29 | my ($method, $url, $file, %fields, $uri); 30 | for %args.kv -> $key, $value { 31 | if $key.lc ~~ any() { 32 | $uri = $value.isa(URI) ?? $value !! URI.new($value); 33 | $method = $key.uc; 34 | } 35 | else { 36 | %fields{$key} = $value; 37 | } 38 | } 39 | 40 | my $header = HTTP::Header.new(|%fields); 41 | self.new($method // 'GET', $uri, $header, :$bin); 42 | } 43 | else { 44 | self.bless 45 | } 46 | } 47 | 48 | multi method new() { self.bless } 49 | 50 | multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin) { 51 | my $url = $uri.grammar.parse_result.orig; 52 | my $file = $uri.path_query || '/'; 53 | 54 | $header.field(Host => get-host-value($uri)) without $header.field('Host'); 55 | 56 | self.bless(:$method, :$url, :$header, :$file, :$uri, binary => $bin) 57 | } 58 | 59 | sub get-host-value(URI $uri --> Str) { 60 | my Str $host = $uri.host; 61 | 62 | if $host { 63 | if ( $uri.port != $uri.default_port ) { 64 | $host ~= ':' ~ $uri.port; 65 | } 66 | } 67 | $host; 68 | } 69 | 70 | method set-method($method) { $.method = $method.uc } 71 | 72 | proto method uri(|) {*} 73 | 74 | multi method uri($uri is copy where URI|Str) { 75 | $!uri = $uri.isa(Str) ?? URI.new($uri) !! $uri ; 76 | $!url = $!uri.grammar.parse_result.orig; 77 | $!file = $!uri.path_query || '/'; 78 | self.field(Host => get-host-value($!uri)); 79 | $!uri 80 | } 81 | 82 | multi method uri() is rw { $!uri } 83 | 84 | proto method host(|) {*} 85 | 86 | multi method host(--> Str:D) is rw { 87 | $!host = ~self.field('Host').values without $!host; 88 | $!host 89 | } 90 | 91 | proto method port(|) {*} 92 | 93 | multi method port(--> Int) is rw { 94 | if not $!port.defined { 95 | # if there isn't a scheme the no default port 96 | if try self.uri.scheme { 97 | $!port = self.uri.port; 98 | } 99 | } 100 | $!port 101 | } 102 | 103 | proto method scheme(|) {*} 104 | 105 | multi method scheme(--> Str:D) is rw { 106 | without $!scheme { 107 | CATCH { 108 | default { $!scheme = 'http' } 109 | } 110 | $!scheme = self.uri.scheme; 111 | } 112 | $!scheme 113 | } 114 | 115 | method add-cookies($cookies) { 116 | $cookies.add-cookie-header(self) if $cookies.cookies; 117 | } 118 | 119 | proto method add-content(|) {*} 120 | 121 | multi method add-content(Str:D $content) { 122 | self.content ~= $content; 123 | self.header.field(Content-Length => self.content.encode.bytes.Str); 124 | } 125 | 126 | proto method add-form-data(|) {*} 127 | 128 | multi method add-form-data(:$multipart, *%data) { 129 | self.add-form-data(%data.sort.Array, :$multipart); 130 | } 131 | 132 | multi method add-form-data(%data, :$multipart) { 133 | self.add-form-data(%data.sort.Array, :$multipart); 134 | } 135 | 136 | multi method add-form-data(Array $data, :$multipart) { 137 | my $ct = do { 138 | my $f = self.header.field('Content-Type'); 139 | if $f { 140 | $f.values[0]; 141 | } else { 142 | if $multipart { 143 | 'multipart/form-data'; 144 | } 145 | else { 146 | 'application/x-www-form-urlencoded'; 147 | } 148 | } 149 | }; 150 | sub form-escape($s) { 151 | uri-escape($s).subst(:g, '%20', '+').subst(:g, '%2A', '*'); 152 | } 153 | given $ct { 154 | when 'application/x-www-form-urlencoded' { 155 | my @parts; 156 | for @$data { 157 | @parts.push: form-escape(.key) ~ "=" ~ form-escape(.value); 158 | } 159 | self.content = @parts.join("&").encode; 160 | self.header.field(Content-Length => self.content.bytes.Str); 161 | 162 | } 163 | when m:i,^ "multipart/form-data" \s* ( ";" | $ ), { 164 | say 'generating form-data' if $HRC_DEBUG; 165 | 166 | my $mt = HTTP::MediaType.parse($ct); 167 | my Str $boundary = $mt.param('boundary') // self.make-boundary(10); 168 | (my $generated-content, $boundary) = self.form-data($data, $boundary); 169 | $mt.param('boundary', $boundary); 170 | $ct = $mt.Str; 171 | my Str $encoded-content = $generated-content; 172 | self.content = $encoded-content; 173 | self.header.field(Content-Length => $encoded-content.encode('ascii').bytes.Str); 174 | } 175 | } 176 | self.header.field(Content-Type => $ct) 177 | } 178 | 179 | 180 | method form-data(Array:D $content, Str:D $boundary) { 181 | my @parts; 182 | for @$content { 183 | my ($k, $v) = $_.key, $_.value; 184 | given $v { 185 | when Str { 186 | $k ~~ s:g/(<[\\ \"]>)/\\$1/; # escape quotes and backslashes 187 | @parts.push: qq!Content-Disposition: form-data; name="$k"$CRLF$CRLF$v!; 188 | } 189 | when Array { 190 | my ($file, $usename, @headers) = @$v; 191 | unless defined $usename { 192 | $usename = $file; 193 | $usename ~~ s!.* "/"!! if defined($usename); 194 | } 195 | $k ~~ s:g/(<[\\ \"]>)/\\$1/; 196 | my $disp = qq!form-data; name="$k"!; 197 | if (defined($usename) and $usename.elems > 0) { 198 | $usename ~~ s:g/(<[\\ \"]>)/\\$1/; 199 | $disp ~= qq!; filename="$usename"!; 200 | } 201 | my $content; 202 | my $headers = HTTP::Header.new(|@headers); 203 | if $file { 204 | # TODO: dynamic file upload support 205 | $content = $file.IO.slurp; 206 | unless $headers.field('Content-Type') { 207 | # TODO: LWP::MediaTypes 208 | $headers.field(Content-Type => 'application/octet-stream'); 209 | } 210 | } 211 | if $headers.field('Content-Disposition') { 212 | $disp = $headers.field('Content-Disposition'); 213 | $headers.remove-field('Content-Disposition'); 214 | } 215 | if $headers.field('Content') { 216 | $content = $headers.field('Content'); 217 | $headers.remove-field('Content'); 218 | } 219 | my $head = ["Content-Disposition: $disp", 220 | $headers.Str($CRLF), 221 | ""].join($CRLF); 222 | given $content { 223 | when Str { 224 | @parts.push: $head ~ $content; 225 | } 226 | default { 227 | die "NYI" 228 | } 229 | } 230 | } 231 | default { 232 | die "unsupported type: $v.WHAT.gist()($content.raku())"; 233 | } 234 | } 235 | } 236 | 237 | say $content if $HRC_DEBUG; 238 | say @parts if $HRC_DEBUG; 239 | return "", "none" unless @parts; 240 | 241 | my $contents; 242 | # TODO: dynamic upload support 243 | my $bno = 10; 244 | CHECK_BOUNDARY: { 245 | for @parts { 246 | if $_.index($boundary).defined { 247 | # must have a better boundary 248 | $boundary = self.make-boundary(++$bno); 249 | redo CHECK_BOUNDARY; 250 | } 251 | } 252 | } 253 | my $generated-content = "--$boundary$CRLF" 254 | ~ @parts.join("$CRLF--$boundary$CRLF") 255 | ~ "$CRLF--$boundary--$CRLF"; 256 | 257 | $generated-content, $boundary 258 | } 259 | 260 | 261 | method make-boundary(int $size=10) { 262 | my $str = (1..$size*3).map({(^256).pick.chr}).join(''); 263 | my $b = MIME::Base64.new.encode_base64($str, :oneline); 264 | $b ~~ s:g/\W/X/; # ensure alnum only 265 | $b 266 | } 267 | 268 | 269 | method Str (:$debug, Bool :$bin) { 270 | $.file = '/' ~ $.file unless $.file.starts-with: '/'; 271 | my $s = "$.method $.file $.protocol"; 272 | $s ~= $CRLF ~ callwith($CRLF, :$debug, :$bin); 273 | } 274 | 275 | method parse($raw_request) { 276 | my @lines = $raw_request.split($CRLF); 277 | ($.method, $.file) = @lines.shift.split(' '); 278 | 279 | $.url = 'http://'; 280 | 281 | for @lines -> $line { 282 | if $line ~~ m:i/host:/ { 283 | $.url ~= $line.split(/\:\s*/)[1]; 284 | } 285 | } 286 | 287 | $.url ~= $.file; 288 | 289 | self.uri = URI.new($.url) ; 290 | 291 | nextsame; 292 | } 293 | 294 | # vim: expandtab shiftwidth=4 295 | -------------------------------------------------------------------------------- /lib/HTTP/Request/Common.rakumod: -------------------------------------------------------------------------------- 1 | use URI; 2 | use URI::Escape; 3 | use HTTP::Request:auth; 4 | use HTTP::MediaType; 5 | use MIME::Base64; 6 | use HTTP::Header; 7 | 8 | constant $CRLF = "\x0d\x0a"; 9 | my $HRC_DEBUG = %*ENV.Bool; 10 | 11 | #- private subs ---------------------------------------------------------------- 12 | my sub get-request( 13 | Str:D $meth, URI:D $uri, Bool :$bin, *%nameds 14 | --> HTTP::Request:D) { 15 | my $request = HTTP::Request.new(|($meth.uc => $uri), :$bin); 16 | $request.header.field(|%nameds); 17 | $request 18 | } 19 | 20 | my sub send-text-content( 21 | Str:D $meth, URI:D $uri, :$content, *%nameds 22 | --> HTTP::Request:D) { 23 | my $request = get-request($meth, $uri, |%nameds); 24 | $request.add-content($_) with $content; 25 | $request 26 | } 27 | 28 | my sub send-binary-content( 29 | Str:D $meth, URI:D $uri, Blob :$content, *%nameds is copy 30 | ) { 31 | %nameds = $content.elems; 32 | if %nameds:!exists and %nameds:!exists { 33 | %nameds = 'application/octet-stream'; 34 | } 35 | my $request = get-request($meth, $uri, |%nameds, :bin); 36 | $request.content = $content; 37 | $request 38 | } 39 | 40 | #- POST ------------------------------------------------------------------------ 41 | # TODO: multipart/form-data 42 | proto sub POST(|) is export {*} 43 | multi sub POST(URI $uri, %form, *%nameds) { 44 | POST($uri, content => %form, |%nameds); 45 | } 46 | 47 | multi sub POST(Str $uri, %form, *%nameds) { 48 | POST(URI.new($uri), content => %form, |%nameds) 49 | } 50 | 51 | multi sub POST(URI $uri, Array :$content, *%nameds) { 52 | my $request = get-request('POST', $uri, |%nameds); 53 | $request.add-form-data($content); 54 | $request 55 | } 56 | 57 | multi sub POST(Str:D $uri, *%nameds) { 58 | POST(URI.new($uri), |%nameds) 59 | } 60 | 61 | multi sub POST(URI:D $uri, Hash :$content, *%nameds) { 62 | POST($uri, content => $content.Array, |%nameds) 63 | } 64 | 65 | multi sub POST(URI:D $uri, Str :$content, *%nameds) { 66 | send-text-content('POST', $uri, :$content, |%nameds) 67 | } 68 | 69 | multi sub POST(Str:D $uri, Blob :$content, *%nameds ) { 70 | POST(URI.new($uri), :$content, |%nameds) 71 | } 72 | 73 | multi sub POST(URI:D $uri, Blob :$content, *%nameds ) { 74 | send-binary-content('POST', $uri, :$content, |%nameds) 75 | } 76 | 77 | #- GET ------------------------------------------------------------------------- 78 | proto sub GET(|) is export {*} 79 | multi sub GET(URI:D $uri, *%nameds) { 80 | get-request('GET', $uri, |%nameds); 81 | } 82 | 83 | multi sub GET(Str:D $uri, *%nameds) { 84 | GET(URI.new($uri), |%nameds) 85 | } 86 | 87 | #- HEAD ------------------------------------------------------------------------ 88 | proto sub HEAD(|) is export {*} 89 | multi sub HEAD(URI:D $uri, *%nameds) { 90 | get-request('HEAD', $uri, |%nameds); 91 | } 92 | 93 | multi sub HEAD(Str:D $uri, *%nameds) { 94 | HEAD(URI.new($uri), |%nameds) 95 | } 96 | 97 | #- DELETE ---------------------------------------------------------------------- 98 | proto sub DELETE(|) is export {*} 99 | multi sub DELETE(URI:D $uri, *%nameds) { 100 | get-request('DELETE', $uri, |%nameds); 101 | } 102 | 103 | multi sub DELETE(Str:D $uri, *%nameds) { 104 | DELETE(URI.new($uri), |%nameds) 105 | } 106 | 107 | #- PUT ------------------------------------------------------------------------- 108 | proto sub PUT(|) is export {*} 109 | multi sub PUT(URI:D $uri, Str :$content, *%nameds) { 110 | send-text-content('PUT', $uri, :$content, |%nameds); 111 | } 112 | 113 | multi sub PUT(Str:D $uri, Str :$content, *%nameds) { 114 | PUT(URI.new($uri), :$content, |%nameds) 115 | } 116 | 117 | multi sub PUT(Str:D $uri, Blob :$content, *%nameds) { 118 | PUT(URI.new($uri), :$content, |%nameds); 119 | } 120 | 121 | multi sub PUT(URI:D $uri, Blob :$content, *%nameds ) { 122 | send-binary-content('PUT', $uri, :$content, |%nameds); 123 | } 124 | 125 | #- PATCH ----------------------------------------------------------------------- 126 | proto sub PATCH(|) is export {*} 127 | multi sub PATCH(URI:D $uri, *%nameds) { 128 | send-text-content('PATCH', $uri, |%nameds); 129 | } 130 | 131 | multi sub PATCH(Str:D $uri, *%nameds) { 132 | PATCH(URI.new($uri), |%nameds) 133 | } 134 | 135 | # vim: expandtab shiftwidth=4 136 | -------------------------------------------------------------------------------- /lib/HTTP/Response.rakumod: -------------------------------------------------------------------------------- 1 | use HTTP::Message; 2 | use HTTP::Status; 3 | use HTTP::Request:auth; 4 | use HTTP::UserAgent::Exception; 5 | 6 | unit class HTTP::Response is HTTP::Message; 7 | 8 | has $.status-line is rw; 9 | has $.code is rw; 10 | has HTTP::Request $.request is rw; 11 | 12 | my $CRLF = "\r\n"; 13 | 14 | submethod BUILD(:$!code) { 15 | $!status-line = self.set-code($!code); 16 | } 17 | 18 | proto method new(|) {*} 19 | 20 | # This candidate makes it easier to test weird responses 21 | multi method new(Blob:D $header-chunk) { 22 | # See https://tools.ietf.org/html/rfc7230#section-3.2.4 23 | my ($rl, $header) = $header-chunk.decode('ISO-8859-1').split(/\r?\n/, 2); 24 | X::HTTP::NoResponse.new.throw unless $rl; 25 | 26 | my $code = (try $rl.split(' ')[1].Int) // 500; 27 | my $response = self.new($code); 28 | $response.header.parse(.subst(/"\r"?"\n"$$/, '')) with $header; 29 | 30 | $response 31 | } 32 | 33 | multi method new(Int:D $code = 200, *%fields) { 34 | my $header = HTTP::Header.new(|%fields); 35 | self.bless(:$code, :$header); 36 | } 37 | 38 | method content-length(--> Int) { 39 | my $content-length = self.field('Content-Length').values[0]; 40 | 41 | with $content-length -> $c { 42 | X::HTTP::ContentLength.new(message => "Content-Length header value '$c' is not numeric").throw 43 | without $content-length = try +$content-length; 44 | $content-length 45 | } 46 | else { 47 | Int 48 | } 49 | } 50 | 51 | method is-success { is-success($!code).Bool } 52 | 53 | # please extend as necessary 54 | method has-content(--> Bool:D) { 55 | (204, 304).grep({ $!code eq $_ }) ?? False !! True; 56 | } 57 | 58 | method is-chunked(--> Bool:D) { 59 | self.field('Transfer-Encoding') 60 | && self.field('Transfer-Encoding') eq 'chunked' 61 | } 62 | 63 | method set-code(Int:D $code) { 64 | $!code = $code; 65 | $!status-line = $code ~ " " ~ get_http_status_msg($code); 66 | } 67 | 68 | method next-request(--> HTTP::Request:D) { 69 | my HTTP::Request $new-request; 70 | 71 | my $location = ~self.header.field('Location').values; 72 | 73 | 74 | if $location.defined { 75 | # Special case for the HTTP status code 303 (redirection): 76 | # The response to the request can be found under another URI using 77 | # a separate GET method. This relates to POST, PUT, DELETE and PATCH 78 | # methods. 79 | my $method = $!request.method; 80 | $method = "GET" 81 | if self.code == 303 82 | && $!request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); 83 | 84 | my %args = $method => $location; 85 | 86 | $new-request = HTTP::Request.new(|%args); 87 | 88 | unless ~$new-request.field('Host').values { 89 | my $hh = ~$!request.field('Host').values; 90 | $new-request.field(Host => $hh); 91 | $new-request.scheme = $!request.scheme; 92 | $new-request.host = $!request.host; 93 | $new-request.port = $!request.port; 94 | } 95 | } 96 | 97 | $new-request 98 | } 99 | 100 | method Str(:$debug) { 101 | my $s = $.protocol ~ " " ~ $!status-line; 102 | $s ~= $CRLF ~ callwith($CRLF, :debug($debug)); 103 | } 104 | 105 | # vim: expandtab shiftwidth=4 106 | -------------------------------------------------------------------------------- /lib/HTTP/UserAgent.rakumod: -------------------------------------------------------------------------------- 1 | unit class HTTP::UserAgent; 2 | 3 | use HTTP::Response:auth; 4 | use HTTP::Request:auth; 5 | use HTTP::Cookies; 6 | use HTTP::UserAgent::Common; 7 | use HTTP::UserAgent::Exception; 8 | 9 | use Encode; 10 | use URI; 11 | 12 | use File::Temp; 13 | use MIME::Base64; 14 | 15 | constant CRLF = Buf.new(13, 10); 16 | 17 | # placeholder role to make signatures nicer 18 | # and enable greater abstraction 19 | role Connection { 20 | method send-request(HTTP::Request $request ) { 21 | $request.field(Connection => 'close') unless $request.field('Connection'); 22 | if $request.binary { 23 | self.print($request.Str(:bin)); 24 | self.write($request.content); 25 | } 26 | else { 27 | self.print($request.Str ~ "\r\n"); 28 | } 29 | } 30 | } 31 | 32 | has Int $.timeout is rw = 180; 33 | has $.useragent; 34 | has HTTP::Cookies $.cookies is rw = HTTP::Cookies.new( 35 | file => tempfile[0], 36 | autosave => 1, 37 | ); 38 | has $.auth_login; 39 | has $.auth_password; 40 | has Int $.max-redirects is rw; 41 | has $.redirects-in-a-row; 42 | has Bool $.throw-exceptions; 43 | has $.debug; 44 | has IO::Handle $.debug-handle; 45 | 46 | my sub search-header-end(Blob $input) { 47 | my $i = 0; 48 | my $input-bytes = $input.bytes; 49 | while $i+2 <= $input-bytes { 50 | # CRLF 51 | if $i+4 <= $input-bytes && $input[$i] == 0x0d && $input[$i+1]==0x0a && $input[$i+2]==0x0d && $input[$i+3]==0x0a { 52 | return $i+4; 53 | } 54 | # LF 55 | if $input[$i] == 0x0a && $input[$i+1]==0x0a { 56 | return $i+2; 57 | } 58 | $i++; 59 | } 60 | Nil 61 | } 62 | 63 | my sub _index_buf(Blob $input, Blob $sub) { 64 | my $end-pos = 0; 65 | while $end-pos < $input.bytes { 66 | if $sub eq $input.subbuf($end-pos, $sub.bytes) { 67 | return $end-pos; 68 | } 69 | $end-pos++; 70 | } 71 | -1 72 | } 73 | 74 | submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row) { 75 | $!useragent = get-ua($!useragent) if $!useragent.defined; 76 | if $!debug.defined { 77 | if $!debug ~~ Bool and $!debug == True { 78 | $!debug-handle = $*OUT; 79 | } 80 | if $!debug ~~ Str { 81 | say $!debug; 82 | $!debug-handle = open($!debug, :w); 83 | $!debug = True; 84 | } 85 | if $!debug ~~ IO::Handle { 86 | $!debug-handle = $!debug; 87 | $!debug = True; 88 | } 89 | } 90 | } 91 | 92 | method auth(Str $login, Str $password) { 93 | $!auth_login = $login; 94 | $!auth_password = $password; 95 | } 96 | 97 | proto method get(|) {*} 98 | 99 | multi method get(URI $uri is copy, Bool :$bin, *%header ) { 100 | my $request = HTTP::Request.new(GET => $uri, |%header); 101 | self.request($request, :$bin) 102 | } 103 | 104 | multi method get(Str $uri is copy, Bool :$bin, *%header ) { 105 | self.get(URI.new(_clear-url($uri)), :$bin, |%header) 106 | } 107 | 108 | proto method post(|) {*} 109 | 110 | multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { 111 | my $request = HTTP::Request.new(POST => $uri, |%header); 112 | $request.add-form-data(%form); 113 | self.request($request, :$bin) 114 | } 115 | 116 | multi method post(Str $uri is copy, %form, Bool :$bin, *%header ) { 117 | self.post(URI.new(_clear-url($uri)), %form, |%header) 118 | } 119 | 120 | proto method put(|) {*} 121 | 122 | multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { 123 | my $request = HTTP::Request.new(PUT => $uri, |%header); 124 | $request.add-form-data(%form); 125 | self.request($request, :$bin) 126 | } 127 | 128 | multi method put(Str $uri is copy, %form, Bool :$bin, *%header ) { 129 | self.put(URI.new(_clear-url($uri)), %form, |%header) 130 | } 131 | 132 | proto method delete(|) {*} 133 | 134 | multi method delete(URI $uri is copy, Bool :$bin, *%header ) { 135 | my $request = HTTP::Request.new(DELETE => $uri, |%header); 136 | self.request($request, :$bin) 137 | } 138 | 139 | multi method delete(Str $uri is copy, Bool :$bin, *%header ) { 140 | self.delete(URI.new(_clear-url($uri)), :$bin, |%header) 141 | } 142 | 143 | method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { 144 | my HTTP::Response $response; 145 | 146 | # add cookies to the request 147 | $request.add-cookies($.cookies); 148 | 149 | # set the useragent 150 | $request.field(User-Agent => $.useragent) if $.useragent.defined; 151 | 152 | # if auth has been provided add it to the request 153 | self.setup-auth($request); 154 | $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; 155 | my Connection $conn = self.get-connection($request); 156 | 157 | if $conn.send-request($request) { 158 | $response = self.get-response($request, $conn, :$bin); 159 | } 160 | $conn.close; 161 | 162 | X::HTTP::Response.new(:rc('No response')).throw unless $response; 163 | 164 | $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; 165 | 166 | # save cookies 167 | $.cookies.extract-cookies($response); 168 | 169 | if $response.code ~~ /^30<[0123]>/ { 170 | $!redirects-in-a-row++; 171 | if $.max-redirects < $.redirects-in-a-row { 172 | X::HTTP::Response.new(:rc('Max redirects exceeded'), :response($response)).throw; 173 | } 174 | my $new-request = $response.next-request(); 175 | return self.request($new-request); 176 | } 177 | else { 178 | $!redirects-in-a-row = 0; 179 | } 180 | if $!throw-exceptions { 181 | given $response.code { 182 | when /^4/ { 183 | X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; 184 | } 185 | when /^5/ { 186 | X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; 187 | } 188 | } 189 | } 190 | 191 | $response 192 | } 193 | 194 | proto method get-content(|) {*} 195 | 196 | # When we have a content-length 197 | multi method get-content(Connection $conn, Blob $content, $content-length --> Blob:D) { 198 | if $content.bytes == $content-length { 199 | $content 200 | } 201 | else { 202 | # Create a Buf with what we have now and append onto 203 | # it until we've read the right amount. 204 | my $buf = Buf.new($content); 205 | my int $total-bytes-read = $content.bytes; 206 | while $content-length > $total-bytes-read { 207 | my $read = $conn.recv($content-length - $total-bytes-read, :bin); 208 | $buf.append($read); 209 | $total-bytes-read += $read.bytes; 210 | } 211 | $buf 212 | } 213 | } 214 | 215 | # fallback when not chunked and no content length 216 | multi method get-content(Connection $conn, Blob $content is rw --> Blob:D) { 217 | 218 | while my $new_content = $conn.recv(:bin) { 219 | $content ~= $new_content; 220 | } 221 | $content; 222 | } 223 | 224 | method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { 225 | my Buf $chunk = $content.clone; 226 | $content = Buf.new; 227 | # We carry on as long as we receive something. 228 | PARSE_CHUNK: loop { 229 | my $end_pos = _index_buf($chunk, CRLF); 230 | if $end_pos >= 0 { 231 | my $size = $chunk.subbuf(0, $end_pos).decode; 232 | # remove optional chunk extensions 233 | $size = $size.subst(/';'.*$/, ''); 234 | # www.yahoo.com sends additional spaces(maybe invalid) 235 | $size = $size.subst(/' '*$/, ''); 236 | $chunk = $chunk.subbuf($end_pos+2); 237 | my $chunk-size = :16($size); 238 | if $chunk-size == 0 { 239 | last PARSE_CHUNK; 240 | } 241 | while $chunk-size+2 > $chunk.bytes { 242 | $chunk ~= $conn.recv($chunk-size+2-$chunk.bytes, :bin); 243 | } 244 | $content ~= $chunk.subbuf(0, $chunk-size); 245 | $chunk = $chunk.subbuf($chunk-size+2); 246 | } 247 | else { 248 | # XXX Reading 1 byte is inefficient code. 249 | # 250 | # But IO::Socket#read/IO::Socket#recv reads from socket until 251 | # fill the requested size. 252 | # 253 | # It cause hang-up on socket reading. 254 | my $byte = $conn.recv(1, :bin); 255 | last PARSE_CHUNK unless $byte.elems; 256 | $chunk ~= $byte; 257 | } 258 | }; 259 | 260 | $content 261 | } 262 | 263 | method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTTP::Response:D) { 264 | my Blob[uint8] $first-chunk = Blob[uint8].new; 265 | my $msg-body-pos; 266 | 267 | CATCH { 268 | when X::HTTP::NoResponse { 269 | X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; 270 | } 271 | when /'Connection reset by peer'/ { 272 | X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; 273 | } 274 | } 275 | 276 | # Header can be longer than one chunk 277 | while my $t = $conn.recv( :bin ) { 278 | $first-chunk ~= $t; 279 | 280 | # Find the header/body separator in the chunk, which means 281 | # we can parse the header seperately and are able to figure 282 | # out the correct encoding of the body. 283 | $msg-body-pos = search-header-end($first-chunk); 284 | last if $msg-body-pos.defined; 285 | } 286 | 287 | 288 | # If the header would indicate that there won't 289 | # be any content there may not be a \r\n\r\n at 290 | # the end of the header. 291 | my $header-chunk = do if $msg-body-pos.defined { 292 | $first-chunk.subbuf(0, $msg-body-pos); 293 | } 294 | else { 295 | # Assume we have the whole header because if the server 296 | # didn't send it we're stuffed anyway 297 | $first-chunk; 298 | } 299 | 300 | 301 | my HTTP::Response $response = HTTP::Response.new($header-chunk); 302 | $response.request = $request; 303 | 304 | if $response.has-content { 305 | if !$msg-body-pos.defined { 306 | X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; 307 | } 308 | 309 | 310 | my $content = $first-chunk.subbuf($msg-body-pos); 311 | # Turn the inner exceptions to ours 312 | # This may really want to be outside 313 | CATCH { 314 | when X::HTTP::ContentLength { 315 | X::HTTP::Header.new( :rc($_.message), :response($response) ).throw 316 | } 317 | } 318 | # We also need to handle 'Transfer-Encoding: chunked', which means 319 | # that we request more chunks and assemble the response body. 320 | if $response.is-chunked { 321 | $content = self.get-chunked-content($conn, $content); 322 | } 323 | elsif $response.content-length -> $content-length is copy { 324 | $content = self.get-content($conn, $content, $content-length); 325 | } 326 | else { 327 | $content = self.get-content($conn, $content); 328 | } 329 | 330 | $response.content = $content andthen $response.content = $response.decoded-content(:$bin); 331 | } 332 | $response 333 | } 334 | 335 | 336 | proto method get-connection(|) {*} 337 | 338 | multi method get-connection(HTTP::Request $request --> Connection:D) { 339 | my $host = $request.host; 340 | my $port = $request.port; 341 | 342 | 343 | if self.get-proxy($request) -> $http_proxy { 344 | $request.file = $request.url; 345 | my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; 346 | ($host, $port) = $proxy_host.split(':'); 347 | $port.=Int; 348 | if $proxy_auth.defined { 349 | $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); 350 | } 351 | $request.field(Connection => 'close'); 352 | } 353 | self.get-connection($request, $host, $port) 354 | } 355 | 356 | my $https_lock = Lock.new; 357 | multi method get-connection(HTTP::Request $request, Str $host, Int $port? --> Connection:D) { 358 | my $conn; 359 | if $request.scheme eq 'https' { 360 | $https_lock.lock; 361 | try require ::("IO::Socket::SSL"); 362 | $https_lock.unlock; 363 | die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; 364 | $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) 365 | } 366 | else { 367 | $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); 368 | } 369 | $conn does Connection; 370 | $conn 371 | } 372 | 373 | # heuristic to determine whether we are running in the CGI 374 | # please adjust as required 375 | method is-cgi() returns Bool { 376 | %*ENV:exists or %*ENV:exists; 377 | } 378 | 379 | has $.http-proxy; 380 | # want the request to possibly match scheme, no_proxy etc 381 | method get-proxy(HTTP::Request $request) { 382 | $!http-proxy //= do if self.is-cgi { 383 | %*ENV || %*ENV; 384 | } 385 | else { 386 | %*ENV || %*ENV; 387 | } 388 | if self.use-proxy( $request ) { 389 | $!http-proxy; 390 | } 391 | } 392 | 393 | has @.no-proxy; 394 | 395 | has Bool $!no-proxy-check = False; 396 | 397 | method no-proxy() { 398 | if @!no-proxy.elems == 0 { 399 | if not $!no-proxy-check { 400 | if (%*ENV || %*ENV ) -> $no-proxy { 401 | @!no-proxy = $no-proxy.split: /\s*\,\s*/; 402 | } 403 | $!no-proxy-check = True; 404 | } 405 | } 406 | @!no-proxy; 407 | } 408 | 409 | proto method use-proxy(|) {*} 410 | 411 | multi method use-proxy(HTTP::Request $request --> Bool:D) { 412 | self.use-proxy($request.host) 413 | } 414 | 415 | multi method use-proxy(Str $host) returns Bool { 416 | my $rc = True; 417 | 418 | for self.no-proxy -> $no-proxy { 419 | if $host ~~ /$no-proxy/ { 420 | $rc = False; 421 | last; 422 | } 423 | } 424 | $rc 425 | } 426 | 427 | multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { 428 | basic-auth-token("{$login}:{$passwd}"); 429 | 430 | } 431 | 432 | multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { 433 | "Basic " ~ MIME::Base64.encode-str($creds, :oneline); 434 | } 435 | 436 | method setup-auth(HTTP::Request $request) { 437 | # use HTTP Auth 438 | if self.use-auth($request) { 439 | $request.field(Authorization => basic-auth-token($!auth_login,$!auth_password)); 440 | } 441 | } 442 | 443 | method use-auth(HTTP::Request $request) { 444 | $!auth_login.defined && $!auth_password.defined; 445 | } 446 | 447 | # :simple 448 | our sub get($target where URI|Str) is export(:simple) { 449 | my $ua = HTTP::UserAgent.new(:throw-exceptions); 450 | my $response = $ua.get($target); 451 | 452 | $response.decoded-content 453 | } 454 | 455 | our sub head(Str $url) is export(:simple) { 456 | my $ua = HTTP::UserAgent.new(:throw-exceptions); 457 | $ua.get($url).header.hash 458 | } 459 | 460 | our sub getprint(Str $url) is export(:simple) { 461 | my $response = HTTP::UserAgent.new(:throw-exceptions).get($url); 462 | print $response.decoded-content; 463 | $response.code 464 | } 465 | 466 | our sub getstore(Str $url, Str $file) is export(:simple) { 467 | $file.IO.spurt: get($url) 468 | } 469 | 470 | sub _clear-url(Str $url is copy) { 471 | $url.starts-with('http://' | 'https://') 472 | ?? $url 473 | !! "http://$url" 474 | } 475 | 476 | # vim: expandtab shiftwidth=4 477 | -------------------------------------------------------------------------------- /lib/HTTP/UserAgent/Common.rakumod: -------------------------------------------------------------------------------- 1 | my constant %useragents = 2 | chrome_w7_64 => 'Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.131 Safari/537.36', 3 | firefox_w7_64 => 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:29.0) Gecko/20100101 Firefox/29.0', 4 | ie_w7_64 => 'Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko', 5 | chrome_w81_64 => 'Mozilla/5.0 (Windows NT 6.3; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.131 Safari/537.36', 6 | firefox_w81_64 => 'Mozilla/5.0 (Windows NT 6.3; WOW64; rv:29.0) Gecko/20100101 Firefox/29.0', 7 | mob_safari_osx => 'Mozilla/5.0 (iPhone; CPU iPhone OS 7_1_1 like Mac OS X) AppleWebKit/537.51.2 (KHTML, like Gecko) Version/7.0 Mobile/11D201 Safari/9537.53', 8 | safari_osx => 'Mozilla/5.0 (Macintosh; Intel Mac OS X 10_9_2) AppleWebKit/537.75.14 (KHTML, like Gecko) Version/7.0.3 Safari/537.75.14', 9 | chrome_osx => 'Mozilla/5.0 (Macintosh; Intel Mac OS X 10_9_2) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.131 Safari/537.36', 10 | firefox_linux => 'Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:29.0) Gecko/20100101 Firefox/29.0', 11 | chrome_linux => 'Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.132 Safari/537.36', 12 | ; 13 | 14 | my sub get-ua($ua) is export { 15 | %useragents{$ua} // $ua 16 | } 17 | 18 | # vim: expandtab shiftwidth=4 19 | -------------------------------------------------------------------------------- /lib/HTTP/UserAgent/Exception.rakumod: -------------------------------------------------------------------------------- 1 | module HTTP::UserAgent::Exception { 2 | use HTTP::Message; 3 | 4 | class X::HTTP is Exception { 5 | has $.rc; 6 | has HTTP::Message $.response; 7 | } 8 | 9 | class X::HTTP::Internal is Exception { 10 | has $.rc; 11 | has $.reason; 12 | 13 | method message { 14 | "Internal Error: '$.reason'"; 15 | } 16 | } 17 | 18 | class X::HTTP::Response is X::HTTP { 19 | has $.message; 20 | method message { 21 | $!message //= "Response error: '$.rc'"; 22 | } 23 | } 24 | 25 | class X::HTTP::Server is X::HTTP { 26 | method message { 27 | "Server error: '$.rc'"; 28 | } 29 | } 30 | 31 | class X::HTTP::Header is X::HTTP::Server { 32 | } 33 | 34 | class X::HTTP::ContentLength is X::HTTP::Response { 35 | } 36 | 37 | class X::HTTP::NoResponse is X::HTTP::Response { 38 | has $.message = "missing or incomplete response line"; 39 | has $.got; 40 | } 41 | } 42 | 43 | # vim: expandtab shiftwidth=4 ft=perl6 44 | -------------------------------------------------------------------------------- /run-tests: -------------------------------------------------------------------------------- 1 | unit sub MAIN( 2 | :a($author), 3 | :i($install), 4 | :$rmd, 5 | :$disable-spesh, 6 | :$disable-spesh-inline, 7 | :$disable-JIT, 8 | :$enable-spesh-nodelay, 9 | :$enable-spesh-blocking, 10 | :$enable-spesh-log, 11 | ); 12 | 13 | say run(, :out).out.slurp.chomp; 14 | say "Running on $*DISTRO.gist().\n"; 15 | 16 | if $rmd { 17 | %*ENV := 1; 18 | say "RAKUDO_MODULE_DEBUG=1"; 19 | } 20 | 21 | if $disable-spesh { 22 | %*ENV := 1; 23 | say "MVM_SPESH_DISABLE=1"; 24 | } 25 | 26 | if $disable-spesh-inline { 27 | %*ENV := 1; 28 | say "MVM_SPESH_INLINE_DISABLE=1"; 29 | } 30 | 31 | if $disable-JIT { 32 | %*ENV := 1; 33 | say "MVM_JIT_DISABLE=1"; 34 | } 35 | 36 | if $enable-spesh-nodelay { 37 | %*ENV := 1; 38 | say "MVM_SPESH_NODELAY=1"; 39 | } 40 | 41 | if $enable-spesh-blocking { 42 | %*ENV := 1; 43 | say "MVM_SPESH_BLOCKING=1"; 44 | } 45 | 46 | my $spesh-log; 47 | if $enable-spesh-log { 48 | $spesh-log = ( 49 | $enable-spesh-log ~~ Bool ?? "spesh-log" !! $enable-spesh-log 50 | ).IO; 51 | %*ENV := $spesh-log.absolute; 52 | say "MVM_SPESH_LOG=$spesh-log.relative()"; 53 | } 54 | 55 | say "" 56 | if $rmd 57 | || $disable-spesh 58 | || $disable-spesh-inline 59 | || $disable-JIT 60 | || $enable-spesh-nodelay 61 | || $enable-spesh-blocking 62 | || $enable-spesh-log; 63 | 64 | say "Testing { 65 | (try "dist.ini".IO.lines.head.substr(7)) // "..." 66 | }{ 67 | " including author tests" if $author 68 | }"; 69 | 70 | my @failed; 71 | my $done = 0; 72 | 73 | sub process($proc, $filename) { 74 | if $proc { 75 | $proc.out.slurp; 76 | $spesh-log.unlink if $spesh-log; 77 | } 78 | else { 79 | @failed.push($filename); 80 | if $proc.out.slurp -> $stdout { 81 | my @lines = $stdout.lines; 82 | with @lines.first( 83 | *.starts-with(" from gen/moar/stage2"),:k) 84 | -> $index { 85 | say @lines[^$index].join("\n"); 86 | } 87 | else { 88 | say $stdout; 89 | } 90 | } 91 | else { 92 | say "No output received, exit-code $proc.exitcode() ($proc.signal()):\n$proc.os-error()"; 93 | } 94 | 95 | if $spesh-log { 96 | say "\nSpesh log requested, showing last 20000 lines:"; 97 | say $spesh-log.lines(:!chomp).tail(20000).join; 98 | $spesh-log.unlink; 99 | } 100 | } 101 | } 102 | 103 | sub install() { 104 | my $zef := $*DISTRO.is-win ?? 'zef.bat' !! 'zef'; 105 | my $proc := run $zef, "install", ".", "--verbose", "--/test", :out,:err,:merge; 106 | process($proc, "*installation*"); 107 | } 108 | 109 | sub test-dir($dir) { 110 | for $dir.IO.dir(:test(*.ends-with: '.t' | '.rakutest')).map(*.Str).sort { 111 | say "=== $_"; 112 | my $proc := run "raku", "--ll-exception", "-I.", $_, :out,:err,:merge; 113 | process($proc, $_); 114 | $done++; 115 | } 116 | } 117 | 118 | test-dir("t"); 119 | test-dir($_) for dir("t", :test({ !.starts-with(".") && "t/$_".IO.d})).map(*.Str).sort; 120 | test-dir("xt") if $author && "xt".IO.e; 121 | if $install { 122 | install; 123 | ++$done; 124 | } 125 | 126 | if @failed { 127 | say "\nFAILED: {+@failed} of $done:"; 128 | say " $_" for @failed; 129 | exit +@failed; 130 | } 131 | 132 | say "\nALL {"$done " if $done > 1}OK"; 133 | 134 | # vim: expandtab shiftwidth=4 135 | -------------------------------------------------------------------------------- /t/001-meta.rakutest: -------------------------------------------------------------------------------- 1 | #!perl6 2 | 3 | use v6; 4 | use lib 'lib'; 5 | 6 | use Test; 7 | 8 | my Bool $got-test-meta = True; 9 | 10 | my &m-meta-ok; 11 | 12 | BEGIN { 13 | require Test::META <&meta-ok>; 14 | $got-test-meta = True; 15 | 16 | &m-meta-ok = &meta-ok; 17 | 18 | CATCH { 19 | when X::CompUnit::UnsatisfiedDependency { 20 | plan 1; 21 | skip-rest "no Test::META - skipping"; 22 | done-testing; 23 | exit; 24 | } 25 | } 26 | 27 | } 28 | 29 | plan 1; 30 | 31 | if $got-test-meta { 32 | m-meta-ok(); 33 | } 34 | else { 35 | skip "no Test::META skipping"; 36 | } 37 | 38 | 39 | done-testing; 40 | # vim: expandtab shiftwidth=4 ft=perl6 41 | -------------------------------------------------------------------------------- /t/010-headers.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::Header; 3 | 4 | plan 23; 5 | 6 | # new 7 | my $h = HTTP::Header.new(a => "A", b => "B"); 8 | 9 | is ~$h.field('b'), 'B', 'new'; 10 | 11 | # field 12 | is ~$h.field('a'), 'A', 'field 1/4'; 13 | 14 | $h.field(a => ['a', 'a1']); 15 | is ~$h.field('a'), 'a, a1', 'field 2/4'; 16 | 17 | $h.field(a => 'a'); 18 | is ~$h.field('a'), 'a', 'field 3/4'; 19 | 20 | # case insensitive 21 | is ~$h.field('A'), 'a', 'field 4/4'; 22 | 23 | # init-field 24 | $h.init-field(b => 'b'); 25 | is ~$h.field('b'), 'B', 'init-field 1/1'; 26 | 27 | # push-field 28 | $h.push-field(a => ['a2', 'a3']); 29 | is ~$h.field('a'), 'a, a2, a3', 'push-field 1/1'; 30 | 31 | # header-field-names 32 | is $h.header-field-names.elems, 2, 'header-field-names 1/3'; 33 | is any($h.header-field-names), 'a', 'header-field-names 2/3'; 34 | is any($h.header-field-names), 'b', 'header-field-names 3/3'; 35 | 36 | # Str 37 | is-deeply $h.Str, "a: a, a2, a3\nb: B\n", 'Str 1/2'; 38 | is-deeply $h.Str('|'), 'a: a, a2, a3|b: B|', 'Str 2/2'; 39 | 40 | # remove-field 41 | $h.remove-field('a'); 42 | ok not $h.field('a'), 'remove-field 1/1'; 43 | 44 | # clear 45 | $h.clear; 46 | ok not $h.field('b'), 'clear 1/1'; 47 | 48 | $h = HTTP::Header.new(One => "one", Two => "two"); 49 | 50 | is $h.hash, "one", "Got one (hash 1/2)"; 51 | is $h.hash, "two", "Got two (hash 2/2)"; 52 | 53 | $h = HTTP::Header.new(); 54 | 55 | lives-ok { $h.parse('ETag: W/"1201-51b0ce7ad3900"') }, "parses ETag"; 56 | is ~$h.field('ETag'), "1201-51b0ce7ad3900", "got the value we expected"; 57 | 58 | lives-ok { $h.parse('expires: Wed, 27 Jan 2016 17:44:43 GMT') }, "parses date on a Wed"; 59 | ok $h.field('expires') ~~ /^^Wed/, "Does not trip start of field value starting with 'W'"; 60 | 61 | # ugexe++ -- See http://irclog.perlgeek.de/perl6/2017-09-27#i_15227591 62 | lives-ok { $h.parse('Custom-Auth-Header: W/7fhEfhkjafeHF') }, "parses ETag like"; 63 | is ~$h.field('Custom-Auth-Header'), 'W/7fhEfhkjafeHF', 'got the non truncated value'; 64 | 65 | subtest { 66 | my $htest = q:to/EOH/; 67 | Cache-Control: max-age=21600 68 | Connection: close 69 | Date: Mon, 25 Jan 2016 17:44:43 GMT 70 | Accept-Ranges: bytes 71 | ETag: "276-422ea2b4cfcc0" 72 | Server: Apache/2 73 | Vary: upgrade-insecure-requests 74 | Content-Length: 630 75 | Content-Type: text/html 76 | Expires: Mon, 25 Jan 2016 23:44:43 GMT 77 | Last-Modified: Thu, 23 Nov 2006 13:37:31 GMT 78 | Client-Date: Mon, 25 Jan 2016 17:44:43 GMT 79 | Client-Peer: 128.30.52.100:80 80 | Client-Response-Num: 1 81 | Link: ; rel="stylesheet" 82 | P3P: policyref="http://www.w3.org/2014/08/p3p.xml" 83 | Title: Test of a utf8 page served as text/html with UTF8 BOM 84 | EOH 85 | my $h = HTTP::Header.new; 86 | $h.parse($htest); 87 | is $h.fields.elems,17, "got the number of fields we expected"; 88 | }, "test full parse of problematic header"; 89 | 90 | # vim: expandtab shiftwidth=4 91 | -------------------------------------------------------------------------------- /t/020-message.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::Message; 3 | 4 | plan 21; 5 | 6 | # new 7 | my $m = HTTP::Message.new('somecontent', a => ['a1', 'a2']); 8 | 9 | isa-ok $m, HTTP::Message, 'new 1/4'; 10 | isa-ok $m.header, HTTP::Header, 'new 2/4'; 11 | is $m.field('a'), 'a1, a2', 'new 3/4'; 12 | is $m.content, 'somecontent', 'new 4/4'; 13 | 14 | # push-field 15 | $m.push-field(a => 'a3'); 16 | is $m.field('a'), 'a1, a2, a3', 'push-field 1/2'; 17 | $m.push-field(a => ); 18 | is $m.field('a'), 'a1, a2, a3, a4, a5', 'push-field 2/2'; 19 | 20 | # add-content 21 | $m.add-content('some'); 22 | is $m.content, 'somecontentsome', 'add-content 1/2'; 23 | 24 | $m.add-content('line'); 25 | is $m.content, 'somecontentsomeline', 'add-content 2/2'; 26 | 27 | # remove-field 28 | $m.remove-field('a'); 29 | nok $m.field('a'), 'remove-field 1/1'; 30 | 31 | # parse 32 | my $to_parse = "GET site HTTP/1.0\r\na: b, c\r\na: d\r\n" 33 | ~ "\r\nline\r\n"; 34 | $m.parse($to_parse); 35 | is $m.field('a'), 'b, c, d', 'parse 1/4'; 36 | is $m.field('a').values[0], 'b', 'parse 2/4'; 37 | is $m.content, 'line', 'parse 3/4'; 38 | is $m.protocol, 'HTTP/1.0', 'parse 4/4'; 39 | 40 | # Str 41 | is $m.Str, "a: b, c, d\n\nline\n", 'Str 1/2'; 42 | is $m.Str("\r\n"), "a: b, c, d\r\n\r\nline\r\n", 'Str 2/2'; 43 | 44 | # clear 45 | $m.clear; 46 | is $m.Str, '', 'clear 1/2'; 47 | is $m.content, '', 'clear 2/2'; 48 | 49 | ## parse a more complex example 50 | # new 51 | my $m2 = HTTP::Message.new; 52 | 53 | my $CRLF = "\r\n"; 54 | # parse 55 | $to_parse = "HTTP/1.1 200 OK\r\n" 56 | ~ "Server: Apache/2.2.3 (CentOS)\r\n" 57 | ~ "Last-Modified: Sat, 31 May 2014 16:39:02 GMT\r\n" 58 | ~ "ETag: \"16d3e2-20416-4fab4ccb03580\"\r\n" 59 | ~ "Vary: Accept-Encoding\r\n" 60 | ~ "Content-Type: text/plain; charset=UTF-8\r\n" 61 | ~ "Transfer-Encoding: chunked\r\n" 62 | ~ "Date: Mon, 02 Jun 2014 17:07:52 GMT\r\n" 63 | ~ "X-Varnish: 1992382947 1992382859\r\n" 64 | ~ "Age: 40\r\n" 65 | ~ "Via: 1.1 varnish\r\n" 66 | ~ "Connection: close\r\n" 67 | ~ "X-Served-By: eu3.develooper.com\r\n" 68 | ~ "X-Cache: HIT\r\n" 69 | ~ "X-Cache-Hits: 2\r\n" 70 | ~ "\r\n" 71 | ~ "008000\r\n" 72 | ~ "# Last updated Sat May 31 16:39:01 2014 (UTC)\n" 73 | ~ "# \n" 74 | ~ "# Explanation of the syntax:\n"; 75 | $m2.parse($to_parse); 76 | 77 | is ~$m2.field('ETag'), '"16d3e2-20416-4fab4ccb03580"', 'parse complex 1/3'; 78 | is ~$m2.field('Transfer-Encoding'), 'chunked', 'parse complex 2/3'; 79 | is ~$m2.field('Content-Type'), 'text/plain; charset=UTF-8', 'parse complex 3/3'; 80 | 81 | subtest { 82 | is HTTP::Message.new.charset, 'iso-8859-1', "dumb default charset"; 83 | is HTTP::Message.new(Content-Type => 'text/plain').charset, 'iso-8859-1', 'default text charset'; 84 | is HTTP::Message.new(Content-Type => 'application/xml').charset, 'utf-8', 'default "non-text" charset'; 85 | is HTTP::Message.new(Content-Type => 'text/html; charset=utf-8').charset, 'utf-8', "explicity charset"; 86 | }, "charset"; 87 | 88 | # vim: expandtab shiftwidth=4 89 | -------------------------------------------------------------------------------- /t/030-cookies.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::Cookies; 3 | # strangely these aren't required for the test to work 4 | 5 | plan 31; 6 | 7 | BEGIN my $file = $*PROGRAM.sibling('cookies.dat').absolute; 8 | LEAVE try $file.IO.unlink; 9 | 10 | my $c = HTTP::Cookies.new( 11 | file => $file, 12 | ); 13 | 14 | # new 15 | ok $c, 'new 1/3'; 16 | is $c.file, $file, 'new 2/3'; 17 | is $c.autosave, 0, 'new 3/3'; 18 | 19 | # set-cookie 20 | $c.set-cookie( 21 | 'Set-Cookie: name1=value1; expires=DATE; Path=/; Domain=gugle.com; Secure; HttpOnly' 22 | ); 23 | my $c1 = $c.cookies[0]; 24 | ok $c1, 'set-cookie 1/11'; 25 | is $c1.name, 'name1', 'set-cookie 2/11'; 26 | is $c1.value, 'value1', 'set-cookie 3/11'; 27 | is $c1.fields.elems, 0, 'set-cookie 4/11'; 28 | is $c1.secure, 'Secure', 'set-cookie 5/11'; 29 | is $c1.httponly, 'HttpOnly', 'set-cookie 6/11'; 30 | 31 | $c.set-cookie( 32 | 'Set-Cookie: name2=value2; expires=DATE2; Path=/path; Domain=gugle.com;' 33 | ); 34 | my $c2 = $c.cookies[1]; 35 | ok $c2, 'set-cookie 7/11'; 36 | is $c2.name, 'name2', 'set-cookie 8/11'; 37 | is $c2.value, 'value2', 'set-cookie 9/11'; 38 | is $c2.fields.elems, 0, 'set-cookie 10/11'; 39 | ok !$c2.secure, 'set-cookie 11/11'; 40 | 41 | # Str 42 | my $result = "Set-Cookie: name1=value1; expires=DATE; Path=/; Domain=gugle.com; Secure; HttpOnly\nSet-Cookie: name2=value2; expires=DATE2; Path=/path; Domain=gugle.com"; 43 | 44 | my token set_cookie { 45 | ^^ Set\-Cookie\:\s+ 46 | } 47 | 48 | my token name_1 { name1\=value1\;\s+ } 49 | my token expires_1 { :i expires\=DATE } 50 | my token path_1 { :i Path\=\/ } 51 | my token domain_1 { :i Domain\=gugle\.com } 52 | my token secure_1 { Secure } 53 | my token http_only_1 { HttpOnly } 54 | my token fields_1 { 55 | [ 56 | | 57 | | 58 | | 59 | | 60 | ] * % '; ' 61 | 62 | } 63 | 64 | my token cookie_1 { 65 | 66 | 67 | 68 | $$ 69 | } 70 | 71 | 72 | my token name_2 { name2\=value2\;\s+ } 73 | 74 | my token expires_2 { :i expires\=DATE2 } 75 | my token path_2 { :i Path\=\/path } 76 | my token domain_2 { :i Domain\=gugle\.com } 77 | 78 | my token fields_2 { 79 | [ 80 | 81 | | 82 | | 83 | ] * % '; ' 84 | } 85 | 86 | 87 | my token cookie_2 { 88 | 89 | 90 | 91 | $$ 92 | } 93 | 94 | 95 | my rule cookies { 96 | 97 | 98 | } 99 | 100 | like $c.Str, /^$/, "Str 1/6"; 101 | like $c.Str, //, "Str 2/6"; 102 | like $c.Str, //, "Str 3/6"; 103 | like $c.Str, //, "Str 4/6"; 104 | like $c.Str, //, "Str 5/6"; 105 | like $c.Str, //, "Str 6/6"; 106 | 107 | 108 | 109 | # save 110 | my $file_header = "#LWP6-Cookies-0.1\n"; 111 | my $elems_before_save = $c.cookies.elems; 112 | $c.save; 113 | 114 | my token file_header { ^^ '#'LWP6\-Cookies\-0\.1 $$ } 115 | 116 | my rule cookie_file { 117 | 118 | 119 | 120 | } 121 | 122 | like $c.file.IO.slurp, //, 'save 1/1'; 123 | 124 | # clear 125 | $c.clear; 126 | ok !$c.cookies, 'clear 1/1'; 127 | 128 | # load 129 | $c.load; 130 | 131 | is $c.cookies.elems, $elems_before_save, "Same number of cookies"; 132 | #like $c.Str, /^$/, "load 1/1"; 133 | 134 | $c = HTTP::Cookies.new( 135 | file => $file, 136 | autosave => 1, 137 | ); 138 | $c.load; 139 | 140 | # add-cookie-header 141 | $c.set-cookie( 142 | 'Set-Cookie: namek=songo; expires=DATE2; Domain=gugyl.com;' 143 | ); 144 | 145 | my $req = HTTP::Request.new(GET => 'http://gugyl.com'); 146 | $c.add-cookie-header($req); 147 | # Domain restriction 148 | is $req.field('Cookie').values.elems, 1, 'add-cookie-header 1/?'; 149 | 150 | $c.set-cookie( 151 | 'Set-Cookie: name3=value3; expires=DATE2; Path=/;' 152 | ); 153 | $req = HTTP::Request.new(GET => 'http://gugle.com'); 154 | $c.add-cookie-header($req); 155 | # 'Domain'less cookies 156 | # 157 | # TODO: 158 | #is $req.field('Cookie').values.elems, 2, 'add-cookie-header 2/3'; 159 | 160 | $req = HTTP::Request.new(GET => 'http://gugle.com/path'); 161 | $c.add-cookie-header($req); 162 | # Path restriction 163 | # 164 | # TODO: 165 | #is $req.field('Cookie').values.elems, 1, 'add-cookie-header 3/3'; 166 | 167 | # extract-cookkies 168 | subtest { 169 | my $resp = HTTP::Response.new(200); 170 | $resp.field(Set-Cookie => 'k=v'); 171 | $c.extract-cookies($resp); 172 | is $c.cookies.elems, 5, 'extract-cookies 1/1'; 173 | }, "extract-cookies 1/1"; 174 | 175 | # clear-expired 176 | $c.set-cookie('Set-Cookie: n1=v1; Expires=Sun, 06 Nov 1994 08:49:37 GMT'); 177 | ok $c.clear-expired, 'clear-expired 1/3'; 178 | is $c.cookies.elems, 5, 'clear-expired 2/3'; 179 | ok ! $c.cookies.grep({ .name eq 'n1' }), 'clear-expired 3/3'; 180 | 181 | # autosave 182 | $c.clear; 183 | is $c.cookies.elems, 0, 'autosave 1/1'; 184 | 185 | subtest { 186 | 187 | lives-ok { 188 | my $c = HTTP::Cookies.new; 189 | lives-ok { $c.set-cookie('Set-Cookie: mykey=myvalue;'); }, "set cookie with mykey=myvalue"; 190 | is $c.cookies.elems, 1, "got one cookie"; 191 | is $c.cookies[0].name, "mykey", "got the expected name"; 192 | is $c.cookies[0].value, "myvalue", "got the expected value"; 193 | }, "no hyphen in either key or value"; 194 | 195 | lives-ok { 196 | my $c = HTTP::Cookies.new; 197 | lives-ok { $c.set-cookie('Set-Cookie: mykey=my-value;'); }, "set cookie with mykey=my-value"; 198 | is $c.cookies.elems, 1, "got one cookie"; 199 | is $c.cookies[0].name, "mykey", "got the expected name"; 200 | is $c.cookies[0].value, "my-value", "got the expected value"; 201 | }, "hyphen in value"; 202 | 203 | lives-ok { 204 | my $c = HTTP::Cookies.new; 205 | lives-ok { $c.set-cookie('Set-Cookie: my-key=myvalue;'); }, "set cookie with my-key=myvalue"; 206 | is $c.cookies.elems, 1, "got one cookie"; 207 | is $c.cookies[0].name, "my-key", "got the expected name"; 208 | is $c.cookies[0].value, "myvalue", "got the expected value"; 209 | }, "hyphen in name"; 210 | 211 | lives-ok { 212 | my $c = HTTP::Cookies.new; 213 | lives-ok { $c.set-cookie('Set-Cookie: my-key=my-value;'); }, "set cookie with my-key=my-value"; 214 | is $c.cookies.elems, 1, "got one cookie"; 215 | is $c.cookies[0].name, "my-key", "got the expected name"; 216 | is $c.cookies[0].value, "my-value", "got the expected value"; 217 | }, "hyphen in name and value"; 218 | 219 | }, "issue #154"; 220 | 221 | subtest { 222 | my $c = HTTP::Cookies.new; 223 | lives-ok { $c.set-cookie('Set-Cookie: icwp-app-flash=deleted; expires=Thu, 01-Jan-1970 00:00:01 GMT; Max-Age=0; path=/'); }, "set cookie with representative values"; 224 | is $c.cookies.elems, 1, "got one cookies"; 225 | is $c.cookies[0].name, "icwp-app-flash", "got right name"; 226 | is $c.cookies[0].value, "deleted", "and the right value"; 227 | is $c.cookies[0].fields.elems, 1, "and got the one field that was expected"; 228 | is $c.cookies[0].fields,0, "and the field is correct"; 229 | }, "issue #163"; 230 | 231 | # vim: expandtab shiftwidth=4 232 | -------------------------------------------------------------------------------- /t/040-request.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::Request; 2 | use Test; 3 | 4 | use URI; 5 | 6 | plan 28; 7 | 8 | my $url = 'http://testsite.ext/cat/f.h?q=1&q=2'; 9 | my $file = '/cat/f.h?q=1&q=2'; 10 | my $host = 'testsite.ext'; 11 | 12 | # new 13 | my $r1 = HTTP::Request.new(POST => $url, test_field => 'this_is_field'); 14 | 15 | is $r1.method, 'post'.uc, 'new 1/8'; 16 | is $r1.url, $url, 'new 2/8'; 17 | is $r1.file, $file, 'new 3/8'; 18 | is $r1.field('Host'), $host, 'new 4/8'; 19 | is $r1.field('test_field'), 'this_is_field', 'new 5/8'; 20 | ok $r1.Str ~~ /^POST\s$file/, 'new 6/8'; 21 | isa-ok $r1, HTTP::Request, 'new 7/8'; 22 | isa-ok $r1, HTTP::Message, 'new 8/8'; 23 | 24 | # content 25 | $r1.add-content('n1=v1&a'); 26 | is $r1.content, 'n1=v1&a', 'content 1/1'; 27 | 28 | # field 29 | $r1.field(Accept => 'test'); 30 | is $r1.field('Accept'), 'test', 'field 1/2'; 31 | $r1.field(Accept => 'test2'); 32 | is $r1.field('Accept'), 'test2', 'field 2/2'; 33 | 34 | # uri 35 | $file = '/cat/b.a?r=1&r=2'; 36 | $r1.uri('http://test.com' ~ $file); 37 | is $r1.url, 'http://test.com' ~ $file, 'uri 1/4'; 38 | is $r1.field('Host'), 'test.com', 'uri 2/4'; 39 | is $r1.file, $file, 'uri 3/4'; 40 | ok $r1.Str ~~ /^POST\s$file/, 'uri 4/4'; 41 | 42 | # check construction of host header 43 | $r1.uri('http://test.com:8080'); 44 | is $r1.url, 'http://test.com:8080', 'uri 3/4'; 45 | is $r1.field('Host'), 'test.com:8080', 'uri 4/4'; 46 | 47 | # set-method 48 | throws-like({ $r1.set-method: 'TEST' }, /'expected HTTP::Request::RequestMethod but got Str'/, "rejects wrong method"); 49 | lives-ok { $r1.set-method: 'PUT' }, "set method"; 50 | is $r1.method, 'PUT', 'set-method 1/1'; 51 | 52 | # parse 53 | my $req = "GET /index HTTP/1.1\r\nHost: somesite\r\nAccept: test\r\n\r\nname=value&a=b\r\n"; 54 | $r1 = HTTP::Request.new.parse($req); 55 | 56 | is $r1.method, 'get'.uc, 'parse 1/6'; 57 | is $r1.file, '/index', 'parse 2/6'; 58 | is $r1.url, 'http://somesite/index', 'parse 3/6'; 59 | is $r1.field('Accept'), 'test', 'parse 4/6'; 60 | is $r1.content, 'name=value&a=b', 'parse 5/6'; 61 | is $r1.Str, $req, 'parse 6/6'; 62 | 63 | subtest { 64 | my $r; 65 | lives-ok { $r = HTTP::Request.new('GET', URI.new('http://foo.com/bar'), HTTP::Header.new(Foo => 'bar') ) }, "mew with positionals"; 66 | is $r.method, 'GET', "right method"; 67 | is $r.file, '/bar', "right file"; 68 | is $r.field('Host'), 'foo.com', 'got right host'; 69 | }, "positional construcutor"; 70 | 71 | subtest { 72 | subtest { 73 | my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/')); 74 | lives-ok { $req.add-form-data({ foo => "b&r\x1F42B", }) }, "add-form-data"; 75 | is $req.method, 'POST'; 76 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 77 | is $req.header.field('content-length'), '21'; 78 | is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; 79 | }, 'add-form-data with positional Hash'; 80 | subtest { 81 | my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/')); 82 | lives-ok { $req.add-form-data( foo => "b&r\x1F42B", ) }, "add-form-data"; 83 | is $req.method, 'POST'; 84 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 85 | is $req.header.field('content-length'), '21'; 86 | is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; 87 | }, 'add-form-data with slurpy hash'; 88 | subtest { 89 | my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', X-Foo => 'Bar'); 90 | lives-ok { $req.add-form-data([foo => "b&r\x1F42B",]) }, "add-form-data with array of pairs"; 91 | is $req.method, 'POST'; 92 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 93 | is $req.header.field('content-length'), '21'; 94 | is $req.header.field('X-Foo'), 'Bar'; 95 | is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; 96 | }, 'content by array'; 97 | subtest { 98 | # need to set the host up front so it compares with the data nicely 99 | my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', Host => '127.0.0.1', content-type => 'multipart/form-data; boundary=XxYyZ'); 100 | lives-ok { $req.add-form-data({ foo => "b&r", x => ['t/dat/foo.txt'], }) }, "add-form-data"; 101 | todo("issue seen on travis regarding line endings"); 102 | is-deeply Buf[uint8].new($req.Str.encode), slurp("t/dat/multipart-1.dat", :bin); 103 | }, 'multipart implied by existing content-type'; 104 | subtest { 105 | my $req = HTTP::Request.new(POST => 'http://127.0.0.1/'); 106 | lives-ok { $req.add-form-data({ foo => "b&r", x => ['t/dat/foo.txt'], }, :multipart) }, "add-form-data"; 107 | like $req.header.field('content-type').Str, /"multipart\/form-data"/, "and got multipart data"; 108 | }, 'multipart explicit'; 109 | subtest { 110 | my $req = HTTP::Request.new(POST => 'http://127.0.0.1/'); 111 | lives-ok { $req.add-form-data( foo => "b&r", x => ['t/dat/foo.txt'], :multipart) }, "add-form-data"; 112 | like $req.header.field('content-type').Str, /"multipart\/form-data"/, "and got multipart data"; 113 | }, 'multipart explicit with slurpy hash (check no gobble adverb)'; 114 | }, 'add-form-data'; 115 | 116 | # vim: expandtab shiftwidth=4 117 | -------------------------------------------------------------------------------- /t/041-form-urlencoded.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::Request; 2 | use Test; 3 | 4 | use URI; 5 | 6 | plan 3; 7 | 8 | # ref: https://url.spec.whatwg.org/#concept-urlencoded-serializer 9 | subtest { 10 | my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/')); 11 | lives-ok { $req.add-form-data({ fO0159 => 'safe-*._', }) }, "add-form-data"; 12 | is $req.method, 'POST'; 13 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 14 | is $req.header.field('content-length'), '15'; 15 | is $req.content.decode, 'fO0159=safe-*._'; 16 | }, 'urlencoded byte serializer - safe characters'; 17 | subtest { 18 | my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/')); 19 | lives-ok { $req.add-form-data({ 'foo bar' => '+ +', }) }, "add-form-data"; 20 | is $req.method, 'POST'; 21 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 22 | is $req.header.field('content-length'), '15'; 23 | is $req.content.decode, 'foo+bar=%2B+%2B'; 24 | }, 'urlencoded byte serializer - spaces'; 25 | subtest { 26 | my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/')); 27 | lives-ok { 28 | $req.add-form-data( 29 | { 30 | url => 'http://example.com/bar?user=baz&pass=xyzzy#"foo"', 31 | } 32 | ) 33 | }, "add-form-data"; 34 | is $req.method, 'POST'; 35 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 36 | is $req.header.field('content-length'), '74'; 37 | is $req.content.decode, 38 | 'url=' 39 | ~ 'http%3A%2F%2Fexample.com%2Fbar%3Fuser%3Dbaz%26pass%3Dxyzzy%23%22foo%22'; 40 | }, 'urlencoded byte serializer - unsafe characters'; 41 | 42 | # vim: expandtab shiftwidth=4 43 | -------------------------------------------------------------------------------- /t/050-response.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::Response; 3 | 4 | plan 28; 5 | 6 | # new 7 | my $r = HTTP::Response.new(200, a => 'a'); 8 | 9 | isa-ok $r, HTTP::Response, 'new 1/3'; 10 | isa-ok $r, HTTP::Message, 'new 2/3'; 11 | is $r.field('a'), 'a', 'new 3/3'; 12 | 13 | # field 14 | $r.field(h => 'h'); 15 | is $r.field('h'), 'h', 'field 1/2'; 16 | $r.field(h => 'abc'); 17 | is $r.field('h'), 'abc', 'field 2/2'; 18 | 19 | # status-line 20 | is $r.status-line, '200 OK', 'status-line 1/1'; 21 | 22 | # is-success 23 | ok $r.is-success, 'is-success 1/2'; 24 | ## 200-300 status is-success 25 | $r.set-code(204); 26 | ok $r.is-success, 'is-success 2/2'; 27 | $r.set-code(404); 28 | ok !$r.is-success, 'is-success 2/3'; 29 | 30 | # set-code 31 | is $r.status-line, '404 Not Found', 'set-code 1/1'; 32 | 33 | # parse 34 | my $res = "HTTP/1.1 200 OK\r\nHost: hoscik\r\n\r\ncontent\r\n"; 35 | $r = HTTP::Response.new.parse($res); 36 | is $r.Str, $res, 'parse - Str 1/4'; 37 | is $r.content, 'content', 'parse - content 2/4'; 38 | is $r.status-line, '200 OK', 'parse - status-line 3/4'; 39 | is $r.protocol, 'HTTP/1.1', 'parse - protocol 4/4'; 40 | 41 | # has-content 42 | 43 | $r = HTTP::Response.new(204); 44 | ok !$r.has-content, "has-content 1/3"; 45 | $r.set-code(304); 46 | ok !$r.has-content, "has-content 2/3"; 47 | $r.set-code(200); 48 | ok $r.has-content, "has-content 3/3"; 49 | 50 | my $buf = Buf[uint8].new(72, 84, 84, 80, 47, 49, 46, 49, 32, 52, 48, 51, 32, 70, 111, 114, 98, 105, 100, 100, 101, 110, 10, 68, 97, 116, 101, 58, 32, 84, 104, 117, 44, 32, 50, 50, 32, 79, 99, 116, 32, 50, 48, 49, 53, 32, 49, 50, 58, 50, 48, 58, 53, 52, 32, 71, 77, 84, 10, 83, 101, 114, 118, 101, 114, 58, 32, 65, 112, 97, 99, 104, 101, 47, 50, 46, 52, 46, 49, 54, 32, 40, 70, 101, 100, 111, 114, 97, 41, 32, 79, 112, 101, 110, 83, 83, 76, 47, 49, 46, 48, 46, 49, 107, 45, 102, 105, 112, 115, 32, 109, 111, 100, 95, 112, 101, 114, 108, 47, 50, 46, 48, 46, 57, 32, 80, 101, 114, 108, 47, 118, 53, 46, 50, 48, 46, 51, 10, 76, 97, 115, 116, 45, 77, 111, 100, 105, 102, 105, 101, 100, 58, 32, 70, 114, 105, 44, 32, 49, 55, 32, 74, 117, 108, 32, 50, 48, 49, 53, 32, 48, 55, 58, 49, 50, 58, 48, 52, 32, 71, 77, 84, 10, 69, 84, 97, 103, 58, 32, 34, 49, 50, 48, 49, 45, 53, 49, 98, 48, 99, 101, 55, 97, 100, 51, 57, 48, 48, 34, 10, 65, 99, 99, 101, 112, 116, 45, 82, 97, 110, 103, 101, 115, 58, 32, 98, 121, 116, 101, 115, 10, 67, 111, 110, 116, 101, 110, 116, 45, 76, 101, 110, 103, 116, 104, 58, 32, 52, 54, 48, 57, 10, 67, 111, 110, 110, 101, 99, 116, 105, 111, 110, 58, 32, 99, 108, 111, 115, 101, 10, 67, 111, 110, 116, 101, 110, 116, 45, 84, 121, 112, 101, 58, 32, 116, 101, 120, 116, 47, 104, 116, 109, 108, 59, 32, 99, 104, 97, 114, 115, 101, 116, 61, 85, 84, 70, 45, 56, 10, 10, 10); 51 | 52 | lives-ok { $r = HTTP::Response.new($buf) }, "create Response from a Buf"; 53 | is $r.code, 403, "got the code we expected"; 54 | is $r.field('ETag').values[0], "1201-51b0ce7ad3900", "got a header we expected"; 55 | 56 | lives-ok { $r = HTTP::Response.new(200, Content-Length => "hsh") }, "create a response with a Content-Length"; 57 | throws-like { $r.content-length }, X::HTTP::ContentLength; 58 | lives-ok { $r = HTTP::Response.new(200, Content-Length => "888") }, "create a response with a Content-Length"; 59 | lives-ok { $r.content-length }, "content-length lives"; 60 | is $r.content-length, 888, "got the right value"; 61 | isa-ok $r.content-length, Int, "and it is an Int"; 62 | 63 | subtest { 64 | my $r; 65 | throws-like { $r = HTTP::Response.new(Buf.new) }, X::HTTP::NoResponse, "create with an empty buf"; 66 | my $garbage = Buf.new(('a' .. 'z', 'A' .. 'Z').pick(20).map({$_.ords}).flat); 67 | lives-ok { 68 | $r = HTTP::Response.new($garbage); 69 | }, "create with garbage"; 70 | is $r.code, 500, "and got a 500 response"; 71 | 72 | }, "failure modes"; 73 | 74 | subtest { 75 | my $res = HTTP::Response.new: "HTTP/1.1 200 OK\r\nX-Duck: 🦆\r\n".encode; 76 | is $res.status-line, '200 OK', 'Can parse responses with non-ASCII header values'; 77 | is $res.header.field('X-Duck'), "ð\x[9F]¦\x[86]", 'Header value decoded as ISO-8859-1'; 78 | }, 'Non-ASCII header values' 79 | 80 | # vim: expandtab shiftwidth=4 81 | -------------------------------------------------------------------------------- /t/060-ua-common.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | 3 | plan 2; 4 | 5 | use HTTP::UserAgent::Common; 6 | 7 | my $chrome_linux = 'Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.132 Safari/537.36'; 8 | 9 | is get-ua('chrome_linux'), $chrome_linux, 'get-ua 1/2'; 10 | is get-ua('im not exist'), 'im not exist', 'get-ua 2/2'; 11 | 12 | # vim: expandtab shiftwidth=4 13 | -------------------------------------------------------------------------------- /t/070-ua-simple.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::UserAgent :simple; 3 | use Test::IO::Capture; 4 | 5 | plan 7; 6 | 7 | if %*ENV { 8 | my $url = 'http://perlmonkeys.org/'; 9 | 10 | my $get = get $url; 11 | 12 | is $get.substr($get.chars - 9), "\n\n", 'get 1/1'; 13 | my $code; 14 | prints-stdout-ok { $code = getprint $url }, $get, 'getprint 1/2'; 15 | is $code, 200, 'getprint 2/2'; 16 | getstore $url, 'newfile'; 17 | is slurp('newfile'), $get, 'getstore 1/1'; 18 | unlink 'newfile'; 19 | 20 | throws-like "use HTTP::UserAgent :simple; get('http://perlmonkeys.org/404here')", X::HTTP::Response, message => "Response error: '404 Not Found'"; 21 | 22 | my $head; 23 | 24 | lives-ok { $head = head $url }, "head works"; 25 | is $head.elems, 5, "got the right number of elements"; 26 | } 27 | else { 28 | skip-rest "NETWORK_TESTING not set won't do network tests"; 29 | } 30 | 31 | # vim: expandtab shiftwidth=4 32 | -------------------------------------------------------------------------------- /t/080-ua.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use HTTP::UserAgent::Common; 3 | use Test; 4 | 5 | use URI; 6 | 7 | plan 11; 8 | 9 | # new 10 | my $ua = HTTP::UserAgent.new; 11 | nok $ua.useragent, 'new 1/3'; 12 | 13 | $ua = HTTP::UserAgent.new(:useragent('test')); 14 | is $ua.useragent, 'test', 'new 2/3'; 15 | 16 | my $newua = get-ua('chrome_linux'); 17 | $ua = HTTP::UserAgent.new(:useragent('chrome_linux')); 18 | is $ua.useragent, $newua, 'new 3/3'; 19 | 20 | if %*ENV { 21 | # user agent 22 | like $ua.get('http://httpbin.org/user-agent').content, /$newua/, 'useragent 1/1'; 23 | 24 | # get 25 | todo "possibly flaky host", 4; 26 | lives-ok { 27 | my $response = $ua.get('github.com/'); 28 | ok $response, 'get 1/3'; 29 | isa-ok $response, HTTP::Response, 'get 2/3'; 30 | ok $response.is-success, 'get 3/3'; 31 | }, "get from 'github.com/'"; 32 | 33 | # non-ascii encodings (github issue #35) 34 | lives-ok { HTTP::UserAgent.new.get('http://www.baidu.com') }, 'Lived through gb2312 encoding'; 35 | 36 | # chunked encoding. 37 | 38 | skip 'Site changed. Need new site to cover this problem See #208'; 39 | # lives-ok { HTTP::UserAgent.new.get('http://rakudo.org') }, "issue#51 - get rakudo.org (chunked encoding foul-up results in incomplete UTF-8 data)"; 40 | 41 | subtest { 42 | my Bool $have-json = True; 43 | CATCH { 44 | when X::CompUnit::UnsatisfiedDependency { 45 | $have-json = False; 46 | } 47 | } 48 | use JSON::Fast; 49 | 50 | my $uri = 'http://httpbin.org/post'; 51 | my %data = (foo => 'bar', baz => 'quux'); 52 | subtest { 53 | my $uri = 'http://eu.httpbin.org/post?foo=42&bar=x'; 54 | my %data = :72foo, :bar<♵>; 55 | my $ua = HTTP::UserAgent.new; 56 | my $res; 57 | lives-ok { $res = $ua.post(URI.new($uri), %data, X-Foo => "foodle") }, "new make post"; 58 | my $ret-data; 59 | 60 | if $have-json { 61 | lives-ok { $ret-data = from-json($res.decoded-content) }, "get JSON body"; 62 | 63 | is $ret-data, 'foodle', "has got our header"; 64 | is $ret-data, "application/x-www-form-urlencoded", "and got the content type we expected"; 65 | is-deeply $ret-data
, %data, "and we sent the right params"; 66 | } 67 | else { 68 | skip("no json parser", 4); 69 | } 70 | }, "with URI object"; 71 | subtest { 72 | my $ua = HTTP::UserAgent.new; 73 | my $res; 74 | lives-ok { $res = $ua.post(URI.new($uri), %data, X-Foo => "foodle") }, "make post"; 75 | my $ret-data; 76 | 77 | if $have-json { 78 | lives-ok { $ret-data = from-json($res.decoded-content) }, "get JSON body"; 79 | 80 | is $ret-data, 'foodle', "has got our header"; 81 | is $ret-data, "application/x-www-form-urlencoded", "and got the content type we expected"; 82 | is-deeply $ret-data, %data, "and we sent the right params"; 83 | } 84 | else { 85 | skip("no json parser", 4); 86 | } 87 | }, "with URI object"; 88 | subtest { 89 | my $ua = HTTP::UserAgent.new; 90 | my $res; 91 | lives-ok { $res = $ua.post($uri, %data, X-Foo => "foodle") }, "make post"; 92 | my $ret-data; 93 | if $have-json { 94 | lives-ok { $ret-data = from-json($res.decoded-content) }, "get JSON body"; 95 | 96 | is $ret-data, 'foodle', "has got our header"; 97 | is $ret-data, "application/x-www-form-urlencoded", "and got the content type we expected"; 98 | is-deeply $ret-data, %data, "and we sent the right params"; 99 | } 100 | else { 101 | skip("no json parser", 4); 102 | 103 | } 104 | }, "with URI string"; 105 | }, "post"; 106 | } 107 | else { 108 | skip "NETWORK_TESTING not set", 8; 109 | } 110 | 111 | # vim: expandtab shiftwidth=4 112 | -------------------------------------------------------------------------------- /t/082-exceptions.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::UserAgent; 3 | 4 | plan 4; 5 | 6 | my $ua = HTTP::UserAgent.new; 7 | my $res; 8 | 9 | lives-ok { $res = $ua.get('http://httpbin.org/status/404') }, "no exception - expect 404"; 10 | 11 | ok !$res.is-success, "and it isn't successful"; 12 | is $res.code, 404, "and a 404"; 13 | 14 | $ua = HTTP::UserAgent.new(:throw-exceptions); 15 | 16 | throws-like { $ua.get('http://httpbin.org/status/404') }, X::HTTP::Response, message => "Response error: '404 Not Found'", response => HTTP::Response; 17 | 18 | # vim: expandtab shiftwidth=4 19 | -------------------------------------------------------------------------------- /t/085-auth.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::UserAgent; 3 | 4 | plan 7; 5 | 6 | my $ua = HTTP::UserAgent.new; 7 | 8 | lives-ok { $ua.auth('test', 'TEST' ) }, "set credentials"; 9 | 10 | is $ua.auth_login, 'test', "login got set okay"; 11 | is $ua.auth_password, 'TEST', "password got set okay"; 12 | 13 | my $res; 14 | 15 | if %*ENV:exists { 16 | lives-ok { $res = $ua.get('http://httpbin.org/basic-auth/xxx/XXX') }, "get site that requires auth (bad credentials)"; 17 | is $res.code, 401, "and it's a 401"; 18 | 19 | lives-ok { $res = $ua.get('http://httpbin.org/basic-auth/test/TEST') }, "get site that requires auth (good credentials)"; 20 | is $res.code, 200, "and it's a 200"; 21 | } 22 | else { 23 | skip("NETWORK_TESTING is not set", 4); 24 | } 25 | 26 | # vim: expandtab shiftwidth=4 27 | -------------------------------------------------------------------------------- /t/090-ua-ssl.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test; 3 | 4 | plan 2; 5 | 6 | try require ::("IO::Socket::SSL"); 7 | if ::('IO::Socket::SSL') ~~ Failure { 8 | skip-rest("IO::Socket::SSL not available"); 9 | exit 0; 10 | } 11 | 12 | unless %*ENV { 13 | diag "NETWORK_TESTING was not set"; 14 | skip-rest("NETWORK_TESTING was not set"); 15 | exit; 16 | } 17 | 18 | todo "OpenSSL is having trouble with httpbin.org"; 19 | throws-like 'use HTTP::UserAgent; my $ssl = HTTP::UserAgent.new(:throw-exceptions); $ssl.get("https://httpbin.org/status/403")', X::HTTP::Response, message => "Response error: '403 Forbidden'"; 20 | 21 | my $url = 'https://github.com/'; 22 | 23 | my $ssl = HTTP::UserAgent.new; 24 | my $get = ~$ssl.get($url); 25 | 26 | my $search-html = "\n\n\r\n"; 27 | is $get.substr($get.chars - $search-html.chars), $search-html, 'get 1/1'; 28 | # it should definitely have more/better tests 29 | 30 | # vim: expandtab shiftwidth=4 31 | -------------------------------------------------------------------------------- /t/100-redirect-ssl.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test; 3 | 4 | plan 2; 5 | 6 | try require ::('IO::Socket::SSL'); 7 | if ::('IO::Socket::SSL') ~~ Failure { 8 | skip-rest("IO::Socket::SSL not available"); 9 | exit 0; 10 | } 11 | 12 | unless %*ENV { 13 | diag "NETWORK_TESTING was not set"; 14 | skip-rest("NETWORK_TESTING was not set"); 15 | exit; 16 | } 17 | 18 | my $url = 'http://github.com'; 19 | 20 | my $ua = HTTP::UserAgent.new; 21 | my $get = ~$ua.get($url); 22 | 23 | ok $get ~~ /''/, 'http -> https redirect get 1/1'; 24 | 25 | throws-like { 26 | temp $ua.max-redirects = 0; 27 | $ua.get($url); 28 | }, X::HTTP::Response, "Max redirects exceeded"; 29 | 30 | # vim: expandtab shiftwidth=4 31 | -------------------------------------------------------------------------------- /t/110-redirect-cookies.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test::Util::ServerPort; 3 | use Test; 4 | 5 | my $port = get-unused-port(); 6 | 7 | use lib $*PROGRAM.sibling('lib').Str; 8 | use TestServer; 9 | 10 | %*ENV = 'localhost'; 11 | 12 | my $test-server = test-server(my $done-promise = Promise.new, :$port); 13 | my $ua = HTTP::UserAgent.new; 14 | 15 | plan 1; 16 | 17 | ok $ua.get("http://localhost:$port/one").is-success, 'redirect preserves cookies'; 18 | 19 | $done-promise.keep("shutdown"); 20 | 21 | # vim: expandtab shiftwidth=4 22 | -------------------------------------------------------------------------------- /t/150-issue-64.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | 3 | use HTTP::UserAgent; 4 | 5 | plan 3; 6 | 7 | unless %*ENV { 8 | diag "NETWORK_TESTING was not set"; 9 | skip-rest("NETWORK_TESTING was not set"); 10 | exit; 11 | } 12 | 13 | my $purl = 'http://purl.org/dc/elements/1.1/'; 14 | 15 | my $ua = HTTP::UserAgent.new( useragent => "firefox_linux" ); 16 | 17 | my HTTP::Response $resp; 18 | 19 | lives-ok { $resp = $ua.get($purl) }, "make request to '$purl' lives"; 20 | ok($resp.is-success, "request was successful"); 21 | 22 | ok($resp.content.defined, "and got some content back"); 23 | 24 | # vim: expandtab shiftwidth=4 25 | -------------------------------------------------------------------------------- /t/160-issue-67.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test; 3 | 4 | plan :skip-all; 5 | plan 2; 6 | 7 | #TODO: This test could be done better locally. 8 | 9 | unless %*ENV { 10 | diag "NETWORK_TESTING was not set"; 11 | skip-rest("NETWORK_TESTING was not set"); 12 | exit; 13 | } 14 | 15 | my @recv_log; 16 | 17 | my $wrapped = IO::Socket::INET.^find_method('recv').wrap(-> $o, |args { 18 | my \ret = callsame; 19 | @recv_log.push(${ args => args, ret => ret }); 20 | ret; 21 | }); 22 | 23 | my $resp = HTTP::UserAgent.new.get( 24 | 'https://www.punoftheday.com/cgi-bin/todayspun.pl' 25 | ); 26 | 27 | IO::Socket::INET.^find_method('recv').unwrap($wrapped); 28 | 29 | is(@recv_log.elems, 1, 'recv calls'); 30 | like($resp.content, rx/^^document.*'\')'$$/, 'resp' ); 31 | 32 | # vim: expandtab shiftwidth=4 33 | -------------------------------------------------------------------------------- /t/170-request-common.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::Request::Common; 3 | use URI; 4 | 5 | plan 7; 6 | 7 | subtest { 8 | subtest { 9 | my $req = POST( 10 | 'http://127.0.0.1/', 11 | { 12 | foo => "b&r", 13 | x => ['t/dat/foo.txt'], 14 | }, 15 | content-type => 'multipart/form-data; boundary=XxYyZ' 16 | ); 17 | todo("issue with line endings on travis"); 18 | is-deeply $req.Str.encode, slurp("t/dat/multipart-1.dat", :bin); 19 | }, 'uri'; 20 | }, 'POST(multi-part)'; 21 | 22 | subtest { 23 | subtest { 24 | my $req = POST(URI.new('http://127.0.0.1/'), { 25 | foo => "b&r\x1F42B", 26 | }); 27 | is $req.method, 'POST'; 28 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 29 | is $req.header.field('content-length'), '21'; 30 | is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; 31 | }, 'uri'; 32 | subtest { 33 | my $req = POST( 34 | 'http://127.0.0.1/', 35 | content => [ 36 | foo => "b&r\x1F42B", 37 | ], 38 | X-Foo => 'Bar'); 39 | is $req.method, 'POST'; 40 | is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; 41 | is $req.header.field('content-length'), '21'; 42 | is $req.header.field('X-Foo'), 'Bar'; 43 | is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; 44 | }, 'content by array'; 45 | subtest { 46 | my $req = POST('http://127.0.0.1/', 47 | content => "bumble", 48 | Content-Type => "text/plain"); 49 | is $req.content.encode, "bumble"; 50 | is $req.header.field('content-length'), 6; 51 | is $req.header.field('Content-Type'), "text/plain"; 52 | } 53 | }, 'POST'; 54 | 55 | subtest { 56 | subtest { 57 | my $req = GET URI.new('http://127.0.0.1/'); 58 | is $req.method, 'GET'; 59 | }, 'URI'; 60 | subtest { 61 | my $req = GET 'http://127.0.0.1/'; 62 | is $req.method, 'GET'; 63 | }, 'Str'; 64 | subtest { 65 | my $req = GET 'http://127.0.0.1/', 66 | X-Foo => 'Bar'; 67 | is $req.method, 'GET'; 68 | is $req.header.field('X-Foo'), 'Bar'; 69 | }, 'header'; 70 | }, 'GET'; 71 | 72 | subtest { 73 | subtest { 74 | my $req = PUT 'http://127.0.0.1/', 75 | X-Foo => 'Bar', 76 | content => 'Yeah!'; 77 | is $req.method, 'PUT'; 78 | is $req.header.field('X-Foo'), 'Bar'; 79 | is $req.content, 'Yeah!'; 80 | }, 'header'; 81 | }, 'PUT'; 82 | 83 | subtest { 84 | subtest { 85 | my $req = DELETE 'http://127.0.0.1/', 86 | X-Foo => 'Bar'; 87 | is $req.method, 'DELETE'; 88 | is $req.header.field('X-Foo'), 'Bar'; 89 | }, 'header'; 90 | }, 'DELETE'; 91 | 92 | subtest { 93 | subtest { 94 | my $req = HEAD 'http://127.0.0.1/', 95 | X-Foo => 'Bar'; 96 | is $req.method, 'HEAD'; 97 | is $req.header.field('X-Foo'), 'Bar'; 98 | }, 'header'; 99 | }, 'HEAD'; 100 | 101 | subtest { 102 | subtest { 103 | my $req = PATCH 'http://127.0.0.1/', 104 | X-Foo => 'Bar', 105 | content => 'Yeah!'; 106 | is $req.method, 'PATCH'; 107 | is $req.header.field('X-Foo'), 'Bar'; 108 | is $req.content, 'Yeah!'; 109 | }, 'header'; 110 | }, 'PATCH'; 111 | 112 | # vim: expandtab shiftwidth=4 113 | -------------------------------------------------------------------------------- /t/180-mediatype.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::MediaType; 2 | use Test; 3 | 4 | plan 5; 5 | 6 | is-deeply( 7 | HTTP::MediaType.parse('text/html; charset=ISO-8859-1'), 8 | HTTP::MediaType.new( 9 | type => 'text/html', 10 | sub-type => 'html', 11 | major-type => 'text', 12 | parameters => [ 13 | charset => 'ISO-8859-1', 14 | ], 15 | ) 16 | , "got media-type with charset"); 17 | is-deeply( 18 | HTTP::MediaType.parse('text/html'), 19 | HTTP::MediaType.new( 20 | type => 'text/html', 21 | sub-type => 'html', 22 | major-type => 'text', 23 | parameters => [], 24 | ) 25 | , "got media-type without charset"); 26 | is HTTP::MediaType.new( 27 | type => 'text/html', 28 | parameters => [], 29 | ).Str, "text/html", "got correct string representation without charset"; 30 | is HTTP::MediaType.new( 31 | type => 'text/html', 32 | parameters => [charset => 'iso-8859-1'], 33 | ).Str, "text/html; charset=iso-8859-1", "got correct string with charset"; 34 | 35 | subtest { 36 | my $mt = HTTP::MediaType.new( 37 | type => 'multipart/form-data', 38 | ); 39 | $mt.param('boundary', 'XxYyZ'); 40 | is $mt.Str, 'multipart/form-data; boundary=XxYyZ', "update param"; 41 | }, 'update param'; 42 | 43 | # vim: expandtab shiftwidth=4 44 | -------------------------------------------------------------------------------- /t/190-issue-116.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test; 3 | 4 | plan 2; 5 | 6 | try require ::('IO::Socket::SSL'); 7 | if ::('IO::Socket::SSL') ~~ Failure { 8 | skip-rest("IO::Socket::SSL not available"); 9 | exit 0; 10 | } 11 | 12 | unless %*ENV { 13 | diag "NETWORK_TESTING was not set"; 14 | skip-rest("NETWORK_TESTING was not set"); 15 | exit; 16 | } 17 | 18 | my $ua = HTTP::UserAgent.new; 19 | 20 | my HTTP::Response $res; 21 | my $request = HTTP::Request.new(GET => 'http://httpbin.org/status/304'); 22 | lives-ok { $res = $ua.request($request) }, "another request that always results in 304 lives"; 23 | is $res.code , 304, "and it is actually a 304"; 24 | 25 | # vim: expandtab shiftwidth=4 26 | -------------------------------------------------------------------------------- /t/200-w3-test-encodings.rakutest: -------------------------------------------------------------------------------- 1 | # TODO probably should contain Bufs of data and test HTTP::Message 2 | # directly rather than go over the wire. 3 | 4 | use HTTP::UserAgent; 5 | use Test; 6 | 7 | my @tests = 3..9; # TODO 1 and 2 8 | plan @tests.elems; 9 | 10 | unless %*ENV { 11 | diag "NETWORK_TESTING was not set"; 12 | skip-rest("NETWORK_TESTING was not set"); 13 | exit; 14 | } 15 | 16 | my $ua = HTTP::UserAgent.new; 17 | 18 | for @tests -> $i { 19 | my $url = "http://www.w3.org/2006/11/mwbp-tests/test-encoding-{$i}.html"; 20 | my $res = $ua.get($url); 21 | ok $res.content ~~ / 'é' /, "got correctly encoded é {$i} from w3.org" or warn :$url.perl; 22 | } 23 | 24 | # vim: expandtab shiftwidth=4 25 | -------------------------------------------------------------------------------- /t/210-content-encoding.rakutest: -------------------------------------------------------------------------------- 1 | use Test; 2 | use HTTP::UserAgent; 3 | 4 | plan 2; 5 | 6 | if %*ENV { 7 | try require ::('Compress::Zlib'); 8 | if ::('Compress::Zlib::Stream') ~~ Failure { 9 | skip-rest("'Compress::Zlib' not installed won't test"); 10 | } 11 | else { 12 | my $ua = HTTP::UserAgent.new; 13 | subtest { 14 | my $res; 15 | lives-ok { $res = $ua.get("http://httpbin.org/gzip") }, "get gzipped okay"; 16 | like $res.content, /gzipped/, "and it is like the right thing"; 17 | }, "gzipped fine"; 18 | subtest { 19 | my $res; 20 | lives-ok { $res = $ua.get("http://httpbin.org/deflate") }, "get deflated okay"; 21 | like $res.content, /deflated/, "and it is like the right thing"; 22 | }, "deflated fine"; 23 | } 24 | 25 | } 26 | else { 27 | skip-rest("'NETWORK_TESTING' not set"); 28 | } 29 | 30 | # vim: expandtab shiftwidth=4 31 | -------------------------------------------------------------------------------- /t/220-binary-content.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test; 3 | 4 | plan 5; 5 | 6 | if %*ENV { 7 | my $ua = HTTP::UserAgent.new; 8 | subtest { 9 | my $res; 10 | lives-ok { $res = $ua.get("http://httpbin.org/image/jpeg") }, "getting image"; 11 | is $res.media-type.type, 'image/jpeg', "and we actually got a JPEG"; 12 | ok $res.is-binary, "and the result says it's binary"; 13 | ok $res.content ~~ Blob, "and we got back a Blob"; 14 | is $res.content.elems, ~$res.field('Content-Length'), "and got the right length"; 15 | }, "get jpeg"; 16 | subtest { 17 | my $res; 18 | lives-ok { $res = $ua.get("http://httpbin.org/image/png") }, "getting image"; 19 | is $res.media-type.type, 'image/png', "and we actually got a PNG"; 20 | ok $res.is-binary, "and the result says it's binary"; 21 | ok $res.content ~~ Blob, "and we got back a Blob"; 22 | is $res.content.elems, ~$res.field('Content-Length'), "and got the right length"; 23 | }, "get png"; 24 | subtest { 25 | my $res; 26 | lives-ok { $res = $ua.get("http://httpbin.org/stream-bytes/1024") }, "getting application/octet-stream"; 27 | is $res.media-type.type, 'application/octet-stream', "and we actually got a bunch of bytes"; 28 | ok $res.is-binary, "and the result says it's binary"; 29 | ok $res.content ~~ Blob, "and we got back a Blob"; 30 | is $res.content.elems, 1024, "and got the right length"; 31 | }, "get octet-stream (chunked)"; 32 | subtest { 33 | my $res; 34 | lives-ok { $res = $ua.get("http://httpbin.org/bytes/1024") }, "getting application/octet-stream"; 35 | is $res.media-type.type, 'application/octet-stream', "and we actually got a bunch of bytes"; 36 | ok $res.is-binary, "and the result says it's binary"; 37 | ok $res.content ~~ Blob, "and we got back a Blob"; 38 | is $res.content.elems, 1024, "and got the right length"; 39 | is $res.content.elems, ~$res.field('Content-Length'), "and got the right length"; 40 | }, "get octet-stream (not-chunked)"; 41 | subtest { 42 | my $res; 43 | lives-ok { $res = $ua.get("http://httpbin.org/get", :bin) }, "get otherwise 'text' content with ':bin' over-ride"; 44 | ok $res.is-text, "and the result says it's text"; 45 | ok $res.content ~~ Blob, "but we got back a Blob"; 46 | }, "get text with a :bin over-ride"; 47 | } 48 | else { 49 | skip-rest("'NETWORK_TESTING' not set not performing tests"); 50 | } 51 | 52 | # vim: expandtab shiftwidth=4 53 | -------------------------------------------------------------------------------- /t/230-binary-request.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use HTTP::Request::Common; 3 | use Test::Util::ServerPort; 4 | 5 | use Test; 6 | 7 | plan 6; 8 | 9 | use lib $*PROGRAM.sibling('lib').Str; 10 | use TestServer; 11 | 12 | %*ENV = 'localhost'; 13 | 14 | my sub get-rand-buff() { 15 | Buf.new((0 .. 0xFF).pick((10 .. 75).pick)); 16 | } 17 | 18 | my $port = get-unused-port(); 19 | 20 | my $p = Promise.new; 21 | my $s = test-server($p, port => $port); 22 | 23 | my $uri = "http://localhost:$port"; 24 | 25 | subtest { 26 | my $ua = HTTP::UserAgent.new; 27 | my $buf = get-rand-buff(); 28 | my $req; 29 | lives-ok { $req = POST($uri, content => $buf); }, "create POST with Buf"; 30 | ok $req.content ~~ Blob, "content is a blob"; 31 | is $req.content.elems, $buf.elems, "content is right length"; 32 | is ~$req.header.field('Content-Length'), $buf.elems, "right 'Content-Length'"; 33 | is ~$req.header.field('Content-Type'), 'application/octet-stream', "right (default) Content-Type"; 34 | ok $req.binary, "and binary is good"; 35 | my $res; 36 | lives-ok { $res = $ua.request($req) }, "make request"; 37 | is $res.content-type, 'application/octet-stream', "got the right ct back"; 38 | ok $res.is-binary, "got binary response"; 39 | is $res.content.elems, $buf.elems, "and we got back what we sent"; 40 | ok $res.content eqv $buf, "and buffer looks the same"; 41 | 42 | }, "POST (with defaults)"; 43 | subtest { 44 | my $ua = HTTP::UserAgent.new; 45 | my $buf = get-rand-buff(); 46 | my $req; 47 | lives-ok { $req = POST($uri, content => $buf, Content-Type => 'image/x-something', Content-Length => 158); }, "create POST with Buf (supplying Content-Type and Content-Length"; 48 | ok $req.content ~~ Blob, "content is a blob"; 49 | is $req.content.elems, $buf.elems, "content is right length"; 50 | is ~$req.header.field('Content-Length'), $buf.elems, "right 'Content-Length'"; 51 | is ~$req.header.field('Content-Type'), 'image/x-something', "right explicit Content-Type"; 52 | ok $req.binary, "and binary is good"; 53 | my $res; 54 | lives-ok { $res = $ua.request($req) }, "make request"; 55 | is $res.content-type, 'image/x-something', "got the right ct back"; 56 | ok $res.is-binary, "got binary response"; 57 | is $res.content.elems, $buf.elems, "and we got back what we sent"; 58 | ok $res.content eqv $buf, "and buffer looks the same"; 59 | 60 | }, "POST (with explicit Content-Type)"; 61 | 62 | subtest { 63 | my $ua = HTTP::UserAgent.new; 64 | # need the "\n" because our server is so crap 65 | my $buf = "Hello, World!\r\n".encode; 66 | my $req; 67 | lives-ok { $req = POST($uri, content => $buf, Content-Type => 'text/plain', Content-Length => 158); }, "create POST with Buf (supplying Content-Type and Content-Length"; 68 | ok $req.content ~~ Blob, "content is a blob"; 69 | is $req.content.elems, $buf.elems, "content is right length"; 70 | is ~$req.header.field('Content-Length'), $buf.elems, "right 'Content-Length'"; 71 | is ~$req.header.field('Content-Type'), 'text/plain', "right explicit Content-Type"; 72 | ok $req.binary, "and binary is good"; 73 | my $res; 74 | lives-ok { $res = $ua.request($req) }, "make request"; 75 | is $res.content-type, 'text/plain', "got the right ct back"; 76 | nok $res.is-binary, "inferred text response"; 77 | ok $res.is-text, "and it's text"; 78 | is $res.content.encode.elems, $buf.elems, "and we got back what we sent"; 79 | is $res.content , "Hello, World!\r\n", "and content looks the same"; 80 | 81 | }, "POST (with something that will be text coming back)"; 82 | 83 | subtest { 84 | my $ua = HTTP::UserAgent.new; 85 | my $buf = get-rand-buff(); 86 | my $req; 87 | lives-ok { $req = PUT($uri, content => $buf); }, "create PUT with Buf"; 88 | ok $req.content ~~ Blob, "content is a blob"; 89 | is $req.content.elems, $buf.elems, "content is right length"; 90 | is ~$req.header.field('Content-Length'), $buf.elems, "right 'Content-Length'"; 91 | is ~$req.header.field('Content-Type'), 'application/octet-stream', "right (default) Content-Type"; 92 | ok $req.binary, "and binary is good"; 93 | my $res; 94 | lives-ok { $res = $ua.request($req) }, "make request"; 95 | is $res.content-type, 'application/octet-stream', "got the right ct back"; 96 | ok $res.is-binary, "got binary response"; 97 | is $res.content.elems, $buf.elems, "and we got back what we sent"; 98 | ok $res.content eqv $buf, "and buffer looks the same"; 99 | 100 | }, "PUT (with defaults)"; 101 | subtest { 102 | my $ua = HTTP::UserAgent.new; 103 | my $buf = get-rand-buff(); 104 | my $req; 105 | lives-ok { $req = PUT($uri, content => $buf, Content-Type => 'image/x-something', Content-Length => 158); }, "create PUT with Buf (supplying Content-Type and Content-Length"; 106 | ok $req.content ~~ Blob, "content is a blob"; 107 | is $req.content.elems, $buf.elems, "content is right length"; 108 | is ~$req.header.field('Content-Length'), $buf.elems, "right 'Content-Length'"; 109 | is ~$req.header.field('Content-Type'), 'image/x-something', "right explicit Content-Type"; 110 | ok $req.binary, "and binary is good"; 111 | my $res; 112 | lives-ok { $res = $ua.request($req) }, "make request"; 113 | is $res.content-type, 'image/x-something', "got the right ct back"; 114 | ok $res.is-binary, "got binary response"; 115 | is $res.content.elems, $buf.elems, "and we got back what we sent"; 116 | ok $res.content eqv $buf, "and buffer looks the same"; 117 | 118 | }, "PUT (with explicit Content-Type)"; 119 | subtest { 120 | my $ua = HTTP::UserAgent.new; 121 | # need the "\n" because our server is so crap 122 | my $buf = "Hello, World!\n".encode; 123 | my $req; 124 | lives-ok { $req = PUT($uri, content => $buf, Content-Type => 'text/plain', Content-Length => 158); }, "create PUT with Buf (supplying Content-Type and Content-Length"; 125 | ok $req.content ~~ Blob, "content is a blob"; 126 | is $req.content.elems, $buf.elems, "content is right length"; 127 | is ~$req.header.field('Content-Length'), $buf.elems, "right 'Content-Length'"; 128 | is ~$req.header.field('Content-Type'), 'text/plain', "right explicit Content-Type"; 129 | ok $req.binary, "and binary is good"; 130 | my $res; 131 | lives-ok { $res = $ua.request($req) }, "make request"; 132 | is $res.content-type, 'text/plain', "got the right ct back"; 133 | nok $res.is-binary, "inferred text response"; 134 | ok $res.is-text, "and it's text"; 135 | is $res.content.encode.elems, $buf.elems, "and we got back what we sent"; 136 | is $res.content , "Hello, World!\n", "and content looks the same"; 137 | 138 | }, "PUT (with something that will be text coming back)"; 139 | 140 | $p.keep("shutdown"); 141 | #try await $s; 142 | 143 | # vim: expandtab shiftwidth=4 144 | -------------------------------------------------------------------------------- /t/250-issue-144.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test::Util::ServerPort; 3 | 4 | use Test; 5 | 6 | plan 1; 7 | 8 | my $port = get-unused-port(); 9 | 10 | # Start a really bad server that just closes the connection 11 | # without sending anything. 12 | my $p = start { 13 | react { 14 | whenever IO::Socket::Async.listen('localhost', $port) -> $conn { 15 | $conn.close; 16 | } 17 | } 18 | 19 | } 20 | 21 | %*ENV = 'localhost'; 22 | 23 | my $ua = HTTP::UserAgent.new; 24 | 25 | my $res; 26 | 27 | todo 'Windows OS error messages are localized' if $*DISTRO.is-win; 28 | throws-like { $res = $ua.get("http://localhost:$port/") }, X::HTTP::Internal, rc => 500, "throws the correct exception"; 29 | 30 | # vim: expandtab shiftwidth=4 31 | -------------------------------------------------------------------------------- /t/260-no-proxy.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use HTTP::Request::Common; 3 | use Test; 4 | 5 | plan 10; 6 | 7 | %*ENV = 'localhost, foo.bar.com , baz.quux.com'; 8 | %*ENV:delete; 9 | %*ENV = "http://cannibal.local/"; 10 | %*ENV:delete; 11 | 12 | my $ua; 13 | 14 | lives-ok { $ua = HTTP::UserAgent.new }, "create with environment NO_PROXY"; 15 | 16 | is-deeply $ua.no-proxy, [], "got all from the environment"; 17 | nok $ua.use-proxy('localhost'), "use-proxy - in no-proxy"; 18 | nok $ua.use-proxy('foo.bar.com'), "use-proxy - in no-proxy"; 19 | nok $ua.use-proxy('baz.quux.com'), "use-proxy - in no-proxy"; 20 | ok $ua.use-proxy('example.com'), "use-proxy - not there"; 21 | ok $ua.use-proxy(GET('http://example.com/')), "use-proxy - with request"; 22 | nok $ua.use-proxy(GET('http://localhost:3333/')), "use-proxy - with request (no-proxy)"; 23 | nok $ua.get-proxy(GET('http://localhost:3333/')), "get-proxy - (no-proxy)"; 24 | is $ua.get-proxy(GET('http://example.com/')), 'http://cannibal.local/', "get-proxy - with proxy"; 25 | 26 | # vim: expandtab shiftwidth=4 27 | -------------------------------------------------------------------------------- /t/270-issue-212.rakutest: -------------------------------------------------------------------------------- 1 | use HTTP::UserAgent; 2 | use Test; 3 | 4 | plan 1; 5 | 6 | unless %*ENV { 7 | diag "NETWORK_TESTING was not set"; 8 | skip-rest("NETWORK_TESTING was not set"); 9 | exit; 10 | } 11 | 12 | my $ua = HTTP::UserAgent.new; 13 | lives-ok { $ua.get("http://httpbin.org/image/png") }; 14 | 15 | # vim: expandtab shiftwidth=4 16 | -------------------------------------------------------------------------------- /t/dat/foo.txt: -------------------------------------------------------------------------------- 1 | bar 2 | -------------------------------------------------------------------------------- /t/dat/multipart-1.dat: -------------------------------------------------------------------------------- 1 | POST / HTTP/1.1 2 | Host: 127.0.0.1 3 | Content-Type: multipart/form-data; boundary=XxYyZ 4 | Content-Length: 190 5 | 6 | --XxYyZ 7 | Content-Disposition: form-data; name="foo" 8 | 9 | b&r 10 | --XxYyZ 11 | Content-Disposition: form-data; name="x"; filename="foo.txt" 12 | Content-Type: application/octet-stream 13 | 14 | bar 15 | 16 | --XxYyZ-- 17 | 18 | -------------------------------------------------------------------------------- /t/lib/TestServer.rakumod: -------------------------------------------------------------------------------- 1 | module TestServer { 2 | 3 | sub test-server(Promise $done-promise, Int :$port --> Promise:D) is export { 4 | my $server-promise = start { 5 | sub _index_buf(Blob $input, Blob $sub) { 6 | my $end-pos = 0; 7 | while $end-pos < $input.bytes { 8 | if $sub eq $input.subbuf($end-pos, $sub.bytes) { 9 | return $end-pos; 10 | } 11 | $end-pos++; 12 | } 13 | return -1; 14 | } 15 | react { 16 | whenever $done-promise { 17 | die $_; 18 | done; 19 | } 20 | whenever IO::Socket::Async.listen('localhost',$port) -> $conn { 21 | my Buf $in-buf = Buf.new; 22 | my Str $req-line; 23 | whenever $conn.Supply(:bin) -> $buf { 24 | if $in-buf.elems == 0 { 25 | my $header-end = _index_buf($buf, Buf.new(13,10)); 26 | $req-line = $buf.subbuf(0, $header-end).decode; 27 | $in-buf ~= $buf.subbuf($header-end + 2); 28 | } 29 | else { 30 | $in-buf ~= $buf; 31 | } 32 | 33 | 34 | if (my $header-end = _index_buf($in-buf, Buf.new(13,10,13,10))) > 0 { 35 | my $header = $in-buf.subbuf(0, $header-end).decode('ascii'); 36 | 37 | if $req-line ~~ /^GET \s+ \/one/ { 38 | $conn.write: "HTTP/1.1 302 Found\r\nLocation: /two\r\nSet-Cookie: test=abc\r\n\r\n".encode; 39 | $conn.close; 40 | } 41 | 42 | elsif $req-line ~~ /^GET \s+ \/?two/ { 43 | if ( $header ~~ /Cookie\: \s+ test\=abc/ ) { 44 | $conn.write: "HTTP/1.1 200 OK\r\n\r\n".encode; 45 | } else { 46 | $conn.write: "HTTP/1.1 404 Not Found\r\n\r\n".encode; 47 | } 48 | $conn.close; 49 | } 50 | 51 | elsif $header ~~ /Content\-Length\:\s+$=[\d+]/ { 52 | my $length = $.Int; 53 | if $in-buf.subbuf($header-end + 4) == $length { 54 | await $conn.write: "HTTP/1.0 200 OK\r\n".encode ~ $in-buf ; 55 | $conn.close; 56 | } 57 | } 58 | } 59 | } 60 | } 61 | } 62 | } 63 | $server-promise 64 | } 65 | } 66 | 67 | # vim: expandtab shiftwidth=4 68 | -------------------------------------------------------------------------------- /xt/coverage.rakutest: -------------------------------------------------------------------------------- 1 | use Test::Coverage; 2 | 3 | plan 2; 4 | 5 | coverage-at-least 75; 6 | 7 | uncovered-at-most 162; 8 | 9 | source-with-coverage; 10 | 11 | report; 12 | 13 | # vim: expandtab shiftwidth=4 14 | --------------------------------------------------------------------------------