test/suika-accounts/add.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 'texts.pl';

our $subject_prefix;

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 == 1 and $path[0] eq 'new-user') {
  if ($cgi->request_method eq 'POST') {
    lock_start ();
    binmode STDOUT, ':encoding(utf-8)';
    
    my $user_id = $cgi->get_parameter ('user-id');

    if ($user_id !~ /\A[0-9a-z-]{4,20}\z/) {
      print_error (400,
                   q[User id %s is invalid; use characters [0-9a-z-]{4,20}],
                   $user_id);
      exit;
    }
    
    if (get_user_prop ($user_id)) {
      print_error (400, q[User id %s is already used], $user_id);
      exit;
    }

    my $pass_crypted = check_password ($cgi);

    my $user_prop = {id => $user_id, pass_crypted => $pass_crypted};
    set_user_prop ($user_id, $user_prop);

    send_mail ("$subject_prefix User $user_id created",
               "User: $user_id\nStatus: User registered\n");

    regenerate_htpasswd_and_htgroup ();
    commit ();

    my $user_url = get_absolute_url ('../edit/users/' . $user_id . '/');

    print qq[Status: 201 User registered
Location: $user_url
Content-Type: text/html; charset=utf-8

<!DOCTYPE HTML>
<html lang=en>
<title>];
    print_text ('User %s registered', sub { print '', htescape ($user_id) });
    print q[</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>];
    print_text ('User %s registered', sub { print '', htescape ($user_id) });
    print q[</h1><p>];
    print_text ('Your user account is created successfully.');
    print q[<p>];
    print_text ('See %s.', sub {
      print qq[<a href="@{[htescape ($user_url)]}">];
      print_text ('your user account information page');
      print q[</a>];
    });
    exit;
  } else {
    binmode STDOUT, ":encoding(utf-8)";
    print q[Content-Type: text/html; charset=utf-8

<!DOCTYPE HTML>
<html lang=en>
<title>];
    print_text ('Create a new user account');
    print q[</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>];
    print_text ('Create a new user account');
    print q[</h1>

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

<p><strong>];
    print_text ('User id');
    print q[</strong>: <input type=text name=user-id
maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}"> (];
    print_text ('Use [0-9a-z-]{4,20}.');
    print q[)<p><strong>];
    print_text ('Password');
    print q[</strong>: <input type=password name=user-pass
size=10 required pattern=".{4,}"> (];
    print_text ('Type 4 characters at minimum');
    print q[)<p><strong>];
    print_text ('Password');
    print q[</strong> (];
    print_text ('type again');
    print q[): <input type=password
name=user-pass2 size=10 required pattern=".{4,}">

<p><input type=submit value="];
    print_text ('Create');
    print q["></form>];
    exit;
  }
} elsif (@path == 0) {
  my $root_url = get_absolute_url ('add/new-user');

  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 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	wakaba	1.3	require 'texts.pl';
12	wakaba	1.1
13	wakaba	1.4	our $subject_prefix;
14
15	wakaba	1.1	require Message::CGI::HTTP;
16			require Encode;
17			my $cgi = Message::CGI::HTTP->new;
18			$cgi->{decoder}->{'#default'} = sub {
19			return Encode::decode ('utf-8', $_[1]);
20			};
21
22	wakaba	1.3	our $Lang = 'ja'
23			if $cgi->get_meta_variable ('HTTP_ACCEPT_LANGUAGE') =~ /\bja\b/; ## TODO: ...
24
25	wakaba	1.1	require Message::DOM::DOMImplementation;
26			my $dom = Message::DOM::DOMImplementation->new;
27
28			my $path = $cgi->path_info;
29			$path = '' unless defined $path;
30
31			my @path = split m#/#, percent_decode ($path), -1;
32			shift @path;
33
34			if (@path == 1 and $path[0] eq 'new-user') {
35			if ($cgi->request_method eq 'POST') {
36			lock_start ();
37			binmode STDOUT, ':encoding(utf-8)';
38
39			my $user_id = $cgi->get_parameter ('user-id');
40
41			if ($user_id !~ /\A[0-9a-z-]{4,20}\z/) {
42	wakaba	1.3	print_error (400,
43			q[User id %s is invalid; use characters [0-9a-z-]{4,20}],
44			$user_id);
45	wakaba	1.1	exit;
46			}
47
48			if (get_user_prop ($user_id)) {
49	wakaba	1.3	print_error (400, q[User id %s is already used], $user_id);
50	wakaba	1.1	exit;
51			}
52
53			my $pass_crypted = check_password ($cgi);
54
55			my $user_prop = {id => $user_id, pass_crypted => $pass_crypted};
56			set_user_prop ($user_id, $user_prop);
57
58	wakaba	1.4	send_mail ("$subject_prefix User $user_id created",
59			"User: $user_id\nStatus: User registered\n");
60
61	wakaba	1.2	regenerate_htpasswd_and_htgroup ();
62	wakaba	1.1	commit ();
63
64			my $user_url = get_absolute_url ('../edit/users/' . $user_id . '/');
65
66			print qq[Status: 201 User registered
67			Location: $user_url
68			Content-Type: text/html; charset=utf-8
69
70			<!DOCTYPE HTML>
71			<html lang=en>
72	wakaba	1.3	<title>];
73			print_text ('User %s registered', sub { print '', htescape ($user_id) });
74			print q[</title>
75	wakaba	1.1	<link rel=stylesheet href="/www/style/html/xhtml">
76	wakaba	1.3	<h1>];
77			print_text ('User %s registered', sub { print '', htescape ($user_id) });
78			print q[</h1><p>];
79			print_text ('Your user account is created successfully.');
80			print q[<p>];
81			print_text ('See %s.', sub {
82	wakaba	1.4	print qq[<a href="@{[htescape ($user_url)]}">];
83	wakaba	1.3	print_text ('your user account information page');
84			print q[</a>];
85			});
86	wakaba	1.1	exit;
87			} else {
88			binmode STDOUT, ":encoding(utf-8)";
89	wakaba	1.3	print q[Content-Type: text/html; charset=utf-8
90	wakaba	1.1
91			<!DOCTYPE HTML>
92			<html lang=en>
93	wakaba	1.3	<title>];
94			print_text ('Create a new user account');
95			print q[</title>
96	wakaba	1.1	<link rel=stylesheet href="/www/style/html/xhtml">
97	wakaba	1.3	<h1>];
98			print_text ('Create a new user account');
99			print q[</h1>
100	wakaba	1.1
101			<form action=new-user accept-charset=utf-8 method=post>
102
103	wakaba	1.3	<p><strong>];
104			print_text ('User id');
105			print q[</strong>: <input type=text name=user-id
106			maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}"> (];
107			print_text ('Use [0-9a-z-]{4,20}.');
108			print q[)<p><strong>];
109			print_text ('Password');
110			print q[</strong>: <input type=password name=user-pass
111			size=10 required pattern=".{4,}"> (];
112			print_text ('Type 4 characters at minimum');
113			print q[)<p><strong>];
114			print_text ('Password');
115			print q[</strong> (];
116			print_text ('type again');
117			print q[): <input type=password
118	wakaba	1.1	name=user-pass2 size=10 required pattern=".{4,}">
119
120	wakaba	1.3	<p><input type=submit value="];
121			print_text ('Create');
122			print q["></form>];
123	wakaba	1.1	exit;
124			}
125			} elsif (@path == 0) {
126			my $root_url = get_absolute_url ('add/new-user');
127
128			print qq[Status: 301 Moved permanently
129			Location: $root_url
130			Content-Type: text/html; charset=us-ascii
131
132			See <a href="@{[htescape ($root_url)]}">other page</a>.];
133			exit;
134			}
135
136			print_error (404, 'Not found');
137			exit;
138
139			sub percent_decode ($) {
140			return $dom->create_uri_reference ($_[0])
141			->get_iri_reference
142			->uri_reference;
143			} # percent_decode
144
145			sub get_absolute_url ($) {
146			return $dom->create_uri_reference ($_[0])
147			->get_absolute_reference ($cgi->request_uri)
148			->get_iri_reference
149			->uri_reference;
150			} # get_absolute_url