Girocco/CGI.pm

   1 package Girocco::CGI;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Girocco::Config;
   7 use Girocco::Util;
   8
   9 BEGIN {
  10         require Exporter;
  11         our $VERSION = '0.1';
  12         our @ISA = qw(Exporter);
  13         our @EXPORT = qw(html_esc);
  14
  15         use CGI qw(:standard :escapeHTML -nosticky);
  16         use CGI::Util qw(unescape);
  17         use CGI::Carp qw(fatalsToBrowser);
  18         eval 'sub CGI::multi_param {CGI::param(@_)}'
  19                 unless CGI->can("multi_param");
  20 }
  21
  22 my $_suppress_header;
  23 BEGIN {$_suppress_header = 0}
  24
  25 my @_randlens;
  26 my @_randchars;
  27 BEGIN {
  28         @_randlens = (
  29         # the prime numbers >= 1024 and < 2048
  30 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, 1087, 1091, 1093, 1097, 1103,
  31 1109, 1117, 1123, 1129, 1151, 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213,
  32 1217, 1223, 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, 1297,
  33 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, 1381, 1399, 1409, 1423,
  34 1427, 1429, 1433, 1439, 1447, 1451, 1453, 1459, 1471, 1481, 1483, 1487, 1489,
  35 1493, 1499, 1511, 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583,
  36 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, 1663, 1667, 1669,
  37 1693, 1697, 1699, 1709, 1721, 1723, 1733, 1741, 1747, 1753, 1759, 1777, 1783,
  38 1787, 1789, 1801, 1811, 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879,
  39 1889, 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, 1993, 1997,
  40 1999, 2003, 2011, 2017, 2027, 2029, 2039
  41         );
  42         @_randchars = (
  43         # IMPORTANT: The '-' MUST be the last character in the array so we can
  44         # use one less than the array length to randomly replace the second '-'
  45         # in any generated '--' sequence.
  46 9, 10, 13, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 46, 47, 48, 49,
  47 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
  48 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
  49 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107,
  50 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123,
  51 124, 125, 126, 45 # '-' (45/0x2D) MUST be last
  52         );
  53 }
  54
  55 sub _randpad {
  56         # return 1K - 2K of random padding that is a random length which
  57         # happens to be prime and is suitable for inclusion as an XHTML comment
  58         # (the comment delimiters are NOT added)
  59         use bytes;
  60         my $len = $_randlens[int(rand(@_randlens))];
  61         my $ccnt = @_randchars;
  62         my $str = '';
  63         for (my $i=1; $i<$len; ++$i) {
  64                 $str .= chr($_randchars[int(rand($ccnt))]);
  65         }
  66         $str =~ s/--/'-'.chr($_randchars[int(rand($ccnt-1))])/gse;
  67         return $str;
  68 }
  69
  70 sub _vulnpad {
  71         # Return suitably commented vulnerability mitigation padding if applicable
  72
  73         # If https is enabled (HTTPS == "on") attempt to avoid the compression
  74         # vulnerability as described in VU#987798/CVE-2013-3587 (aka BREACH).
  75         # This only need be done for POST requests as nothing else has sensitive data.
  76         # See http://www.kb.cert.org/vuls/id/987798 for further information.
  77
  78         my $vulnrandpad = "";
  79         if (($ENV{'HTTPS'} && lc($ENV{'HTTPS'}) eq 'on') &&
  80             ($ENV{'REQUEST_METHOD'} && lc($ENV{'REQUEST_METHOD'}) eq 'post')) {
  81                 # Add some random padding to mitigate the vulnerability
  82                 $vulnrandpad = "<!-- Mitigate VU#987798/CVE-2013-3587 with random padding -->\n";
  83                 $vulnrandpad .= "<!-- " . _randpad . " -->\n";
  84         }
  85         return $vulnrandpad;
  86 }
  87
  88 sub enableHeader {
  89         $_suppress_header = $_[0] ? 0 : 1;
  90 }
  91
  92 sub new {
  93         my $class = shift;
  94         my ($heading, $section, $extraheadhtml, $sectionlink) = @_;
  95         my $gcgi = {};
  96         my $vulnrandpad = _vulnpad;
  97
  98         $heading = CGI::escapeHTML($heading || '');
  99         $section = CGI::escapeHTML($section || 'administration');
 100         $section = "<a href=\"$sectionlink\">$section</a>" if $sectionlink;
 101         # $extraheadhtml is optional RAW html code to include, DO NOT escapeHTML it!
 102         $extraheadhtml = $extraheadhtml || '';
 103         my $name = CGI::escapeHTML($Girocco::Config::name || '');
 104
 105         $gcgi->{cgi} = CGI->new;
 106
 107         my $cgiurl = $gcgi->{cgi}->url(-absolute => 1);
 108         ($gcgi->{srcname}) = ($cgiurl =~ m#^.*/\([a-zA-Z0-9_.\/-]+?\.cgi\)$#); #
 109         $gcgi->{srcname} = "cgi/".$gcgi->{srcname} if $gcgi->{srcname};
 110
 111         print $gcgi->{cgi}->header(-type=>'text/html', -charset => 'utf-8')
 112                 unless $_suppress_header;
 113
 114         print <<EOT;
 115 <?xml version="1.0" encoding="utf-8"?>
 116 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 117 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US" lang="en-US">
 118
 119 <head>
 120 <meta charset="utf-8" />
 121 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 122 <title>$name :: $heading</title>
 123 <link rel="stylesheet" type="text/css" href="@{[url_path($Girocco::Config::gitwebfiles)]}/gitweb.css" />
 124 <link rel="stylesheet" type="text/css" href="@{[url_path($Girocco::Config::gitwebfiles)]}/girocco.css" />
 125 <link rel="shortcut icon" href="@{[url_path($Girocco::Config::gitwebfiles)]}/git-favicon.png" type="image/png" />
 126 <script src="@{[url_path($Girocco::Config::gitwebfiles)]}/mootools.js" type="text/javascript"></script>
 127 <script src="@{[url_path($Girocco::Config::gitwebfiles)]}/girocco.js" type="text/javascript"></script>
 128 $extraheadhtml$vulnrandpad</head>
 129
 130 <body>
 131
 132 <div class="page_header">
 133 <a href="http://git-scm.com/" title="Git homepage"><img src="@{[url_path($Girocco::Config::gitwebfiles)]}/git-logo.png" width="72" height="27" alt="git" style="float:right; border-width:0px;" /></a>
 134 <a href="@{[url_path($Girocco::Config::gitweburl,1)]}">$name</a> / $section / $heading
 135 </div>
 136
 137 EOT
 138
 139         bless $gcgi, $class;
 140 }
 141
 142 sub DESTROY {
 143         my $self = shift;
 144         my $vulnrandpad = _vulnpad;
 145         if ($self->{srcname} and $Girocco::Config::giroccourl) {
 146                 my $hb = $Girocco::Config::giroccobranch ?
 147                         "hb=$Girocco::Config::giroccobranch;" : "";
 148                 print <<EOT;
 149 <div align="right">
 150 <a href="@{[url_path($Girocco::Config::giroccourl)]}?a=blob;${hb}f=$self->{srcname}">(view source)</a>
 151 </div>
 152 EOT
 153         }
 154         print <<EOT;
 155 </body>
 156 $vulnrandpad</html>
 157 EOT
 158 }
 159
 160 sub cgi {
 161         my $self = shift;
 162         $self->{cgi};
 163 }
 164
 165 # return previous value of $self->{errprelude}
 166 # if at least one argument is given, then set $self->{errprelude} to the first arg
 167 # if $self->{errprelude} is non-empty at the time the first err call happens then
 168 #   $self->{errprelude} will be output just before the first error message
 169 sub err_prelude {
 170         my $self = shift;
 171         my $result = $self->{errprelude};
 172         $self->{errprelude} = $_[0] if @_ >= 1;
 173         return $result;
 174 }
 175
 176 sub err {
 177         my $self = shift;
 178         print $self->{errprelude} if !$self->{err} && defined($self->{errprelude});
 179         print "<p style=\"color: #c00000; word-wrap: break-word\">@_</p>\n";
 180         $self->{err}++;
 181 }
 182
 183 sub ok {
 184         my $self = shift;
 185         my $err = $self->{err}||0;
 186         return $err == 0;
 187 }
 188
 189 sub err_check {
 190         my $self = shift;
 191         my $err = $self->{err}||0;
 192         my $s = $err == 1 ? '' : 's';
 193         $err and print "<p style=\"font-weight: bold\">Operation aborted due to $err error$s.</p>\n";
 194         $err;
 195 }
 196
 197 sub wparam {
 198         my $self = shift;
 199         my ($param) = @_;
 200         my $val = $self->{cgi}->param($param);
 201         defined $val and $val =~ s/^\s*(.*?)\s*$/$1/;
 202         $val;
 203 }
 204
 205 sub srcname {
 206         my $self = shift;
 207         my ($srcname) = @_;
 208         $self->{srcname} = $srcname if $srcname;
 209         $self->{srcname};
 210 }
 211
 212 sub html_esc($;$) {
 213         my $str = shift;
 214         my $charentityokay = shift;
 215         defined($str) or $str = '';
 216         if ($charentityokay) {
 217                 $str =~ s/&(?!#(?:[xX][a-fA-F0-9]+|\d+);)/&amp;/g;
 218         } else {
 219                 $str =~ s/&/&amp;/g;
 220         }
 221         $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g;
 222         $str =~ s/[""]/&quot;/g; $str =~ s/['']/&apos;/g;
 223         $str;
 224 }
 225
 226 # Option 1:
 227 #  $instance->print_form_fields({<fieldmap>}, {<valuemap>}, @<field names>)
 228 # Option 2:
 229 #  $instance->print_form_fields({<fieldmap>}, {<protectmap>}, {valuemap}, @<fields>)
 230 # If ref(3rd-arg) eq 'HASH' it's option 2 otherwise option 1
 231 sub print_form_fields {
 232         my $self = shift;
 233         my $fieldmap = shift;
 234         my $protectmap = ref($_[1]) eq 'HASH' ? shift : {};
 235         my ($valuemap, @fields) = @_;
 236         my $protflag;
 237
 238         my $print_form_field = sub {
 239                 my $field = shift;
 240                 my $title='';
 241                 if (defined($field->[3]) && $field->[3] ne '') {
 242                         $title=' title="'.html_esc($field->[3], 1).'"'
 243                 }
 244                 print '<tr'.$title.'><td class="formlabel">'.$field->[0].':</td>';
 245                 if ($protflag || $protectmap->{$field->[1]}) {
 246                         $protflag = 1;
 247                         print '<td class="formdata">Enter <b>Admin password</b> and use &#x201c;View All&#x201d; button to view/edit.';
 248                 } elsif ($field->[2] eq 'text') {
 249                         print '<td><input type="text" name="'.$field->[1].'" size="80"';
 250                         print ' value="'.$valuemap->{$field->[1]}.'"' if $valuemap;
 251                         print ' />';
 252                 } elsif ($field->[2] eq 'checkbox') {
 253                         print '<td class="formdatatd"><input type="checkbox" name="'.$field->[1].'"';
 254                         print ' checked="checked"' if $valuemap && $valuemap->{$field->[1]};
 255                         printf ' value="%s"', ($valuemap && $valuemap->{$field->[1]} ? $valuemap->{$field->[1]} : "1");
 256                         print ' />';
 257                 } elsif ($field->[2] eq 'select') {
 258                         print '<td class="formdatatd"><select size="1" name="'.$field->[1].'">';
 259                         if (ref($field->[4]) eq 'CODE') {
 260                                 my $selval = defined($valuemap->{$field->[1]}) ? $valuemap->{$field->[1]} : '';
 261                                 for (&{$field->[4]}($$valuemap{__project__})) {
 262                                         next if /^\s*$/;
 263                                         my $selected = $selval eq $_ ? ' selected="selected"' : '';
 264                                         print "<option$selected>".Girocco::CGI::html_esc($_)."</option>";
 265                                 }
 266                         }
 267                         print '</select>';
 268                 } else {
 269                         print '<td><textarea name="'.$field->[1].'" rows="5" cols="80">';
 270                         print $valuemap->{$field->[1]} if $valuemap;
 271                         print '</textarea>';
 272                 }
 273                 print "</td></tr>\n";
 274         };
 275         foreach my $fieldset (map { $fieldmap->{$_} } @fields) {
 276                 ref($fieldset) eq 'ARRAY' or next;
 277                 $fieldset = [$fieldset] unless ref($$fieldset[0]) eq 'ARRAY';
 278                 $protflag = 0;
 279                 foreach (@$fieldset) {
 280                         defined($$_[0]) && $$_[0] ne "" or next;
 281                         defined($$_[1]) && $$_[1] ne "" or next;
 282                         defined($$_[2]) && $$_[2] ne "" or next;
 283                         $$_[2] eq 'placeholder' || $$_[2] !~ /^[A-Za-z]/ and next;
 284                         &$print_form_field($_);
 285                 }
 286         }
 287 }
 288
 289
 290 1;