File Coverage

blib/lib/Net/ACME2/Error.pm
Criterion Covered Total %
statement 21 43 48.8
branch 0 6 0.0
condition 0 5 0.0
subroutine 7 11 63.6
pod 0 4 0.0
total 28 69 40.5


line stmt bran cond sub pod time code
1             package Net::ACME2::Error;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Net::ACME2::Error - error parsing logic for ACME
8              
9             =head1 SYNOPSIS
10              
11             use Net::ACME2::Error;
12              
13             my $err = Net::ACME2::Error->new( { type => '..', .. } );
14              
15             =head1 DESCRIPTION
16              
17             This simple module interfaces with ACME2 “error” objects,
18             which are described in the ACME protocol specification.
19              
20             =head1 NOTES
21              
22             ACME’s errors are basically just HTTP API problem detail documents,
23             which are described in more detail at L.
24              
25             =cut
26              
27 2     2   13 use strict;
  2         5  
  2         61  
28 2     2   10 use warnings;
  2         4  
  2         66  
29              
30 2     2   10 use parent qw( Net::ACME2::AccessorBase );
  2         3  
  2         19  
31              
32             my $URN_PREFIX = 'urn:ietf:params:acme:error:';
33              
34 2         269 use constant _ACCESSORS => qw(
35             detail
36             instance
37             status
38             title
39             type
40 2     2   119 );
  2         6  
41              
42             #cf. https://ietf-wg-acme.github.io/acme/#errors
43 2         754 use constant _TYPE_DESCRIPTION => {
44             badCSR => 'The CSR is unacceptable (e.g., due to a short key)',
45             badNonce => 'The client sent an unacceptable anti-replay nonce',
46             badSignatureAlgorithm => 'The JWS was signed with an algorithm the server does not support',
47             invalidContact => 'A contact URL for an account was invalid',
48             unsupportedContact => 'A contact URL for an account used an unsupported protocol scheme',
49             accountDoesNotExist => 'The request specified an account that does not exist',
50             malformed => 'The request message was malformed',
51             rateLimited => 'The request exceeds a rate limit',
52             rejectedIdentifier => 'The server will not issue for the identifier',
53             serverInternal => 'The server experienced an internal error',
54             unauthorized => 'The client lacks sufficient authorization',
55             unsupportedIdentifier => 'Identifier is not supported, but may be in the future',
56             userActionRequired => 'Visit the “instance” URL and take actions specified there',
57             badRevocationReason => 'The revocation reason provided is not allowed by the server',
58             dns => 'There was a problem with a DNS query',
59              
60             connection => 'The server could not connect to a validation target',
61             dnssec => 'The server could not validate a DNSSEC signed domain',
62             caa => 'CAA records forbid the CA from issuing',
63             tls => 'The server received a TLS error during validation',
64             incorrectResponse => 'Response received didn’t match the challenge’s requirements',
65 2     2   12 };
  2         5  
66              
67             sub type {
68 0     0 0   my ($self) = @_;
69              
70 0   0       return $self->SUPER::type() || 'about:blank';
71             }
72              
73             sub description {
74 0     0 0   my ($self) = @_;
75              
76 0           my $type = $self->type();
77              
78 0           $type =~ s<\A$URN_PREFIX><>;
79              
80 0           return _TYPE_DESCRIPTION()->{$type};
81             }
82              
83             sub subproblems {
84 0     0 0   my ($self) = @_;
85              
86 0           Call::Context::must_be_list();
87              
88 0 0         my $subs_ar = $self->{'_subproblems'} or return;
89              
90 0           return map { Net::ACME2::Error::Subproblem->new($_) } @$subs_ar;
  0            
91             }
92              
93             sub to_string {
94 0     0 0   my ($self) = @_;
95              
96 0           my $str = $self->status() . ' ' . $self->type();
97              
98 0           for my $attribute ( qw( title description detail instance ) ) {
99 0           my $value = $self->$attribute();
100 0 0 0       if ( defined $value && length $value ) {
101 0           $str .= " ($value)";
102             }
103             }
104              
105 0           my @subs = $self->subproblems();
106 0 0         if (@subs) {
107 0           $str .= ' (' . join(', ', map { $_->to_string() } @subs) . ')';
  0            
108             }
109              
110 0           return $str;
111             }
112              
113             #----------------------------------------------------------------------
114              
115             package Net::ACME2::Error::Subproblem;
116              
117 2     2   14 use parent qw( Net::ACME2::Error );
  2         6  
  2         9  
118              
119 2         129 use constant _ACCESSORS => (
120             __PACKAGE__->SUPER::_ACCESSORS(),
121             'identifier',
122 2     2   153 );
  2         3  
123              
124             1;