lib/UCW/Gallery/Web.pm

   1 # Simple Photo Gallery: Web Interface
   2 # (c) 2003--2021 Martin Mares <mj@ucw.cz>
   3
   4 package UCW::Gallery::Web;
   5
   6 use common::sense;
   7
   8 use UCW::Gallery;
   9 use UCW::CGI;
  10 use Digest::SHA;
  11 use File::Spec;
  12
  13 my $show_img;
  14 my $want_archive;
  15 my $auth_password;
  16
  17 my %args = (
  18         'i'     => { 'var' => \$show_img, 'check' => '\d+' },
  19         'a'     => { 'var' => \$want_archive },
  20         'pw'    => { 'var' => \$auth_password },
  21 );
  22
  23 sub error($) {
  24         print "<p style='color:red'>Bad luck, the script is broken. Sorry.\n<p>$_[0]\n";
  25         print "</body></html>\n";
  26 }
  27
  28 sub get($$) {
  29         my ($self, $key) = @_;
  30         return $self->{gal}->get($key);
  31 }
  32
  33 sub try_get($$) {
  34         my ($self, $key) = @_;
  35         return $self->{gal}->try_get($key);
  36 }
  37
  38 sub extras($$) {
  39         my ($self, $key) = @_;
  40         my $val = $self->get($key);
  41         if (ref $val eq 'CODE') {
  42                 return &$val($self);
  43         } else {
  44                 return $val;
  45         }
  46 }
  47
  48 # For use by extras hooks
  49 sub gallery($) {
  50         my ($self) = @_;
  51         return $self->{gal};
  52 }
  53
  54 # For use by extras hooks: return true if we are showing an image page, false for index page
  55 sub showing_image($) {
  56         my ($self) = @_;
  57         return $show_img ne "";
  58 }
  59
  60 sub html_top($) {
  61         my ($self) = @_;
  62         my $title = $self->get('Title');
  63         my $hextras = $self->extras('WebHeadExtras');
  64         my $theme_hextras = $self->theme_head_extras;
  65         print <<EOF ;
  66 Content-Type: text/html
  67
  68 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
  69 <html><head>
  70 $hextras$theme_hextras<title>$title</title>
  71 </head><body>
  72 EOF
  73
  74         $UCW::CGI::ErrorHandler::error_hook = \&error;
  75
  76         # WebTopExtras are evaluated separately, since they can override the error hook
  77         print $self->extras('WebTopExtras');
  78 }
  79
  80 sub html_bot($) {
  81         my ($self) = @_;
  82         print $self->extras('WebBotExtras'), "</body></html>\n";
  83 }
  84
  85 sub show_img($) {
  86         my ($self) = @_;
  87
  88         if ($show_img < 1 || $show_img > $self->{num_photos}) {
  89                 UCW::CGI::http_error('404 No such photo');
  90                 return;
  91         }
  92
  93         my $meta = $self->{meta};
  94         my $id = $meta->{sequence}->[$show_img-1];
  95         my $m = $meta->{photo}->{$id} or die;
  96         $self->html_top;
  97
  98         $self->show_links(($show_img > 1 ? ("?i=".($show_img-1)) : ""),
  99                           ".",
 100                           ($show_img < $self->{num_photos} ? ("?i=".($show_img+1)) : ""));
 101
 102         my $t = UCW::CGI::html_escape($m->{title});
 103         my $w = $m->{w};
 104         my $h = $m->{h};
 105         print "<h1>$t</h1>\n" if $t ne "";
 106         my $img = $self->get('PhotoUrlPrefix') . $self->{gal}->photo_file_name($m, $id);
 107         print "<p class=large><img src='$img' width=$w height=$h alt='$t'>\n";
 108
 109         $self->html_bot;
 110 }
 111
 112 sub show_pre_thumbs($) {
 113         my ($self) = @_;
 114 }
 115
 116 sub show_post_thumbs($) {
 117         my ($self) = @_;
 118 }
 119
 120 sub show_common_header($) {
 121         my ($self) = @_;
 122         $self->html_top;
 123
 124         $self->show_links($self->get('BackURL'), $self->get('ParentURL'), $self->get('FwdURL'));
 125         print "<h1>", $self->get('Title'), "</h1>\n";
 126         my $subtitle = $self->get('SubTitle');
 127         print "<h2>$subtitle</h2>\n" if $subtitle ne "";
 128 }
 129
 130 sub show_list($) {
 131         my ($self) = @_;
 132         $self->show_common_header;
 133         $self->show_pre_thumbs;
 134
 135         my $meta = $self->{meta};
 136         for my $idx (1..$self->{num_photos}) {
 137                 my $id = $meta->{sequence}->[$idx-1];
 138                 my $m = $meta->{photo}->{$id};
 139                 my $click_url;
 140                 if ($self->get('WebImageSubpages')) {
 141                         $click_url = "?i=$idx";
 142                 } else {
 143                         $click_url = $self->get('PhotoUrlPrefix') . $self->{gal}->photo_file_name($m, $id);
 144                 }
 145                 $self->show_thumb($meta, $id, $click_url);
 146         }
 147
 148         $self->show_post_thumbs;
 149         $self->html_bot();
 150 }
 151
 152 sub show_login_page($$) {
 153         my ($self, $login_failed) = @_;
 154
 155         $self->show_common_header;
 156
 157         print "<div class='gal-login'>\n";
 158         print $self->extras('WebLoginExtras');
 159
 160         my $wrong = $login_failed ? " class='gal-login-bad'" : "";
 161         print "\t<form method=POST action='.'>\n";
 162         print "\t\t<input type=password name=pw$wrong>\n";
 163         print "\t\t<input type=submit value='Login'>\n";
 164         print "\t</form>\n";
 165
 166         print "</div>\n";
 167         $self->html_bot;
 168 }
 169
 170 sub auth_check($) {
 171         my ($self) = @_;
 172
 173         my $needed = $self->auth_get_needed;
 174         @$needed or return 1;
 175
 176         if (length $auth_password) {
 177                 my $passwords = $self->get('AuthPasswords');
 178                 my $match = 0;
 179                 for my $zone (@$needed) {
 180                         if (defined $passwords->{$zone} && $passwords->{$zone} eq $auth_password) {
 181                                 my @opts = ();
 182                                 my $path = $self->try_get('AuthCookiePath');
 183                                 push @opts, 'path', $path if defined $path;
 184                                 push @opts, 'secure', undef if $self->get('AuthCookieSecure');
 185                                 UCW::CGI::set_cookie($self->get('AuthCookiePrefix') . $zone, $self->auth_zone_hash($zone), @opts);
 186                                 $match++;
 187                         }
 188                 }
 189
 190                 if ($match) {
 191                         my $abs = $self->try_get('WebAbsURL');
 192                         if (defined $abs) {
 193                                 print "Status: 303\n";
 194                                 print "Location: $abs\n\n";
 195                                 exit 0;
 196                         }
 197                         return 1;
 198                 }
 199
 200                 $self->show_login_page($match == 0);
 201                 return;
 202         }
 203
 204         my $known_tokens = $self->auth_parse_cookies;
 205         for my $zone (@$needed) {
 206                 return 1 if $known_tokens->{$zone};
 207         }
 208
 209         $self->show_login_page(0);
 210         return;
 211 }
 212
 213 sub auth_get_needed($) {
 214         my ($self) = @_;
 215
 216         my $auth = $self->get('AuthNeeded');
 217         defined $auth or return [];
 218         if (ref $auth) {
 219                 return $auth;
 220         } else {
 221                 $auth ne "" or return [];
 222                 return [$auth];
 223         }
 224 }
 225
 226 sub auth_parse_cookies($) {
 227         my ($self) = @_;
 228         my $known_tokens = {};
 229
 230         my %cookies = UCW::CGI::parse_cookies;
 231         my $px = $self->get('AuthCookiePrefix');
 232         for my $k (keys %cookies) {
 233                 if (substr($k, 0, length $px) eq $px) {
 234                         my $zone = substr($k, length $px);
 235                         my $v = $cookies{$k};
 236                         if ($v eq $self->auth_zone_hash($zone)) {
 237                                 $known_tokens->{$zone} = 1;
 238                         } else {
 239                                 print STDERR "Gallery: Invalid auth cookie for zone $zone\n";
 240                         }
 241                 }
 242         }
 243
 244         return $known_tokens;
 245 }
 246
 247 sub auth_zone_hash($) {
 248         my ($self, $zone) = @_;
 249         my $secret = $self->get('AuthSecret');
 250         return substr(Digest::SHA::hmac_sha256_hex($zone, $secret), 0, 16);
 251 }
 252
 253 sub dispatch($) {
 254         my ($self) = @_;
 255         binmode STDOUT, ':utf8';
 256         UCW::CGI::parse_args(\%args);
 257
 258         $self->auth_check or return;
 259
 260         $self->{meta} = $self->{gal}->read_meta(File::Spec->catfile($self->get('CacheDir'), 'cache.meta'));
 261         $self->{num_photos} = scalar @{$self->{meta}->{sequence}};
 262
 263         if ($want_archive) {
 264                 require UCW::Gallery::Archive;
 265                 UCW::Gallery::Archive::send_archive($self->{gal}, $self->{meta});
 266         } elsif ($show_img ne "") {
 267                 $self->show_img;
 268         } else {
 269                 $self->show_list;
 270         }
 271 }
 272
 273 sub attach($$) {
 274         my ($class, $gal) = @_;
 275         my $self = { gal => $gal };
 276         $gal->def(
 277                 WebFE => $self,
 278
 279                 # Extras are either strings or functions called with the current gallery object as parameter
 280                 WebHeadExtras => "",
 281                 WebTopExtras => "",
 282                 WebBotExtras => "",
 283                 WebLoginExtras => "",
 284
 285                 # Used by the theming logic
 286                 WebThemeCSS => undef,
 287
 288                 # 1 if thumbnail link to sub-pages with images, 0 if they link directly to image files
 289                 WebImageSubpages => 1,
 290
 291                 # If enabled, calling the CGI with a=zip produces a ZIP archive with all photos.
 292                 WebAllowArchives => 1,
 293
 294                 # Optional absolute URL of the current gallery. This is useful for redirects after login.
 295                 # If it is not set, form POST does not redirect to GET.
 296                 WebAbsURL => undef,
 297
 298                 # Authentication: Known zones and their passwords.
 299                 # AuthPasswords => { 'zone' => 'passwd' },
 300
 301                 # Authentication: Which zones have access to the current gallery.
 302                 AuthNeeded => [],
 303
 304                 # Authentication: Secret used for encryption of cookies.
 305                 # AuthSecret => "",
 306
 307                 # Authentication: Properties of cookies.
 308                 AuthCookiePrefix => 'gal_',
 309                 AuthCookiePath => undef,
 310                 AuthCookieSecure => 1,
 311         );
 312         bless $self, $class;
 313         return $self;
 314 }
 315
 316 42;