File Coverage

blib/lib/GDPR/IAB/TCFv2.pm

Criterion	Covered	Total	%
statement	225	232	96.9
branch	50	66	75.7
condition	11	18	61.1
subroutine	62	63	98.4
pod	27	27	100.0
total	375	406	92.3

package GDPR::IAB::TCFv2;

use strict;
use warnings;
use integer;
use bytes;

use Carp         qw;
use MIME::Base64 qw;
use POSIX        qw;

use GDPR::IAB::TCFv2::BitField;
use GDPR::IAB::TCFv2::BitUtils qw
  get_uint2
  get_uint3
  get_uint6
  get_uint12
  get_uint16
  get_uint36
  get_char6_pair
>;
use GDPR::IAB::TCFv2::Publisher;
use GDPR::IAB::TCFv2::RangeSection;

our $VERSION = "0.203";

use constant {
    CONSENT_STRING_TCF_V2 => {
        SEPARATOR     => quotemeta q<.>,
        PREFIX        => q,
        MIN_BYTE_SIZE => 29,
    },
    EXPECTED_TCF_V2_VERSION => 2,
    MAX_SPECIAL_FEATURE_ID  => 12,
    MAX_PURPOSE_ID          => 24,
    DATE_FORMAT_ISO_8601    => '%Y-%m-%dT%H:%M:%SZ',
    SEGMENT_TYPES           => {
        CORE         => 0,
        PUBLISHER_TC => 3,
    },
    OFFSETS => {
        SEGMENT_TYPE            => 0,
        VERSION                 => 0,
        CREATED                 => 6,
        LAST_UPDATED            => 42,
        CMP_ID                  => 78,
        CMP_VERSION             => 90,
        CONSENT_SCREEN          => 102,
        CONSENT_LANGUAGE        => 108,
        VENDOR_LIST_VERSION     => 120,
        POLICY_VERSION          => 132,
        SERVICE_SPECIFIC        => 138,
        USE_NON_STANDARD_STACKS => 139,
        SPECIAL_FEATURE_OPT_IN  => 140,
        PURPOSE_CONSENT_ALLOWED => 152,
        PURPOSE_LIT_ALLOWED     => 176,
        PURPOSE_ONE_TREATMENT   => 200,
        PUBLISHER_COUNTRY_CODE  => 201,
        VENDOR_CONSENT          => 213,
    },
};

use overload q<""> => \&tc_string;

# ABSTRACT: gdpr iab tcf v2 consent string parser

sub Parse {
    my ( $klass, $tc_string, %opts ) = @_;

    croak 'missing gdpr consent string' unless $tc_string;

    my $segments = _decode_tc_string_segments($tc_string);

    my $strict = !!$opts{strict};

    my %options = (
        json   => $opts{json} || {},
        strict => $strict,
    );

    $options{json}->{date_format}    ||= DATE_FORMAT_ISO_8601;
    $options{json}->{boolean_values} ||= [ _json_false(), _json_true() ];

    if ( exists $opts{prefetch} ) {
        my $prefetch = $opts{prefetch};

        $prefetch = [$prefetch] if ref($prefetch) ne ref( [] );

        $options{prefetch} = $prefetch;
    }

    my $self = {
        core_data         => $segments->{core_data},
        publisher_tc_data => $segments->{publisher_tc},
        options           => \%options,
        tc_string         => $tc_string,

        vendor_consents             => undef,
        vendor_legitimate_interests => undef,
        publisher                   => undef,
    };

    bless $self, $klass;

    croak "consent string is not tcf version @{[ EXPECTED_TCF_V2_VERSION ]}"
      if $strict && $self->version != EXPECTED_TCF_V2_VERSION;

    croak 'invalid vendor list version' if $self->vendor_list_version == 0;

    my $next_offset = $self->_parse_vendor_section();

    $self->_parse_publisher_section($next_offset);

    return $self;
}

sub tc_string {
    my $self = shift;

    return $self->{tc_string};
}

sub version {
    my $self = shift;

    return scalar( get_uint6( $self->{core_data}, OFFSETS->{VERSION} ) );
}

sub created {
    my $self = shift;

    my ( $seconds, $nanoseconds ) = $self->_get_epoch( OFFSETS->{CREATED} );

    return wantarray ? ( $seconds, $nanoseconds ) : $seconds;
}

sub last_updated {
    my $self = shift;

    my ( $seconds, $nanoseconds ) =
      $self->_get_epoch( OFFSETS->{LAST_UPDATED} );

    return wantarray ? ( $seconds, $nanoseconds ) : $seconds;
}

sub _get_epoch {
    my ( $self, $offset ) = @_;

    my $deciseconds = scalar( get_uint36( $self->{core_data}, $offset ) );

    return (
        ( $deciseconds / 10 ),
        ( ( $deciseconds % 10 ) * 100_000_000 ),
    );
}

