[160] | 1 | package Vote::DB::Poll; |
---|
| 2 | |
---|
| 3 | # $Id$ |
---|
| 4 | |
---|
| 5 | use strict; |
---|
| 6 | use warnings; |
---|
| 7 | use Vote; |
---|
[171] | 8 | use Crypt::RSA; |
---|
[175] | 9 | use Crypt::RSA::Key::Public::SSH; |
---|
| 10 | use Crypt::RSA::Key::Private::SSH; |
---|
[171] | 11 | use Crypt::CBC; |
---|
| 12 | use XML::Simple; |
---|
| 13 | use MIME::Base64; |
---|
[160] | 14 | use base 'Vote::DB::common'; |
---|
| 15 | use Vote::DB::Ballot; |
---|
| 16 | use Vote::DB::Voting; |
---|
[165] | 17 | use Vote::DB::Choice; |
---|
[160] | 18 | |
---|
| 19 | =head1 NAME |
---|
| 20 | |
---|
| 21 | Vote::Model::Vote - Catalyst Model |
---|
| 22 | |
---|
| 23 | =head1 DESCRIPTION |
---|
| 24 | |
---|
| 25 | Catalyst Model. |
---|
| 26 | |
---|
| 27 | =cut |
---|
| 28 | |
---|
| 29 | sub new { |
---|
| 30 | my ($class, $dbstring, $voteid) = @_; |
---|
| 31 | |
---|
| 32 | bless { |
---|
| 33 | voteid => $voteid, |
---|
| 34 | dbstring => $dbstring, |
---|
| 35 | db => Vote::DB::common::_newdb($dbstring), |
---|
| 36 | }, $class; |
---|
| 37 | } |
---|
| 38 | |
---|
| 39 | sub voteid { $_[0]->{voteid} } |
---|
| 40 | |
---|
[175] | 41 | sub setup { |
---|
| 42 | my ($self) = @_; |
---|
| 43 | $self->param( |
---|
| 44 | free_choice => 0, |
---|
| 45 | choice_count => 1, |
---|
| 46 | ); |
---|
| 47 | } |
---|
| 48 | |
---|
[160] | 49 | sub param { |
---|
| 50 | my ($self, %attr) = @_; |
---|
| 51 | |
---|
| 52 | keys %attr or return; |
---|
| 53 | my @online_f = qw(label start end owner password); |
---|
| 54 | |
---|
| 55 | if (grep { exists($attr{$_}) } @online_f) { |
---|
| 56 | my $sth = $self->db->prepare_cached( |
---|
| 57 | q{update poll set } . |
---|
| 58 | join(',', map { qq("$_" = ?) } grep { exists $attr{$_} } @online_f) . |
---|
| 59 | q{ where id = ?} |
---|
| 60 | ); |
---|
| 61 | $sth->execute((map { $attr{$_} } grep { exists $attr{$_} } @online_f), $self->voteid) |
---|
| 62 | or do { |
---|
| 63 | $self->db->rollback; |
---|
| 64 | return; |
---|
| 65 | }; |
---|
| 66 | } |
---|
| 67 | |
---|
| 68 | # vote settings in settings table |
---|
| 69 | foreach my $var (keys %attr) { |
---|
| 70 | grep { $var eq $_ } @online_f and next; |
---|
| 71 | $self->set_settings($var, $attr{$var}); |
---|
| 72 | } |
---|
| 73 | 1 |
---|
| 74 | } |
---|
| 75 | |
---|
| 76 | sub status { |
---|
| 77 | my ($self) = @_; |
---|
| 78 | |
---|
| 79 | my $sth = $self->db->prepare_cached( |
---|
| 80 | q{ |
---|
| 81 | select (start > now() or start is null) as before, |
---|
| 82 | "end" < now() as after |
---|
| 83 | from poll |
---|
| 84 | where id = ? |
---|
| 85 | } |
---|
| 86 | ); |
---|
| 87 | $sth->execute($self->voteid); |
---|
| 88 | my $res = $sth->fetchrow_hashref; |
---|
| 89 | $sth->finish; |
---|
| 90 | $res or return; |
---|
| 91 | if ($res->{before}) { |
---|
| 92 | return 'BEFORE'; |
---|
| 93 | } elsif ($res->{after}) { |
---|
| 94 | return 'AFTER'; |
---|
| 95 | } else { |
---|
| 96 | return 'RUNNING'; |
---|
| 97 | } |
---|
| 98 | } |
---|
| 99 | |
---|
| 100 | sub info { |
---|
| 101 | my ($self) = @_; |
---|
| 102 | |
---|
| 103 | my $sth = $self->db->prepare_cached( |
---|
| 104 | q{ |
---|
| 105 | select *, |
---|
| 106 | to_char("start", 'DD/MM/YYYY') as dstart, |
---|
| 107 | to_char("start", 'HH24:MI:SS') as hstart, |
---|
| 108 | to_char("end", 'DD/MM/YYYY') as dend, |
---|
| 109 | to_char("end", 'HH24:MI:SS') as hend |
---|
| 110 | from poll where id = ? |
---|
| 111 | } |
---|
| 112 | ); |
---|
| 113 | |
---|
| 114 | $sth->execute($self->voteid); |
---|
| 115 | my $res = $sth->fetchrow_hashref; |
---|
| 116 | $sth->finish; |
---|
| 117 | if ($res) { |
---|
| 118 | my $get = $self->db->prepare_cached( |
---|
| 119 | q{select var, val from settings where poll = ?} |
---|
| 120 | ); |
---|
| 121 | $get->execute($self->voteid); |
---|
| 122 | while (my $set = $get->fetchrow_hashref) { |
---|
| 123 | $res->{$set->{var}} = $set->{val}; |
---|
| 124 | } |
---|
| 125 | } |
---|
| 126 | $res->{free_choice} ||= 0; # avoiding undef |
---|
| 127 | $res |
---|
| 128 | } |
---|
| 129 | |
---|
| 130 | sub set_settings { |
---|
| 131 | my ($self, $var, $val) = @_; |
---|
| 132 | |
---|
| 133 | my $upd = $self->db->prepare_cached( |
---|
| 134 | q{update settings set val = ? where poll = ? and var = ?} |
---|
| 135 | ); |
---|
| 136 | |
---|
| 137 | if ($upd->execute($val, $self->voteid, $var) == 0) { |
---|
| 138 | my $add = $self->db->prepare_cached( |
---|
| 139 | q{insert into settings (poll, var, val) values (?,?,?)} |
---|
| 140 | ); |
---|
| 141 | |
---|
| 142 | $add->execute($self->voteid, $var, $val); |
---|
| 143 | } |
---|
| 144 | } |
---|
| 145 | |
---|
| 146 | sub signing { |
---|
| 147 | my ($self) = @_; |
---|
| 148 | |
---|
| 149 | my $sth = $self->db->prepare_cached( |
---|
| 150 | q{ |
---|
| 151 | select *, voting.key as vkey from voting left join signing |
---|
| 152 | on signing.key = voting.key |
---|
| 153 | where poll = ? order by voting.mail |
---|
| 154 | } |
---|
| 155 | ); |
---|
| 156 | $sth->execute($self->voteid); |
---|
| 157 | my @people; |
---|
| 158 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 159 | push(@people, $res); |
---|
| 160 | } |
---|
| 161 | @people |
---|
| 162 | } |
---|
| 163 | |
---|
| 164 | sub voting { |
---|
| 165 | my ($self, $votingkey) = @_; |
---|
| 166 | |
---|
| 167 | my $sth = $self->db->prepare_cached( |
---|
| 168 | q{ |
---|
| 169 | select key from voting where poll = ? and key = ? |
---|
| 170 | } |
---|
| 171 | ); |
---|
| 172 | |
---|
| 173 | $sth->execute($self->voteid, $votingkey); |
---|
| 174 | my $res = $sth->fetchrow_hashref; |
---|
| 175 | $sth->finish; |
---|
[161] | 176 | return $res ? Vote::DB::Voting->new($self->{dbstring}, $votingkey) : undef; |
---|
[160] | 177 | } |
---|
| 178 | |
---|
| 179 | sub voting_from_mail { |
---|
| 180 | my ($self, $mail) = @_; |
---|
| 181 | |
---|
| 182 | my $sth = $self->db->prepare_cached( |
---|
| 183 | q{ |
---|
| 184 | select key from voting where poll = ? and mail = ? |
---|
| 185 | } |
---|
| 186 | ); |
---|
| 187 | |
---|
| 188 | $sth->execute($self->voteid, $mail); |
---|
| 189 | my $res = $sth->fetchrow_hashref; |
---|
| 190 | $sth->finish; |
---|
[161] | 191 | return $res ? Vote::DB::Voting->new($self->{dbstring}, $res->{key}) : undef; |
---|
[160] | 192 | } |
---|
| 193 | |
---|
| 194 | sub voting_keys { |
---|
| 195 | my ($self) = @_; |
---|
| 196 | |
---|
| 197 | my $sth = $self->db->prepare_cached( |
---|
| 198 | q{ |
---|
| 199 | select key from voting |
---|
| 200 | where poll = ? order by voting.mail |
---|
| 201 | } |
---|
| 202 | ); |
---|
| 203 | $sth->execute($self->voteid); |
---|
| 204 | my @people; |
---|
| 205 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 206 | push(@people, $res->{key}); |
---|
| 207 | } |
---|
| 208 | @people |
---|
| 209 | } |
---|
| 210 | |
---|
| 211 | sub voting_info { |
---|
| 212 | my ($self) = @_; |
---|
| 213 | |
---|
| 214 | my $sth = $self->db->prepare_cached( |
---|
| 215 | q{ |
---|
| 216 | select *, voting.key as vkey from voting left join signing |
---|
| 217 | on signing.key = voting.key |
---|
| 218 | where voting.key = ? |
---|
| 219 | } |
---|
| 220 | ); |
---|
| 221 | $sth->execute($self->voteid); |
---|
| 222 | |
---|
| 223 | my $res = $sth->fetchrow_hashref; |
---|
| 224 | $sth->finish; |
---|
| 225 | $res |
---|
| 226 | } |
---|
| 227 | |
---|
[165] | 228 | sub choice { |
---|
| 229 | my ($self, $chid) = @_; |
---|
| 230 | |
---|
| 231 | my $sth = $self->db->prepare_cached( |
---|
| 232 | q{ |
---|
| 233 | select key from choice where poll = ? and key = ? |
---|
| 234 | } |
---|
| 235 | ); |
---|
| 236 | $sth->execute($self->voteid, $chid); |
---|
| 237 | my $res = $sth->fetchrow_hashref; |
---|
| 238 | $sth->finish; |
---|
| 239 | return $res ? Vote::DB::Choice->new($self->{dbstring}, $chid) : undef; |
---|
| 240 | } |
---|
| 241 | |
---|
[160] | 242 | sub choices { |
---|
| 243 | my ($self) = @_; |
---|
| 244 | |
---|
| 245 | my $sth = $self->db->prepare_cached( |
---|
| 246 | q{ |
---|
| 247 | select key from choice where poll = ? |
---|
| 248 | order by label |
---|
| 249 | } |
---|
| 250 | ); |
---|
| 251 | $sth->execute($self->voteid); |
---|
| 252 | my @ch; |
---|
| 253 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 254 | push(@ch, $res->{key}); |
---|
| 255 | } |
---|
| 256 | @ch |
---|
| 257 | } |
---|
| 258 | |
---|
| 259 | sub add_choice { |
---|
| 260 | my ($self, $label) = @_; |
---|
| 261 | |
---|
| 262 | my $sth = $self->db->prepare_cached( |
---|
| 263 | q{insert into choice (poll, label) values (?,?)} |
---|
| 264 | ); |
---|
| 265 | |
---|
| 266 | $sth->execute($self->voteid, $label) or do { |
---|
| 267 | $self->db->rollback; |
---|
| 268 | return; |
---|
| 269 | }; |
---|
| 270 | |
---|
| 271 | 1 |
---|
| 272 | } |
---|
| 273 | |
---|
[165] | 274 | sub delete_choice { |
---|
| 275 | my ($self, $chid) = @_; |
---|
| 276 | |
---|
| 277 | my $sth = $self->db->prepare_cached( |
---|
| 278 | q{delete from choice where key = ?} |
---|
| 279 | ); |
---|
| 280 | |
---|
| 281 | $sth->execute($chid); |
---|
| 282 | } |
---|
| 283 | |
---|
[160] | 284 | sub _register_signing { |
---|
| 285 | my ($self, $mail, $referal) = @_; |
---|
| 286 | |
---|
| 287 | my $vinfo = $self->voting_info_id($mail) or return; |
---|
| 288 | |
---|
| 289 | my $sth = $self->db->prepare_cached( |
---|
| 290 | q{ |
---|
| 291 | insert into signing (key, referal) values (?,?) |
---|
| 292 | } |
---|
| 293 | ); |
---|
| 294 | $sth->execute($vinfo->{key}, $referal) or do { |
---|
| 295 | $self->db->rollback; |
---|
| 296 | return; |
---|
| 297 | }; |
---|
| 298 | |
---|
| 299 | 1; |
---|
| 300 | } |
---|
| 301 | |
---|
| 302 | sub _register_ballot { |
---|
| 303 | my ($self, $choice, $fchoice) = @_; |
---|
| 304 | |
---|
[175] | 305 | my $uid = ($self->is_crypted |
---|
| 306 | ? $self->_register_ballot_crypted($choice, $fchoice) |
---|
| 307 | : $self->_register_ballot_clear($choice, $fchoice)) |
---|
| 308 | or do { |
---|
| 309 | self->db->rollback; |
---|
| 310 | return; |
---|
| 311 | }; |
---|
| 312 | |
---|
| 313 | $uid |
---|
| 314 | } |
---|
| 315 | |
---|
| 316 | sub _register_ballot_clear { |
---|
| 317 | my ($self, $choice, $fchoice, $uid) = @_; |
---|
| 318 | |
---|
[160] | 319 | my $addb = $self->db->prepare_cached( |
---|
| 320 | q{ |
---|
| 321 | insert into ballot (id, poll, invalid) values (?,?,?) |
---|
| 322 | } |
---|
| 323 | ); |
---|
[175] | 324 | $uid ||= Vote::DB::common::gen_uid(); |
---|
[160] | 325 | $addb->execute($uid, $self->voteid, scalar(@{$fchoice || []}) ? undef : 'f') or do { |
---|
| 326 | self->db->rollback; |
---|
| 327 | return; |
---|
| 328 | }; |
---|
| 329 | |
---|
[171] | 330 | $self->_register_ballot_items($uid, $choice, $fchoice) or do { |
---|
| 331 | self->db->rollback; |
---|
| 332 | return; |
---|
| 333 | }; |
---|
| 334 | |
---|
| 335 | $uid |
---|
| 336 | } |
---|
| 337 | |
---|
[191] | 338 | sub find_choice_key { |
---|
| 339 | my ($self, $value) = @_; |
---|
| 340 | |
---|
| 341 | my $sth = $self->prepare_cached( |
---|
| 342 | q{select key from choice where lower(label) = ? and poll = ?} |
---|
| 343 | ); |
---|
| 344 | $sth->execute(lc($value), $self->pollid); |
---|
| 345 | my $res = $sth->fetchrow_hashref; |
---|
| 346 | $sth->finish; |
---|
| 347 | $res->{key} |
---|
| 348 | } |
---|
| 349 | |
---|
[171] | 350 | sub _register_ballot_items { |
---|
| 351 | my ($self, $uid, $choice, $fchoice) = @_; |
---|
| 352 | |
---|
[160] | 353 | my $addbc = $self->db->prepare_cached( |
---|
| 354 | q{ |
---|
| 355 | insert into ballot_item (id, value, fromlist) values (?,?,?) |
---|
| 356 | } |
---|
| 357 | ); |
---|
| 358 | foreach (@{ $choice || []}) { |
---|
| 359 | $addbc->execute($uid, $_, 't') or do { |
---|
| 360 | $self->db->rollback; |
---|
| 361 | return; |
---|
| 362 | }; |
---|
| 363 | } |
---|
| 364 | foreach (@{ $fchoice || []}) { |
---|
| 365 | $_ or next; |
---|
[191] | 366 | my $chkey = $self->find_choice_key($_); |
---|
| 367 | $addbc->execute($uid, $_, $chkey ? 't' : 'f') or do { |
---|
[160] | 368 | $self->db->rollback; |
---|
| 369 | return; |
---|
| 370 | }; |
---|
| 371 | } |
---|
| 372 | |
---|
| 373 | $uid; |
---|
| 374 | } |
---|
| 375 | |
---|
[175] | 376 | sub _register_ballot_crypted { |
---|
| 377 | my ($self, $choice, $fchoice) = @_; |
---|
| 378 | my $xml = XML::Simple->new(ForceArray => 1, RootName => 'ballot'); |
---|
| 379 | my $symkey = map{ chr(rand(256)) } (1 .. (256 / 8)); |
---|
| 380 | my $cipher = new Crypt::CBC($symkey, 'DES'); |
---|
| 381 | my $ballotuid = Vote::DB::common::gen_uid(); |
---|
| 382 | my $encryptedballot = $cipher->encrypt_hex( |
---|
| 383 | $xml->XMLout({ |
---|
| 384 | id => $ballotuid, |
---|
| 385 | sbal => $choice, |
---|
| 386 | fsbal => $fchoice |
---|
| 387 | }) |
---|
| 388 | ); |
---|
| 389 | my $encsymkey = $self->rsa->encrypt ( |
---|
| 390 | Message => $symkey, |
---|
| 391 | Key => $self->public_key, |
---|
| 392 | Armour => 1, |
---|
| 393 | ) || die $self->rsa->errstr(); |
---|
| 394 | |
---|
| 395 | my $addenc = $self->db->prepare_cached( |
---|
| 396 | q{insert into ballot_enc (id, data, enckey, poll) values (?,?,?,?)} |
---|
| 397 | ); |
---|
| 398 | |
---|
| 399 | my $uid = Vote::DB::common::gen_uid(); |
---|
| 400 | $addenc->execute($uid, $encryptedballot, $encsymkey, $self->voteid); |
---|
| 401 | $ballotuid; |
---|
| 402 | } |
---|
| 403 | |
---|
| 404 | sub _decrypted_ballot { |
---|
| 405 | my ($self, $ballotid, $privkey) = @_; |
---|
| 406 | my $sth = $self->db->prepare_cached( |
---|
| 407 | q{select * from ballot_enc where id = ? for update} |
---|
| 408 | ); |
---|
| 409 | $sth->execute($ballotid); |
---|
| 410 | my $ballot = $sth->fetchrow_hashref; |
---|
| 411 | $sth->finish; |
---|
| 412 | my $encsymkey = $ballot->{enckey}; |
---|
| 413 | my $data = $ballot->{data}; |
---|
| 414 | my $symkey = $self->rsa->decrypt ( |
---|
| 415 | Cyphertext => $encsymkey, |
---|
| 416 | Key => $privkey, |
---|
| 417 | Armour => 1, |
---|
| 418 | ) || die $self->rsa->errstr(); |
---|
| 419 | my $cipher = new Crypt::CBC($symkey, 'DES'); |
---|
| 420 | my $xmldata = XMLin($cipher->decrypt_hex($data), ForceArray => 1); |
---|
| 421 | $self->_register_ballot_clear($xmldata->{sbal}, $xmldata->{fsbal}, $xmldata->{id}); |
---|
| 422 | my $upd = $self->db->prepare_cached(q{update ballot_enc set decrypted = true where id = ?}); |
---|
| 423 | if ($upd->execute($ballotid)) { |
---|
| 424 | $self->db->commit; |
---|
| 425 | return; |
---|
| 426 | } else { |
---|
| 427 | $self->db->rollback; |
---|
| 428 | return 1; |
---|
| 429 | } |
---|
| 430 | } |
---|
| 431 | |
---|
| 432 | sub decrypted_ballots { |
---|
| 433 | my ($self, $password) = @_; |
---|
| 434 | my $privkey = $self->private_key($password); |
---|
| 435 | foreach ($self->list_ballot_need_dec) { |
---|
| 436 | $self->_decrypted_ballot($_, $privkey); |
---|
| 437 | } |
---|
| 438 | } |
---|
| 439 | |
---|
[160] | 440 | sub register_ballot { |
---|
| 441 | my ($self, $vid, $choice, $fchoice, $referal) = @_; |
---|
| 442 | |
---|
| 443 | my $uid; |
---|
| 444 | for (0..2) { # 3 try |
---|
| 445 | # First we register voting has voted |
---|
| 446 | $self->_register_signing($vid, $referal) or return; # TODO error ? |
---|
| 447 | |
---|
| 448 | # registring choices |
---|
| 449 | $uid = $self->_register_ballot($choice, $fchoice); |
---|
| 450 | defined($uid) and last; |
---|
| 451 | |
---|
| 452 | } |
---|
| 453 | # everything went fine, saving! |
---|
| 454 | $self->db->commit; |
---|
| 455 | |
---|
| 456 | |
---|
| 457 | $uid |
---|
| 458 | } |
---|
| 459 | |
---|
| 460 | sub voting_count { |
---|
| 461 | my ($self) = @_; |
---|
| 462 | |
---|
| 463 | my $sth = $self->db->prepare_cached( |
---|
| 464 | q{ |
---|
| 465 | select count(*) from voting |
---|
| 466 | where poll = ? |
---|
| 467 | } |
---|
| 468 | ); |
---|
| 469 | $sth->execute($self->voteid); |
---|
| 470 | my $res = $sth->fetchrow_hashref; |
---|
| 471 | $sth->finish; |
---|
| 472 | $res->{count} |
---|
| 473 | } |
---|
| 474 | |
---|
| 475 | sub signing_count { |
---|
| 476 | my ($self) = @_; |
---|
| 477 | |
---|
| 478 | my $sth = $self->db->prepare_cached( |
---|
| 479 | q{ |
---|
| 480 | select count(*) from signing join voting |
---|
| 481 | on voting.key = signing.key where poll = ? |
---|
| 482 | } |
---|
| 483 | ); |
---|
| 484 | |
---|
| 485 | $sth->execute($self->voteid); |
---|
| 486 | my $res = $sth->fetchrow_hashref; |
---|
| 487 | $sth->finish; |
---|
| 488 | $res->{count} |
---|
| 489 | } |
---|
| 490 | |
---|
[175] | 491 | sub is_crypted { |
---|
| 492 | my ($self) = @_; |
---|
| 493 | return $self->info->{public_key} ? 1 : 0; |
---|
| 494 | } |
---|
| 495 | |
---|
[160] | 496 | sub ballot_count { |
---|
| 497 | my ($self) = @_; |
---|
[175] | 498 | return $self->is_crypted |
---|
| 499 | ? $self->ballot_count_crypt |
---|
| 500 | : $self->ballot_count_clear; |
---|
| 501 | } |
---|
[160] | 502 | |
---|
[175] | 503 | sub ballot_count_clear { |
---|
| 504 | my ($self) = @_; |
---|
| 505 | |
---|
[160] | 506 | my $sth = $self->db->prepare_cached( |
---|
[175] | 507 | q{select count(*) from ballot where poll = ?} |
---|
[160] | 508 | ); |
---|
| 509 | |
---|
| 510 | $sth->execute($self->voteid); |
---|
| 511 | my $res = $sth->fetchrow_hashref; |
---|
| 512 | $sth->finish; |
---|
| 513 | $res->{count} |
---|
| 514 | } |
---|
| 515 | |
---|
[175] | 516 | sub ballot_count_crypt { |
---|
| 517 | my ($self) = @_; |
---|
| 518 | |
---|
| 519 | my $sth = $self->db->prepare_cached( |
---|
| 520 | q{select count(*) from ballot_enc where poll = ?} |
---|
| 521 | ); |
---|
| 522 | |
---|
| 523 | $sth->execute($self->voteid); |
---|
| 524 | my $res = $sth->fetchrow_hashref; |
---|
| 525 | $sth->finish; |
---|
| 526 | $res->{count} |
---|
| 527 | } |
---|
| 528 | |
---|
[160] | 529 | sub voting_info_id { |
---|
| 530 | my ($self, $mail) = @_; |
---|
| 531 | |
---|
| 532 | my $sth = $self->db->prepare_cached( |
---|
| 533 | q{ |
---|
| 534 | select * from voting where mail = ? and poll = ? |
---|
| 535 | } |
---|
| 536 | ); |
---|
| 537 | $sth->execute($mail, $self->voteid); |
---|
| 538 | my $res = $sth->fetchrow_hashref(); |
---|
| 539 | $sth->finish; |
---|
| 540 | $res |
---|
| 541 | } |
---|
| 542 | |
---|
| 543 | sub auth_voting { |
---|
| 544 | my ($self, $mail, $password) = @_; |
---|
| 545 | my $userinfo = $self->voting_info_id($mail) or return; |
---|
| 546 | |
---|
| 547 | $userinfo->{passwd} or return; |
---|
| 548 | if (crypt($password, $userinfo->{passwd} || '') eq $userinfo->{passwd}) { |
---|
| 549 | return 1; |
---|
| 550 | } else { |
---|
| 551 | return 0; |
---|
| 552 | } |
---|
| 553 | } |
---|
| 554 | |
---|
| 555 | sub auth_poll { |
---|
| 556 | my ($self, $passwd) = @_; |
---|
| 557 | |
---|
| 558 | my $vinfo = $self->info or return; |
---|
| 559 | |
---|
| 560 | $vinfo->{password} or return; |
---|
| 561 | $passwd or return; |
---|
| 562 | if (crypt($passwd, $vinfo->{password} || '') eq $vinfo->{password}) { |
---|
| 563 | return 1; |
---|
| 564 | } else { |
---|
| 565 | return 0; |
---|
| 566 | } |
---|
| 567 | } |
---|
| 568 | |
---|
| 569 | sub voting_has_sign { |
---|
| 570 | my ($self, $user) = @_; |
---|
[161] | 571 | warn $user; |
---|
[160] | 572 | $self->voting_from_mail($user)->has_sign; |
---|
| 573 | } |
---|
| 574 | |
---|
| 575 | # Requete de decompte des voix: |
---|
| 576 | |
---|
[176] | 577 | sub can_show_result { |
---|
| 578 | my ($self) = @_; |
---|
| 579 | |
---|
| 580 | # If ballot are encrypted, no |
---|
| 581 | if ($self->list_ballot_need_dec) { |
---|
| 582 | return; |
---|
| 583 | } |
---|
| 584 | |
---|
| 585 | return 1; |
---|
| 586 | } |
---|
| 587 | |
---|
[160] | 588 | sub ballot { |
---|
| 589 | my ($self, $id) = @_; |
---|
| 590 | |
---|
| 591 | my $sth = $self->db->prepare_cached( |
---|
| 592 | q{ |
---|
| 593 | select id from ballot where poll = ? and id = ? |
---|
| 594 | } |
---|
| 595 | ); |
---|
| 596 | |
---|
| 597 | $sth->execute($self->voteid, $id); |
---|
| 598 | my $res = $sth->fetchrow_hashref; |
---|
| 599 | $sth->finish; |
---|
| 600 | return $res ? Vote::DB::Ballot->new($self->{dbstring}, $id) : undef; |
---|
| 601 | } |
---|
| 602 | |
---|
| 603 | sub list_ballot { |
---|
| 604 | my ($self) = @_; |
---|
| 605 | |
---|
| 606 | my $sth = $self->db->prepare_cached( |
---|
| 607 | q{ |
---|
| 608 | select id from ballot where poll = ? |
---|
| 609 | order by id |
---|
| 610 | } |
---|
| 611 | ); |
---|
| 612 | $sth->execute($self->voteid); |
---|
| 613 | my @ids; |
---|
| 614 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 615 | push(@ids, $res->{id}); |
---|
| 616 | } |
---|
| 617 | @ids |
---|
| 618 | } |
---|
| 619 | |
---|
[175] | 620 | sub list_ballot_enc { |
---|
| 621 | my ($self) = @_; |
---|
| 622 | |
---|
| 623 | my $sth = $self->db->prepare_cached( |
---|
| 624 | q{ |
---|
| 625 | select id from ballot_enc where poll = ? |
---|
| 626 | order by id |
---|
| 627 | } |
---|
| 628 | ); |
---|
| 629 | $sth->execute($self->voteid); |
---|
| 630 | my @ids; |
---|
| 631 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 632 | push(@ids, $res->{id}); |
---|
| 633 | } |
---|
| 634 | @ids |
---|
| 635 | } |
---|
| 636 | |
---|
| 637 | sub list_ballot_need_dec { |
---|
| 638 | my ($self) = @_; |
---|
| 639 | |
---|
| 640 | my $sth = $self->db->prepare_cached( |
---|
| 641 | q{ |
---|
| 642 | select id from ballot_enc where poll = ? and decrypted = 'false' |
---|
| 643 | order by id |
---|
| 644 | } |
---|
| 645 | ); |
---|
| 646 | $sth->execute($self->voteid); |
---|
| 647 | my @ids; |
---|
| 648 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 649 | push(@ids, $res->{id}); |
---|
| 650 | } |
---|
| 651 | @ids |
---|
| 652 | } |
---|
| 653 | |
---|
[160] | 654 | sub list_ballot_needvalid { |
---|
| 655 | my ($self) = @_; |
---|
| 656 | |
---|
| 657 | my $sth = $self->db->prepare_cached( |
---|
| 658 | q{ |
---|
| 659 | select id from ballot where poll = ? |
---|
| 660 | and invalid is null order by id |
---|
| 661 | } |
---|
| 662 | ); |
---|
| 663 | $sth->execute($self->voteid); |
---|
| 664 | my @ids; |
---|
| 665 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 666 | push(@ids, $res->{id}); |
---|
| 667 | } |
---|
| 668 | @ids |
---|
| 669 | } |
---|
| 670 | |
---|
| 671 | sub ballot_untrusted_values { |
---|
| 672 | my ($self) = @_; |
---|
| 673 | |
---|
| 674 | my $getval = $self->db->prepare_cached( |
---|
| 675 | q{ |
---|
| 676 | select value from ballot join ballot_item |
---|
| 677 | on ballot.id = ballot_item.id |
---|
| 678 | where poll = ? and fromlist = false and corrected is null |
---|
| 679 | group by value order by value |
---|
| 680 | } |
---|
| 681 | ); |
---|
| 682 | $getval->execute($self->voteid); |
---|
| 683 | my @vals; |
---|
| 684 | while (my $res = $getval->fetchrow_hashref) { |
---|
| 685 | push(@vals, $res->{value}); |
---|
| 686 | } |
---|
| 687 | @vals |
---|
| 688 | } |
---|
| 689 | |
---|
| 690 | sub ballot_values { |
---|
| 691 | my ($self) = @_; |
---|
| 692 | |
---|
| 693 | my $getval = $self->db->prepare_cached( |
---|
| 694 | q{ |
---|
| 695 | select coalesce(corrected, value) as value from ballot join ballot_item |
---|
| 696 | on ballot.id = ballot_item.id |
---|
| 697 | where poll = ? |
---|
| 698 | group by coalesce(corrected, value) order by coalesce(corrected, value) |
---|
| 699 | } |
---|
| 700 | ); |
---|
| 701 | $getval->execute($self->voteid); |
---|
| 702 | my @vals; |
---|
| 703 | while (my $res = $getval->fetchrow_hashref) { |
---|
| 704 | push(@vals, $res->{value}); |
---|
| 705 | } |
---|
| 706 | @vals |
---|
| 707 | } |
---|
| 708 | |
---|
| 709 | sub map_value { |
---|
| 710 | my ($self, $from, $to) = @_; |
---|
| 711 | |
---|
| 712 | my $sth = $self->db->prepare_cached( |
---|
| 713 | q{ |
---|
| 714 | update ballot_item set corrected = ? where |
---|
| 715 | id in (select id from ballot where poll = ?) |
---|
| 716 | and (value = ? or corrected = ?) |
---|
| 717 | } |
---|
| 718 | ); |
---|
| 719 | |
---|
| 720 | $sth->execute($to, $self->voteid, $from, $from) or $self->db->rollback; |
---|
| 721 | $self->db->commit; |
---|
| 722 | } |
---|
| 723 | |
---|
| 724 | sub addupd_voting { |
---|
| 725 | my ($self, $mail, $id) = @_; |
---|
| 726 | |
---|
| 727 | $mail =~ s/\s*$//; |
---|
| 728 | $mail =~ s/^\s*//; |
---|
| 729 | $mail = lc($mail); |
---|
| 730 | $id =~ s/\s*$//; |
---|
| 731 | $id =~ s/^\s//; |
---|
| 732 | my $upd = $self->db->prepare_cached( |
---|
| 733 | q{ |
---|
| 734 | update voting set label = ? where mail = ? and poll = ? |
---|
| 735 | } |
---|
| 736 | ); |
---|
| 737 | |
---|
| 738 | if ($upd->execute($id || '', $mail, $self->voteid) == 0) { |
---|
| 739 | my $add = $self->db->prepare_cached(q{ |
---|
| 740 | insert into voting (poll, label, mail) values (?,?,?) |
---|
| 741 | }); |
---|
| 742 | |
---|
| 743 | $add->execute($self->voteid, $id || '', $mail); |
---|
| 744 | } |
---|
| 745 | } |
---|
| 746 | |
---|
| 747 | sub voting_from_file { |
---|
| 748 | my ($self, $fh, $delete) = @_; |
---|
| 749 | |
---|
| 750 | if ($delete) { |
---|
| 751 | my $sth = $self->db->prepare(q{delete from voting where poll = ?}); |
---|
| 752 | $sth->execute($self->voteid); |
---|
| 753 | } |
---|
| 754 | |
---|
| 755 | while (my $line = <$fh>) { |
---|
| 756 | chomp($line); |
---|
| 757 | my ($mail, $name) = split(';', $line); |
---|
| 758 | $mail or do { |
---|
| 759 | $self->db->rollback; |
---|
| 760 | return; |
---|
| 761 | }; |
---|
| 762 | $self->addupd_voting($self->voteid, $mail, $name || ''); |
---|
| 763 | } |
---|
| 764 | 1; |
---|
| 765 | } |
---|
| 766 | |
---|
[182] | 767 | sub list_voting_no_passwd { |
---|
| 768 | my ($self) = @_; |
---|
[160] | 769 | |
---|
| 770 | my $list_voting = $self->db->prepare_cached( |
---|
| 771 | q{select key from voting where poll = ? and passwd is null or passwd = ''} |
---|
| 772 | ); |
---|
| 773 | |
---|
| 774 | $list_voting->execute($self->voteid); |
---|
[182] | 775 | my @ids; |
---|
[160] | 776 | while (my $res = $list_voting->fetchrow_hashref) { |
---|
[182] | 777 | push(@ids, $res->{key}); |
---|
[160] | 778 | } |
---|
[182] | 779 | @ids |
---|
[160] | 780 | } |
---|
| 781 | |
---|
| 782 | sub mail_voting_passwd { |
---|
| 783 | my ($self, $id, $mailinfo) = @_; |
---|
[161] | 784 | $self->voting($id)->mail_voting_passwd($mailinfo); |
---|
[160] | 785 | } |
---|
| 786 | |
---|
[171] | 787 | # crypto part |
---|
| 788 | |
---|
| 789 | sub rsa { |
---|
| 790 | my ($self) = @_; |
---|
| 791 | $self->{rsa} ||= new Crypt::RSA ES => 'PKCS1v15'; |
---|
| 792 | } |
---|
| 793 | |
---|
| 794 | sub gen_poll_keys { |
---|
[175] | 795 | my ($self, $password) = @_; |
---|
[171] | 796 | my ($public, $private) = $self->rsa->keygen ( |
---|
| 797 | Identity => 'Epoll Vote ' . $self->voteid, |
---|
| 798 | Size => 768, |
---|
[175] | 799 | Password => $password, |
---|
[171] | 800 | Verbosity => 0, |
---|
| 801 | KF=>'SSH', |
---|
| 802 | ) or die $self->rsa->errstr(); # TODO avoid die |
---|
| 803 | $self->param( |
---|
| 804 | public_key => $public->serialize, |
---|
| 805 | private_key => encode_base64($private->serialize), |
---|
| 806 | ); |
---|
| 807 | } |
---|
| 808 | |
---|
| 809 | sub public_key { |
---|
| 810 | my ($self) = @_; |
---|
| 811 | my $serialize = $self->info->{public_key} or return; |
---|
[175] | 812 | my $pubkey = Crypt::RSA::Key::Public::SSH->new; |
---|
| 813 | $pubkey->deserialize(String => [ $serialize ]); |
---|
[171] | 814 | $pubkey |
---|
| 815 | } |
---|
| 816 | |
---|
[175] | 817 | sub private_key { |
---|
| 818 | my ($self, $password) = @_; |
---|
| 819 | my $serialize = $self->info->{private_key} or return; |
---|
| 820 | my $privkey = Crypt::RSA::Key::Private::SSH->new; |
---|
| 821 | $privkey->deserialize(String => [ decode_base64($serialize) ], Passphrase => $password); |
---|
| 822 | $privkey |
---|
| 823 | } |
---|
[160] | 824 | =head1 AUTHOR |
---|
| 825 | |
---|
| 826 | Thauvin Olivier |
---|
| 827 | |
---|
| 828 | =head1 LICENSE |
---|
| 829 | |
---|
| 830 | This library is free software, you can redistribute it and/or modify |
---|
| 831 | it under the same terms as Perl itself or CeCILL. |
---|
| 832 | |
---|
| 833 | =cut |
---|
| 834 | |
---|
| 835 | 1; |
---|