test/suika-accounts/edit.cgi

#!/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

<!DOCTYPE HTML>
<html lang=en>
<title>User $e_user_id</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>User $e_user_id</h1>
];

      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[<section id=groups><h2>Groups</h2>];
      
      if (@joined) {
        print_list_section
            (id => 'groups-joined',
             title => 'Groups you have joined',
             items => \@joined,
             print_item => sub {
               my $group_id = shift;
               print q[<form action="group.] . htescape ($group_id);
               print q[" accept-charset=utf-8 method=post>];
               print q[<a href="../../groups/].htescape ($group_id) . '/';
               print q[">] . htescape ($group_id), q[</a> ];
               print q[<input type=hidden name=action value=leave>];
               print q[<input type=submit value="Leave this group"></form>];
             });
      }
      
      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[<form action="group.] . htescape ($group_id);
               print q[" accept-charset=utf-8 method=post>];
               print q[<a href="../../groups/].htescape ($group_id) . '/';
               print q[">] . htescape ($group_id), q[</a> ];
               print q[<input type=hidden name=action value=leave>];
               print q[<input type=submit value="Cancel the request"></form>];
             });
      }
      
      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[<form action="group.] . htescape ($group_id);
               print q[" accept-charset=utf-8 method=post>];
               print q[<a href="../../groups/].htescape ($group_id) . '/';
               print q[">] . htescape ($group_id), q[</a> ];
               print q[<input type=hidden name=action value=join>];
               print q[<input type=submit value="Join this group"></form>];
             });
      }
      
      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[<form action="group.] . htescape ($group_id);
               print q[" accept-charset=utf-8 method=post>];
               print q[<a href="../../groups/].htescape ($group_id) . '/';
               print q[">] . htescape ($group_id), q[</a>];
               print q[<input type=hidden name=action value=join>];
               print q[<input type=submit value="Join this group"></form>];
             });
      }
      
      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[<form action="group.] . htescape ($group_id);
               print q[" accept-charset=utf-8 method=post>];
               print q[<a href="../../groups/].htescape ($group_id) . '/';
               print q[">] . htescape ($group_id), q[</a> ];
               print q[<input type=hidden name=action value=join>];
               print q[<input type=submit value="Join this group"></form>];
             });
      }
      
      print q[</section>];

      print qq[<section id=password>
<h2>Password</h2>

<form action=password method=post accept-charset=utf-8>

<p>You can change the password.

<p><strong>New password</strong>: <input type=password name=user-pass
size=10 required pattern=".{4,}" title="Type 4 characters at minimum">

<p><strong>New password</strong> (type again): <input type=password
name=user-pass2 size=10 required pattern=".{4,}">

<p><input type=submit value=Change>

</form>
</section>

<section id=disable-account><h2>Disable account</h2>

<form action=disabled method=post accept-charset=utf-8>

<p><label><input type=checkbox name=action value=enable
@{[$user_prop->{disabled} ? '' : 'checked']}> Enable this
account.</label>

<p><strong>Caution!</strong> Once you disable your own account, you
cannot enable your account by yourself.

<p><input type=submit value=Change>

</form>

</section>];

      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

<!DOCTYPE HTML>
<html lang=en>
<title>Group $e_group_id</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>Group $e_group_id</h1>
        
<section id=members><h2>Members</h2>];

      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[<form action="user.] . htescape ($user_id);
               print q[" accept-charset=utf-8 method=post>];
                 print qq[<a href="../../users/@{[htescape ($user_id)]}/">];
                 print '' . htescape ($user_id) . q[</a> ];
                 print q[<input type=hidden name=action value=unapprove>];
                 print q[<input type=submit value="Kick"></form>];
               });
        }
        
        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[<form action="user.] . htescape ($user_id);
                 print q[" accept-charset=utf-8 method=post>];
                 print qq[<a href="../../users/@{[htescape ($user_id)]}/">];
                 print '' . htescape ($user_id) . q[</a> ];
                 print q[<input type=hidden name=action value=approve>];
                 print q[<input type=submit value=Approve></form>];
               });
        }
        
        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[<form action="user.] . htescape ($user_id);
                 print q[" accept-charset=utf-8 method=post>];               
                 print qq[<a href="../../users/@{[htescape ($user_id)]}/">];
                 print '' . htescape ($user_id), q[</a> ];
                 print q[<input type=hidden name=action value=unapprove>];
                 print q[<input type=submit value="Cancel invitation"></form>];
               });
        }
      }

      my $join_condition = $group_prop->{join_condition};
      my $disabled = $ac->{write} ? '' : 'disabled';
      print qq[<section id=member-approval>
<h3>Member approval policy</h3>

<form action=join-condition method=post accept-charset=utf-8>

<p><label><input type=radio name=condition value=invitation $disabled
@{[$join_condition->{invitation} ? 'checked' : '']}> A user who is
invited by an administrator of the group can join the group.</label>

<p><label><input type=radio name=condition value=approval $disabled
@{[(not $join_condition->{invitation} and $join_condition->{approval})
?  'checked' : '']}> A user who is invited or approved by an
administrator of the group can join the group.</label>

<p><label><input type=radio name=condition value=anyone $disabled
@{[(not $join_condition->{invitation} and not
$join_condition->{approval}) ?  'checked' : '']}> Any user can join
the group.</label>

@{[$disabled ? '' : '<p><input type=submit value=Change>']}

</form>

</section>];

      if ($ac->{write}) {
        print q[<section id=member-invitation>
<h3>Invite a user</h3>

<form action=invite-user accept-charset=utf-8 method=post>

<p><strong>User id</strong>: <input type=text name=user-id
maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}">

<p><input type=submit value=Invite>

</form>

</section>];
      }

      print q[</section>];

      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

<!DOCTYPE HTML>
<html lang=en>
<title>Group "@{[htescape ($group_id)]}" registered</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>Group "@{[htescape ($group_id)]}" registered</h1>
<p>The new group is created successfully.
<p>See <a href="@{[htescape ($group_url)]}">the group information page</a>.];
    exit;
  } else {
    binmode STDOUT, ":encoding(utf-8)";
    print qq[Content-Type: text/html; charset=utf-8

<!DOCTYPE HTML>
<html lang=en>
<title>Create a new group</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>Create a new group</h1>

<form action=new-group accept-charset=utf-8 method=post>

<p><strong>Group id</strong>: <input type=text name=group-id
maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}"
title="Use a string of characters 'a'..'z', '0'..'9', and '-' with length 4..10 (inclusive)">

<p><input type=submit value=Create>

</form>];
    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 <a href="@{[htescape ($user_url)]}">your user page</a>.];
  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 <a href="@{[htescape ($root_url)]}">other page</a>.];
  exit;
}

