1#!/usr/bin/perl
2# Copyright (c) 2010-2014 Sampo Kellomaki (sampo@iki.fi), All Rights Reserved.
3# This is confidential unpublished proprietary source code of the author.
4# NO WARRANTY, not even implied warranties. Contains trade secrets.
5# Distribution prohibited unless authorized in writing.
6# Licensed under Apache License 2.0, see file COPYING.
7# $Id$
8#
9# 13.3.2010, created --Sampo
10# 14.2.2014, perfected local login with IdP --Sampo
11#
12# Web GUI CGI for exploring ZXID logs and audit trail
13#
14# CGI / QUERY_STRING variables
15#   c  $cmd    Command
16#   d  $dir    Path to ZXID config directory, e.g: /var/zxid/ or /var/zxid/idp
17#   e  $eid    Filter logs by Entity ID
18#   n  $nid    Filter logs by Name ID
19#   s  $sid    Filter logs by session ID
20
21$usage = <<USAGE;
22Web GUI for attribute selection and privacy preferences
23Usage: http://localhost:8081/zxidatsel.pl?QUERY_STRING
24       ./zxidatsel.pl -a QUERY_STRING
25         -a Ascii mode
26USAGE
27    ;
28die $usage if $ARGV[0] =~ /^-[Hh?]/;
29
30$cpath = '/var/zxid/idp';
31
32use Net::SAML;
33use Data::Dumper;
34
35close STDERR;
36open STDERR, ">>/var/tmp/zxid.stderr" or die "Cant open error log: $!";
37select STDERR; $|=1; select STDOUT;
38
39#warn "$$: START env: " . Dumper(\%ENV);
40
41$ENV{QUERY_STRING} ||= shift;
42$qs = $ENV{QUERY_STRING};
43cgidec($qs);
44
45if ($ENV{CONTENT_LENGTH}) {
46    sysread STDIN, $qs, $ENV{CONTENT_LENGTH};
47    #warn "GOT($qs) $ENV{CONTENT_LENGTH}";
48    cgidec($qs);
49}
50
51$confdata = readall("${cpath}zxid.conf",1);
52($ses_cookie_name) = $confdata =~ /^SES_COOKIE_NAME=(.*)$/m;
53$ses_cookie_name ||= 'ZXIDSES';
54($ses_from_cookie) = $ENV{HTTP_COOKIE} =~ /$ses_cookie_name=([^; \t]+)/;
55
56warn "$$ s-from-c($ses_from_cookie) cgi: " . Dumper(\%cgi);
57
58### Due to circumstances, zxididp typically will not have set the cookie so we need to set it here
59
60if (!$ses_from_cookie) {
61    $ses_from_cookie = $cgi{'s'};
62    $setcookie = "\r\nSet-Cookie: $ses_cookie_name=$ses_from_cookie";
63}
64if ($cgi{'s'}) {
65    if ($cgi{'s'} ne $ses_from_cookie) {
66	$cgi{'s'} = $ses_from_cookie;
67	$setcookie = "\r\nSet-Cookie: $ses_cookie_name=$ses_from_cookie";
68    }
69} else {
70    $cgi{'s'} = $ses_from_cookie;
71    $setcookie = "\r\nSet-Cookie: $ses_cookie_name=$ses_from_cookie";
72}
73
74$sesdata = readall("${cpath}ses/$cgi{'s'}/.ses", 1);
75$persona = readall("${cpath}ses/$cgi{'s'}/.persona", 1);
76if (!length $sesdata) {
77    $qs = $qs ? "$qs&" : "";
78    $qs .= "o=F&redirafter=$ENV{SCRIPT_NAME}?s=X";
79    warn "No session! Need to login($cgi{'s'}).  qs($qs)";
80    $cf = Net::SAML::new_conf_to_cf("CPATH=$cpath");
81    $res = Net::SAML::simple_cf($cf, -1, $qs, undef, 0x3fff); # 0x1829
82    cgidec($res);
83    warn "$$: SSO done($res): " . Dumper(\%cgi);
84    # *** figure out the IdP session
85    $sesdata = readall("${cpath}ses/XXX/.ses",1);
86    $persona = readall("${cpath}ses/XXX/.persona",1);
87}
88(undef, undef, undef, undef, $uid) = split /\|/, $sesdata;
89warn "uid($uid) sesdata($sesdata)";
90
91sub uridec {
92    my ($val) = @_;
93    $val =~ s/\+/ /g;
94    $val =~ s/%([0-9a-f]{2})/chr(hex($1))/gsex;  # URI decode
95    return $val;
96}
97
98sub urienc {
99    my ($val) = @_;
100    $val =~ s/([^A-Za-z0-9.,_-])/sprintf("%%%02x",ord($1))/gsex; # URI enc
101    return $val;
102}
103
104sub cgidec {
105    my ($d) = @_;
106    for $nv (split '&', $d) {
107	($n, $v) = split '=', $nv, 2;
108	$cgi{$n} = uridec($v);
109    }
110}
111
112# ./zxlogview /var/zxid/idppem/logsign-nopw-cert.pem /var/zxid/idppem/logenc-nopw-cert.pem </var/zxid/idpuid/Fool11/.log
113
114sub read_user_log {
115    my ($uid, $repeat, $nlog) = @_;
116    open LOG, "tail -$nlog ${cpath}uid/$uid/.log | ./zxlogview ${cpath}pem/logsign-nopw-cert.pem ${cpath}pem/logenc-nopw-cert.pem|"
117	or die "Cannot open log decoding pipe: $!";
118    $/ = "\n";
119    my ($what, $line, $x);
120    my $accu = '';
121    while ($line = <LOG>) {
122	# 0     1   2  3 4                   5                   6   7 8 9 10     mm11   v r op
123	# ----+ 104 PP - 20100217-151751.352 19700101-000000.501 -:- - - - -      zxcall N W GOTMD http://idp.tas3.eu/zxididp?o=B -
124	my ($pre, $len, $se, $sig3, $ourts, $srcts5, $ipport6, $ent, $mid, $a7nid, $nid, $mm11, $vvv, $res, $op, $para, @rest) = split /\s+/, $line;
125	#                                                                                           $para                        rest0       rest1
126	# ----+ 124 PP - 20100314-172308.720 19700101-000000.501 -:- - - - -      zxidp N K INEWSES MSESey_n-6_oVkMlBR2dQCkgAlKs uid(Fool11) pw
127	if ($op eq 'INEWSES') {
128	    if ($rest[1] eq 'yk') {
129		$what = "Authenticated using Yubikey. New session created.";
130	    } elsif ($rest[1] eq 'pw') {
131		$what = "Authenticated using password. New session created.";
132	    } else {
133		$what = "Other authn. New session created.";
134	    }
135	} elsif ($op eq 'DIA7N') {
136	    $what = "Web Service Provider Bootstrap or Discovery.";
137	} elsif ($op eq 'SSOA7N') {
138	    $what = "Single Sign-On (SSO).";
139	} else {
140	    $what = "$op $para ".join(' ', @rest);
141	}
142	my %s = (when => $ourts, sp => $ent, id => $a7nid, what => $what);
143	($x = $repeat) =~ s/!!(\w+)/$s{$1}/g;
144	$accu .= $x;
145    }
146    close LOG;
147    return $accu;
148}
149
150sub read_cot {
151    my ($repeat, $selected_sp) = @_;
152    open COT, "./zxcot ${cpath}cot|" or die "Cannot open zxcot pipe: $!";
153    $/ = "\n";
154    my ($line, $x);
155    my $accu = '';
156    while ($line = <COT>) {
157	my ($file, $eid, $dpy_name) = split /\s+/, $line;
158	my $selected = $eid eq $selected_sp ? 'selected' : '';
159	my %s = (sp => $eid, spnice => $dpy_name, selectedsp => $selected);
160	($x = $repeat) =~ s/!!(\w+)/$s{$1}/g;
161	$accu .= $x;
162    }
163    close LOG;
164    return $accu;
165}
166
167sub persona_menu {
168    my ($repeat, $selected_persona, $ar_personae) = @_;
169    my ($line, $x);
170    my $accu = '';
171    for $line (sort @{$ar_personae}) {
172	my $selected = $line eq $selected_persona ? 'selected' : '';
173	my %s = (pp => $line, selectedpp => $selected);
174	($x = $repeat) =~ s/!!(\w+)/$s{$1}/g;
175	$accu .= $x;
176    }
177    return $accu;
178}
179
180sub readall {
181    my ($f, $nofatal) = @_;
182    my ($pkg, $srcfile, $line) = caller;
183    undef $/;         # Read all in, without breaking on lines
184    open F, "<$f" or do { if ($nofatal) { warn "$srcfile:$line: Cant read($f): $!"; return undef; } else { die "$srcfile:$line: Cant read($f): $!"; } };
185    binmode F;
186    my $x = <F>;
187    close F;
188    return $x;
189}
190
191#######################################################################
192### Typical idiom for loops (not supported directly by bangbang)
193###    <!--REPEAT-->
194###    <b>!!EDITION</b>: Pub date !!DATE
195###    <!--END_REPEAT-->
196###
197### $t = filex::slurp('edition.ht');
198### $t =~ s/<!--REPEAT-->(.*)<!--END_REPEAT-->/!!REPEAT/s;
199### $repeat = $1;
200### for $ed (1425, 1426) {
201###	my %s = (EDITION => $ed, DATE => $shortdate{$ed});
202###	($x = $repeat) =~ s/!!(\w+)/$s{$1}/g;
203###	$accu .= $x;
204### }
205### $subst{REPEAT} = $accu;
206###
207### Typical idiom for ifs (supported directly by bangbang)
208###    <!--IF(NEW)-->
209###      <h3>Yes</h3>
210###    <!--ELSE(NEW)-->
211###      <h3>Else</h3>
212###    <!--FI(NEW)-->
213###
214### bangbang(\$p, \%subst);   # modifies template $p in place
215###
216### The conditions can contain ! (not), && (and), and || (or) boolean
217### operators. Parenthesis are not supported. No whitespace should be
218### inserted between variables and operators.
219
220sub eval_cond {
221    my ($cond, $sr) = @_;
222    my ($a,$op,$b);
223  or_loop: for my $and_clause (split /\|\|/, $cond) {  # split by or
224	for my $var (split /&&/, $and_clause) {
225	    if (($a,$op,$b) = $var =~ /^(\w+)([<>=!]+)(\w+)$/) {
226		$a = $$sr{$a} if $a !~ /^\d+$/;
227		$b = $$sr{$b} if $b !~ /^\d+$/;
228		next or_loop if $op eq '==' && $a ne $b;   # short circuit fail
229		next or_loop if $op eq '!=' && $a eq $b;
230		next or_loop if $op eq '<'  && $a >= $b;
231		next or_loop if $op eq '>'  && $a <= $b;
232		next or_loop if $op eq '<=' && $a >  $b;
233		next or_loop if $op eq '>=' && $a <  $b;
234	    } else {
235		if (substr($var,0,1)eq'!') {
236		    next or_loop if $$sr{substr($var,1)};  # short circuit fail
237		} else {
238		    next or_loop if !$$sr{$var};           # short circuit fail
239		}
240	    }
241	}
242	return 1;  # true: all ANDs were ok --> short circuit success
243    }
244    return ();  # false: all ORs failed
245}
246
247sub bangbang {
248    my ($pr, $sr) = @_;
249
250    ### Early substitutions
251    my $n = 0;
252    $n++ while $n<5 && $$pr =~ s/!%!(\w+)/$$sr{$1}/g;
253    warn "$n levels of early substitution" if $n>=3;
254
255    #warn "=======>$$pr<=======";
256    1 while  # Process as many times as possible, handles nested ifs
257    #do { warn "===>$$pr<===\n\n\n " if $x eq 'po_a' } while  # Debug
258    #warn "==>$$sr{$3}:$1:$2:$3<==\n" while  # Debug
259    #                     1-cond          2-then  3-else
260	$$pr =~ s/<!--IF\(([\w!|&=<>]+)\)-->(.*?)
261	          (?:<!--ELSE\(\1\)-->(.*?))?
262		  <!--FI\(\1\)-->
263	       / eval_cond($1,$sr) ? $2 : $3 /gsex;
264
265    $n = 0;
266    #do { $n++; warn "\n===>$$pr<===\n " if $x eq 'A105-pt'; } while $$pr =~ s/!!(\w+)/$$sr{$1}/g;
267    $n++ while $n<20 && $$pr =~ s/!!(\w+)/$$sr{$1}/g;  # Do any remaining substitutions as many times it takes
268    warn "$n levels of variable substitution" if $n>=10;
269}
270
271### $accu .= filex::bang($templ, 'err here', A=>"b", C=>"d");
272
273sub show_templ {
274    my ($templ, $hr) = @_;
275    $templ = readall($templ);
276    $templ =~ s/!!(\w+)/$$hr{$1}/gs;
277    my $len = length $templ;
278    syswrite STDOUT, "Content-Type: text/html\r\nContent-Length: $len$setcookie\r\n\r\n$templ";
279    exit;
280}
281
282sub show_atsel {
283    my ($uid, $hr) = @_;
284    my $templ = readall("atsel-main.html");
285    $templ =~ s/<!--REPEAT_LOG-->(.*)<!--END_REPEAT_LOG-->/!!REPEAT_LOG/s;
286    my $repeat_log = $1;
287    $templ =~ s/<!--REPEAT_SP-->(.*)<!--END_REPEAT_SP-->/!!REPEAT_SP/s;
288    my $repeat_sp = $1;
289    $templ =~ s/<!--REPEAT_PP-->(.*)<!--END_REPEAT_PP-->/!!REPEAT_PP/s;
290    my $repeat_pp = $1;
291    $templ =~ s/<!--REPEAT_ATTR-->(.*)<!--END_REPEAT_ATTR-->/!!REPEAT_ATTR/s;
292    my $repeat_attr = $1;
293
294    $$hr{NLOG} = 10;
295    $$hr{REPEAT_LOG} = read_user_log($uid, $repeat_log, $$hr{NLOG});
296    $$hr{REPEAT_SP}  = read_cot($repeat_sp, $selected_sp);
297    $$hr{REPEAT_PP}  = read_cot($repeat_sp, $persona);
298
299    # Scan all attributes according to algorithm
300
301
302
303    bangbang(\$templ, $hr);
304    my $len = length $templ;
305    syswrite STDOUT, "Content-Type: text/html\r\nContent-Length: $len$setcookie\r\n\r\n$templ";
306    exit;
307}
308
309show_atsel($uid, \%cgi);
310
311__END__
312