lib/TWiki/UI.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
permissions -rw-r--r--
RELEASE 4.2.0 freetown
colas@0
     1
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0
     2
#
colas@0
     3
# Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
colas@0
     4
# and TWiki Contributors. All Rights Reserved. TWiki Contributors
colas@0
     5
# are listed in the AUTHORS file in the root of this distribution.
colas@0
     6
# NOTE: Please extend that file, not this notice.
colas@0
     7
#
colas@0
     8
# This program is free software; you can redistribute it and/or
colas@0
     9
# modify it under the terms of the GNU General Public License
colas@0
    10
# as published by the Free Software Foundation; either version 2
colas@0
    11
# of the License, or (at your option) any later version. For
colas@0
    12
# more details read LICENSE in the root of this distribution.
colas@0
    13
#
colas@0
    14
# This program is distributed in the hope that it will be useful,
colas@0
    15
# but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0
    16
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0
    17
#
colas@0
    18
# As per the GPL, removal of this notice is prohibited.
colas@0
    19
colas@0
    20
=pod
colas@0
    21
colas@0
    22
---+ package TWiki::UI
colas@0
    23
colas@0
    24
Service functions used by the UI packages
colas@0
    25
colas@0
    26
=cut
colas@0
    27
colas@0
    28
package TWiki::UI;
colas@0
    29
colas@0
    30
use strict;
colas@0
    31
use Error qw( :try );
colas@0
    32
use Assert;
colas@0
    33
colas@0
    34
require TWiki;
colas@0
    35
require TWiki::Sandbox;
colas@0
    36
require TWiki::OopsException;
colas@0
    37
colas@0
    38
sub TRACE_PASSTHRU {
colas@0
    39
    # Change to a 1 to trace passthrough
colas@0
    40
    0;
colas@0
    41
};
colas@0
    42
colas@0
    43
=pod
colas@0
    44
colas@0
    45
---++ StaticMethod run( \&method, ... )
colas@0
    46
colas@0
    47
Entry point for execution of a UI function. The parameter is a
colas@0
    48
reference to the method.
colas@0
    49
colas@0
    50
... is a list of name-value pairs that define initial context identifiers
colas@0
    51
that must be set during initPlugin. This set will be extended to include
colas@0
    52
command_line if the script is detected as being run outside the browser.
colas@0
    53
colas@0
    54
=cut
colas@0
    55
colas@0
    56
