test/suika-accounts/users.pl

use strict;

my $mail_from = q<webmaster@suika.fam.cx>;
my $mail_to = q<webmaster@suika.fam.cx>;
my $subject_prefix = q<[suika.fam.cx account]>;

my $user_data_dir_name = 'data/';
my $user_prop_file_suffix = '.user';

my $group_data_dir_name = 'data/';
my $group_prop_file_suffix = '.group';

my $htpasswd_file_name = 'data/htpasswd';
my $htgroup_file_name = 'data/htgroup';

my $lock_file_name = $user_data_dir_name . '.lock';

use Fcntl ':flock';
my $Lock;

sub lock_start () {
  return if $Lock;

  open $Lock, '>', $lock_file_name or die "$0: $lock_file_name: $!";
  flock $Lock, LOCK_EX;
} # lock_start

sub get_prop_hash ($) {
  my $user_prop_file_name = shift;

  return undef unless -f $user_prop_file_name;

  my $r = {};
  
  open my $user_prop_file, '<:encoding(utf8)', $user_prop_file_name
      or die "$0: $user_prop_file_name: $!";
  while (<$user_prop_file>) {
    tr/\x0D\x0A//d;
    my ($n, $v) = split /:/, $_, 2;
    if ($n =~ s/^\@//) {
      push @{$r->{$n} ||= []}, $v // '';
    } elsif ($n =~ s/^%//) {
      $r->{$n}->{$v // ''} = 1;
    } else {
      $n =~ s/^\$//;
      $r->{$n} = $v // '';
    }
  }
  
  return $r;
} # get_prop_hash

sub set_prop_hash ($$) {
  my $user_prop_file_name = shift;;
  my $prop = shift;
  
  my $has_file = -f $user_prop_file_name;
  
  open my $user_prop_file, '>:encoding(utf8)', $user_prop_file_name
      or die "$0: $user_prop_file_name: $!";
  for my $prop_name (sort {$a cmp $b} keys %$prop) {
    if (ref $prop->{$prop_name} eq 'ARRAY') {
      my $v = '@' . $prop_name;
      $v =~ tr/\x0D\x0A://d;
      for (@{$prop->{$prop_name}}) {
        my $pv = $_;
        $pv =~ tr/\x0D\x0A/  /;
        print $user_prop_file $v . ':' . $pv . "\x0A";
      }
    } elsif (ref $prop->{$prop_name} eq 'HASH') {
      my $v = '%' . $prop_name;
      $v =~ tr/\x0D\x0A://d;
      for (sort {$a cmp $b} keys %{$prop->{$prop_name}}) {
        next unless $prop->{$prop_name}->{$_};
        my $pv = $_;
        $pv =~ tr/\x0D\x0A/  /;
        print $user_prop_file $v . ':' . $pv . "\x0A";
      }
    } else {
      my $v = '$' . $prop_name;
      $v =~ tr/\x0D\x0A://d;
      my $pv = $prop->{$prop_name};
      $pv =~ tr/\x0D\x0A/  /;
      print $user_prop_file $v . ':' . $pv . "\x0A";
    }
  }
  close $user_prop_file;

  system_ ('cvs', 'add', $user_prop_file_name) unless $has_file;
} # set_prop_hash

sub commit ($) {
  my $msg = shift // $0;
  system_ ('cvs', 'commit', -m => $msg, $user_data_dir_name);
} # commit

sub get_user_prop ($) {
  my $user_id = shift;
  return get_prop_hash ($user_data_dir_name . $user_id . $user_prop_file_suffix);
} # get_user_prop

sub set_user_prop ($$) {
  my ($user_id, $prop) = @_;
  return set_prop_hash ($user_data_dir_name . $user_id . $user_prop_file_suffix,
                        $prop);
} # set_user_prop

sub get_group_prop ($) {
  my $group_id = shift;
  return get_prop_hash ($group_data_dir_name .
                        $group_id . $group_prop_file_suffix);
} # get_group_prop

sub set_group_prop ($$) {
  my ($group_id, $prop) = @_;
  return set_prop_hash ($group_data_dir_name .
                        $group_id . $group_prop_file_suffix,
                        $prop);
} # set_group_prop

sub get_all_users () {
  my @r;
  opendir my $user_data_dir, $user_data_dir_name;
  for (readdir $user_data_dir) {
    if (/^([0-9a-z-]+)\Q$user_prop_file_suffix\E$/) {
      push @r, $1;
    }
  }
  return @r;
} # get_all_users

sub get_all_groups () {
  my @r;
  opendir my $group_data_dir, $group_data_dir_name;
  for (readdir $group_data_dir) {
    if (/^([0-9a-z-]+)\Q$group_prop_file_suffix\E$/) {
      push @r, $1;
    }
  }
  return @r;
} # get_all_groups

sub regenerate_htpasswd_and_htgroup () {
  my %htpasswd;
  my %htgroup;
  
  my @group = get_all_groups ();
  
  for my $user_id (get_all_users ()) {
    my $user_prop = get_user_prop ($user_id);
    next if $user_prop->{disabled};
    next unless $user_prop->{pass_crypted};

    $htpasswd{$user_id} = $user_prop->{pass_crypted};

    for (@group) {
      if ($user_prop->{'group.' . $_}->{member}) {
        $htgroup{$_}->{$user_id} = 1;
      }
    }
  }

  open my $file, '>', $htpasswd_file_name or die "$0: $htpasswd_file_name: $!";
  for (sort {$a cmp $b} keys %htpasswd) {
    print $file $_, ':', $htpasswd{$_}, "\x0A";
  }
  
  open my $file, '>', $htgroup_file_name or die "$0: $htgroup_file_name: $!";
  for my $group_id (sort {$a cmp $b} keys %htgroup) {
    print $file $group_id, ': ',
        join ' ', sort {$a cmp $b} keys %{$htgroup{$group_id}};
    print $file "\x0A";
  }
} # regenerate_htpasswd_and_htgroup

sub print_error ($$;$) {
  my ($code, $text, $text_arg) = @_;
  our $Lang;
  binmode STDOUT, ':encoding(utf-8)';
  my $_text = $text;
  $_text =~ s/%s/$text_arg/g;
  print qq[Status: $code $_text
Content-Type: text/html; charset=utf-8

<!DOCTYPE HTML>
<html lang="$Lang" class=account-error>
<title lang=en>$code @{[htescape ($_text)]}</title>
<link rel=stylesheet href="/admin/style/common">
<h1>];
  print_text ('Error');
  print q[</h1><p>];
  print_text ($text, sub { print '', htescape ($text_arg) });
  print_text ('.');
  print q[<!--];
  print 0 for 0..511; # for WinIE
  print q[-->];
} # print_error

sub check_password ($) {
  my $cgi = shift;

  my $user_pass = $cgi->get_parameter ('user-pass');
  my $user_pass2 = $cgi->get_parameter ('user-pass2');
  if ($user_pass ne $user_pass2) {
    print_error (400, 'Two passwords you input are different');
    exit;
  }
    
  if (4 > length $user_pass) {
    print_error (400, 'Password must be longer than 3 characters');
    exit;
  }

  my $pass_crypted = crypt $user_pass,
      join '', (0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64];
  return $pass_crypted;
} # check_password

sub send_mail ($$) {
  require Net::SMTP;
  require Encode;
  
  my $smtp = Net::SMTP->new ('localhost');
  $smtp->mail ($mail_from);
  $smtp->to ($mail_to);
  ## NOTE: What's wrong with UTF-8 Subject? :-)
  $smtp->data (Encode::encode ('utf-8', "From: <$mail_from>
To: <$mail_to>
Subject: $_[0]
Content-Type: text/plain; charset=utf-8
MIME-Version: 1.0

$_[1]"));
  $smtp->send;
} # send_mail

sub system_ (@) {
  (system join (' ', map {quotemeta $_} @_) . " > /dev/null") == 0
      or die "$0: $?";
} # system_

sub htescape ($) {
  my $s = shift;
  $s =~ s/&/&amp;/g;
  $s =~ s/</&lt;/g;
  $s =~ s/>/&gt;/g;
  $s =~ s/"/&quot;/g;
  return $s;
} # htescape

1;
1	wakaba	1.1	use strict;
2
3	wakaba	1.4	my $mail_from = q<webmaster@suika.fam.cx>;
4			my $mail_to = q<webmaster@suika.fam.cx>;
5			my $subject_prefix = q<[suika.fam.cx account]>;
6
7	wakaba	1.1	my $user_data_dir_name = 'data/';
8			my $user_prop_file_suffix = '.user';
9
10			my $group_data_dir_name = 'data/';
11			my $group_prop_file_suffix = '.group';
12
13			my $htpasswd_file_name = 'data/htpasswd';
14			my $htgroup_file_name = 'data/htgroup';
15
16			my $lock_file_name = $user_data_dir_name . '.lock';
17
18			use Fcntl ':flock';
19			my $Lock;
20
21			sub lock_start () {
22			return if $Lock;
23
24			open $Lock, '>', $lock_file_name or die "$0: $lock_file_name: $!";
25			flock $Lock, LOCK_EX;
26			} # lock_start
27
28			sub get_prop_hash ($) {
29			my $user_prop_file_name = shift;
30
31			return undef unless -f $user_prop_file_name;
32
33			my $r = {};
34
35			open my $user_prop_file, '<:encoding(utf8)', $user_prop_file_name
36			or die "$0: $user_prop_file_name: $!";
37			while (<$user_prop_file>) {
38			tr/\x0D\x0A//d;
39			my ($n, $v) = split /:/, $_, 2;
40			if ($n =~ s/^\@//) {
41			push @{$r->{$n} \|\|= []}, $v // '';
42			} elsif ($n =~ s/^%//) {
43			$r->{$n}->{$v // ''} = 1;
44			} else {
45			$n =~ s/^\$//;
46			$r->{$n} = $v // '';
47			}
48			}
49
50			return $r;
51			} # get_prop_hash
52
53			sub set_prop_hash ($$) {
54			my $user_prop_file_name = shift;;
55			my $prop = shift;
56
57			my $has_file = -f $user_prop_file_name;
58
59			open my $user_prop_file, '>:encoding(utf8)', $user_prop_file_name
60			or die "$0: $user_prop_file_name: $!";
61			for my $prop_name (sort {$a cmp $b} keys %$prop) {
62			if (ref $prop->{$prop_name} eq 'ARRAY') {
63			my $v = '@' . $prop_name;
64			$v =~ tr/\x0D\x0A://d;
65			for (@{$prop->{$prop_name}}) {
66			my $pv = $_;
67			$pv =~ tr/\x0D\x0A/ /;
68			print $user_prop_file $v . ':' . $pv . "\x0A";
69			}
70			} elsif (ref $prop->{$prop_name} eq 'HASH') {
71			my $v = '%' . $prop_name;
72			$v =~ tr/\x0D\x0A://d;
73			for (sort {$a cmp $b} keys %{$prop->{$prop_name}}) {
74			next unless $prop->{$prop_name}->{$_};
75			my $pv = $_;
76			$pv =~ tr/\x0D\x0A/ /;
77			print $user_prop_file $v . ':' . $pv . "\x0A";
78			}
79			} else {
80			my $v = '$' . $prop_name;
81			$v =~ tr/\x0D\x0A://d;
82			my $pv = $prop->{$prop_name};
83			$pv =~ tr/\x0D\x0A/ /;
84			print $user_prop_file $v . ':' . $pv . "\x0A";
85			}
86			}
87	wakaba	1.6	close $user_prop_file;
88	wakaba	1.1
89			system_ ('cvs', 'add', $user_prop_file_name) unless $has_file;
90			} # set_prop_hash
91
92			sub commit ($) {
93			my $msg = shift // $0;
94			system_ ('cvs', 'commit', -m => $msg, $user_data_dir_name);
95			} # commit
96
97			sub get_user_prop ($) {
98			my $user_id = shift;
99			return get_prop_hash ($user_data_dir_name . $user_id . $user_prop_file_suffix);
100			} # get_user_prop
101
102			sub set_user_prop ($$) {
103			my ($user_id, $prop) = @_;
104			return set_prop_hash ($user_data_dir_name . $user_id . $user_prop_file_suffix,
105			$prop);
106			} # set_user_prop
107
108			sub get_group_prop ($) {
109			my $group_id = shift;
110			return get_prop_hash ($group_data_dir_name .
111			$group_id . $group_prop_file_suffix);
112			} # get_group_prop
113
114			sub set_group_prop ($$) {
115			my ($group_id, $prop) = @_;
116			return set_prop_hash ($group_data_dir_name .
117			$group_id . $group_prop_file_suffix,
118			$prop);
119			} # set_group_prop
120
121			sub get_all_users () {
122			my @r;
123			opendir my $user_data_dir, $user_data_dir_name;
124			for (readdir $user_data_dir) {
125			if (/^([0-9a-z-]+)\Q$user_prop_file_suffix\E$/) {
126			push @r, $1;
127			}
128			}
129			return @r;
130			} # get_all_users
131
132			sub get_all_groups () {
133			my @r;
134			opendir my $group_data_dir, $group_data_dir_name;
135			for (readdir $group_data_dir) {
136			if (/^([0-9a-z-]+)\Q$group_prop_file_suffix\E$/) {
137			push @r, $1;
138			}
139			}
140			return @r;
141			} # get_all_groups
142
143			sub regenerate_htpasswd_and_htgroup () {
144			my %htpasswd;
145			my %htgroup;
146
147			my @group = get_all_groups ();
148
149			for my $user_id (get_all_users ()) {
150			my $user_prop = get_user_prop ($user_id);
151			next if $user_prop->{disabled};
152			next unless $user_prop->{pass_crypted};
153
154			$htpasswd{$user_id} = $user_prop->{pass_crypted};
155
156			for (@group) {
157			if ($user_prop->{'group.' . $_}->{member}) {
158			$htgroup{$_}->{$user_id} = 1;
159			}
160			}
161			}
162
163			open my $file, '>', $htpasswd_file_name or die "$0: $htpasswd_file_name: $!";
164			for (sort {$a cmp $b} keys %htpasswd) {
165			print $file $_, ':', $htpasswd{$_}, "\x0A";
166			}
167
168			open my $file, '>', $htgroup_file_name or die "$0: $htgroup_file_name: $!";
169			for my $group_id (sort {$a cmp $b} keys %htgroup) {
170			print $file $group_id, ': ',
171			join ' ', sort {$a cmp $b} keys %{$htgroup{$group_id}};
172			print $file "\x0A";
173			}
174			} # regenerate_htpasswd_and_htgroup
175
176	wakaba	1.3	sub print_error ($$;$) {
177			my ($code, $text, $text_arg) = @_;
178			our $Lang;
179	wakaba	1.1	binmode STDOUT, ':encoding(utf-8)';
180	wakaba	1.3	my $_text = $text;
181			$_text =~ s/%s/$text_arg/g;
182			print qq[Status: $code $_text
183	wakaba	1.1	Content-Type: text/html; charset=utf-8
184
185			<!DOCTYPE HTML>
186	wakaba	1.5	<html lang="$Lang" class=account-error>
187	wakaba	1.3	<title lang=en>$code @{[htescape ($_text)]}</title>
188	wakaba	1.5	<link rel=stylesheet href="/admin/style/common">
189	wakaba	1.3	<h1>];
190			print_text ('Error');
191			print q[</h1><p>];
192			print_text ($text, sub { print '', htescape ($text_arg) });
193			print_text ('.');
194			print q[<!--];
195	wakaba	1.1	print 0 for 0..511; # for WinIE
196			print q[-->];
197			} # print_error
198
199			sub check_password ($) {
200			my $cgi = shift;
201
202			my $user_pass = $cgi->get_parameter ('user-pass');
203			my $user_pass2 = $cgi->get_parameter ('user-pass2');
204			if ($user_pass ne $user_pass2) {
205			print_error (400, 'Two passwords you input are different');
206			exit;
207			}
208
209			if (4 > length $user_pass) {
210			print_error (400, 'Password must be longer than 3 characters');
211			exit;
212			}
213
214			my $pass_crypted = crypt $user_pass,
215			join '', (0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64];
216			return $pass_crypted;
217			} # check_password
218	wakaba	1.4
219			sub send_mail ($$) {
220			require Net::SMTP;
221			require Encode;
222
223			my $smtp = Net::SMTP->new ('localhost');
224			$smtp->mail ($mail_from);
225			$smtp->to ($mail_to);
226			## NOTE: What's wrong with UTF-8 Subject? :-)
227			$smtp->data (Encode::encode ('utf-8', "From: <$mail_from>
228			To: <$mail_to>
229			Subject: $_[0]
230			Content-Type: text/plain; charset=utf-8
231			MIME-Version: 1.0
232
233			$_[1]"));
234			$smtp->send;
235			} # send_mail
236	wakaba	1.1
237			sub system_ (@) {
238			(system join (' ', map {quotemeta $_} @_) . " > /dev/null") == 0
239			or die "$0: $?";
240			} # system_
241
242			sub htescape ($) {
243			my $s = shift;
244			$s =~ s/&/&/g;
245			$s =~ s/</</g;
246			$s =~ s/>/>/g;
247			$s =~ s/"/"/g;
248			return $s;
249			} # htescape
250
251			1;