view release on metacpan or  search on metacpan

lib/Cookies/Roundtrip.pm  view on Meta::CPAN

package Cookies::Roundtrip;

# NOTE: HTTP::Cookies and HTTP::CookieJar and
# Firefox::Marionette::Cookie
# have expires or expiry fields.
# some can be undef which has a special meaning:
# they are session cookies (which are deleted when session/browser/tab is closed).
# THEY ALL store expiry as unix epoch seconds.
# BUT SetCookie needs a "YYYY-MM-DD hh:mm:ssZ"-formatted string representing Universal Time.
# use this: HTTP::Date::time2isoz(epochsecs)

use strict;
use warnings;

our $VERSION = '0.01';

use HTTP::Cookies;
use HTTP::CookieJar;
use Firefox::Marionette::Cookie;
use HTTP::Date qw(str2time parse_date time2str);
use HTTP::Response;
use HTTP::Request;
use DateTime;
use HTTP::Headers::Util qw/join_header_words/;
use Data::Compare;
use Devel::StackTrace; # until the module is stable

use Data::Roundtrip qw/perl2dump no-unicode-escape-permanently/;

use Exporter; # you need to import 'import' if you don't define it further down
# the EXPORT_OK and EXPORT_TAGS is code by [kcott] @ Perlmongs.org, thanks!
# see https://perlmonks.org/?node_id=11115288
our (@EXPORT_OK, %EXPORT_TAGS);
# For all the EXPORT subs and tags see the BEGIN{} block at the end

sub	lwpuseragent_get_cookies {
	my ($ua, $verbosity) = @_;
	#$verbosity //= 0;
	#my $parent = ( caller(1) )[3] || "N/A";
	#my $whoami = ( caller(0) )[3];
	return $ua->cookie_jar
}

# Save cookies of LWP::UserAgent (they are HTTP::CookieJar)
# into a file. The file will be empty if no cookies.
# It returns 1 on failure, 0 on success.
sub	lwpuseragent_save_cookies_to_file {
	my ($ua, $filename, $skip_discard, $verbosity) = @_;
	$verbosity //= 0;
	my $parent = ( caller(1) )[3] || "N/A";
	my $whoami = ( caller(0) )[3];

	# LWP::UserAgent supports both HTTP::Cookies and HTTP::CookieJar
	# cookie jars (depending on the 'cookie_jar_class' param to their constructor)
	# we need to find the class of the cookie jar of mech
	# this is probably unsupported but there is no other way:
	my $cookie_jar_class = $ua->{'cookie_jar_class'};

	if( $cookie_jar_class eq 'HTTP::Cookies' ){
		if( httpcookies2file(
			defined($ua->cookie_jar) ? $ua->cookie_jar : $cookie_jar_class->new(),
			$filename, $skip_discard, $verbosity
		) ){ print STDERR "${whoami}, line ".__LINE__." (via $parent): error, call to ".'httpcookies2file()'." has failed.\n"; return 1 }
	} elsif( ($cookie_jar_class eq 'HTTP::CookieJar') || ($cookie_jar_class eq 'HTTP::CookieJar::LWP') ){
		if( httpcookiejar2file(
			defined($ua->cookie_jar) ? $ua->cookie_jar : $cookie_jar_class->new(),
			$filename, $skip_discard, $verbosity
		) ){ print STDERR "${whoami}, line ".__LINE__." (via $parent): error, call to ".'httpcookies2file()'." has failed.\n"; return 1 }
	} else {
		print STDERR "${whoami}, line ".__LINE__." (via $parent): error, input cookies type '$cookie_jar_class' is not known. Known cookies types are 'HTTP::Cookies' and 'HTTP::CookieJar'.\n";
		return 0
	}

	return 0 # success
}

# Convenience method to load any kind of cookies
# or a cookies file, into the LWP::UserAgent
# it returns the $ua's cookie_jar on success or undef on failure
sub	lwpuseragent_load_cookies {
	my ($ua, $cookies_or_file_etc, $verbosity) = @_;
	$verbosity //= 0;

lib/Cookies/Roundtrip.pm  view on Meta::CPAN

	# from HTTP/Cookies.pm, set_cookie signature:
	#    my($version,
	#       $key, $val, $path, $domain, $port,
	#       $path_spec, $secure, $maxage, $discard, $rest) = @_;

	# it expects a max-age but we could have expires
	# and expires can be an epoch or a string date
	if( exists $parsed_setcookie->{'expires'} ){
		if( ! defined $parsed_setcookie->{'expires'} ){ $parsed_setcookie->{'max-age'} = undef }
		elsif( $parsed_setcookie->{'expires'}=~ /^\d+$/ ){
			$parsed_setcookie->{'max-age'} = $parsed_setcookie->{'expires'} - DateTime->now()->epoch();
		} else {
			$parsed_setcookie->{'max-age'} = HTTP::Date::str2time($parsed_setcookie->{'expires'}) - DateTime->now()->epoch();
		}
		delete $parsed_setcookie->{'expires'}; # does not care if you do
	}
	if( ! exists($parsed_setcookie->{'secure'}) || ! defined($parsed_setcookie->{'secure'}) ){
		$parsed_setcookie->{'secure'} = 0;
	}

	return $parsed_setcookie;
}


