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