sub cmp_id {
    my $self = shift;

    return scalar( get_uint12( $self->{core_data}, OFFSETS->{CMP_ID} ) );
}

sub cmp_version {
    my $self = shift;

    return scalar( get_uint12( $self->{core_data}, OFFSETS->{CMP_VERSION} ) );
}

sub consent_screen {
    my $self = shift;

    return
      scalar( get_uint6( $self->{core_data}, OFFSETS->{CONSENT_SCREEN} ) );
}

sub consent_language {
    my $self = shift;

    return
      scalar(
        get_char6_pair( $self->{core_data}, OFFSETS->{CONSENT_LANGUAGE} ) );
}

sub vendor_list_version {
    my $self = shift;

    return
      scalar(
        get_uint12( $self->{core_data}, OFFSETS->{VENDOR_LIST_VERSION} ) );
}

sub policy_version {
    my $self = shift;

    return
      scalar( get_uint6( $self->{core_data}, OFFSETS->{POLICY_VERSION} ) );
}

sub is_service_specific {
    my $self = shift;

    return scalar( is_set( $self->{core_data}, OFFSETS->{SERVICE_SPECIFIC} ) );
}

sub use_non_standard_stacks {
    my $self = shift;

    return
      scalar(
        is_set( $self->{core_data}, OFFSETS->{USE_NON_STANDARD_STACKS} ) );
}

sub is_special_feature_opt_in {
    my ( $self, $id ) = @_;

    croak
      "invalid special feature id $id: must be between 1 and @{[ MAX_SPECIAL_FEATURE_ID ]}"
      if $id < 1 || $id > MAX_SPECIAL_FEATURE_ID;

    return $self->_safe_is_special_feature_opt_in($id);
}

sub _safe_is_special_feature_opt_in {
    my ( $self, $id ) = @_;

    return scalar(
        is_set(
            $self->{core_data}, OFFSETS->{SPECIAL_FEATURE_OPT_IN} + $id - 1
        )
    );
}

sub is_purpose_consent_allowed {
    my ( $self, $id ) = @_;

    croak "invalid purpose id $id: must be between 1 and @{[ MAX_PURPOSE_ID ]}"
      if $id < 1 || $id > MAX_PURPOSE_ID;

    return $self->_safe_is_purpose_consent_allowed($id);
}

sub _safe_is_purpose_consent_allowed {
    my ( $self, $id ) = @_;
    return scalar(
        is_set(
            $self->{core_data}, OFFSETS->{PURPOSE_CONSENT_ALLOWED} + $id - 1
        )
    );
}

sub is_purpose_legitimate_interest_allowed {
    my ( $self, $id ) = @_;

    croak "invalid purpose id $id: must be between 1 and @{[ MAX_PURPOSE_ID ]}"
      if $id < 1 || $id > MAX_PURPOSE_ID;

    return $self->_safe_is_purpose_legitimate_interest_allowed($id);
}

sub _safe_is_purpose_legitimate_interest_allowed {
    my ( $self, $id ) = @_;

    return
      scalar(
        is_set( $self->{core_data}, OFFSETS->{PURPOSE_LIT_ALLOWED} + $id - 1 )
      );
}

sub purpose_one_treatment {
    my $self = shift;

    return
      scalar( is_set( $self->{core_data}, OFFSETS->{PURPOSE_ONE_TREATMENT} ) );
}

sub publisher_country_code {
    my $self = shift;

    return scalar(
        get_char6_pair(
            $self->{core_data}, OFFSETS->{PUBLISHER_COUNTRY_CODE}
        )
    );
}

sub max_vendor_id_consent {
    my $self = shift;

    return $self->{vendor_consents}->max_id;
}

sub max_vendor_id_legitimate_interest {
    my $self = shift;

    return $self->{vendor_legitimate_interests}->max_id;
}

sub vendor_consent {
    my ( $self, $id ) = @_;

    return $self->{vendor_consents}->contains($id);
}

sub vendor_legitimate_interest {
    my ( $self, $id ) = @_;

    return $self->{vendor_legitimate_interests}->contains($id);
}

sub check_publisher_restriction {
    my $self = shift;

    my ( $purpose_id, $restriction_type, $vendor_id );

    if ( scalar(@_) == 6 ) {
        my (%opts) = @_;

        $purpose_id       = $opts{purpose_id};
        $restriction_type = $opts{restriction_type};
        $vendor_id        = $opts{vendor_id};
    }

    ( $purpose_id, $restriction_type, $vendor_id ) = @_;

    return $self->{publisher}
      ->check_restriction( $purpose_id, $restriction_type, $vendor_id );
}

