#!/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 'texts.pl';
require Message::CGI::HTTP;
require Encode;
my $cgi = Message::CGI::HTTP->new;
$cgi->{decoder}->{'#default'} = sub {
return Encode::decode ('utf-8', $_[1]);
};
our $Lang = 'ja'
if $cgi->get_meta_variable ('HTTP_ACCEPT_LANGUAGE') =~ /\bja\b/; ## TODO: ...
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];
my $ac = 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 q[Content-Type: text/html; charset=utf-8
];
print_text ('User %s', sub { print $e_user_id });
print q[
];
print_text ('User %s', sub { print $e_user_id });
print q[ ];
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 q[];
print_text ('Groups');
print q[ ];
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_text ('Properties');
print q[ ];
print_text (q[Don't expose any confidential data.]);
print q[ ];
print_prop_list ($ac, $user_prop,
{
name => 'full_name',
label => 'Full name',
field_type => 'text',
},
{
name => 'mail_addr',
label => 'Mail address',
field_type => 'email',
},
{
name => 'home_url',
label => 'Web site URL',
field_type => 'url',
},
);
print qq[
];
print_text ('Password');
print q[
];
print_text ('Disable account');
print q[
];
print_text ('Joining the group %s', sub { print $e_group_id });
print q[
];
print_text ('Joining the group %s', sub { print $e_group_id });
print q[
];
print_text ('Description');
print qq[ @{[$group_prop->{desc}]}
];
exit;
}
} 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 ();
redirect (303, $status, './#groups');
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[2] eq 'prop') {
if ($cgi->request_method eq 'POST') {
lock_start ();
my $user_prop = get_user_prop ($user_id);
if ($user_prop) {
binmode STDOUT, ':encoding(utf-8)';
my $prop_name = $cgi->get_parameter ('name');
if (defined $prop_name and
{
full_name => 1,
mail_addr => 1,
home_url => 1,
}->{$prop_name}) {
$user_prop->{$prop_name} = $cgi->get_parameter ('value');
set_user_prop ($user_id, $user_prop);
commit ();
print "Status: 204 Property updated\n\n";
exit;
} else {
print_error (400, 'Bad property');
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 q[Content-Type: text/html; charset=utf-8
];
print_text ('Group %s', sub { print $e_group_id });
print q[
];
if (defined $group_prop->{favicon_url}) {
print q[ ];
print q[];
print_text ('Properties');
print q[ ];
print_prop_list ($ac, $group_prop,
{
name => 'desc',
label => 'Description',
field_type => 'textarea',
public => 1,
},
{
name => 'admin_group',
label => 'Administrative group',
field_type => 'text',
},
{
name => 'favicon_url',
label => 'Group icon URL',
field_type => 'url',
},
);
print q[];
print_text ('Members');
print q[ ];
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[];
print_text ('Member approval policy');
print qq[
];
print_text ('Invite a user');
print q[
];
print_text ('Group %s registered', sub { print '', htescape ($group_id) });
print q[
];
print_text ('Group %s registered', sub { print '', htescape ($group_id) });
print q[ ];
print_text ('The new group is created successfully.');
print q[
];
print_text ('See %s.', sub {
print qq[];
print_text ('the group information page');
print qq[ ];
});
exit;
} else {
binmode STDOUT, ":encoding(utf-8)";
print q[Content-Type: text/html; charset=utf-8
];
print_text ('Create a new group');
print q[
];
print_text ('Create a new group');
print q[
];
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/;
redirect (303, 'See other', 'users/' . $user_id . '/');
exit;
} elsif (@path == 0) {
redirect (301, 'Moved', 'edit/');
exit;
}
print_error (404, 'Not found');
exit;
sub print_list_section (%) {
my %opt = @_;
$opt{level} ||= 3;
print q[];
print_text ($opt{title});
print q[ ];
for my $item (sort {$a cmp $b} @{$opt{items}}) {
print q[];
$opt{print_item}->($item);
}
print q[ ];
print_text ($prop->{label});
print q[ : ];
print $prop_hash->{$prop->{name}};
}
if ($ac->{write}) {
print q[
];
}
}
} # print_prop_list
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;
my $ac = {};
my $return_ac;
if ($opt{allowed_users}->{$user_id}) {
$ac->{write} = 1;
$return_ac = 1;
}
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) {
if (defined $group_prop->{admin_group}) {
my $ag_prop = get_group_prop ($group_prop->{admin_group});
if ($ag_prop and
$user_prop->{'group.' . $group_prop->{admin_group}}->{member}) {
return {write => 1, read_group_member_list => 1};
}
}
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 %s)], $user);
} else {
print_error (403, 'Forbidden');
}
exit;
} # forbidden
sub redirect ($$$) {
my ($code, $status, $url) = @_;
my $abs_url = get_absolute_url ($url);
print qq[Status: $code $status
Location: $abs_url
Content-Type: text/html; charset=us-ascii
See other page .];
} # redirect
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