sub run {
colas@0
    57
    my ( $method, %initialContext ) = @_;
colas@0
    58
colas@0
    59
    my ( $query, $pathInfo, $user, $url, $topic );
colas@0
    60
colas@0
    61
    # Use unbuffered IO
colas@0
    62
    $| = 1;
colas@0
    63
colas@0
    64
    # -------------- Only needed to work around an Apache 2.0 bug on Unix
colas@0
    65
    # OPTIONAL
colas@0
    66
    # If you are running TWiki on Apache 2.0 on Unix you might experience
colas@0
    67
    # TWiki scripts hanging forever. This is a known Apache 2.0 bug. A fix is 
colas@0
    68
    # available at http://issues.apache.org/bugzilla/show_bug.cgi?id=22030.
colas@0
    69
    # You are recommended to patch your Apache installation.
colas@0
    70
    #
colas@0
    71
    # As a workaround, uncomment ONE of the lines below. As a drawback,
colas@0
    72
    # errors will not be reported to the browser via CGI::Carp any more.
colas@0
    73
colas@0
    74
    # Opening STDERR here and not in the BEGIN block as some perl accelerators
colas@0
    75
    # close STDERR after each request so that we need to reopen it here again
colas@0
    76
colas@0
    77
    # open(STDERR, ">>/dev/null");      # throw away cgi script errors, or
colas@0
    78
    # open(STDERR, ">>$TWiki::cfg{DataDir}/error.log"); # redirect errors to a log file
colas@0
    79
colas@0
    80
colas@0
    81
    if( DEBUG || $TWiki::cfg{WarningsAreErrors} ) {
colas@0
    82
        # For some mysterious reason if this handler is defined
colas@0
    83
        # in 'new TWiki' it gets lost again before we get here
colas@0
    84
        $SIG{__WARN__} = sub { die @_; };
colas@0
    85
    }
colas@0
    86
colas@0
    87
    if( $ENV{'GATEWAY_INTERFACE'} ) {
colas@0
    88
        # script is called by browser
colas@0
    89
        $query = new CGI;
colas@0
    90
colas@0
    91
        if( $TWiki::cfg{DrainStdin} ) {
colas@0
    92
            # drain STDIN.  This may be necessary if the script is called
colas@0
    93
            # due to a redirect and the original query was a POST. In this
colas@0
    94
            # case the web server is waiting to write the POST data to
colas@0
    95
            # this script's STDIN, but CGI.pm won't drain STDIN as it is
colas@0
    96
            # seeing a GET because of the redirect, not a POST.  This script
colas@0
    97
            # tries to write to STDOUT, which goes back to the web server,
colas@0
    98
            # but the server isn't paying attention to that (as its waiting for
colas@0
    99
            # the script to _read_, not _write_), and everything blocks.
colas@0
   100
            # Some versions of apache seem to be more susceptible than others to
colas@0
   101
            # this.
colas@0
   102
            my $content_length =
colas@0
   103
                defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
colas@0
   104
            read(STDIN, my $buf, $content_length, 0 ) if $content_length;
colas@0
   105
        }
colas@0
   106
        my $cache = $query->param('twiki_redirect_cache');
colas@0
   107
        # Never trust input data from a query. We will only accept an MD5 32 character string
colas@0
   108
        if ($cache && $cache =~ /^([a-f0-9]{32})$/) {
colas@0
   109
            $cache = $1;
colas@0
   110
            # Read cached post parameters
colas@0
   111
            my $passthruFilename = $TWiki::cfg{WorkingDir} . '/tmp/passthru_' . $cache;
colas@0
   112
            if (open(F, '<'.$passthruFilename)) {
colas@0
   113
                local $/;
colas@0
   114
                if (TRACE_PASSTHRU) {
colas@0
   115
                    print STDERR "Passthru: Loading cache for ",
colas@0
   116
                      $query->url(),'?',$query->query_string(),"\n";
colas@0
   117
                    print STDERR <F>,"\n";
colas@0
   118
                    close(F);
colas@0
   119
                    open(F, '<'.$passthruFilename);
colas@0
   120
                }
colas@0
   121
                $query = new CGI(\*F);
colas@0
   122
                close(F);
colas@0
   123
                unlink($passthruFilename);
colas@0
   124
                print STDERR "Passthru: Loaded and unlinked $passthruFilename\n"
colas@0
   125
                  if TRACE_PASSTHRU;
colas@0
   126
            } else {
colas@0
   127
                print STDERR "Passthru: Could not find $passthruFilename\n"
colas@0
   128
                  if TRACE_PASSTHRU;
colas@0
   129
            }
colas@0
   130
        }
colas@0
   131
    } else {
colas@0
   132
        # script is called by cron job or user
colas@0
   133
        $initialContext{command_line} = 1;
colas@0
   134
colas@0
   135
        $user = $TWiki::cfg{SuperAdminGroup};
colas@0
   136
        $query = new CGI();
colas@0
   137
        while( scalar( @ARGV )) {
colas@0
   138
            my $arg = shift( @ARGV );
colas@0
   139
            if ( $arg =~ /^-?([A-Za-z0-9_]+)$/o ) {
colas@0
   140
                my $name = $1;
colas@0
   141
                my $arg = TWiki::Sandbox::untaintUnchecked( shift( @ARGV ));
colas@0
   142
                if( $name eq 'user' ) {
colas@0
   143
                    $user = $arg;
colas@0
   144
                } else {
colas@0
   145
                    $query->param( -name => $name, -value => $arg );
colas@0
   146
                }
colas@0
   147
            } else {
colas@0
   148
                $query->path_info( TWiki::Sandbox::untaintUnchecked( $arg ));
colas@0
   149
            }
colas@0
   150
        }
colas@0
   151
    }
colas@0
   152
colas@0
   153
    my $session = new TWiki( $user, $query, \%initialContext );
colas@0
   154
colas@0
   155
    local $SIG{__DIE__} = \&Carp::confess;
colas@0
   156
colas@0
   157
    try {
colas@0
   158
        $session->{users}->{loginManager}->checkAccess();
colas@0
   159
        &$method( $session );
colas@0
   160
    } catch TWiki::AccessControlException with {
colas@0
   161
        my $e = shift;
colas@0
   162
        unless( $session->{users}->{loginManager}->forceAuthentication() ) {
colas@0
   163
            # Login manager did not want to authenticate, perhaps because
colas@0
   164
            # we are already authenticated.
colas@0
   165
            my $exception = new TWiki::OopsException(
colas@0
   166
                'accessdenied',
colas@0
   167
                web => $e->{web}, topic => $e->{topic},
colas@0
   168
                def => 'topic_access',
colas@0
   169
                params => [ $e->{mode}, $e->{reason} ] );
colas@0
   170
colas@0
   171
            $exception->redirect( $session );
colas@0
   172
        }
colas@0
   173
colas@0
   174
    } catch TWiki::OopsException with {
colas@0
   175
        shift->redirect( $session );
colas@0
   176
colas@0
   177
    } catch Error::Simple with {
colas@0
   178
        my $e = shift;
colas@0
   179
        print "Content-type: text/plain\n\n";
colas@0
   180
        if( DEBUG ) {
colas@0
   181
            # output the full message and stacktrace to the browser
colas@0
   182
            print $e->stringify();
colas@0
   183
        } else {
colas@0
   184
            my $mess = $e->stringify();
colas@0
   185
            print STDERR $mess;
colas@0
   186
            $session->writeWarning( $mess );
colas@0
   187
            # tell the browser where to look for more help
colas@0
   188
            print 'TWiki detected an internal error - please check your TWiki logs and webserver logs for more information.'."\n\n";
colas@0
   189
            $mess =~ s/ at .*$//s;
colas@0
   190
            # cut out pathnames from public announcement
colas@0
   191
            $mess =~ s#/[\w./]+#path#g;
colas@0
   192
            print $mess;
colas@0
   193
        }
colas@0
   194
    } otherwise {
colas@0
   195
        print "Content-type: text/plain\n\n";
colas@0
   196
        print "Unspecified error";
colas@0
   197
    };
colas@0
   198
colas@0
   199
    # Finished with the session
colas@0
   200
    $session->finish();
colas@0
   201
}
colas@0
   202
