Trog-Auth-libravatar.t 3.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108
  1. #!/usr/bin/env perl
  2. use 5.040;
  3. use re '/aasx';
  4. use warnings FATAL => 'all';
  5. use Test::More;
  6. use Test::MockModule qw{strict};
  7. use FindBin::libs;
  8. require_ok('Trog::Auth') or BAIL_OUT("Can't load Trog::Auth");
  9. subtest 'users_with_emails -- no rows returned' => sub {
  10. my $sqlite_mock = Test::MockModule->new('Trog::SQLite');
  11. $sqlite_mock->redefine(
  12. 'dbh',
  13. sub {
  14. my $fake_dbh = bless {}, 'FakeDBH_NoRows';
  15. no warnings 'once';
  16. *FakeDBH_NoRows::selectall_arrayref = sub { undef };
  17. return $fake_dbh;
  18. }
  19. );
  20. my $result = Trog::Auth::users_with_emails();
  21. is( ref $result, 'ARRAY', 'returns arrayref even when DB returns undef' );
  22. is( scalar @$result, 0, 'empty arrayref when no rows' );
  23. };
  24. subtest 'users_with_emails -- returns populated list' => sub {
  25. my $fake_rows = [
  26. { name => 'alice', contact_email => 'alice@test.test' },
  27. { name => 'bob', contact_email => 'bob@test.test' },
  28. ];
  29. my $sqlite_mock = Test::MockModule->new('Trog::SQLite');
  30. $sqlite_mock->redefine(
  31. 'dbh',
  32. sub {
  33. my $fake_dbh = bless {}, 'FakeDBH_WithRows';
  34. no warnings 'once';
  35. *FakeDBH_WithRows::selectall_arrayref = sub { $fake_rows };
  36. return $fake_dbh;
  37. }
  38. );
  39. my $result = Trog::Auth::users_with_emails();
  40. is( ref $result, 'ARRAY', 'returns arrayref' );
  41. is( scalar @$result, 2, 'correct number of users' );
  42. is( $result->[0]{name}, 'alice', 'first user name' );
  43. is( $result->[0]{contact_email}, 'alice@test.test', 'first user email' );
  44. is( $result->[1]{name}, 'bob', 'second user name' );
  45. };
  46. subtest 'libravatar hash matching logic' => sub {
  47. use Digest::MD5 qw{md5_hex};
  48. use Digest::SHA qw{sha256_hex};
  49. my $email = 'Test@Example.COM';
  50. my $norm = lc($email);
  51. my $sha256 = sha256_hex($norm);
  52. my $md5 = md5_hex($norm);
  53. isnt( $sha256, $md5, 'SHA-256 and MD5 hashes differ' );
  54. is( length($sha256), 64, 'SHA-256 hash is 64 hex chars' );
  55. is( length($md5), 32, 'MD5 hash is 32 hex chars' );
  56. # Case-normalisation must be consistent with what the endpoint does
  57. is( sha256_hex( lc($email) ), $sha256, 'lc() gives stable SHA-256' );
  58. is( md5_hex( lc($email) ), $md5, 'lc() gives stable MD5' );
  59. # Simulate the lookup: given a hash, find the matching email
  60. my @users = (
  61. { name => 'alice', contact_email => 'alice@test.test' },
  62. { name => 'bob', contact_email => 'bob@test.test' },
  63. );
  64. my $target_hash = sha256_hex( lc('alice@test.test') );
  65. my $matched;
  66. for my $u (@users) {
  67. my $e = lc( $u->{contact_email} );
  68. if ( $target_hash eq sha256_hex($e) || $target_hash eq md5_hex($e) ) {
  69. $matched = $u->{name};
  70. last;
  71. }
  72. }
  73. is( $matched, 'alice', 'SHA-256 lookup finds the correct user' );
  74. my $target_md5 = md5_hex( lc('bob@test.test') );
  75. $matched = undef;
  76. for my $u (@users) {
  77. my $e = lc( $u->{contact_email} );
  78. if ( $target_md5 eq sha256_hex($e) || $target_md5 eq md5_hex($e) ) {
  79. $matched = $u->{name};
  80. last;
  81. }
  82. }
  83. is( $matched, 'bob', 'MD5 lookup finds the correct user' );
  84. # Unknown hash returns no match
  85. $matched = undef;
  86. for my $u (@users) {
  87. my $e = lc( $u->{contact_email} );
  88. if ( 'deadbeef' eq sha256_hex($e) || 'deadbeef' eq md5_hex($e) ) {
  89. $matched = $u->{name};
  90. last;
  91. }
  92. }
  93. is( $matched, undef, 'unknown hash returns no match' );
  94. };
  95. done_testing;