1use warnings; 2use strict; 3 4package Jifty::LetMe; 5use Digest::MD5 (); 6use Math::BigInt::Calc; 7use String::Koremutake (); 8 9use base qw/Jifty::Object Class::Accessor::Fast/; 10 11__PACKAGE__->mk_accessors ( qw/checksum_provided email path args until user/); 12 13=head1 NAME 14 15Jifty::LetMe - A way to expose single-link URLs to your applications 16 17=head2 new 18 19Create a new "LetMe" authentication object; it takes no parameters. 20It calls L</_init> to do any initialization. 21 22A LetMe is a way to provide a one-time-use URL for a particular purpose. 23All LetMe objects give you a way to validate a user's identity and to 24allow them a very small set of possible actions or page-access permissions. 25 26For example, you can put a LetMe URL in an email to a new user, 27so that when they click on the URL you know that their email address 28is valid. 29 30=cut 31 32sub new { 33 my $class = shift; 34 my $self = {}; 35 bless $self, $class; 36 $self->args({}); 37 $self->_init(@_); 38 return $self; 39 40} 41 42=head2 _init @_ 43 44Called with whatever L</new> was called with. By default, does nothing. 45 46=cut 47 48sub _init { return shift } 49 50=head2 user 51 52Contains an app-specific "user" object. 53 54=cut 55 56=head2 validated_current_user 57 58If the user has presented a valid token, returns an (app-specific 59subclass of the) L<Jifty::CurrentUser> object for the user who has the 60email address in $self->email. If no user has that email address, 61returns undef. 62 63=cut 64 65sub validated_current_user { 66 my $self = shift; 67 return undef unless ( $self->validate ); 68 my $currentuser = Jifty->app_class("CurrentUser"); 69 return Jifty->app_class('CurrentUser')->new( email => $self->email ); 70 71} 72 73 74=head2 _user_from_email ADDRESS 75 76Returns an (app-specific subclass of the) L<Jifty::CurrentUser> object 77for the user who has the email address I<ADDRESS>. 78 79=cut 80 81sub _user_from_email { 82 my $self = shift; 83 my $email = shift; 84 my $currentuser_object_class = Jifty->app_class("CurrentUser"); 85 my $u = $currentuser_object_class->new( email => $email )->user_object; 86 # we want to be able to get at their auth token. 87 $u->current_user( $currentuser_object_class->superuser ); 88 return $u; 89} 90 91sub _generate_digest { 92 my $self = shift; 93 94 # get user's generic secret 95 my $user; 96 return '' unless ( $user = $self->user || $self->_user_from_email($self->email) ); 97 return '' unless ($user->auth_token); 98 99 100 # build an md5sum of the email token and until and our secret 101 my $digest = Digest::MD5->new(); 102 $digest->add( $user->auth_token ); 103 $digest->add( $self->path ); 104 my %args = %{$self->args}; 105 $digest->add( Encode::encode_utf8($_), Encode::encode_utf8($args{$_})) for sort keys %args; 106 $digest->add( $self->until ) if ($self->until); 107 return $digest->hexdigest(); 108} 109 110 111 112=head2 generate_checksum 113 114Returns an authentication checksum for the current combination of: 115 116 user 117 path 118 arguments 119 until 120 121=cut 122 123sub generate_checksum { 124 my $self = shift; 125 126 return substr( $self->_generate_digest, 0, 16 ); 127} 128 129=head2 generate_koremutake_checksum 130 131Generate a slightly more pronounceable version of the checksum using 132L<String::Koremutake>. Due to hex -> integer limitations, this is 133imprecise and may vary depending on the platform it is used on; as 134such, it is deprecated. 135 136=cut 137 138sub generate_koremutake_checksum { 139 my $self = shift; 140 141 # Only take the first 16 characters. We're really just trying to 142 # get something reasonably short, memorable and unguessable. Also, 143 # don't use Math::BigInt->new directly for simple computation, 144 # because it insists exporting overload to us, which makes 145 # devel::cover and devel::dprof very sad. This is deprecated in 146 # favor of generate_checksum, which returns a straight hex digest. 147 my $integer_digest = Math::BigInt::Calc->_str( 148 Math::BigInt::Calc->_from_hex( 149 substr( $self->_generate_digest, 0, 16 ) 150 ) 151 ); 152 153 # koremutake it. This loses precision, since most perls can't 154 # deal with 64 bits with precision. Thus, $integer_digest ends up 155 # being rounded, possibly in unpredicatable ways. 156 my $k = String::Koremutake->new; 157 return( $k->integer_to_koremutake($integer_digest)); 158 159} 160 161=head2 from_token PATH 162 163Parse a string of the form 164 165mylongusername@example.com/update_task/23/until/20050101/bekidrikufryvagygefuba 166 167into 168 169 email => mylongusername@example.com, 170 path => 'update_task/23' 171 until => 20050101, 172 checksum_provided => bekidrikufryvagygefuba 173 174=cut 175 176sub from_token { 177 my $self = shift; 178 my $token = shift; 179 180 my @atoms = split('/',$token); 181 182 $self->email( Jifty::I18N->maybe_decode_utf8(URI::Escape::uri_unescape( shift @atoms )) ); 183 $self->path( shift @atoms ); 184 $self->checksum_provided( pop @atoms ); 185 186 # If they don't even have the right number of items in the path, then we know that it's not valid 187 return undef unless (scalar @atoms % 2 == 0); 188 189 my %args = map { Jifty::I18N->maybe_decode_utf8(URI::Escape::uri_unescape($_)) } @atoms; 190 $self->until( delete $args{until} ) if $args{until}; 191 192 $self->args(\%args); 193} 194 195 196=head2 as_token 197 198Returns the "letme" token for this set of credentials. This should round 199trip cleanly with from_token 200 201=cut 202 203sub as_token { 204 my $self = shift; 205 $self->_generate_token( email => $self->email ); 206} 207 208=head2 as_encoded_token 209 210A variant of as_token that encodes the user's email address suitably 211for passing in a URL 212 213=cut 214 215sub as_encoded_token { 216 my $self = shift; 217 $self->_generate_token( email => URI::Escape::uri_escape_utf8($self->email) ); 218} 219 220sub _generate_token { 221 my $self = shift; 222 my %args = (email => undef, @_); 223 return join ('/', 224 $args{'email'}, 225 $self->path, 226 (map {URI::Escape::uri_escape_utf8($_)} %{$self->args}), 227 (defined $self->until ? ( 'until', $self->until ) : () ), #? 228 $self->generate_checksum 229 ); 230} 231 232 233=head2 as_url 234 235Returns the fully qualified URL for this LetMe. It's composed of 236Jifty->web->url, L</base_path> and L</as_encoded_token> 237 238=cut 239 240sub as_url { 241 my $self = shift; 242 return Jifty->web->url(path => $self->base_path . $self->as_encoded_token); 243 244} 245 246 247=head2 base_path 248 249By default, all "LetMe" actions live at URLs under '/let' inside your 250application. Override this subroutine to change that. 251 252By default, it returns '/let/' 253 254=cut 255 256sub base_path { 257 return '/let/'; 258 259} 260 261 262=head2 validate 263 264Returns true if the credentials the user presented validate OK. 265Returns false otherwise. 266 267=cut 268 269sub validate { 270 my $self = shift; 271 272 # email must exist 273 274 unless ($self->_user_from_email($self->email)) { 275 $self->log->debug("Token validation failed - Invalid user"); 276 return undef; 277 } 278 279 unless ($self->path) { 280 $self->log->debug("Token validation failed - Invalid path"); 281 return undef; 282 } 283 unless ($self->checksum_provided) { 284 $self->log->debug("Token validation failed - Checksum not provided"); 285 return undef; 286 } 287 288 289 unless ($self->_correct_checksum_provided) { 290 $self->log->debug("Token validation failed - Checksum not correct"); 291 return undef; 292 } 293 294 return 1; 295} 296 297 298=head2 _correct_checksum_provided 299 300Returns true if the checksum the user provided is correct. Doesn't 301actually do much input checking. You want to call "validate" 302 303=cut 304 305sub _correct_checksum_provided { 306 my $self = shift; 307 $self->log->debug("LetMe checksum: ".$self->checksum_provided . " vs ". $self->generate_checksum ); 308 return undef 309 unless ( $self->checksum_provided eq $self->generate_checksum ) 310 or 311 ( $self->checksum_provided eq $self->generate_koremutake_checksum ); 312 313 return 1; 314} 315 3161; 317