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