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 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 == 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, qq[User id "$user_id" is invalid; use characters [0-9a-z-]{4,20}]);
      exit;
    }
    
    if (get_user_prop ($user_id)) {
      print_error (400, qq[User id "$user_id" is already used]);
      exit;
    }

    my $pass_crypted = check_password ($cgi);

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

    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>User "@{[htescape ($user_id)]}" registered</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>User "@{[htescape ($user_id)]}" registered</h1>
<p>Your user account is created successfully.
<p>See <a href="@{[htescape ($user_url)]}">your user account 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 user account</title>
<link rel=stylesheet href="/www/style/html/xhtml">
<h1>Create a new user account</h1>

<form action=new-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}"
title="Use a string of characters 'a'..'z', '0'..'9', and '-' with length 4..10 (inclusive)">

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

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

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

</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
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 == 1 and $path[0] eq 'new-user') {
29			if ($cgi->request_method eq 'POST') {
30			lock_start ();
31			binmode STDOUT, ':encoding(utf-8)';
32
33			my $user_id = $cgi->get_parameter ('user-id');
34
35			if ($user_id !~ /\A[0-9a-z-]{4,20}\z/) {
36			print_error (400, qq[User id "$user_id" is invalid; use characters [0-9a-z-]{4,20}]);
37			exit;
38			}
39
40			if (get_user_prop ($user_id)) {
41			print_error (400, qq[User id "$user_id" is already used]);
42			exit;
43			}
44
45			my $pass_crypted = check_password ($cgi);
46
47			my $user_prop = {id => $user_id, pass_crypted => $pass_crypted};
48			set_user_prop ($user_id, $user_prop);
49
50	wakaba	1.2	regenerate_htpasswd_and_htgroup ();
51	wakaba	1.1	commit ();
52
53			my $user_url = get_absolute_url ('../edit/users/' . $user_id . '/');
54
55			print qq[Status: 201 User registered
56			Location: $user_url
57			Content-Type: text/html; charset=utf-8
58
59			<!DOCTYPE HTML>
60			<html lang=en>
61			<title>User "@{[htescape ($user_id)]}" registered</title>
62			<link rel=stylesheet href="/www/style/html/xhtml">
63			<h1>User "@{[htescape ($user_id)]}" registered</h1>
64			<p>Your user account is created successfully.
65			<p>See <a href="@{[htescape ($user_url)]}">your user account information page</a>.];
66			exit;
67			} else {
68			binmode STDOUT, ":encoding(utf-8)";
69			print qq[Content-Type: text/html; charset=utf-8
70
71			<!DOCTYPE HTML>
72			<html lang=en>
73			<title>Create a new user account</title>
74			<link rel=stylesheet href="/www/style/html/xhtml">
75			<h1>Create a new user account</h1>
76
77			<form action=new-user accept-charset=utf-8 method=post>
78
79			<p><strong>User id</strong>: <input type=text name=user-id
80			maxlength=20 size=10 required pattern="[0-9a-z-]{4,20}"
81			title="Use a string of characters 'a'..'z', '0'..'9', and '-' with length 4..10 (inclusive)">
82
83			<p><strong>Password</strong>: <input type=password name=user-pass
84			size=10 required pattern=".{4,}" title="Type 4 characters at minimum">
85
86			<p><strong>Password</strong> (type again): <input type=password
87			name=user-pass2 size=10 required pattern=".{4,}">
88
89			<p><input type=submit value=Create>
90
91			</form>];
92			exit;
93			}
94			} elsif (@path == 0) {
95			my $root_url = get_absolute_url ('add/new-user');
96
97			print qq[Status: 301 Moved permanently
98			Location: $root_url
99			Content-Type: text/html; charset=us-ascii
100
101			See <a href="@{[htescape ($root_url)]}">other page</a>.];
102			exit;
103			}
104
105			print_error (404, 'Not found');
106			exit;
107
108			sub percent_decode ($) {
109			return $dom->create_uri_reference ($_[0])
110			->get_iri_reference
111			->uri_reference;
112			} # percent_decode
113
114			sub get_absolute_url ($) {
115			return $dom->create_uri_reference ($_[0])
116			->get_absolute_reference ($cgi->request_uri)
117			->get_iri_reference
118			->uri_reference;
119			} # get_absolute_url