#!/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[
]; print q[] . htescape ($group_id), q[ ]; print q[]; 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[
]; print q[] . htescape ($group_id), q[ ]; print q[]; 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[
]; print q[] . htescape ($group_id), q[ ]; print q[]; 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[
]; print q[] . htescape ($group_id), q[]; print q[]; 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[] . htescape ($group_id), q[ ]; print q[]; 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 ('You can change the password.'); print q[

]; print_text ('New password'); print q[: (]; print_text ('Type 4 characters at minimum'); print q[)

]; print_text ('New password'); print q[ (]; print_text ('type again'); print q[):

]; print_text ('Disable account'); print q[

]; print_text ('Caution!'); print q[ ]; print_text ('Once you disable your own account, you cannot enable your account by yourself.'); print q[

]; 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 (scalar $cgi->get_parameter ('agreed')) { 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]; # } } } else { my $e_group_id = htescape ($group_id); print q[Content-Type: text/html; charset=utf-8 ]; 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}]}

]; print_text ('Do you really want to join this group?'); print q[

]; 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, './'); 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[

]; print_text ('Group %s', sub { print $e_group_id }); 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', }, ); 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[
]; print qq[]; print '' . htescape ($user_id) . q[ ]; print q[]; 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[
]; print qq[]; print '' . htescape ($user_id) . q[ ]; print q[]; 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[
]; print qq[]; print '' . htescape ($user_id), q[ ]; print q[]; print q[
]; }); } } my $join_condition = $group_prop->{join_condition}; my $disabled = $ac->{write} ? '' : 'disabled'; print qq[

]; print_text ('Member approval policy'); print qq[

]; unless ($disabled) { print q[

]; } print q[

]; if ($ac->{write}) { print q[

]; print_text ('Invite a user'); print q[

]; print_text ('User id'); print q[:

]; } 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] eq 'prop') { 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 $prop_name = $cgi->get_parameter ('name'); if (defined $prop_name and {desc => 1, admin_group => 1}->{$prop_name}) { $group_prop->{$prop_name} = $cgi->get_parameter ('value'); set_group_prop ($group_id, $group_prop); commit (); print "Status: 204 Property updated\n\n"; exit; } else { print_error (400, 'Bad property'); 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, q[Group id %s is invalid; use characters [0-9a-z-]{4,20}], $group_id); exit; } if (get_group_prop ($group_id)) { print_error (400, q[Group id %s is already used], $group_id); 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 ]; 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[

]; print_text ('Group id'); print q[: (]; print_text ('Use [0-9a-z-]{4,20}.'); 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[
]; } # print_list_section sub print_prop_list ($$@) { my $ac = shift; my $prop_hash = shift; for my $prop (@_) { if ($prop->{public}) { print q[

]; print_text ($prop->{label}); print q[: ]; print $prop_hash->{$prop->{name}}; } if ($ac->{write}) { print q[

]; print q[]; if ($prop->{field_type} eq 'textarea') { print q[

]; print q[

]; } else { print q[

]; print q[]; } 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