# Convert an array of Set-Cookie strings into a fresh
# or user-supplied (this is appending) HTTP::Cookies object
# and return it. Optionally specifying $verbosity (as integer).
# $httpcookiejar is optional, if given, then cookies
# will be appended in it and return it. Else
# a fresh HTTP::Cookies will be created, loaded and returned.
# It returns undef on failure.
sub	setcookies2httpcookies {
	my ($setcookies, $httpcookies, $verbosity) = @_;
	$verbosity //= 0;
	my $parent = ( caller(1) )[3] || "N/A";
	my $whoami = ( caller(0) )[3];
	if( ! defined $httpcookies ){
		if( ! defined($httpcookies = HTTP::Cookies->new()) ){ print STDERR "${whoami}, line ".__LINE__." (via $parent): error, call to ".'HTTP::Cookies->new()'." has failed.\n"; return undef }
	}
	for my $asc (@$setcookies){
		if( $verbosity > 1 ){
			my $parsed_setcookie_hash = setcookie2hash($asc, $verbosity);
			if( ! defined $parsed_setcookie_hash ){ print STDERR "--begin SetCookie:\n${asc}\n--end cookie.\n"."${whoami}, line ".__LINE__." (via $parent): error, call to ".'setcookie2hash()'." has failed for above SetCookie string.\n"; return undef }
			print STDOUT perl2dump($parsed_setcookie_hash)."${whoami}, line ".__LINE__." (via $parent): parse this SetCookie into the above hash: ${asc}\n";
		}

		my $parsed_setcookie_array = setcookie2httpcookies_set_cookie_array($asc, $verbosity);
		if( ! defined $parsed_setcookie_array ){ print STDERR "--begin SetCookie:\n${asc}\n--end cookie.\n"."${whoami}, line ".__LINE__." (via $parent): error, call to ".'setcookie2httpcookies_set_cookie_array()'." has failed for above SetCookie string.\n"...

		# from HTTP/Cookies.pm, set_cookie signature:
		#    my($version,
		#       $key, $val, $path, $domain, $port,
		#       $path_spec, $secure, $maxage, $discard, $rest) = @_;

		$httpcookies->set_cookie(@$parsed_setcookie_array);
		if( $verbosity > 0 ){ print STDOUT "${whoami}, line ".__LINE__." (via $parent): inserting 1 Set-Cookies into HTTP::Cookies which now has ".count_httpcookies($httpcookies, undef, $verbosity)." cookies.\n" }

# this way is bogus, what with response and request and url and all
#		my $response = HTTP::Response->new(200);
#		my $request = HTTP::Request->new(GET => $url);
#		$response->request($request);
#		$response->header('Set-Cookie2', $newasc); # TODO: does it push multiple Cookie headers or overrides?
#		if( ! defined $httpcookies->extract_cookies($response) ){ print STDERR "--begin cookies:\n".as_string_setcookies($setcookies)."\n--end cookies.\n\n"."${whoami}, line ".__LINE__." (via $parent): error, call to ".'httpcookies->extract_cookies()'." h...
#		if( $verbosity > 0 ){ print STDOUT "${whoami}, line ".__LINE__." (via $parent): inserting 1 Set-Cookies into HTTP::Cookies which now has ".count_httpcookies($httpcookies, undef, $verbosity)." cookies.\n" }
	}
	if( $verbosity > 0 ){ print STDOUT "${whoami}, line ".__LINE__." (via $parent): done all, inserted ".count_setcookies($setcookies)." Set-Cookies into HTTP::Cookies which now has ".count_httpcookies($httpcookies, undef, $verbosity)." cookies.\n" }
	return $httpcookies;
}

# Array of Firefox::Marionette::Cookie to array of cookies.
# Each of the output cookie resembles a Set-Cookie header and,
# logically, it can be loaded by any cookies container.
# It converts the specified Array of Firefox::Marionette::Cookie object into
# an array of cookies which can then be loaded into other exotic
# cookie containers.
# It returns the cookies as ARRAY_REF.
# for Set-Cookie format see:
#   https://developer.mozilla.org/en-US/docs/Web/HTTP/Reference/Headers/Set-Cookie
sub     firefoxmarionettecookies2setcookies {
        my ($firefoxmarionettecookies, $setcookies, $skip_discard, $verbosity) = @_;
	$skip_discard //= 0;
	$verbosity //= 0;

	my $parent = ( caller(1) )[3] || "N/A";
	my $whoami = ( caller(0) )[3];

	if( ! defined $setcookies ){ $setcookies = [] }

	for my $afc (@$firefoxmarionettecookies){
		my @h = ($afc->name, $afc->value);
		push @h, 'path', $afc->path;
		push @h, 'domain', $afc->domain;
		# no port in F:M:C
		# boolean, it can be present or not present, it has no value like secure=...
		push(@h, 'secure') if $afc->secure;
		if( defined $afc->expiry ){
			# we can have expires as Date or max-age as epoch
			push @h, 'expires', HTTP::Date::time2isoz($afc->expiry)
		}
		# SameSite can be one of: Lax, None, Strict
		if( $afc->same_site !~ /^(None|Lax|Strict)$/ ){ print STDERR "${whoami}, line ".__LINE__." (via $parent): error, field 'same_site' (".$afc->same_site.") is not one of: 'Lax', 'None', 'Strict'.\n"; return undef }
		push @h, 'SameSite', $afc->same_site;
		# boolean, it can be present or not present, it has no value like secure=...
		push(@h, 'HttpOnly') if $afc->http_only;

		my $cookstr = HTTP::Headers::Util::join_header_words(\@h);

		# and yet again we suffer from the quotes, perhaps HTTP::CookieJar::load_cookies()
		# assumes no quotes?!
		$cookstr =~ s/\bpath="([^"]*)";/path=$1;/;
		$cookstr =~ s/\bexpires="([^"]*)";/expires=$1;/;
		#push(@$setcookies, "Set-Cookie3: " . $cookstr); # this is for a header?
		push(@$setcookies, $cookstr);
	}
	return $setcookies;
}

# Convert an array of Firefox::Marionette::Cookie objects into
# a fresh or user-supplied (this is appending)
# HTTP::CookieJar and return it. Optionally specifying $verbosity (as integer).