Release a new version of the Apache module, with the context support.
[itkacl] / itkacl-web-1.0 / include / itkaclcommon.pm
1 #! /usr/bin/perl
2 use strict;
3 use warnings;
4 use CGI;
5 use DBI;
6 use Apache::Session::Postgres;
7 use Encode;
8 use HTML::Entities;
9 use Digest::HMAC_SHA1;
10 use locale;
11 use utf8;
12
13 require 'config.pm';
14
15 package itkaclcommon;
16
17 our $cgi;
18 our $dbh;
19 our $last_modified = '$Date: 2011-11-19 11:08:01 $';
20 our %session;
21 our $csrf_token;
22 our $masked_csrf_token;
23
24 sub init {
25         $cgi = new CGI;
26         $dbh = DBI->connect("dbi:Pg:dbname=$itkaclconfig::db_name;host=$itkaclconfig::db_host",
27                 $itkaclconfig::db_user, $itkaclconfig::db_pass)
28                 or die "Couldn't connect to database";
29         $dbh->{pg_enable_utf8} = 1;
30         $last_modified = '$Date: 2011-11-19 11:08:01 $';
31         %session = ();
32
33         if (defined($ENV{'REMOTE_USER'})) {
34                 $csrf_token = Digest::HMAC_SHA1::hmac_sha1($ENV{'REMOTE_USER'}, $itkaclcommon::hmac_key);
35
36                 # Mask the CSRF token to avoid the BREACH attack.
37                 my @hmac_bytes = map { ord($_) } (split //, $csrf_token);
38                 my @random_bytes = map { int(rand(256)) } (0..$#hmac_bytes);
39                 my @masked_bytes = map { $hmac_bytes[$_] ^ $random_bytes[$_] } (0..$#hmac_bytes);
40                 
41                 my $random_bytes_string = join('', map { chr($_) } (@random_bytes));
42                 my $masked_bytes_string = join('', map { chr($_) } (@masked_bytes));
43                 $masked_csrf_token = unpack('H*', $random_bytes_string) . '_' . unpack("H*", $masked_bytes_string);
44         } else {
45                 $csrf_token = '';
46                 $masked_csrf_token = '';
47         }
48 }
49
50 sub check_csrf_token {
51         if ($csrf_token eq '') {
52                 # Not logged in, so always fine.
53                 return 1;
54         }
55         
56         my $candidate_csrf_token = $cgi->param('csrftoken');
57         if ($candidate_csrf_token !~ /^([0-9a-f]+)_([0-9a-f]+)$/) {
58                 die "Invalid CSRF token!";
59         }
60
61         my ($random_bytes_string, $masked_bytes_string) = ($1, $2);
62         if (length($random_bytes_string) != length($masked_bytes_string)) {
63                 die "Length mismatch in CSRF token!";
64         }
65
66         my @random_bytes = map { ord($_) } (split //, pack('H*', $random_bytes_string));
67         my @masked_bytes = map { ord($_) } (split //, pack('H*', $masked_bytes_string));
68         my @hmac_bytes = map { $masked_bytes[$_] ^ $random_bytes[$_] } (0..$#masked_bytes);
69         my $hmac_string = join('', map { chr($_) } (@hmac_bytes));
70
71         die "CSRF token mismatch!" if ($hmac_string ne $csrf_token);
72 }
73
74 sub print_header {
75         init();
76
77         # Find the cookie, if any
78         my $session_id = $cgi->cookie('itkaclsession');
79         tie %session, 'Apache::Session::Postgres', $session_id, {
80                 DataSource => "dbi:Pg:dbname=$itkaclconfig::sessiondb_name;host=$itkaclconfig::sessiondb_host",
81                 UserName   => $itkaclconfig::sessiondb_user,
82                 Password   => $itkaclconfig::sessiondb_pass,
83                 Commit     => 1
84         };
85
86         # Update with open/close
87         my $open = $cgi->param('open');
88         my $close = $cgi->param('close');
89         if (defined($open)) {
90                 $session{$open} = 1;
91         } elsif (defined($close)) {
92                 undef $session{$close};
93         }
94
95         my $cookie = $cgi->cookie(-name=>'itkaclsession',
96                         -value=>$session{_session_id},
97                         -expires=>'+1h');
98
99         binmode STDOUT, ":utf8";
100         print $cgi->header(-type=>'application/xhtml+xml; charset=utf-8', cookie=>$cookie, -expires=>'now');
101         
102         open HEADER, "<", $itkaclconfig::header
103                 or die "Couldn't open $itkaclconfig::header: $!";
104
105         # Find out if we're using SSO.
106         my $sso = "";
107         if (defined($ENV{'AUTH_TYPE'}) && $ENV{'AUTH_TYPE'} eq 'Negotiate') {
108                 $sso = '<img src="https://itk.samfundet.no/images/ssso-button.png" alt="Samfundet single sign-on" title="Samfundet single sign-on"/>';
109         }
110
111         # Set secure path.
112         local @ENV;
113         delete @ENV{qw(IFS CDPATH ENV BASH_ENV PATH)};
114
115         my $quote;
116         if (defined($itkaclconfig::quotescript)) {
117                 # Hent inn quotes. Stygt, jodal! =)
118                 $quote = `$itkaclconfig::quotescript`;
119                 $quote = Encode::decode_utf8($quote);
120         }
121
122         while (<HEADER>) {
123                 s/\%QUOTES\%/$quote/ if defined($quote);
124                 s/\%SSO\%/$sso/;
125                 s/\%META\%//;
126                 s/\%TITLE\%/ITKACL-tre/;
127                 s/"http:\/\/([^"]*\.(css|png))"/"https:\/\/$1"/;
128                 print;
129         }
130
131         close HEADER;
132 }
133
134 sub print_footer {
135         untie %session;
136         
137         # Print footer
138         open FOOTER, "<", $itkaclconfig::footer
139                 or die "Couldn't open $itkaclconfig::footer: $!";
140
141         # Strip RCS stuff from $::last_modified
142         (my $lm = $last_modified) =~ s/^\$[D]ate: (.*) \$$/$1/;
143
144         while (<FOOTER>) {
145                 s/\%LAST_MODIFIED\%/$lm/;
146                 print;
147         }
148
149         close FOOTER;
150 }
151
152 sub print_tree {
153         my ($fulltree, $boldelem) = @_;
154         if ($fulltree) {
155                 print "    <div class=\"tree\">\n";
156         } else {
157                 print "    <div class=\"tree floatingtree\">\n";
158         }
159         
160         print "      <p><img src=\"/img/base-folder.png\" alt=\"\" width=\"21\" height=\"18\" />Samfundet</p>\n";
161
162         print_tree_element($dbh, undef, 0, [], $fulltree, $boldelem);
163
164         print "    </div>\n";
165 }
166
167 sub print_tree_element {
168         my ($dbh, $curr_obj, $level, $vbars, $fulltree, $boldelem) = @_;
169         
170         my $refs;
171         if (defined($curr_obj)) {
172                 $refs = $dbh->selectall_arrayref('SELECT id,name,description FROM objects WHERE parent=? ORDER BY name', undef, $curr_obj);
173         } else {
174                 $refs = $dbh->selectall_arrayref('SELECT id,name,description FROM objects WHERE parent IS NULL ORDER BY name');
175         }
176
177         my $i = 0;
178         my $count = (scalar @{$refs}) - 1;
179         for my $ref (@{$refs}) {
180                 # More siblings?
181                 my $msb;
182                 my @vbarscopy = @{$vbars};
183                 if ($i == $count) {
184                         $msb = "";
185                         push @vbarscopy, 0;
186                 } else {
187                         $msb = "-moresiblings";
188                         push @vbarscopy, 1;
189                 }
190
191                 print "    <p>";
192
193                 # Stuff to the left of folder
194                 for my $i (1..$level) {
195                         if ($vbars->[$i - 1]) {
196                                 print '<img src="/img/verticalbar.png" alt="|" width="16" height="18" />';
197                         } else {
198                                 print '<img src="/img/whitespace.png" alt="&nbsp;" width="16" height="18" />';
199                         }
200                 }
201
202                 # The folder itself
203                 my $countref = $dbh->selectrow_hashref('SELECT COUNT(*) AS num FROM objects WHERE parent=?', undef, $ref->[0]);
204                 if ($countref->{'num'} == 0) {
205                         if ($i == $count) {
206                                 print "<img src=\"/img/folder-nochildren.png\" alt=\"\" width=\"37\" height=\"18\" />";
207                         } else {
208                                 print "<img src=\"/img/folder-nochildren-moresiblings.png\" alt=\"|\" width=\"37\" height=\"18\" />";
209                         }
210                 } else {
211                         my $url = $cgi->url(-absolute=>1) . "?";
212                         my @params = ();
213                         for my $p ($cgi->param()) {
214                                 next if ($p eq 'open');
215                                 next if ($p eq 'close');
216                                 push @params, "$p=" . $cgi->param($p);
217                         }
218                         if (scalar @params > 0) {
219                                 $url .= join('&amp;', @params) . "&amp;";
220                         }
221                                                          
222                         if (defined($session{$ref->[0]})) {
223                                 print "<a href=\"${url}close=$ref->[0]\"><img src=\"/img/folder-open$msb.png\" alt=\"-\" width=\"37\" height=\"18\" /></a>";
224                         } else {
225                                 print "<a href=\"${url}open=$ref->[0]\"><img src=\"/img/folder-closed$msb.png\" alt=\"+\" width=\"37\" height=\"18\" /></a>";
226                         }
227                 }
228
229                 if (defined($boldelem) && $boldelem == $ref->[0]) {
230                         print "<strong>";
231                 }
232         
233                 my $e_entity = HTML::Entities::encode_entities($ref->[1]);
234                 my $e_description = HTML::Entities::encode_entities($ref->[2]);
235         
236                 if ($fulltree) {
237                         print "<a href=\"/view.pl?entry=$ref->[0]\">$e_entity: $e_description</a>";
238                 } else {
239                         print "<a href=\"/view.pl?entry=$ref->[0]\" title=\"$e_description\">$e_entity</a>";
240                 }
241                 
242                 if (defined($boldelem) && $boldelem == $ref->[0]) {
243                         print "</strong>";
244                 }
245                 print "</p>\n";
246                 
247                 if ($countref->{'num'} > 0 && defined($session{$ref->[0]})) {
248                         print_tree_element($dbh, $ref->[0], $level + 1, \@vbarscopy, $fulltree, $boldelem);
249                 }
250                 ++$i;
251         }
252 }
253
254 1;