colas@0
   203
=pod twiki
colas@0
   204
colas@0
   205
---++ StaticMethod checkWebExists( $session, $web, $topic, $op )
colas@0
   206
colas@0
   207
Check if the web exists. If it doesn't, will throw an oops exception.
colas@0
   208
 $op is the user operation being performed.
colas@0
   209
colas@0
   210
=cut
colas@0
   211
colas@0
   212
sub checkWebExists {
colas@0
   213
    my ( $session, $webName, $topic, $op ) = @_;
colas@0
   214
    ASSERT($session->isa( 'TWiki')) if DEBUG;
colas@0
   215
colas@0
   216
    unless ( $session->{store}->webExists( $webName ) ) {
colas@0
   217
        throw
colas@0
   218
          TWiki::OopsException( 'accessdenied',
colas@0
   219
                                def => 'no_such_web',
colas@0
   220
                                web => $webName,
colas@0
   221
                                topic => $topic,
colas@0
   222
                                params => [ $op ] );
colas@0
   223
    }
colas@0
   224
}
colas@0
   225
colas@0
   226
=pod
colas@0
   227
colas@0
   228
---++ StaticMethod topicExists( $session, $web, $topic, $op ) => boolean
colas@0
   229
colas@0
   230
Check if the given topic exists, throwing an OopsException
colas@0
   231
if it doesn't. $op is the user operation being performed.
colas@0
   232
colas@0
   233
=cut
colas@0
   234
colas@0
   235
