Adding otpauth URI

README.md

@@ -632,6 +632,13 @@ generic methods.
 
     See _news_ scheme and [RFC 5538](https://tools.ietf.org/html/rfc5538).
 
+- **otpauth**:
+
+    The _otpauth_ URI scheme is specified in [https://github.com/google/google-authenticator/wiki/Key-Uri-Format](https://github.com/google/google-authenticator/wiki/Key-Uri-Format).
+    The scheme is used to encode secret keys for use in TOTP or HOTP schemes.
+
+    `URI` objects belonging to the otpauth scheme support the common methods.
+
 - **pop**:
 
     The _pop_ URI scheme is specified in RFC 2384. The scheme is used to

cpanfile

@@ -28,6 +28,7 @@ on 'runtime' => sub {
     requires "Data::Dumper" => "0";
     requires "Encode" => "0";
     requires "Exporter" => "5.57";
+    requires "MIME::Base32" => "0";
     requires "MIME::Base64" => "2";
     requires "Net::Domain" => "0";
     requires "Scalar::Util" => "0";

dist.ini

@@ -23,6 +23,7 @@ filename = t/escape.t
 filename = t/http.t
 filename = t/icap.t
 filename = t/old-base.t
+filename = t/otpauth.t
 filename = t/pop.t
 filename = t/rtsp.t
 filename = uri-test
@@ -146,6 +147,12 @@ stopword = UNC
 stopword = uppercasing
 stopword = unicode
 stopword = xn
+stopword = totp
+stopword = hotp
+stopword = TOTP
+stopword = HOTP
+stopword = OTP
+stopword = cryptographic
 
 ;;; pre-release actions
 

lib/URI.pm

@@ -1087,6 +1087,13 @@ See I<news> scheme.
 
 See I<news> scheme and L<RFC 5538|https://tools.ietf.org/html/rfc5538>.
 
+=item B<otpauth>:
+
+The I<otpauth> URI scheme is specified in L<https://github.com/google/google-authenticator/wiki/Key-Uri-Format>.
+The scheme is used to encode secret keys for use in TOTP or HOTP schemes.
+
+C<URI> objects belonging to the otpauth scheme support the common methods.
+
 =item B<pop>:
 
 The I<pop> URI scheme is specified in RFC 2384. The scheme is used to

lib/URI/otpauth.pm

@@ -0,0 +1,298 @@
+package URI::otpauth;
+
+use warnings;
+use strict;
+use MIME::Base32();
+use URI::Split();
+use URI::Escape();
+
+use parent qw( URI URI::_query );
+
+our $VERSION = '5.29';
+
+sub new {
+    my ($class, @parameters) = @_;
+    my %fields = $class->_set(@parameters);
+    my $uri    = URI::Split::uri_join(
+        'otpauth', $fields{type},
+        $class->_path(%fields),
+        $class->_query(%fields),
+    );
+    return bless \$uri, $class;
+}
+
+sub _parse {
+    my $self = shift;
+    my ($scheme, $type, $path, $query, $frag) = URI::Split::uri_split(${$self});
+    $path =~ s/^\///smxg;
+    my @path_parts = split /:/smx, $path;
+    my ($issuer_prefix, $account_name);
+    if (scalar @path_parts == 1) {
+        $account_name = $path_parts[0];
+    }
+    else {
+        $issuer_prefix = $path_parts[0];
+        $account_name  = $path_parts[1];
+    }
+    my %fields = (label => $path, type => $type, account_name => $account_name);
+    my $issuer_parameter = $self->query_param('issuer');
+    if (defined $issuer_parameter) {
+        if ((defined $issuer_prefix) && ($issuer_prefix ne $issuer_parameter)) {
+            Carp::carp(
+                "Issuer prefix from label '$issuer_prefix' does not match issuer parameter '$issuer_parameter'"
+            );
+        }
+        $fields{issuer} = $issuer_parameter;
+    }
+    elsif (defined $issuer_prefix) {
+        $fields{issuer} = URI::Escape::uri_unescape($issuer_prefix);
+    }
+    if (my $encoded_secret = $self->query_param('secret')) {
+        $fields{secret} = MIME::Base32::decode_base32($encoded_secret);
+    }
+    foreach my $name (qw(algorithm digits counter period)) {
+        if (my $value = $self->query_param($name)) {
+            $fields{$name} = $value;
+        }
+    }
+    %fields = $self->_set(%fields);
+    return ($scheme, $fields{type}, \%fields, $query, $frag);
+}
+
+my $label_escape_regex = qr/[^[:alnum:]@.]/smx;
+
+sub _set {
+    my ($self, %fields) = @_;
+    delete $fields{label};
+    if (defined $fields{account_name}) {
+        if (defined $fields{issuer}) {
+            $fields{label} = $fields{issuer} . q[:] . $fields{account_name};
+        }
+        else {
+            $fields{label} = $fields{account_name};
+        }
+    }
+    if (!length $fields{type}) {
+        $fields{type} = 'totp';
+    }
+    return %fields;
+}
+
+my %field_names = map { $_ => 1 }
+    qw(secret label counter algorithm period digits issuer type account_name);
+my @query_names = qw(secret issuer algorithm digits counter period);
+my %defaults = (algorithm => 'SHA1', digits => 6, type => 'totp', period => 30);
+
+sub _field {
+    my ($self, $name, @remainder) = @_;
+    my ($scheme, $type, $fields, $query, $frag) = $self->_parse();
+
+    if (!@remainder) {
+        if (defined $fields->{$name}) {
+            return $fields->{$name};
+        }
+        else {
+            return $defaults{$name};
+        }
+    }
+    $fields->{$name} = shift @remainder;
+    ${$self} = URI::Split::uri_join(
+        $scheme, $fields->{type},
+        $self->_path(%{$fields}),
+        $self->_query(%{$fields}), $frag
+    );
+    return $self;
+}
+
+sub _query {
+    my ($class, %fields) = @_;
+    if (defined $fields{secret}) {
+        $fields{secret} = MIME::Base32::encode_base32($fields{secret});
+    }
+    else {
+        Carp::croak('secret is a mandatory parameter for ' . __PACKAGE__);
+    }
+    return join q[&],
+        map { join q[=], $_ => $fields{$_} }
+        grep { exists $fields{$_} } @query_names;
+}
+
+sub _path {
+    my ($class, %fields) = @_;
+    my $path = $fields{label};
+    return $path;
+}
+
+sub type {
+    my ($self, @parameters) = @_;
+    return $self->_field('type', @parameters);
+}
+
+sub label {
+    my ($self, @parameters) = @_;
+    return $self->_field('label', @parameters);
+}
+
+sub account_name {
+    my ($self, @parameters) = @_;
+    return $self->_field('account_name', @parameters);
+}
+
+sub issuer {
+    my ($self, @parameters) = @_;
+    return $self->_field('issuer', @parameters);
+}
+
+sub secret {
+    my ($self, @parameters) = @_;
+    return $self->_field('secret', @parameters);
+}
+
+sub algorithm {
+    my ($self, @parameters) = @_;
+    return $self->_field('algorithm', @parameters);
+}
+
+sub counter {
+    my ($self, @parameters) = @_;
+    return $self->_field('counter', @parameters);
+}
+
+sub digits {
+    my ($self, @parameters) = @_;
+    return $self->_field('digits', @parameters);
+}
+
+sub period {
+    my ($self, @parameters) = @_;
+    return $self->_field('period', @parameters);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::otpauth - URI scheme for secret keys for OTP secrets.  Usually found in QR codes
+
+=head1 VERSION
+
+Version 5.29
+
+=head1 SYNOPSIS
+
+  use URI;
+
+  # optauth URI from textual uri
+  my $uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=NFZS25DINFZV643VOAZXELLTGNRXEM3UH4&issuer=Example' );
+
+  # same URI but created from arguments
+  my $uri = URI::otpauth->new( type => 'totp', issuer => 'Example', account_name => 'alice@google.com', secret => 'is-this_sup3r-s3cr3t?' );
+
+=head1 DESCRIPTION
+
+This URI scheme is defined in L<https://github.com/google/google-authenticator/wiki/Key-Uri-Format/>:
+
+=head1 SUBROUTINES/METHODS
+
+=head2 C<< new >>
+
+Create a new URI::otpauth. The available arguments are listed below;
+
+=over
+
+=item * account_name - this can be the account name (probably an email address) used when authenticating with this secret.  It is an optional field.
+
+=item * algorithm - this is the L<cryptographic hash function|https://en.wikipedia.org/wiki/Cryptographic_hash_function> that should be used.  Current values are L<SHA1|https://en.wikipedia.org/wiki/SHA-1>, L<SHA256|https://en.wikipedia.org/wiki/SHA-2> or L<SHA512|https://en.wikipedia.org/wiki/SHA-2>.  It is an optional field and will default to SHA1.
+
+=item * counter - this is only required when the type is HOTP.
+
+=item * digits - this determines the L<length|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#digits> of the code presented to the user.  It is an optional field and will default to 6 digits.
+
+=item * issuer - this can be the L<application / system|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#issuer> that this secret can be used to authenticate to.  It is an optional field.
+
+=item * label - this is the L<issuer and the account name|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#label> joined with a ":" character.  It is an optional field.
+
+=item * period - this is the L<period that the TOTP code is valid for|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#counter>.  It is an optional field and will default to 30 seconds.
+
+=item * secret - this is the L<key|https://en.wikipedia.org/wiki/Key_(cryptography)> that the L<TOTP|https://en.wikipedia.org/wiki/Time-based_one-time_password>/L<HOTP|https://en.wikipedia.org/wiki/HMAC-based_one-time_password> algorithm uses to derive the value.  It is an arbitrary byte string and must remain private.  This field is mandatory.
+
+=item * type - this can be 'L<hotp|https://en.wikipedia.org/wiki/HMAC-based_one-time_password>' or 'L<totp|https://en.wikipedia.org/wiki/Time-based_one-time_password>'.  This field will default to 'totp'.
+
+=back
+
+=head2 C<algorithm>
+
+Get or set the algorithm of this otpauth URI.
+
+=head2 C<account_name>
+
+Get or set the account_name of this otpauth URI.
+
+=head2 C<counter>
+
+Get or set the counter of this otpauth URI.
+
+=head2 C<digits>
+
+Get or set the digits of this otpauth URI.
+
+=head2 C<issuer>
+
+Get or set the issuer of this otpauth URI.
+
+=head2 C<label>
+
+Get or set the label of this otpauth URI.
+
+=head2 C<period>
+
+Get or set the period of this otpauth URI.
+
+=head2 C<secret>
+
+Get or set the secret of this otpauth URI.
+
+=head2 C<type>
+
+Get or set the type of this otpauth URI.
+
+  my $type = $uri->type('hotp');
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+URI::otpauth requires no configuration files or environment variables.
+
+=head1 DEPENDENCIES
+
+L<URI>
+
+=head1 DIAGNOSTICS
+
+=over
+
+=item C<< secret is a mandatory parameter for URI::otpauth >>
+
+The secret parameter was not detected for the URI::otpauth->new() method.
+
+=back
+
+=head1 INCOMPATIBILITIES
+
+None reported.
+
+=head1 BUGS AND LIMITATIONS
+
+To report a bug, or view the current list of bugs, please visit L<https://github.com/libwww-perl/URI/issues>
+
+=head1 AUTHOR
+
+David Dick C<< <ddick@cpan.org> >>
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2024, David Dick C<< <ddick@cpan.org> >>.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.