lib/Gruntmaster/Handlers.pm

   1 package Gruntmaster::Handlers;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 our $VERSION = '0.001';
   7
   8 use Apache2::Access;
   9 use Apache2::Authen::Passphrase qw/pwcheck pwset USER_REGEX/;
  10 use Apache2::AuthzCaps qw/hascaps/;
  11 use Apache2::RequestRec;
  12 use Apache2::RequestIO;
  13 use Apache2::Request;
  14 use Apache2::Const qw/OK DECLINED/;
  15 use Apache2::Log;
  16 use Apache2::Upload;
  17
  18 use Cwd qw/cwd/;
  19 use File::Basename qw/fileparse/;
  20 use File::Temp qw/tempdir/;
  21 use File::Copy qw/move/;
  22 use Gruntmaster::Data qw/contest_start contest_end push_job set_job_inmeta insert_user PUBLISH/;
  23
  24 use constant FORMAT_EXTENSION => {
  25         C => 'c',
  26         CPP => 'cpp',
  27         MONO => 'cs',
  28         JAVA => 'java',
  29         PASCAL => 'pas',
  30         PERL => 'pl',
  31         PYTHON => 'py',
  32         RUBY => 'rb',
  33 };
  34
  35 sub aputs{
  36         my ($r, $str) = @_;
  37         $r->set_content_length(length $str);
  38         $r->puts($str);
  39         $r->content_type('text/plain');
  40         OK
  41 }
  42
  43 sub submit{
  44   my $r = shift;
  45   my $req = Apache2::Request->new($r);
  46   my ($problem, $format, $contest, $private, $prog) = map {scalar $req->param($_)} 'problem', 'prog_format', 'contest', 'private', 'source_code';
  47   my $upload = $req->upload('prog');
  48   if (defined $upload) {
  49           my $temp;
  50           $upload->slurp($temp);
  51           $prog = $temp if $temp
  52   }
  53   die if defined $contest && $contest !~ /^\w+$/ ;
  54   die if defined $contest && (time < contest_start $contest || time > contest_end $contest);
  55   return aputs 'A required parameter was not supplied' if grep { !defined } $problem, $format, $prog;
  56
  57   local $Gruntmaster::Data::contest = $contest;
  58
  59   my $job = push_job (
  60           date => time,
  61           problem => $problem,
  62           user => $r->user,
  63           defined $private ? (private => $private) : (),
  64           defined $contest ? (contest => $contest, private => 1) : (),
  65           filesize => length $prog,
  66           extension => FORMAT_EXTENSION->{$format},
  67   );
  68
  69   set_job_inmeta $job, {
  70           files => {
  71                   prog => {
  72                           format => $format,
  73                           name => 'prog.' . FORMAT_EXTENSION->{$format},
  74                           content => $prog,
  75                   }
  76           }
  77   };
  78
  79   $contest //= '';
  80   PUBLISH 'jobs', "$contest.$job";
  81   $r->print("Job submitted");
  82   OK
  83 }
  84
  85 sub register{
  86         my $r = shift;
  87         my $req = Apache2::Request->new($r);
  88         my ($username, $password, $confirm_password, $name, $email, $phone, $town, $university, $level) = map { die if length > 200; $_ } map {scalar $req->param($_)} qw/username password confirm_password name email phone town university level/;
  89
  90         local $Apache2::Authen::Passphrase::rootdir = $r->dir_config('AuthenPassphraseRootdir');
  91         return aputs $r, 'Bad username. Allowed characters are letters, digits and underscores, and the username must be between 2 and 20 characters long.' unless $username =~ USER_REGEX;
  92         return aputs $r, 'Username already in use' if -e "$Apache2::Authen::Passphrase::rootdir/$username.yml";
  93         return aputs $r, 'The two passwords do not match' unless $password eq $confirm_password;
  94         return aputs $r, 'All fields are required' if grep { !length } $username, $password, $confirm_password, $name, $email, $phone, $town, $university, $level;
  95         pwset $username, $password;
  96
  97         insert_user $username, name => $name, email => $email, phone => $phone, town => $town, university => $university, level => $level;
  98
  99         PUBLISH genpage =>  "us/index.html";
 100         PUBLISH genpage =>  "us/$username.html";
 101         aputs $r, 'Registered successfully';
 102 }
 103
 104 sub passwd{
 105         my $r = shift;
 106         my $req = Apache2::Request->new($r);
 107         my ($oldpass, $newpass, $confirm) = map {scalar $req->param($_)} 'password', 'new_password', 'confirm_new_password';
 108
 109         local $Apache2::Authen::Passphrase::rootdir = $r->dir_config('AuthenPassphraseRootdir');
 110         return aputs $r, 'Incorrect password' unless eval { pwcheck $r->user, $oldpass; 1 };
 111         return aputs $r, 'The two passwords do not match' unless $newpass eq $confirm;
 112
 113         pwset $r->user, $newpass;
 114         aputs $r, 'Password changed successfully';
 115 }
 116
 117 =begin comment
 118
 119 sub private{
 120   my $r = shift;
 121   my $dir = (fileparse $r->uri)[1];
 122   my $user = $r->user;
 123   chdir $r->dir_config('root') . $dir;
 124
 125   for my $requirement (map { $_->{requirement} } @{$r->requires}) {
 126         my ($command, @args) = split ' ', $requirement;
 127
 128         given ($command){
 129           when('admin-if-private'){
 130                 my $meta = LoadFile 'meta.yml';
 131                 return OK if !$meta->{private} || ($r->user && hascaps $r->user, 'gmadm')
 132           }
 133
 134         }
 135   }
 136
 137   DECLINED
 138 }
 139
 140 =end comment
 141
 142 =cut
 143
 144 1;
 145 __END__
 146 # Below is stub documentation for your module. You'd better edit it!
 147
 148 =head1 NAME
 149
 150 Gruntmaster::Handlers - Perl extension for blah blah blah
 151
 152 =head1 SYNOPSIS
 153
 154   use Gruntmaster::Handlers;
 155   blah blah blah
 156
 157 =head1 DESCRIPTION
 158
 159 Stub documentation for Gruntmaster::Handlers, created by h2xs. It looks like the
 160 author of the extension was negligent enough to leave the stub
 161 unedited.
 162
 163 Blah blah blah.
 164
 165
 166 =head1 SEE ALSO
 167
 168 Mention other useful documentation such as the documentation of
 169 related modules or operating system documentation (such as man pages
 170 in UNIX), or any relevant external documentation such as RFCs or
 171 standards.
 172
 173 If you have a mailing list set up for your module, mention it here.
 174
 175 If you have a web site set up for your module, mention it here.
 176
 177 =head1 AUTHOR
 178
 179 Marius Gavrilescu, E<lt>marius@E<gt>
 180
 181 =head1 COPYRIGHT AND LICENSE
 182
 183 Copyright (C) 2013 by Marius Gavrilescu
 184
 185 This library is free software; you can redistribute it and/or modify
 186 it under the same terms as Perl itself, either Perl version 5.18.1 or,
 187 at your option, any later version of Perl 5 you may have available.
 188
 189
 190 =cut