sub publisher_restrictions {
    my ( $self, $vendor_id ) = @_;

    return $self->{publisher}->restrictions($vendor_id);
}

sub publisher_tc {
    my $self = shift;

    return $self->{publisher}->publisher_tc;
}

sub _format_date {
    my ( $self, $epoch, $nanoseconds ) = @_;

    return $epoch if !!$self->{options}->{json}->{use_epoch};

    my $format = $self->{options}->{json}->{date_format};

    return $format->( $epoch, $nanoseconds ) if ref($format) eq ref( sub { } );

    return strftime( $format, gmtime($epoch) );
}

sub _json_true { 1 == 1 }

sub _json_false { 1 == 0 }

sub _format_json_subsection {
    my ( $self, @data ) = @_;

    if ( !!$self->{options}->{json}->{compact} ) {
        return [ map { $_->[0] } grep { $_->[1] } @data ];
    }

    my $verbose = !!$self->{options}->{json}->{verbose};

    return { map { @{$_} } grep { $verbose || $_->[1] } @data };
}

sub TO_JSON {
    my $self = shift;

    my ( $false, $true ) = @{ $self->{options}->{json}->{boolean_values} };

    my $created      = $self->_format_date( $self->created );
    my $last_updated = $self->_format_date( $self->last_updated );

    return {
        tc_string               => $self->tc_string,
        version                 => $self->version,
        created                 => $created,
        last_updated            => $last_updated,
        cmp_id                  => $self->cmp_id,
        cmp_version             => $self->cmp_version,
        consent_screen          => $self->consent_screen,
        consent_language        => $self->consent_language,
        vendor_list_version     => $self->vendor_list_version,
        policy_version          => $self->policy_version,
        is_service_specific     => $self->is_service_specific ? $true : $false,
        use_non_standard_stacks => $self->use_non_standard_stacks
        ? $true
        : $false,
        purpose_one_treatment => $self->purpose_one_treatment ? $true : $false,
        publisher_country_code  => $self->publisher_country_code,
        special_features_opt_in => $self->_format_json_subsection(
            map {
                [     $_ => $self->_safe_is_special_feature_opt_in($_)
                    ? $true
                    : $false
                ]
            } 1 .. MAX_SPECIAL_FEATURE_ID
        ),
        purpose => {
            consents => $self->_format_json_subsection(
                map {
                    [     $_ => $self->_safe_is_purpose_consent_allowed($_)
                        ? $true
                        : $false
                    ]
                } 1 .. MAX_PURPOSE_ID,
            ),
            legitimate_interests => $self->_format_json_subsection(
                map {
                    [   $_ =>
                          $self->_safe_is_purpose_legitimate_interest_allowed(
                            $_)
                        ? $true
                        : $false
                    ]
                } 1 .. MAX_PURPOSE_ID,
            ),
        },
        vendor => {
            consents             => $self->{vendor_consents}->TO_JSON,
            legitimate_interests =>
              $self->{vendor_legitimate_interests}->TO_JSON,
        },
        publisher => $self->{publisher}->TO_JSON,
    };
}

sub _decode_tc_string_segments {
    my $tc_string = shift;

    my ( $core, @parts ) = split CONSENT_STRING_TCF_V2->{SEPARATOR},
      $tc_string;

    my $core_data      = _validate_and_decode_base64($core);
    my $core_data_size = length($core_data) / 8;

    croak
      "vendor consent strings are at least @{[ CONSENT_STRING_TCF_V2->{MIN_BYTE_SIZE} ]} bytes long (got ${core_data_size} bytes)"
      if $core_data_size < CONSENT_STRING_TCF_V2->{MIN_BYTE_SIZE};

    my %segments;

    foreach my $part (@parts) {
        my $decoded = _validate_and_decode_base64($part);

        my $segment_type = get_uint3( $decoded, OFFSETS->{SEGMENT_TYPE} );

        $segments{$segment_type} = $decoded;
    }

    my $publisher_tc = $segments{ SEGMENT_TYPES->{PUBLISHER_TC} };

    return {
        core_data    => $core_data,
        publisher_tc => $publisher_tc,
    };
}

sub _validate_and_decode_base64 {
    my $s = shift;

    # see: https://www.perlmonks.org/?node_id=775820
    croak "invalid base64 format" unless $s =~ m{
        ^
        (?: [A-Za-z0-9-_]{4} )*
        (?:
            [A-Za-z0-9-_]{2} [AEIMQUYcgkosw048]
        |
            [A-Za-z0-9-_] [AQgw]
        )?
        \z
    }x;

    return unpack 'B*', _decode_base64url($s);
}

