Improve output of make test
Marc Bradshaw
6 years ago
| 8 | 8 | use Net::DNS::Resolver::Mock; |
| 9 | 9 | |
| 10 | 10 | use Mail::DKIM; |
| 11 | ||
| 11 | 12 | #$Mail::DKIM::SORTTAGS = 1; |
| 12 | 13 | |
| 13 | 14 | use Mail::DKIM::ARC::Signer; |
| 27 | 28 | |
| 28 | 29 | =cut |
| 29 | 30 | |
| 30 | sub new { | |
| 31 | sub new { | |
| 31 | 32 | my ( $class, %args ) = @_; |
| 32 | 33 | my $self = {}; |
| 33 | 34 | bless $self, $class; |
| 47 | 48 | |
| 48 | 49 | sub LoadFile { |
| 49 | 50 | my ( $self, $file ) = @_; |
| 50 | my @data = YAML::XS::LoadFile( $file ); | |
| 51 | $self->{ 'tests' } = \@data; | |
| 51 | my @data = YAML::XS::LoadFile($file); | |
| 52 | $self->{'tests'} = \@data; | |
| 52 | 53 | return; |
| 53 | 54 | } |
| 54 | 55 | |
| 62 | 63 | |
| 63 | 64 | sub SetOperation { |
| 64 | 65 | my ( $self, $operation ) = @_; |
| 65 | die "Invalid operation $operation" unless $operation =~ m{^(validate|sign)$}; | |
| 66 | $self->{ 'operation' } = $operation; | |
| 66 | die "Invalid operation $operation" | |
| 67 | unless $operation =~ m{^(validate|sign)$}; | |
| 68 | $self->{'operation'} = $operation; | |
| 67 | 69 | return; |
| 68 | 70 | } |
| 69 | 71 | |
| 79 | 81 | |
| 80 | 82 | sub DumpTests { |
| 81 | 83 | my ( $self, $testpat ) = @_; |
| 82 | $self->{ 'testpat' } = $testpat; | |
| 84 | $self->{'testpat'} = $testpat; | |
| 83 | 85 | return; |
| 84 | 86 | } |
| 85 | 87 | |
| 99 | 101 | my ( $self, $nsx ) = @_; |
| 100 | 102 | |
| 101 | 103 | $nskip = $nsx if $nsx > 0; |
| 102 | foreach my $Scenario ( @{ $self->{ 'tests' } } ) { | |
| 103 | $self->RunScenario( $Scenario ); | |
| 104 | foreach my $Scenario ( @{ $self->{'tests'} } ) { | |
| 105 | $self->RunScenario($Scenario); | |
| 104 | 106 | } |
| 105 | 107 | return; |
| 106 | 108 | } |
| 116 | 118 | sub RunScenario { |
| 117 | 119 | my ( $self, $scenario ) = @_; |
| 118 | 120 | |
| 119 | my $description = $scenario->{ 'description' }; | |
| 120 | my $tests = $scenario->{ 'tests' }; | |
| 121 | my $txt_records = $scenario->{ 'txt-records' } || q{}; | |
| 122 | my $comment = $scenario->{ 'comment' }; | |
| 123 | my $domain = $scenario->{ 'domain '}; | |
| 124 | my $sel = $scenario->{ 'sel' }; | |
| 125 | my $private_key = $scenario->{ 'privatekey' } || q{}; | |
| 126 | ||
| 127 | diag("--- $description ---"); | |
| 121 | my $description = $scenario->{'description'}; | |
| 122 | my $tests = $scenario->{'tests'}; | |
| 123 | my $txt_records = $scenario->{'txt-records'} || q{}; | |
| 124 | my $comment = $scenario->{'comment'}; | |
| 125 | my $domain = $scenario->{'domain '}; | |
| 126 | my $sel = $scenario->{'sel'}; | |
| 127 | my $private_key = $scenario->{'privatekey'} || q{}; | |
| 128 | ||
| 129 | diag("--- $description ---") unless $ENV{HARNESS_ACTIVE}; | |
| 128 | 130 | |
| 129 | 131 | # remove key BEGIN / END |
| 130 | if($private_key) { | |
| 132 | if ($private_key) { | |
| 131 | 133 | my @chompkey = split( "\n", $private_key ); |
| 132 | $private_key = join( q{}, @chompkey[1..($#chompkey-1)] ); | |
| 134 | $private_key = join( q{}, @chompkey[ 1 .. ( $#chompkey - 1 ) ] ); | |
| 133 | 135 | } |
| 134 | 136 | |
| 135 | 137 | my $ZoneFile = q{}; |
| 136 | 138 | foreach my $Record ( sort keys %$txt_records ) { |
| 137 | my $Txt = $txt_records->{ $Record }; | |
| 139 | my $Txt = $txt_records->{$Record}; | |
| 138 | 140 | $ZoneFile .= $Record . '. 60 TXT'; |
| 139 | 141 | foreach my $TxtLine ( split "\n", $Txt ) { |
| 140 | 142 | $ZoneFile .= ' "' . $TxtLine . '"'; |
| 142 | 144 | $ZoneFile .= "\n"; |
| 143 | 145 | } |
| 144 | 146 | my $FakeResolver = Net::DNS::Resolver::Mock->new(); |
| 145 | $FakeResolver->zonefile_parse( $ZoneFile ); | |
| 146 | ||
| 147 | TEST: | |
| 147 | $FakeResolver->zonefile_parse($ZoneFile); | |
| 148 | ||
| 149 | TEST: | |
| 148 | 150 | foreach my $test ( sort keys %$tests ) { |
| 149 | 151 | |
| 150 | if($nskip > 0) { | |
| 151 | diag("skip $description - $test"); | |
| 152 | if ( $nskip > 0 ) { | |
| 153 | diag("skip $description - $test") unless $ENV{HARNESS_ACTIVE}; | |
| 152 | 154 | $nskip--; |
| 153 | 155 | next; |
| 154 | 156 | } |
| 155 | my $testhash = $tests->{ $test }; | |
| 157 | my $testhash = $tests->{$test}; | |
| 156 | 158 | |
| 157 | 159 | # keys relevant to validate and signing tests |
| 158 | my $comment = $testhash->{ 'comment' }; | |
| 159 | my $cv = $testhash->{ 'cv' }; | |
| 160 | my $description = $testhash->{ 'description' }; | |
| 161 | my $message = $testhash->{ 'message' }; | |
| 162 | my $spec = $testhash->{ 'spec' }; | |
| 160 | my $comment = $testhash->{'comment'}; | |
| 161 | my $cv = $testhash->{'cv'}; | |
| 162 | my $description = $testhash->{'description'}; | |
| 163 | my $message = $testhash->{'message'}; | |
| 164 | my $spec = $testhash->{'spec'}; | |
| 163 | 165 | |
| 164 | 166 | # dump test to a file |
| 165 | if($self->{ 'testpat' }) { | |
| 167 | if ( $self->{'testpat'} ) { | |
| 166 | 168 | local *TOUT; |
| 167 | 169 | my $tfn = $test; |
| 168 | 170 | $tfn =~ s:[ /]:_:g; |
| 169 | 171 | |
| 170 | open TOUT, ">" . sprintf($self->{ 'testpat' }, $tfn) | |
| 171 | or die "cannot write file for $description"; | |
| 172 | open TOUT, ">" . sprintf( $self->{'testpat'}, $tfn ) | |
| 173 | or die "cannot write file for $description"; | |
| 172 | 174 | print TOUT $message; |
| 173 | 175 | close TOUT; |
| 174 | 176 | } |
| 175 | 177 | |
| 176 | 178 | # HACK - skip sha1 tests |
| 177 | if($test =~ /sha1/) { | |
| 178 | #diag("Skip SHA-1 test $test"); | |
| 179 | if ( $test =~ /sha1/ ) { | |
| 180 | diag("Skip SHA-1 test $test") unless $ENV{HARNESS_ACTIVE}; | |
| 179 | 181 | next; |
| 180 | 182 | } |
| 181 | 183 | |
| 182 | 184 | $message =~ s/\015?\012/\015\012/g; |
| 183 | 185 | |
| 184 | if ($self->{ 'operation' } eq 'validate' and (!defined $cv or $cv eq q{}) ) { | |
| 185 | $cv = 'fail'; | |
| 186 | #diag( "Null test cv treated as fail for $description - $test" ); | |
| 187 | } | |
| 188 | ||
| 189 | 186 | my $arc_result; |
| 190 | 187 | |
| 191 | if($self->{ 'operation' } eq 'validate') { | |
| 192 | if (!defined $cv or $cv eq q{}) { | |
| 188 | if ( $self->{'operation'} eq 'validate' ) { | |
| 189 | if ( !defined $cv or $cv eq q{} ) { | |
| 193 | 190 | $cv = 'fail'; |
| 194 | diag( "Null test cv treated as fail for $description - $test" ); | |
| 191 | diag("Null test cv treated as fail for $description - $test") | |
| 192 | unless $ENV{HARNESS_ACTIVE}; | |
| 195 | 193 | } |
| 196 | 194 | |
| 197 | 195 | eval { |
| 198 | my $arc = new Mail::DKIM::ARC::Verifier(Strict => $self->{"Strict"}); | |
| 199 | Mail::DKIM::DNS::resolver( $FakeResolver ); | |
| 200 | $arc->PRINT( $message ); | |
| 201 | $arc->CLOSE(); | |
| 202 | $arc_result = $arc->result(); | |
| 203 | my $arc_result_detail = $arc->result_detail(); | |
| 204 | my $mycv = lc $arc_result eq 'pass' ? 'Pass' : | |
| 205 | lc $arc_result eq 'none' ? 'None' : 'Fail'; | |
| 206 | ||
| 207 | is( lc $mycv, lc $cv, "$description - $test ARC Result $mycv want $cv" ); | |
| 208 | if ( lc $mycv ne lc $cv ) { | |
| 209 | diag( "Got: $arc_result ( $arc_result_detail )" ); | |
| 210 | } | |
| 196 | my $arc = | |
| 197 | new Mail::DKIM::ARC::Verifier( Strict => $self->{"Strict"} ); | |
| 198 | Mail::DKIM::DNS::resolver($FakeResolver); | |
| 199 | $arc->PRINT($message); | |
| 200 | $arc->CLOSE(); | |
| 201 | $arc_result = $arc->result(); | |
| 202 | my $arc_result_detail = $arc->result_detail(); | |
| 203 | my $mycv = | |
| 204 | lc $arc_result eq 'pass' ? 'Pass' | |
| 205 | : lc $arc_result eq 'none' ? 'None' | |
| 206 | : 'Fail'; | |
| 207 | ||
| 208 | is( lc $mycv, lc $cv, | |
| 209 | "$description - $test ARC Result $mycv want $cv" ); | |
| 210 | if ( lc $mycv ne lc $cv ) { | |
| 211 | diag("Got: $arc_result ( $arc_result_detail )") | |
| 212 | unless $ENV{HARNESS_ACTIVE}; | |
| 213 | } | |
| 211 | 214 | }; |
| 212 | 215 | if ( my $error = $@ ) { |
| 213 | 216 | is( 0, 1, "$description- $test - died with $error" ); |
| 216 | 219 | } |
| 217 | 220 | |
| 218 | 221 | # keys relevant to signing tests only |
| 219 | my $aar = $testhash->{ 'AAR' }; | |
| 220 | my $ams = $testhash->{ 'AMS' }; | |
| 221 | my $as = $testhash->{ 'AS' }; | |
| 222 | my $sigheaders = $testhash->{ 'sig-headers' }; | |
| 223 | my $srvid = $testhash->{ 'srv-id' } || $domain; | |
| 224 | my $t = $testhash->{ 't' }; | |
| 222 | my $aar = $testhash->{'AAR'}; | |
| 223 | my $ams = $testhash->{'AMS'}; | |
| 224 | my $as = $testhash->{'AS'}; | |
| 225 | my $sigheaders = $testhash->{'sig-headers'}; | |
| 226 | my $srvid = $testhash->{'srv-id'} || $domain; | |
| 227 | my $t = $testhash->{'t'}; | |
| 225 | 228 | |
| 226 | 229 | my $arc = Mail::DKIM::ARC::Signer->new( |
| 227 | 'Algorithm' => 'rsa-sha256', | |
| 228 | 'Domain' => $domain, | |
| 229 | 'SrvId' => $srvid, | |
| 230 | 'Selector' => $sel, | |
| 231 | 'Key' => Mail::DKIM::PrivateKey->load( 'Data' => $private_key ), | |
| 232 | 'Chain' => 'ar', # use the result from A-R, since message might have changed since verified | |
| 233 | 'Headers' => $sigheaders, | |
| 234 | 'Timestamp' => $t, | |
| 230 | 'Algorithm' => 'rsa-sha256', | |
| 231 | 'Domain' => $domain, | |
| 232 | 'SrvId' => $srvid, | |
| 233 | 'Selector' => $sel, | |
| 234 | 'Key' => Mail::DKIM::PrivateKey->load( 'Data' => $private_key ), | |
| 235 | 'Chain' => 'ar' | |
| 236 | , # use the result from A-R, since message might have changed since verified | |
| 237 | 'Headers' => $sigheaders, | |
| 238 | 'Timestamp' => $t, | |
| 235 | 239 | ); |
| 236 | $arc->{ 'NoDefaultHeaders' } = 1; | |
| 240 | $arc->{'NoDefaultHeaders'} = 1; | |
| 237 | 241 | $Mail::DKIM::SORTTAGS = 1; |
| 238 | Mail::DKIM::DNS::resolver( $FakeResolver ); | |
| 239 | $arc->PRINT( $message ); | |
| 242 | Mail::DKIM::DNS::resolver($FakeResolver); | |
| 243 | $arc->PRINT($message); | |
| 240 | 244 | $arc->CLOSE(); |
| 241 | 245 | my $arcsign_result = $arc->as_string(); |
| 242 | my $arcsign_as = $arc->{ '_AS' }; | |
| 243 | my $arcsign_ams = $arc->{ '_AMS' }; | |
| 244 | my $arcsign_aar = $arc->{ '_AAR' }; | |
| 245 | ||
| 246 | is( sqish( $arcsign_as ), sqish( 'ARC-Seal: ' . $as ), "$description - $test ARC-Seal" ); | |
| 247 | is( sqish( $arcsign_ams ), sqish( 'ARC-Message-Signature: ' . $ams ), "$description - $test ARC-Message-Signature" ); | |
| 248 | is( sqsh( $arcsign_aar), sqsh( 'ARC-Authentication-Results: ' . $aar) , "$description - $test ARC-Authentication-Results" ); | |
| 246 | my $arcsign_as = $arc->{'_AS'}; | |
| 247 | my $arcsign_ams = $arc->{'_AMS'}; | |
| 248 | my $arcsign_aar = $arc->{'_AAR'}; | |
| 249 | ||
| 250 | is( | |
| 251 | sqish($arcsign_as), | |
| 252 | sqish( 'ARC-Seal: ' . $as ), | |
| 253 | "$description - $test ARC-Seal" | |
| 254 | ); | |
| 255 | is( | |
| 256 | sqish($arcsign_ams), | |
| 257 | sqish( 'ARC-Message-Signature: ' . $ams ), | |
| 258 | "$description - $test ARC-Message-Signature" | |
| 259 | ); | |
| 260 | is( | |
| 261 | sqsh($arcsign_aar), | |
| 262 | sqsh( 'ARC-Authentication-Results: ' . $aar ), | |
| 263 | "$description - $test ARC-Authentication-Results" | |
| 264 | ); | |
| 249 | 265 | |
| 250 | 266 | } |
| 251 | 267 | return; |
| 253 | 269 | |
| 254 | 270 | # sort tags |
| 255 | 271 | sub srt { |
| 256 | my ( $header ) = @_; | |
| 272 | my ($header) = @_; | |
| 257 | 273 | my ( $key, $value ) = split( ': ', $header, 2 ); |
| 258 | 274 | $value =~ s/^\s+//gm; |
| 259 | $value =~s/\n//g; | |
| 275 | $value =~ s/\n//g; | |
| 260 | 276 | my @values = split( /;\s*/, $value ); |
| 277 | ||
| 261 | 278 | # @values = map { local $_ = $_ ; s/^\s+|\s+$//g ; $_ } @values; |
| 262 | 279 | @values = map { s/^\s+|\s+$//g } @values; |
| 263 | 280 | my $sorted = join( '; ', sort @values ); |
| 266 | 283 | |
| 267 | 284 | # squash all white space |
| 268 | 285 | sub sqish { |
| 269 | my ( $header ) = @_; | |
| 270 | return "" unless $header; # completely empty | |
| 286 | my ($header) = @_; | |
| 287 | return "" unless $header; # completely empty | |
| 271 | 288 | my ( $key, $value ) = split( ': ', $header, 2 ); |
| 272 | return "" unless $value; # empty value | |
| 273 | ||
| 274 | $value =~ s/[ \t\r\n]+//gs; # remove all white space | |
| 275 | $value =~ s/\s*;\s*/; /g; # squash put in one space around semicolons | |
| 276 | #print "SQUISH $key: $value\n"; | |
| 289 | return "" unless $value; # empty value | |
| 290 | ||
| 291 | $value =~ s/[ \t\r\n]+//gs; # remove all white space | |
| 292 | $value =~ s/\s*;\s*/; /g; # squash put in one space around semicolons | |
| 293 | #print "SQUISH $key: $value\n"; | |
| 277 | 294 | return "$key: $value"; |
| 278 | 295 | } |
| 279 | 296 | |
| 280 | 297 | # squash white space between fields |
| 281 | 298 | sub sqsh { |
| 282 | my ( $header ) = @_; | |
| 283 | return "" unless $header; # completely empty | |
| 299 | my ($header) = @_; | |
| 300 | return "" unless $header; # completely empty | |
| 284 | 301 | my ( $key, $value ) = split( ': ', $header, 2 ); |
| 285 | return "" unless $value; # empty value | |
| 286 | ||
| 287 | $value =~ s/^\s+|[ \t\r\n]+$//gs; # remove leading and trailing white space | |
| 288 | $value =~ s/\n/ /g; # flatten into one line | |
| 289 | $value =~ s/\s*;\s*/; /g; # squash white space around semicolons | |
| 290 | #print "SQUASH $key: $value\n"; | |
| 302 | return "" unless $value; # empty value | |
| 303 | ||
| 304 | $value =~ s/^\s+|[ \t\r\n]+$//gs; # remove leading and trailing white space | |
| 305 | $value =~ s/\n/ /g; # flatten into one line | |
| 306 | $value =~ s/\s*;\s*/; /g; # squash white space around semicolons | |
| 307 | #print "SQUASH $key: $value\n"; | |
| 291 | 308 | return "$key: $value"; |
| 292 | 309 | } |
| 293 | 310 | |
| 296 | 313 | |
| 297 | 314 | =head1 AUTHORS |
| 298 | 315 | |
| 299 | Marc Bradshaw, E<lt>marc@marcbradshaw.netE<gt>, | |
| 300 | 316 | Bron Gondwana, E<lt>brong@fastmailteam.comE<gt>, |
| 301 | 317 | John Levine, E<lt>john.levine@standcore.comE<gt> |
| 302 | 318 | |