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