#!/usr/bin/perl
use strict;
use lib qw[/home/httpd/html/www/markup/html/whatpm
/home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];
require Message::CGI::Carp;
require 'users.pl';
require Message::CGI::HTTP;
require Encode;
my $cgi = Message::CGI::HTTP->new;
$cgi->{decoder}->{'#default'} = sub {
return Encode::decode ('utf-8', $_[1]);
};
require Message::DOM::DOMImplementation;
my $dom = Message::DOM::DOMImplementation->new;
my $path = $cgi->path_info;
$path = '' unless defined $path;
my @path = split m#/#, percent_decode ($path), -1;
shift @path;
if (@path == 3 and
$path[0] eq 'users' and
$path[1] =~ /\A[0-9a-z-]+\z/) {
my $user_id = $path[1];
check_access_right (allowed_users => {$user_id => 1},
allowed_groups => {'admin-users' => 1});
if ($path[2] eq '') {
my $user_prop = get_user_prop ($user_id);
if ($user_prop) {
binmode STDOUT, ':encoding(utf-8)';
my $e_user_id = htescape ($user_id);
print qq[Content-Type: text/html; charset=utf-8
User $e_user_id
User $e_user_id
];
my @joined;
my @requested;
my @invited;
my @can_join;
my @can_request;
for my $group_id (get_all_groups ()) {
my $gs = $user_prop->{'group.' . $group_id};
if ($gs->{member}) {
push @joined, $group_id;
} elsif ($gs->{no_approval}) {
push @requested, $group_id;
} elsif ($gs->{invited}) {
push @invited, $group_id;
} else {
my $group_prop = get_group_prop ($group_id);
if ($group_prop->{join_condition}->{invitation}) {
#
} elsif ($group_prop->{join_condition}->{approval}) {
push @can_request, $group_id;
} else {
push @can_join, $group_id;
}
}
}
print qq[
Groups
];
if (@joined) {
print_list_section
(id => 'groups-joined',
title => 'Groups you have joined',
items => \@joined,
print_item => sub {
my $group_id = shift;
print q[];
});
}
if (@requested) {
print_list_section
(id => 'groups-requested',
title => 'Groups you have requested to join but not approved yet',
items => \@requested,
print_item => sub {
my $group_id = shift;
print q[];
});
}
if (@invited) {
print_list_section
(id => 'groups-invited',
title => 'Groups you have been invited but not joined yet, or you have left',
items => \@invited,
print_item => sub {
my $group_id = shift;
print q[];
});
}
if (@can_join) {
print_list_section
(id => 'groups-can-join',
title => 'Groups you can join now (without approval)',
items => \@can_join,
print_item => sub {
my $group_id = shift;
print q[];
});
}
if (@can_request) {
print_list_section
(id => 'groups-can-request',
title => 'Groups you can request to join (approval required to join)',
items => \@can_request,
print_item => sub {
my $group_id = shift;
print q[];
});
}
print q[];
print qq[
Password
Disable account
];
exit;
}
} elsif ($path[2] =~ /\Agroup\.([0-9a-z-]+)\z/) {
my $group_id = $1;
if ($cgi->request_method eq 'POST') {
lock_start ();
binmode STDOUT, ':encoding(utf-8)';
my $user_prop = get_user_prop ($user_id);
my $group_prop = get_group_prop ($group_id);
if ($user_prop and $group_prop) {
my $gs = ($user_prop->{'group.' . $group_id} ||= {});
my $action = $cgi->get_parameter ('action');
my $status;
if ($action eq 'join') {
if ($gs->{member}) {
$status = q[You are a member];
#
} elsif ($gs->{no_approval}) {
$status = q[You are waiting for an approval];
#
} elsif ($gs->{invited}) {
$gs->{member} = 1;
$status = q[Registered];
#
} else {
if ($group_prop->{join_condition}->{invitation}) {
print_error (403, 'You are not invited to this group');
exit;
} elsif ($group_prop->{join_condition}->{approval}) {
$gs->{no_approval} = 1;
$status = q[Request submitted];
#
} else {
$gs->{member} = 1;
$status = q[Registered];
#
}
}
} elsif ($action eq 'leave') {
if ($gs->{member}) {
delete $gs->{member};
$gs->{invited} = 1;
$status = 'Unregistered';
#
} elsif ($gs->{no_approval}) {
delete $gs->{no_approval};
delete $gs->{invited};
$status = 'Request canceled';
#
} else {
$status = 'You are not a member';
#
}
} else {
print_error (400, 'Bad action parameter');
exit;
}
set_user_prop ($user_id, $user_prop);
regenerate_htpasswd_and_htgroup ();
commit ();
print qq[Status: 204 $status\n\n];
exit;
}
}
} elsif ($path[2] eq 'password') {
if ($cgi->request_method eq 'POST') {
lock_start ();
binmode STDOUT, ':encoding(utf-8)';
my $user_prop = get_user_prop ($user_id);
if ($user_prop) {
$user_prop->{pass_crypted} = check_password ($cgi);
set_user_prop ($user_id, $user_prop);
regenerate_htpasswd_and_htgroup ();
commit ();
## Browsers do not support 205.
#print qq[Status: 205 Password changed\n\n];
print qq[Status: 204 Password changed\n\n];
exit;
}
}
} elsif ($path[2] eq 'disabled') {
if ($cgi->request_method eq 'POST') {
lock_start ();
binmode STDOUT, ':encoding(utf-8)';
my $user_prop = get_user_prop ($user_id);
if ($user_prop) {
my $action = $cgi->get_parameter ('action');
if (defined $action and $action eq 'enable') {
delete $user_prop->{disabled};
} else {
$user_prop->{disabled} = 1;
}
set_user_prop ($user_id, $user_prop);
regenerate_htpasswd_and_htgroup ();
commit ();
print "Status: 204 Property updated\n\n";
exit;
}
}
}
} elsif (@path == 3 and
$path[0] eq 'groups' and
$path[1] =~ /\A[0-9a-z-]+\z/) {
my $group_id = $path[1];
my $ac = check_access_right (allowed_groups => {'admin-groups' => 1},
group_context => $group_id);
if ($path[2] eq '') {
my $group_prop = get_group_prop ($group_id);
if ($group_prop) {
binmode STDOUT, ':encoding(utf-8)';
my $e_group_id = htescape ($group_id);
print qq[Content-Type: text/html; charset=utf-8
Group $e_group_id
Group $e_group_id
Members
];
if ($ac->{read_group_member_list}) {
my @members;
my @apps;
my @invited;
for my $user_id (get_all_users ()) {
my $user_prop = get_user_prop ($user_id);
my $gs = $user_prop->{'group.' . $group_id};
if ($gs->{member}) {
push @members, $user_id;
} elsif ($gs->{no_approval}) {
push @apps, $user_id;
} elsif ($gs->{invited}) {
push @invited, $user_id;
}
}
if (@members) {
print_list_section
(id => 'formal-members',
title => 'Formal members',
items => \@members,
print_item => sub {
my $user_id = shift;
print q[];
});
}
if (@apps) {
print_list_section
(id => 'non-approved-users',
title => 'Users who are waiting for the approval to join',
items => \@apps,
print_item => sub {
my $user_id = shift;
print q[];
});
}
if (@invited) {
print_list_section
(id => 'invited-users',
title => 'Users who are invited but not joined or are leaved',
items => \@invited,
print_item => sub {
my $user_id = shift;
print q[];
});
}
}
my $join_condition = $group_prop->{join_condition};
my $disabled = $ac->{write} ? '' : 'disabled';
print qq[
Member approval policy
];
if ($ac->{write}) {
print q[
Invite a user
];
}
print q[];
exit;
}
} elsif ($path[2] eq 'join-condition') {
forbidden () unless $ac->{write};
if ($cgi->request_method eq 'POST') {
lock_start ();
my $group_prop = get_group_prop ($group_id);
if ($group_prop) {
binmode STDOUT, ':encoding(utf-8)';
my $new_condition = $cgi->get_parameter ('condition');
if ($new_condition eq 'invitation') {
$group_prop->{join_condition}->{invitation} = 1;
$group_prop->{join_condition}->{approval} = 1;
} elsif ($new_condition eq 'approval') {
$group_prop->{join_condition}->{approval} = 1;
delete $group_prop->{join_condition}->{invitation};
} else {
delete $group_prop->{join_condition}->{invitation};
delete $group_prop->{join_condition}->{approval};
}
set_group_prop ($group_id, $group_prop);
commit ();
print "Status: 204 join-condition property updated\n\n";
exit;
}
}
} elsif ($path[2] =~ /\Auser\.([0-9a-z-]+)\z/ or
$path[2] eq 'invite-user') {
my $user_id = $1 // $cgi->get_parameter ('user-id') // '';
if ($user_id =~ /\A[0-9a-z-]+\z/ and
$cgi->request_method eq 'POST') {
forbidden () unless $ac->{write};
lock_start ();
my $group_prop = get_group_prop ($group_id);
my $user_prop = get_user_prop ($user_id);
if ($group_prop and $user_prop) {
binmode STDOUT, ':encoding(utf-8)';
my $gs = ($user_prop->{'group.' . $group_id} ||= {});
my $action = $cgi->get_parameter ('action');
$action = 'approve' if $path[2] eq 'invite-user';
my $status;
if ($action eq 'approve') {
if ($gs->{member}) {
$status = 'He is a member';
#
} elsif ($gs->{no_approval}) {
$gs->{member} = 1;
delete $gs->{no_approval};
$status = 'Registered';
#
} elsif ($gs->{invited}) {
$status = 'He has been invited';
#
} else {
$gs->{invited} = 1;
$status = 'Invited';
#
}
} elsif ($action eq 'unapprove') {
if ($gs->{member}) {
delete $gs->{member};
delete $gs->{invited};
$status = 'Unregistered';
#
} elsif ($gs->{invited}) {
delete $gs->{invited};
$status = 'Invitation canceled';
#
} else {
$status = 'Not a member';
#
}
} else {
print_error (400, 'Bad action parameter');
exit;
}
set_user_prop ($user_id, $user_prop);
regenerate_htpasswd_and_htgroup ();
commit ();
print "Status: 204 $status\n\n";
exit;
}
}
}
} elsif (@path == 1 and $path[0] eq 'new-group') {
check_access_right (allowed_groups => {'admin-groups' => 1});
if ($cgi->request_method eq 'POST') {
lock_start ();
binmode STDOUT, ':encoding(utf-8)';
my $group_id = $cgi->get_parameter ('group-id');
if ($group_id !~ /\A[0-9a-z-]{4,20}\z/) {
print_error (400, qq[Group id "$group_id" is invalid; use characters [0-9a-z-]{4,20}]);
exit;
}
if (get_group_prop ($group_id)) {
print_error (400, qq[Group id "$group_id" is already used]);
exit;
}
my $group_prop = {id => $group_id};
set_group_prop ($group_id, $group_prop);
commit ();
my $group_url = get_absolute_url ('groups/' . $group_id . '/');
print qq[Status: 201 Group registered
Location: $group_url
Content-Type: text/html; charset=utf-8
Group "@{[htescape ($group_id)]}" registered
Group "@{[htescape ($group_id)]}" registered
The new group is created successfully.
See the group information page.];
exit;
} else {
binmode STDOUT, ":encoding(utf-8)";
print qq[Content-Type: text/html; charset=utf-8
Create a new group
Create a new group
];
exit;
}
} elsif (@path == 1 and $path[0] eq '') {
my $user_id = $cgi->remote_user;
forbidden () if not defined $user_id or $user_id !~ /\A[0-9a-z-]+\z/;
my $user_url = get_absolute_url ('users/' . $user_id . '/');
print qq[Status: 303 See Other
Location: $user_url
Content-Type: text/html; charset=us-ascii
See your user page.];
exit;
} elsif (@path == 0) {
my $root_url = get_absolute_url ('edit/');
print qq[Status: 301 Moved permanently
Location: $root_url
Content-Type: text/html; charset=us-ascii
See other page.];
exit;
}
print_error (404, 'Not found');
exit;
sub print_list_section (%) {
my %opt = @_;
$opt{level} ||= 3;
print q[] . htescape ($opt{title});
print q[
];
for my $item (sort {$a cmp $b} @{$opt{items}}) {
print q[
];
$opt{print_item}->($item);
}
print q[
];
} # print_list_section
sub check_access_right (%) {
my %opt = @_;
my $user_id = $cgi->remote_user;
forbidden () if not defined $user_id or $user_id !~ /\A[0-9a-z-]+\z/;
my $user_prop = get_user_prop ($user_id);
forbidden () unless $user_prop;
if ($opt{allowed_users}->{$user_id}) {
return {
write => 1,
#read_group_member_list => 0,
};
}
my $ac = {};
my $return_ac;
for my $group_id (keys %{$opt{allowed_groups} or {}}) {
my $group_prop = get_group_prop ($group_id);
next unless $group_prop;
my $gs = $user_prop->{'group.' . $group_id};
if ($gs->{member}) {
return {write => 1, read_group_member_list => 1};
}
}
if (defined $opt{group_context}) {
my $group_prop = get_group_prop ($opt{group_context});
if ($group_prop) {
my $gs = $user_prop->{'group.' . $opt{group_context}};
if ($gs->{member}) {
$return_ac = 1;
} elsif ($gs->{invited}) {
$return_ac = 1;
} elsif ($group_prop->{join_condition}->{acception}) {
$return_ac = 1;
} elsif (not $group_prop->{join_condition}->{invitation}) {
$return_ac = 1;
}
}
}
return $ac if $return_ac;
forbidden ();
} # check_access_right
sub forbidden () {
my $user = $cgi->remote_user;
if (defined $user) {
print_error (403, q[Forbidden (you've logged in as ] . $user . ')');
} else {
print_error (403, 'Forbidden');
}
exit;
} # forbidden
sub percent_decode ($) {
return $dom->create_uri_reference ($_[0])
->get_iri_reference
->uri_reference;
} # percent_decode
sub get_absolute_url ($) {
return $dom->create_uri_reference ($_[0])
->get_absolute_reference ($cgi->request_uri)
->get_iri_reference
->uri_reference;
} # get_absolute_url