sub checkTopicExists {
colas@0
   236
    my ( $session, $webName, $topic, $op ) = @_;
colas@0
   237
    ASSERT($session->isa( 'TWiki')) if DEBUG;
colas@0
   238
colas@0
   239
    unless( $session->{store}->topicExists( $webName, $topic )) {
colas@0
   240
        throw TWiki::OopsException( 'accessdenied',
colas@0
   241
                                    def => 'no_such_topic',
colas@0
   242
                                    web => $webName,
colas@0
   243
                                    topic => $topic,
colas@0
   244
                                    params => [ $op ] );
colas@0
   245
    }
colas@0
   246
}
colas@0
   247
colas@0
   248
=pod twiki
colas@0
   249
colas@0
   250
---++ StaticMethod checkMirror( $session, $web, $topic )
colas@0
   251
colas@0
   252
Checks if this web is a mirror web, throwing an OopsException
colas@0
   253
if it is.
colas@0
   254
colas@0
   255
=cut
colas@0
   256
colas@0
   257
sub checkMirror {
colas@0
   258
    my ( $session, $webName, $topic ) = @_;
colas@0
   259
    ASSERT($session->isa( 'TWiki')) if DEBUG;
colas@0
   260
colas@0
   261
    my( $mirrorSiteName, $mirrorViewURL ) =
colas@0
   262
      $session->readOnlyMirrorWeb( $webName );
colas@0
   263
colas@0
   264
    return unless ( $mirrorSiteName );
colas@0
   265
colas@0
   266
    throw Error::Simple(
colas@0
   267
        "This is a mirror site $mirrorSiteName, $mirrorViewURL" );
colas@0
   268
}
colas@0
   269
colas@0
   270
=pod twiki
colas@0
   271
colas@0
   272
---++ StaticMethod checkAccess( $web, $topic, $mode, $user )
colas@0
   273
colas@0
   274
Check if the given mode of access by the given user to the given
colas@0
   275
web.topic is permissible, throwing a TWiki::OopsException if not.
colas@0
   276
colas@0
   277
=cut
colas@0
   278
colas@0
   279
sub checkAccess {
colas@0
   280
    my ( $session, $web, $topic, $mode, $user ) = @_;
colas@0
   281
    ASSERT($session->isa( 'TWiki')) if DEBUG;
colas@0
   282
colas@0
   283
    unless( $session->security->checkAccessPermission(
colas@0
   284
        $mode, $user, undef, undef, $topic, $web )) {
colas@0
   285
        throw TWiki::OopsException( 'accessdenied',
colas@0
   286
                                    def => 'topic_access',
colas@0
   287
                                    web => $web,
colas@0
   288
                                    topic => $topic,
colas@0
   289
                                    params =>
colas@0
   290
                                      [ $mode,
colas@0
   291
                                        $session->security->getReason()]);
colas@0
   292
    }
colas@0
   293
}
colas@0
   294
colas@0
   295
=pod
colas@0
   296
colas@0
   297
---++ StaticMethod readTemplateTopic( $session, $theTopicName ) -> ( $meta, $text )
colas@0
   298
colas@0
   299
Read a topic from the TWiki web, or if that fails from the current
colas@0
   300
web.
colas@0
   301
colas@0
   302
=cut
colas@0
   303
colas@0
   304
sub readTemplateTopic {
colas@0
   305
    my( $session, $theTopicName ) = @_;
colas@0
   306
    ASSERT($session->isa( 'TWiki')) if DEBUG;
colas@0
   307
colas@0
   308
    $theTopicName =~ s/$TWiki::cfg{NameFilter}//go;
colas@0
   309
colas@0
   310
    my $web = $TWiki::cfg{SystemWebName};
colas@0
   311
    if( $session->{store}->topicExists( $session->{webName}, $theTopicName )) {
colas@0
   312
        # try to read from current web, if found
colas@0
   313
        $web = $session->{webName};
colas@0
   314
    }
colas@0
   315
    return $session->{store}->readTopic(
colas@0
   316
        $session->{user}, $web, $theTopicName, undef );
colas@0
   317
}
colas@0
   318
colas@0
   319
1;