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
  56   my $job = push_job (
  57           date => time,
  58           problem => $problem,
  59           user => $r->user,
  60           defined $private ? (private => $private) : (),
  61           defined $contest ? (contest => $contest, private => 1) : (),
  62           filesize => length $prog,
  63           extension => FORMAT_EXTENSION->{$format},
  64   );
  65
  66   set_job_inmeta $job, {
  67           files => {
  68                   prog => {
  69                           format => $format,
  70                           name => 'prog.' . FORMAT_EXTENSION->{$format},
  71                           content => $prog,
  72                   }
  73           }
  74   };
  75
  76   PUBLISH 'jobs', $job;
  77   $r->print("Job submitted");
  78   OK
  79 }
  80
  81 sub register{
  82         my $r = shift;
  83         my $req = Apache2::Request->new($r);
  84         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/;
  85
  86         local $Apache2::Authen::Passphrase::rootdir = $r->dir_config('AuthenPassphraseRootdir');
  87         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;
  88         return aputs $r, 'Username already in use' if -e "$Apache2::Authen::Passphrase::rootdir/$username.yml";
  89         return aputs $r, 'The two passwords do not match' unless $password eq $confirm_password;
  90         return aputs $r, 'All fields are required' if grep { !length } $username, $password, $confirm_password, $name, $email, $phone, $town, $university, $level;
  91         pwset $username, $password;
  92
  93         insert_user $username, name => $name, email => $email, phone => $phone, town => $town, university => $university, level => $level;
  94
  95         PUBLISH genpage =>  "us/index.html";
  96         PUBLISH genpage =>  "us/$username.html";
  97         aputs $r, 'Registered successfully';
  98 }
  99
 100 sub passwd{
 101         my $r = shift;
 102         my $req = Apache2::Request->new($r);
 103         my ($oldpass, $newpass, $confirm) = map {scalar $req->param($_)} 'password', 'new_password', 'confirm_new_password';
 104
 105         local $Apache2::Authen::Passphrase::rootdir = $r->dir_config('AuthenPassphraseRootdir');
 106         return aputs $r, 'Incorrect password' unless eval { pwcheck $r->user, $oldpass; 1 };
 107         return aputs $r, 'The two passwords do not match' unless $newpass eq $confirm;
 108
 109         pwset $r->user, $newpass;
 110         aputs $r, 'Password changed successfully';
 111 }
 112
 113 =begin comment
 114
 115 sub private{
 116   my $r = shift;
 117   my $dir = (fileparse $r->uri)[1];
 118   my $user = $r->user;
 119   chdir $r->dir_config('root') . $dir;
 120
 121   for my $requirement (map { $_->{requirement} } @{$r->requires}) {
 122         my ($command, @args) = split ' ', $requirement;
 123
 124         given ($command){
 125           when('admin-if-private'){
 126                 my $meta = LoadFile 'meta.yml';
 127                 return OK if !$meta->{private} || ($r->user && hascaps $r->user, 'gmadm')
 128           }
 129
 130         }
 131   }
 132
 133   DECLINED
 134 }
 135
 136 =end comment
 137
 138 =cut
 139
 140 1;
 141 __END__
 142 # Below is stub documentation for your module. You'd better edit it!
 143
 144 =head1 NAME
 145
 146 Gruntmaster::Handlers - Perl extension for blah blah blah
 147
 148 =head1 SYNOPSIS
 149
 150   use Gruntmaster::Handlers;
 151   blah blah blah
 152
 153 =head1 DESCRIPTION
 154
 155 Stub documentation for Gruntmaster::Handlers, created by h2xs. It looks like the
 156 author of the extension was negligent enough to leave the stub
 157 unedited.
 158
 159 Blah blah blah.
 160
 161
 162 =head1 SEE ALSO
 163
 164 Mention other useful documentation such as the documentation of
 165 related modules or operating system documentation (such as man pages
 166 in UNIX), or any relevant external documentation such as RFCs or
 167 standards.
 168
 169 If you have a mailing list set up for your module, mention it here.
 170
 171 If you have a web site set up for your module, mention it here.
 172
 173 =head1 AUTHOR
 174
 175 Marius Gavrilescu, E<lt>marius@E<gt>
 176
 177 =head1 COPYRIGHT AND LICENSE
 178
 179 Copyright (C) 2013 by Marius Gavrilescu
 180
 181 This library is free software; you can redistribute it and/or modify
 182 it under the same terms as Perl itself, either Perl version 5.18.1 or,
 183 at your option, any later version of Perl 5 you may have available.
 184
 185
 186 =cut