sub _decode_base64url {
    my $s = shift;
    $s =~ tr[-_][+/];
    $s .= '=' while length($s) % 4;
    return decode_base64($s);
}

sub _parse_vendor_section {
    my $self = shift;

    # parse vendor consent

    my $legitimate_interest_offset =
      $self->_parse_vendor_consents( OFFSETS->{VENDOR_CONSENT} );

    # parse vendor legitimate interest

    my $pub_restriction_offset =
      $self->_parse_vendor_legitimate_interests($legitimate_interest_offset);

    return $pub_restriction_offset;
}

sub _parse_vendor_consents {
    my ( $self, $vendor_consent_offset ) = @_;

    my ( $vendor_consents, $legitimate_interest_offset ) =
      $self->_parse_bitfield_or_range(
        $vendor_consent_offset,
      );

    $self->{vendor_consents} = $vendor_consents;

    return $legitimate_interest_offset;
}

sub _parse_vendor_legitimate_interests {
    my ( $self, $legitimate_interest_offset ) = @_;

    my $data_size = length( $self->{core_data} );

    my ( $vendor_legitimate_interests, $pub_restriction_offset ) =
      $self->_parse_bitfield_or_range(
        $legitimate_interest_offset,
        sub {
            my $legitimate_interest_start = shift;

            croak "invalid consent data: no legitimate interest start position"
              if $legitimate_interest_start >= $data_size;
        }
      );

    $self->{vendor_legitimate_interests} = $vendor_legitimate_interests;

    return $pub_restriction_offset;
}

sub _parse_publisher_section {
    my ( $self, $pub_restriction_offset ) = @_;

    # parse public restrictions

    my $core_data      = substr( $self->{core_data}, $pub_restriction_offset );
    my $core_data_size = length( $self->{core_data} );

    my $publisher = GDPR::IAB::TCFv2::Publisher->Parse(
        core_data         => $core_data,
        core_data_size    => $core_data_size,
        publisher_tc_data => $self->{publisher_tc_data},
        options           => $self->{options},
    );

    $self->{publisher} = $publisher;
}

sub _parse_bitfield_or_range {
    my ( $self, $offset, $validate_next_offset ) = @_;

    my $something;

    my ( $max_id, $next_offset ) = get_uint16( $self->{core_data}, $offset );

    $validate_next_offset->($next_offset) if defined $validate_next_offset;

    my $is_range;

    ( $is_range, $next_offset ) = is_set(
        $self->{core_data},
        $next_offset,
    );

    if ($is_range) {
        ( $something, $next_offset ) = $self->_parse_range_section(
            $max_id,
            $next_offset,
        );
    }
    else {
        ( $something, $next_offset ) = $self->_parse_bitfield(
            $max_id,
            $next_offset,
        );
    }

    return wantarray ? ( $something, $next_offset ) : $something;
}

sub _parse_range_section {
    my ( $self, $max_id, $range_section_start_offset ) = @_;

    my $data      = substr( $self->{core_data}, $range_section_start_offset );
    my $data_size = length( $self->{core_data} );

    my ( $range_section, $next_offset ) =
      GDPR::IAB::TCFv2::RangeSection->Parse(
        data      => $data,
        data_size => $data_size,
        offset    => 0,
        max_id    => $max_id,
        options   => $self->{options},
      );

    return
      wantarray
      ? ( $range_section, $range_section_start_offset + $next_offset )
      : $range_section;
}

sub _parse_bitfield {
    my ( $self, $max_id, $bitfield_start_offset ) = @_;

    my $data = substr( $self->{core_data}, $bitfield_start_offset, $max_id );
    my $data_size = length( $self->{core_data} );

    my ( $bitfield, $next_offset ) = GDPR::IAB::TCFv2::BitField->Parse(
        data      => $data,
        data_size => $data_size,
        max_id    => $max_id,
        options   => $self->{options},
    );

    return wantarray
      ? ( $bitfield, $bitfield_start_offset + $next_offset )
      : $bitfield;
}

sub looksLikeIsConsentVersion2 {
    my ($gdpr_consent_string) = @_;

    return unless defined $gdpr_consent_string;

    return
      rindex( $gdpr_consent_string, CONSENT_STRING_TCF_V2->{PREFIX}, 0 ) == 0;
}

BEGIN {
    if ( my $native_decode_base64url = MIME::Base64->can("decode_base64url") )
    {
        no warnings q;

        *_decode_base64url = $native_decode_base64url;
    }

    eval {
        require JSON;

        if ( my $native_json_true = JSON->can("true") ) {
            no warnings q;

            *_json_true = $native_json_true;
        }

        if ( my $native_json_false = JSON->can("false") ) {
            no warnings q;

            *_json_false = $native_json_false;
        }
    };
}


1;
__END__