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