print_error (404, 'Not found');
exit;

sub print_list_section (%) {
  my %opt = @_;
  $opt{level} ||= 3;
  
  print q[<section id="] . htescape ($opt{id});
  print q["><h] . $opt{level} . q[>] . htescape ($opt{title});
  print q[</h] . $opt{level} . q[><ul>];
  for my $item (sort {$a cmp $b} @{$opt{items}}) {
    print q[<li>];
    $opt{print_item}->($item);
  }
  print q[</ul></section>];
} # 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
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4			use lib qw[/home/httpd/html/www/markup/html/whatpm
5			/home/wakaba/work/manakai2/lib];
6
7			use CGI::Carp qw[fatalsToBrowser];
8			require Message::CGI::Carp;
9
10			require 'users.pl';
11
12			require Message::CGI::HTTP;
13			require Encode;
14			my $cgi = Message::CGI::HTTP->new;
15			$cgi->{decoder}->{'#default'} = sub {
16			return Encode::decode ('utf-8', $_[1]);
17			};
18
19			require Message::DOM::DOMImplementation;
20			my $dom = Message::DOM::DOMImplementation->new;
21
22			my $path = $cgi->path_info;
23			$path = '' unless defined $path;
24
25			my @path = split m#/#, percent_decode ($path), -1;
26			shift @path;
27
28			if (@path == 3 and
29			$path[0] eq 'users' and
30			$path[1] =~ /\A[0-9a-z-]+\z/) {
31			my $user_id = $path[1];
32			check_access_right (allowed_users => {$user_id => 1},
33			allowed_groups => {'admin-users' => 1});
34
35			if ($path[2] eq '') {
36			my $user_prop = get_user_prop ($user_id);
37			if ($user_prop) {
38			binmode STDOUT, ':encoding(utf-8)';
39
40			my $e_user_id = htescape ($user_id);
41
42			print qq[Content-Type: text/html; charset=utf-8
43
44			<!DOCTYPE HTML>
45			<html lang=en>
46			<title>User $e_user_id</title>
47			<link rel=stylesheet href="/www/style/html/xhtml">
48			<h1>User $e_user_id</h1>
49			];
50
51			my @joined;
52			my @requested;
53			my @invited;
54			my @can_join;
55			my @can_request;
56			for my $group_id (get_all_groups ()) {
57			my $gs = $user_prop->{'group.' . $group_id};
58			if ($gs->{member}) {
59			push @joined, $group_id;
60			} elsif ($gs->{no_approval}) {
61			push @requested, $group_id;
62			} elsif ($gs->{invited}) {
63			push @invited, $group_id;
64			} else {
65			my $group_prop = get_group_prop ($group_id);
66			if ($group_prop->{join_condition}->{invitation}) {
67			#
68			} elsif ($group_prop->{join_condition}->{approval}) {
69			push @can_request, $group_id;
70			} else {
71			push @can_join, $group_id;
72			}
73			}
74			}
75
76			print qq[<section id=groups><h2>Groups</h2>];
77
78			if (@joined) {
79			print_list_section
80			(id => 'groups-joined',
81			title => 'Groups you have joined',
82			items => \@joined,
83			print_item => sub {
84			my $group_id = shift;
85			print q[<form action="group.] . htescape ($group_id);
86			print q[" accept-charset=utf-8 method=post>];
87			print q[<a href="../../groups/].htescape ($group_id) . '/';
88			print q[">] . htescape ($group_id), q[</a> ];
89			print q[<input type=hidden name=action value=leave>];
90			print q[<input type=submit value="Leave this group"></form>];
91			});
92			}
93
94			if (@requested) {
95			print_list_section
96			(id => 'groups-requested',
97			title => 'Groups you have requested to join but not approved yet',
98			items => \@requested,
99			print_item => sub {
100			my $group_id = shift;
101			print q[<form action="group.] . htescape ($group_id);
102			print q[" accept-charset=utf-8 method=post>];
103			print q[<a href="../../groups/].htescape ($group_id) . '/';
104			print q[">] . htescape ($group_id), q[</a> ];
105			print q[<input type=hidden name=action value=leave>];
106			print q[<input type=submit value="Cancel the request"></form>];
107			});
108			}
109
110			if (@invited) {
111			print_list_section
112			(id => 'groups-invited',
113			title => 'Groups you have been invited but not joined yet, or you have left',
114			items => \@invited,
115			print_item => sub {
116			my $group_id = shift;
117			print q[<form action="group.] . htescape ($group_id);
118			print q[" accept-charset=utf-8 method=post>];
119			print q[<a href="../../groups/].htescape ($group_id) . '/';
120			print q[">] . htescape ($group_id), q[</a> ];
121			print q[<input type=hidden name=action value=join>];
122			print q[<input type=submit value="Join this group"></form>];
123			});
124			}
125
126			if (@can_join) {
127			print_list_section
128			(id => 'groups-can-join',
129			title => 'Groups you can join now (without approval)',
130			items => \@can_join,
131			print_item => sub {
132			my $group_id = shift;
133			print q[<form action="group.] . htescape ($group_id);
134			print q[" accept-charset=utf-8 method=post>];
135			print q[<a href="../../groups/].htescape ($group_id) . '/';
136			print q[">] . htescape ($group_id), q[</a>];
137			print q[<input type=hidden name=action value=join>];
138			print q[<input type=submit value="Join this group"></form>];
139			});
140			}
141
142			if (@can_request) {
143			print_list_section
144			(id => 'groups-can-request',
145			title => 'Groups you can request to join (approval required to join)',
146			items => \@can_request,
147			print_item => sub {
148			my $group_id = shift;
149			print q[<form action="group.] . htescape ($group_id);
150			print q[" accept-charset=utf-8 method=post>];
151			print q[<a href="../../groups/].htescape ($group_id) . '/';
152			print q[">] . htescape ($group_id), q[</a> ];
153			print q[<input type=hidden name=action value=join>];
154			print q[<input type=submit value="Join this group"></form>];
155			});
156			}
157
158			print q[</section>];
159
160			print qq[<section id=password>
161			<h2>Password</h2>
162
163			<form action=password method=post accept-charset=utf-8>
164
165			<p>You can change the password.
166
167			<p><strong>New password</strong>: <input type=password name=user-pass
168			size=10 required pattern=".{4,}" title="Type 4 characters at minimum">
169
170			<p><strong>New password</strong> (type again): <input type=password
171			name=user-pass2 size=10 required pattern=".{4,}">
172
173			<p><input type=submit value=Change>
174
175			</form>
176			</section>
177
178			<section id=disable-account><h2>Disable account</h2>
179
180			<form action=disabled method=post accept-charset=utf-8>
181
182			<p><label><input type=checkbox name=action value=enable
183			@{[$user_prop->{disabled} ? '' : 'checked']}> Enable this
184			account.</label>
185
186			<p><strong>Caution!</strong> Once you disable your own account, you
187			cannot enable your account by yourself.
188
189			<p><input type=submit value=Change>
190
191			</form>
192
193			</section>];
194
195			exit;
196			}
197			} elsif ($path[2] =~ /\Agroup\.([0-9a-z-]+)\z/) {
198			my $group_id = $1;
199			if ($cgi->request_method eq 'POST') {
200			lock_start ();
201			binmode STDOUT, ':encoding(utf-8)';
202
203			my $user_prop = get_user_prop ($user_id);
204			my $group_prop = get_group_prop ($group_id);
205
206			if ($user_prop and $group_prop) {
207			my $gs = ($user_prop->{'group.' . $group_id} \|\|= {});
208
209			my $action = $cgi->get_parameter ('action');
210			my $status;
211			if ($action eq 'join') {
212			if ($gs->{member}) {
213			$status = q[You are a member];
214			#
215			} elsif ($gs->{no_approval}) {
216			$status = q[You are waiting for an approval];
217			#
218			} elsif ($gs->{invited}) {
219			$gs->{member} = 1;
220			$status = q[Registered];
221			#
222			} else {
223			if ($group_prop->{join_condition}->{invitation}) {
224			print_error (403, 'You are not invited to this group');
225			exit;
226			} elsif ($group_prop->{join_condition}->{approval}) {
227			$gs->{no_approval} = 1;
228			$status = q[Request submitted];
229			#
230			} else {
231			$gs->{member} = 1;
232			$status = q[Registered];
233			#
234			}
235			}
236			} elsif ($action eq 'leave') {
237			if ($gs->{member}) {
238			delete $gs->{member};
239			$gs->{invited} = 1;
240			$status = 'Unregistered';
241			#
242			} elsif ($gs->{no_approval}) {
243			delete $gs->{no_approval};
244			delete $gs->{invited};
245			$status = 'Request canceled';
246			#
247			} else {
248			$status = 'You are not a member';
249			#
250			}
251			} else {
252			print_error (400, 'Bad action parameter');
253			exit;
254			}
255
256			set_user_prop ($user_id, $user_prop);
257			regenerate_htpasswd_and_htgroup ();
258			commit ();
259
260			print qq[Status: 204 $status\n\n];
261			exit;
262			}
263			}
264			} elsif ($path[2] eq 'password') {
265			if ($cgi->request_method eq 'POST') {
266			lock_start ();
267			binmode STDOUT, ':encoding(utf-8)';
268
269			my $user_prop = get_user_prop ($user_id);
270
271			if ($user_prop) {
272			$user_prop->{pass_crypted} = check_password ($cgi);
273
274			set_user_prop ($user_id, $user_prop);
275			regenerate_htpasswd_and_htgroup ();
276			commit ();
277
278			## Browsers do not support 205.
279			#print qq[Status: 205 Password changed\n\n];
280			print qq[Status: 204 Password changed\n\n];
281			exit;
282			}
283			}
284			} elsif ($path[2] eq 'disabled') {
285			if ($cgi->request_method eq 'POST') {
286			lock_start ();
287			binmode STDOUT, ':encoding(utf-8)';
288
289			my $user_prop = get_user_prop ($user_id);
290
291			if ($user_prop) {
292			my $action = $cgi->get_parameter ('action');
293			if (defined $action and $action eq 'enable') {
294			delete $user_prop->{disabled};
295			} else {
296			$user_prop->{disabled} = 1;
297			}
298
299			set_user_prop ($user_id, $user_prop);
300			regenerate_htpasswd_and_htgroup ();
301			commit ();
302
303			print "Status: 204 Property updated\n\n";
304			exit;
305			}
306			}
307			}
308			} elsif (@path == 3 and
309			$path[0] eq 'groups' and
310			$path[1] =~ /\A[0-9a-z-]+\z/) {
311			my $group_id = $path[1];
312			my $ac = check_access_right (allowed_groups => {'admin-groups' => 1},
313			group_context => $group_id);
314
315			if ($path[2] eq '') {
316			my $group_prop = get_group_prop ($group_id);
317			if ($group_prop) {
318			binmode STDOUT, ':encoding(utf-8)';
319
320			my $e_group_id = htescape ($group_id);
321
322			print qq[Content-Type: text/html; charset=utf-8
323
324			<!DOCTYPE HTML>
325			<html lang=en>
326			<title>Group $e_group_id</title>
327			<link rel=stylesheet href="/www/style/html/xhtml">
328			<h1>Group $e_group_id</h1>
329
330			<section id=members><h2>Members</h2>];
331
332			if ($ac->{read_group_member_list}) {
333			my @members;
334			my @apps;
335			my @invited;
336			for my $user_id (get_all_users ()) {
337			my $user_prop = get_user_prop ($user_id);
338			my $gs = $user_prop->{'group.' . $group_id};
339			if ($gs->{member}) {
340			push @members, $user_id;
341			} elsif ($gs->{no_approval}) {
342			push @apps, $user_id;
343			} elsif ($gs->{invited}) {
344			push @invited, $user_id;
345			}
346			}
347
348			if (@members) {
349			print_list_section
350			(id => 'formal-members',
351			title => 'Formal members',
352			items => \@members,
353			print_item => sub {
354			my $user_id = shift;
355			print q[<form action="user.] . htescape ($user_id);
356			print q[" accept-charset=utf-8 method=post>];
357			print qq[<a href="../../users/@{[htescape ($user_id)]}/">];
358			print '' . htescape ($user_id) . q[</a> ];
359			print q[<input type=hidden name=action value=unapprove>];
360			print q[<input type=submit value="Kick"></form>];
361			});
362			}
363
364			if (@apps) {
365			print_list_section
366			(id => 'non-approved-users',
367			title => 'Users who are waiting for the approval to join',
368			items => \@apps,
369			print_item => sub {
370			my $user_id = shift;
371			print q[<form action="user.] . htescape ($user_id);
372			print q[" accept-charset=utf-8 method=post>];
373			print qq[<a href="../../users/@{[htescape ($user_id)]}/">];
374			print '' . htescape ($user_id) . q[</a> ];
375			print q[<input type=hidden name=action value=approve>];
376			print q[<input type=submit value=Approve></form>];
377			});
378			}
379
380			if (@invited) {
381			print_list_section
382			(id => 'invited-users',
383			title => 'Users who are invited but not joined or are leaved',
384			items => \@invited,
385			print_item => sub {
386			my $user_id = shift;
387			print q[<form action="user.] . htescape ($user_id);
388			print q[" accept-charset=utf-8 method=post>];
389			print qq[<a href="../../users/@{[htescape ($user_id)]}/">];
390			print '' . htescape ($user_id), q[</a> ];
391			print q[<input type=hidden name=action value=unapprove>];
392			print q[<input type=submit value="Cancel invitation"></form>];
393			});
394			}
395			}
396
397			my $join_condition = $group_prop->{join_condition};
398			my $disabled = $ac->{write} ? '' : 'disabled';
399			print qq[<section id=member-approval>
400			<h3>Member approval policy</h3>
401
402			<form action=join-condition method=post accept-charset=utf-8>
403
404			<p><label><input type=radio name=condition value=invitation $disabled
405			@{[$join_condition->{invitation} ? 'checked' : '']}> A user who is
406			invited by an administrator of the group can join the group.</label>
407
408			<p><label><input type=radio name=condition value=approval $disabled
409			@{[(not $join_condition->{invitation} and $join_condition->{approval})
410			? 'checked' : '']}> A user who is invited or approved by an
411			administrator of the group can join the group.</label>
412
413			<p><label><input type=radio name=condition value=anyone $disabled
414			@{[(not $join_condition->{invitation} and not
415			$join_condition->{approval}) ? 'checked' : '']}> Any user can join
416			the group.</label>
417
418			@{[$disabled ? '' : '<p><input type=submit value=Change>']}
419
420			</form>
421
422			</section>];
423
424			if ($ac->{write}) {
425			print q[<section id=member-invitation>
426			<h3>Invite a user</h3>
427
428			<form action=invite-user accept-charset=utf-8 method=post>
429
430			<p><strong>User id</strong>: <input type=text name=user-id
431			maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}">
432
433			<p><input type=submit value=Invite>
434
435			</form>
436
437			</section>];
438			}
439
440			print q[</section>];
441
442			exit;
443			}
444			} elsif ($path[2] eq 'join-condition') {
445			forbidden () unless $ac->{write};
446
447			if ($cgi->request_method eq 'POST') {
448			lock_start ();
449			my $group_prop = get_group_prop ($group_id);
450			if ($group_prop) {
451			binmode STDOUT, ':encoding(utf-8)';
452
453			my $new_condition = $cgi->get_parameter ('condition');
454			if ($new_condition eq 'invitation') {
455			$group_prop->{join_condition}->{invitation} = 1;
456			$group_prop->{join_condition}->{approval} = 1;
457			} elsif ($new_condition eq 'approval') {
458			$group_prop->{join_condition}->{approval} = 1;
459			delete $group_prop->{join_condition}->{invitation};
460			} else {
461			delete $group_prop->{join_condition}->{invitation};
462			delete $group_prop->{join_condition}->{approval};
463			}
464
465			set_group_prop ($group_id, $group_prop);
466			commit ();
467
468			print "Status: 204 join-condition property updated\n\n";
469			exit;
470			}
471			}
472			} elsif ($path[2] =~ /\Auser\.([0-9a-z-]+)\z/ or
473			$path[2] eq 'invite-user') {
474			my $user_id = $1 // $cgi->get_parameter ('user-id') // '';
475			if ($user_id =~ /\A[0-9a-z-]+\z/ and
476			$cgi->request_method eq 'POST') {
477			forbidden () unless $ac->{write};
478
479			lock_start ();
480			my $group_prop = get_group_prop ($group_id);
481			my $user_prop = get_user_prop ($user_id);
482			if ($group_prop and $user_prop) {
483			binmode STDOUT, ':encoding(utf-8)';
484
485			my $gs = ($user_prop->{'group.' . $group_id} \|\|= {});
486
487			my $action = $cgi->get_parameter ('action');
488			$action = 'approve' if $path[2] eq 'invite-user';
489			my $status;
490			if ($action eq 'approve') {
491			if ($gs->{member}) {
492			$status = 'He is a member';
493			#
494			} elsif ($gs->{no_approval}) {
495			$gs->{member} = 1;
496			delete $gs->{no_approval};
497			$status = 'Registered';
498			#
499			} elsif ($gs->{invited}) {
500			$status = 'He has been invited';
501			#
502			} else {
503			$gs->{invited} = 1;
504			$status = 'Invited';
505			#
506			}
507			} elsif ($action eq 'unapprove') {
508			if ($gs->{member}) {
509			delete $gs->{member};
510			delete $gs->{invited};
511			$status = 'Unregistered';
512			#
513			} elsif ($gs->{invited}) {
514			delete $gs->{invited};
515			$status = 'Invitation canceled';
516			#
517			} else {
518			$status = 'Not a member';
519			#
520			}
521			} else {
522			print_error (400, 'Bad action parameter');
523			exit;
524			}
525
526			set_user_prop ($user_id, $user_prop);
527			regenerate_htpasswd_and_htgroup ();
528			commit ();
529
530			print "Status: 204 $status\n\n";
531			exit;
532			}
533			}
534			}
535			} elsif (@path == 1 and $path[0] eq 'new-group') {
536			check_access_right (allowed_groups => {'admin-groups' => 1});
537
538			if ($cgi->request_method eq 'POST') {
539			lock_start ();
540			binmode STDOUT, ':encoding(utf-8)';
541
542			my $group_id = $cgi->get_parameter ('group-id');
543
544			if ($group_id !~ /\A[0-9a-z-]{4,20}\z/) {
545			print_error (400, qq[Group id "$group_id" is invalid; use characters [0-9a-z-]{4,20}]);
546			exit;
547			}
548
549			if (get_group_prop ($group_id)) {
550			print_error (400, qq[Group id "$group_id" is already used]);
551			exit;
552			}
553
554			my $group_prop = {id => $group_id};
555			set_group_prop ($group_id, $group_prop);
556
557			commit ();
558
559			my $group_url = get_absolute_url ('groups/' . $group_id . '/');
560
561			print qq[Status: 201 Group registered
562			Location: $group_url
563			Content-Type: text/html; charset=utf-8
564
565			<!DOCTYPE HTML>
566			<html lang=en>
567			<title>Group "@{[htescape ($group_id)]}" registered</title>
568			<link rel=stylesheet href="/www/style/html/xhtml">
569			<h1>Group "@{[htescape ($group_id)]}" registered</h1>
570			<p>The new group is created successfully.
571			<p>See <a href="@{[htescape ($group_url)]}">the group information page</a>.];
572			exit;
573			} else {
574			binmode STDOUT, ":encoding(utf-8)";
575			print qq[Content-Type: text/html; charset=utf-8
576
577			<!DOCTYPE HTML>
578			<html lang=en>
579			<title>Create a new group</title>
580			<link rel=stylesheet href="/www/style/html/xhtml">
581			<h1>Create a new group</h1>
582
583			<form action=new-group accept-charset=utf-8 method=post>
584
585			<p><strong>Group id</strong>: <input type=text name=group-id
586			maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}"
587			title="Use a string of characters 'a'..'z', '0'..'9', and '-' with length 4..10 (inclusive)">
588
589			<p><input type=submit value=Create>
590
591			</form>];
592			exit;
593			}
594			} elsif (@path == 1 and $path[0] eq '') {
595			my $user_id = $cgi->remote_user;
596			forbidden () if not defined $user_id or $user_id !~ /\A[0-9a-z-]+\z/;
597
598			my $user_url = get_absolute_url ('users/' . $user_id . '/');
599
600			print qq[Status: 303 See Other
601			Location: $user_url
602			Content-Type: text/html; charset=us-ascii
603
604			See <a href="@{[htescape ($user_url)]}">your user page</a>.];
605			exit;
606			} elsif (@path == 0) {
607			my $root_url = get_absolute_url ('edit/');
608
609			print qq[Status: 301 Moved permanently
610			Location: $root_url
611			Content-Type: text/html; charset=us-ascii
612
613			See <a href="@{[htescape ($root_url)]}">other page</a>.];
614			exit;
615			}
616
617			print_error (404, 'Not found');
618			exit;
619
620			sub print_list_section (%) {
621			my %opt = @_;
622			$opt{level} \|\|= 3;
623
624			print q[<section id="] . htescape ($opt{id});
625			print q["><h] . $opt{level} . q[>] . htescape ($opt{title});
626			print q[</h] . $opt{level} . q[><ul>];
627			for my $item (sort {$a cmp $b} @{$opt{items}}) {
628			print q[<li>];
629			$opt{print_item}->($item);
630			}
631			print q[</ul></section>];
632			} # print_list_section
633
634			sub check_access_right (%) {
635			my %opt = @_;
636
637			my $user_id = $cgi->remote_user;
638			forbidden () if not defined $user_id or $user_id !~ /\A[0-9a-z-]+\z/;
639
640			my $user_prop = get_user_prop ($user_id);
641			forbidden () unless $user_prop;
642
643			if ($opt{allowed_users}->{$user_id}) {
644			return {
645			write => 1,
646			#read_group_member_list => 0,
647			};
648			}
649
650			my $ac = {};
651			my $return_ac;
652			for my $group_id (keys %{$opt{allowed_groups} or {}}) {
653			my $group_prop = get_group_prop ($group_id);
654			next unless $group_prop;
655
656			my $gs = $user_prop->{'group.' . $group_id};
657			if ($gs->{member}) {
658			return {write => 1, read_group_member_list => 1};
659			}
660			}
661
662			if (defined $opt{group_context}) {
663			my $group_prop = get_group_prop ($opt{group_context});
664			if ($group_prop) {
665			my $gs = $user_prop->{'group.' . $opt{group_context}};
666			if ($gs->{member}) {
667			$return_ac = 1;
668			} elsif ($gs->{invited}) {
669			$return_ac = 1;
670			} elsif ($group_prop->{join_condition}->{acception}) {
671			$return_ac = 1;
672			} elsif (not $group_prop->{join_condition}->{invitation}) {
673			$return_ac = 1;
674			}
675			}
676			}
677
678			return $ac if $return_ac;
679
680			forbidden ();
681			} # check_access_right
682
683			sub forbidden () {
684			my $user = $cgi->remote_user;
685			if (defined $user) {
686			print_error (403, q[Forbidden (you've logged in as ] . $user . ')');
687			} else {
688			print_error (403, 'Forbidden');
689			}
690			exit;
691			} # forbidden
692
693			sub percent_decode ($) {
694			return $dom->create_uri_reference ($_[0])
695			->get_iri_reference
696			->uri_reference;
697			} # percent_decode
698
699			sub get_absolute_url ($) {
700			return $dom->create_uri_reference ($_[0])
701			->get_absolute_reference ($cgi->request_uri)
702			->get_iri_reference
703			->uri_reference;
704			} # get_absolute_url