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 sub print_form_fields {
 227         my $self = shift;
 228         my ($fieldmap, $valuemap, @fields) = @_;
 229
 230         foreach my $field (map { $fieldmap->{$_} } @fields) {
 231                 defined($field->[2]) && $field->[2] ne 'placeholder' or next;
 232                 my $title='';
 233                 if (defined($field->[3]) && $field->[3] ne '') {
 234                         $title=' title="'.html_esc($field->[3], 1).'"'
 235                 }
 236                 print '<tr'.$title.'><td class="formlabel">'.$field->[0].':</td>';
 237                 if ($field->[2] eq 'text') {
 238                         print '<td><input type="text" name="'.$field->[1].'" size="80"';
 239                         print ' value="'.$valuemap->{$field->[1]}.'"' if $valuemap;
 240                         print ' />';
 241                 } elsif ($field->[2] eq 'checkbox') {
 242                         print '<td class="formdatatd"><input type="checkbox" name="'.$field->[1].'"';
 243                         print ' checked="checked"' if $valuemap && $valuemap->{$field->[1]};
 244                         printf ' value="%s"', ($valuemap && $valuemap->{$field->[1]} ? $valuemap->{$field->[1]} : "1");
 245                         print ' />';
 246                 } else {
 247                         print '<td><textarea name="'.$field->[1].'" rows="5" cols="80">';
 248                         print $valuemap->{$field->[1]} if $valuemap;
 249                         print '</textarea>';
 250                 }
 251                 print "</td></tr>\n";
 252         }
 253 }
 254
 255
 256 1;