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 <title>$name :: $heading</title>
 112 <link rel="stylesheet" type="text/css" href="@{[url_path($Girocco::Config::gitwebfiles)]}/gitweb.css"/>
 113 <link rel="stylesheet" type="text/css" href="@{[url_path($Girocco::Config::gitwebfiles)]}/girocco.css"/>
 114 <link rel="shortcut icon" href="@{[url_path($Girocco::Config::gitwebfiles)]}/git-favicon.png" type="image/png"/>
 115 <script src="@{[url_path($Girocco::Config::gitwebfiles)]}/mootools.js" type="text/javascript"></script>
 116 <script src="@{[url_path($Girocco::Config::gitwebfiles)]}/girocco.js" type="text/javascript"></script>
 117 $extraheadhtml$vulnrandpad</head>
 118
 119 <body>
 120
 121 <div class="page_header">
 122 <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>
 123 <a href="@{[url_path($Girocco::Config::gitweburl,1)]}">$name</a> / $section / $heading
 124 </div>
 125
 126 EOT
 127
 128         bless $gcgi, $class;
 129 }
 130
 131 sub DESTROY {
 132         my $self = shift;
 133         my $vulnrandpad = _vulnpad;
 134         if ($self->{srcname} and $Girocco::Config::giroccourl) {
 135                 my $hb = $Girocco::Config::giroccobranch ?
 136                         "hb=$Girocco::Config::giroccobranch;" : "";
 137                 print <<EOT;
 138 <div align="right">
 139 <a href="@{[url_path($Girocco::Config::giroccourl)]}?a=blob;${hb}f=$self->{srcname}">(view source)</a>
 140 </div>
 141 EOT
 142         }
 143         print <<EOT;
 144 </body>
 145 $vulnrandpad</html>
 146 EOT
 147 }
 148
 149 sub cgi {
 150         my $self = shift;
 151         $self->{cgi};
 152 }
 153
 154 # return previous value of $self->{errprelude}
 155 # if at least one argument is given, then set $self->{errprelude} to the first arg
 156 # if $self->{errprelude} is non-empty at the time the first err call happens then
 157 #   $self->{errprelude} will be output just before the first error message
 158 sub err_prelude {
 159         my $self = shift;
 160         my $result = $self->{errprelude};
 161         $self->{errprelude} = $_[0] if @_ >= 1;
 162         return $result;
 163 }
 164
 165 sub err {
 166         my $self = shift;
 167         print $self->{errprelude} if !$self->{err} && defined($self->{errprelude});
 168         print "<p style=\"color: #c00000; word-wrap: break-word\">@_</p>\n";
 169         $self->{err}++;
 170 }
 171
 172 sub ok {
 173         my $self = shift;
 174         my $err = $self->{err}||0;
 175         return $err == 0;
 176 }
 177
 178 sub err_check {
 179         my $self = shift;
 180         my $err = $self->{err}||0;
 181         my $s = $err == 1 ? '' : 's';
 182         $err and print "<p style=\"font-weight: bold\">Operation aborted due to $err error$s.</p>\n";
 183         $err;
 184 }
 185
 186 sub wparam {
 187         my $self = shift;
 188         my ($param) = @_;
 189         my $val = $self->{cgi}->param($param);
 190         defined $val and $val =~ s/^\s*(.*?)\s*$/$1/;
 191         $val;
 192 }
 193
 194 sub srcname {
 195         my $self = shift;
 196         my ($srcname) = @_;
 197         $self->{srcname} = $srcname if $srcname;
 198         $self->{srcname};
 199 }
 200
 201 sub html_esc($;$) {
 202         my $str = shift;
 203         my $charentityokay = shift;
 204         defined($str) or $str = '';
 205         if ($charentityokay) {
 206                 $str =~ s/&(?!#(?:[xX][a-fA-F0-9]+|\d+);)/&amp;/g;
 207         } else {
 208                 $str =~ s/&/&amp;/g;
 209         }
 210         $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g;
 211         $str =~ s/[""]/&quot;/g; $str =~ s/['']/&apos;/g;
 212         $str;
 213 }
 214
 215 sub print_form_fields {
 216         my $self = shift;
 217         my ($fieldmap, $valuemap, @fields) = @_;
 218
 219         foreach my $field (map { $fieldmap->{$_} } @fields) {
 220                 defined($field->[2]) && $field->[2] ne 'placeholder' or next;
 221                 my $title='';
 222                 if (defined($field->[3]) && $field->[3] ne '') {
 223                         $title=' title="'.html_esc($field->[3], 1).'"'
 224                 }
 225                 print '<tr'.$title.'><td class="formlabel">'.$field->[0].':</td>';
 226                 if ($field->[2] eq 'text') {
 227                         print '<td><input type="text" name="'.$field->[1].'" size="80"';
 228                         print ' value="'.$valuemap->{$field->[1]}.'"' if $valuemap;
 229                         print ' />';
 230                 } elsif ($field->[2] eq 'checkbox') {
 231                         print '<td class="formdatatd"><input type="checkbox" name="'.$field->[1].'"';
 232                         print ' checked="checked"' if $valuemap && $valuemap->{$field->[1]};
 233                         printf ' value="%s"', ($valuemap && $valuemap->{$field->[1]} ? $valuemap->{$field->[1]} : "1");
 234                         print ' />';
 235                 } else {
 236                         print '<td><textarea name="'.$field->[1].'" rows="5" cols="80">';
 237                         print $valuemap->{$field->[1]} if $valuemap;
 238                         print '</textarea>';
 239                 }
 240                 print "</td></tr>\n";
 241         }
 242 }
 243
 244
 245 1;