1#!/usr/bin/perl
2# Copyright (c) 2012-2014 Synergetics SA (sampo@synergetics.be), All Rights Reserved.
3# Copyright (c) 2010 Sampo Kellomaki (sampo@iki.fi), All Rights Reserved.
4# This is confidential unpublished proprietary source code of the author.
5# NO WARRANTY, not even implied warranties. Contains trade secrets.
6# Distribution prohibited unless authorized in writing.
7# Licensed under Apache License 2.0, see file COPYING.
8# $Id$
9#
10# 8.3.2010, created --Sampo
11# 5.2.2012, changed zxpasswd to use -n instead of -c --Sampo
12# 9.2.2014, changed to use zxpasswd -new
13#
14# Web GUI for creating new user, possibly in middle of login sequence.
15# The AuthnRequest is preserved through new user creation by passing ar.
16
17$from = 'sampo-pwbot-noreply@zxid.org';
18$admin_mail = 'sampo-pwadm@zxid.org';
19$dir = '/var/zxid/idp';
20
21$usage = <<USAGE;
22Web GUI for creating new user, possibly in middle of login sequence.
23Usage: http://localhost:8081/zxidnewuser.pl?QUERY_STRING
24       ./zxidnewuser.pl -a QUERY_STRING
25         -a Ascii mode
26         -t Test mode
27USAGE
28    ;
29die $usage if $ARGV[0] =~ /^-[Hh?]/;
30if ($ARGV[0] eq '-t') {
31    warn "Sending...";
32    send_detail("Test $$");
33    exit;
34}
35
36use Data::Dumper;
37use MIME::Base64;
38
39close STDERR;
40open STDERR, ">>/var/tmp/zxid.stderr" or die "Cant open error log: $!";
41select STDERR; $|=1; select STDOUT;
42
43($sec,$min,$hour,$mday,$mon,$year) = gmtime(time);
44$ts = sprintf "%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec;
45#warn "$$: START env: " . Dumper(\%ENV);
46
47$ENV{QUERY_STRING} ||= shift;
48cgidec($ENV{QUERY_STRING});
49
50if ($ENV{CONTENT_LENGTH}) {
51    sysread STDIN, $data, $ENV{CONTENT_LENGTH};
52    #warn "GOT($data) $ENV{CONTENT_LENGTH}";
53    cgidec($data);
54}
55warn "$$: cgi: " . Dumper(\%cgi);
56
57sub uridec {
58    my ($val) = @_;
59    $val =~ s/\+/ /g;
60    $val =~ s/%([0-9a-f]{2})/chr(hex($1))/gsexi;  # URI decode
61    return $val;
62}
63
64sub urienc {
65    my ($val) = @_;
66    $val =~ s/([^A-Za-z0-9.,_-])/sprintf("%%%02x",ord($1))/gsex; # URI enc
67    return $val;
68}
69
70sub cgidec {
71    my ($d) = @_;
72    for $nv (split '&', $d) {
73	($n, $v) = split '=', $nv, 2;
74	$cgi{$n} = uridec($v);
75    }
76}
77
78sub readall {
79    my ($f) = @_;
80    my ($pkg, $srcfile, $line) = caller;
81    undef $/;         # Read all in, without breaking on lines
82    open F, "<$f" or die "$srcfile:$line: Cant read($f): $!";
83    binmode F;
84    my $x = <F>;
85    close F;
86    return $x;
87}
88
89sub show_templ {
90    my ($templ, $hr) = @_;
91    $templ = readall($templ);
92    $templ =~ s/!!(\w+)/$$hr{$1}/gs;
93    my $len = length $templ;
94    syswrite STDOUT, "Content-Type: text/html\r\nContent-Length: $len\r\n\r\n$templ";
95    exit;
96}
97
98sub redirect {
99    my ($url) = @_;
100    syswrite STDOUT, "Location: $url\r\n\r\n";
101    exit;
102}
103
104sub send_mail {
105    my ($to, $subj, $body) = @_;
106    open S, "|/usr/sbin/sendmail -i -B 8BITMIME -t" or die "No sendmail in path: $! $?";
107    $msg = <<MAIL;
108From: $from
109To: $to
110Subject: $subj
111MIME-Version: 1.0
112Content-Type: text/plain; charset=ISO-8859-1
113Content-Transfer-Encoding: 8bit
114
115$body
116MAIL
117;
118    warn "msr($msg)";
119    print S $msg;
120    close S;
121}
122
123sub send_detail {
124    my ($subj) = @_;
125    send_mail($admin_mail, $subj, <<BODY);
126uid: $cgi{'au'}
127ip: $ENV{REMOTE_ADDR}
128title: $cgi{'title'}
129o: $cgi{'o'}
130ou: $cgi{'ou'}
131email: $cgi{'email'}
132im: $cgi{'im'}
133tel: $cgi{'tel'}
134tag: $cgi{'tag'}
135
136Comments or special requests:
137$cgi{'comment'}
138BODY
139    ;
140}
141
142if (length $cgi{'continue'}) {
143    if ($cgi{'zxidpurl'} && $cgi{'zxrfr'} && $cgi{'ar'}) {
144       warn "Redirecting back to IdP";
145       redirect("$cgi{'zxidpurl'}?o=$cgi{'zxrfr'}&ar=$cgi{'ar'}");
146    } else {
147       warn "Redirecting back to index page.";
148       redirect("/");
149    }
150}
151
152### MAIN
153
154if (length $cgi{'ok'}) {
155    if (length $cgi{'au'} < 3 || length $cgi{'au'} > 40) {
156	$cgi{'ERR'} = "Username must be at least 3 characters long (and no longer than 40 chars).";
157    } elsif ($cgi{'au'} !~ /^[A-Za-z0-9_-]+$/s) {
158	$cgi{'ERR'} = "Username can only contain characters [A-Za-z0-9_-]";
159    } elsif (length $cgi{'ap'} < 5 || length $cgi{'ap'} > 80) {
160	$cgi{'ERR'} = "Password must be at least 5 characters long (and no longer than 80 chars).";
161    } elsif (-e "${dir}uid/$cgi{'au'}") {
162	$cgi{'ERR'} = "Username already taken.";
163    } else {
164	warn "Creating new user($cgi{'au'})";
165	open P, "|./zxpasswd -new $cgi{'au'} ${dir}uid" or die "Cant open pipe to zxpasswd: $! $?";
166	print P $cgi{'ap'};
167	close P;
168	warn "Populating user($cgi{'au'})";
169	if (-e "${dir}uid/$cgi{'au'}") {
170	    open LOG, ">${dir}uid/$cgi{'au'}/.log" or die "Cant open write .log: $!";
171	    print LOG "$ts Created $cgi{'au'} ip=$ENV{REMOTE_ADDR}\n" or die "Cant write .log: $!";
172	    close LOG or die "Cant close write .log: $!";
173
174	    open IP, ">${dir}uid/$cgi{'au'}/.regip" or die "Cant open write .regip: $!";
175	    print IP $ENV{REMOTE_ADDR} or die "Cant write .regip: $!";
176	    close IP or die "Cant close write .regip: $!";
177
178	    if ($cgi{'humanintervention'} > 0) {
179		open HUMAN, ">${dir}uid/$cgi{'au'}/.human" or die "Cant open write .human: $!";
180		print HUMAN $cgi{'humanintervention'} or die "Cant write .human: $!";
181		close HUMAN or die "Cant close write .human: $!";
182	    }
183	    #mkdir "${dir}uid/$cgi{'au'}/.bs" or warn "Cant mkdir .bs: $!"; zxpasswd creates .bs
184	    open AT, ">${dir}uid/$cgi{'au'}/.bs/.at" or die "Cant write .bs/.at: $!";
185	    open OPTAT, ">${dir}uid/$cgi{'au'}/.bs/.optat" or die "Cant write .bs/.optat: $!";
186
187	    for $at (qw(cn title taxno o ou street citystc email im tel lang tag)) {
188		$val = $cgi{$at};
189		$val =~ s/[\r\n]//g;
190		next if !length $val;
191		if ($cgi{"${at}share"}) {
192		    print AT "$at: $val\n";
193		} else {
194		    print OPTAT "$at: $val\n";
195		}
196	    }
197
198	    close AT;
199	    close OPTAT;
200
201	    send_detail("New User $cgi{'au'}");
202
203            if ($cgi{'zxidpurl'} && $cgi{'zxrfr'} && $cgi{'ar'}) {
204		warn "Created user($cgi{'au'})";
205		$cgi{MSG} = "Success! Created user $cgi{'au'}. Click Continue to get back to IdP login.";
206		show_templ("newuser-status.html", \%cgi);
207            } else {
208		warn "Created user($cgi{'au'})";
209		$cgi{MSG} = "Success! Created user $cgi{'au'}. Click Continue to get back to top.";
210		show_templ("newuser-status.html", \%cgi);
211            }
212	} else {
213	    $cgi{'ERR'} = "User creation failed. System error (${dir}uid/$cgi{'au'}).";
214	}
215    }
216}
217
218$cgi{'humaninterventionchecked'} = $cgi{'humanintervention'} eq '1' ? ' checked':'';
219$cgi{'ip'} = $ENV{REMOTE_ADDR};
220if (!length $cgi{'ap'}) {
221    open R, "</dev/urandom" or die "Cant open read /dev/urandom: $!";
222    sysread R, $pw, 9;
223    close R;
224    $cgi{'ap'} = encode_base64($pw,'');  # Just a suggestion
225}
226show_templ("newuser-main.html", \%cgi);
227
228__END__
229