lib/stemmaweb/Controller/Root.pm

   1 package stemmaweb::Controller::Root;
   2 use Moose;
   3 use namespace::autoclean;
   4 use Text::Tradition::Analysis qw/ run_analysis /;
   5 use TryCatch;
   6
   7
   8 BEGIN { extends 'Catalyst::Controller' }
   9
  10 #
  11 # Sets the actions in this controller to be registered with no prefix
  12 # so they function identically to actions created in MyApp.pm
  13 #
  14 __PACKAGE__->config(namespace => '');
  15
  16 =head1 NAME
  17
  18 stemmaweb::Controller::Root - Root Controller for stemmaweb
  19
  20 =head1 DESCRIPTION
  21
  22 Serves up the main container pages.
  23
  24 =head1 URLs
  25
  26 =head2 index
  27
  28 The root page (/).  Serves the main container page, from which the various
  29 components will be loaded.
  30
  31 =cut
  32
  33 sub index :Path :Args(0) {
  34     my ( $self, $c ) = @_;
  35
  36     $c->stash->{template} = 'index.tt';
  37 }
  38
  39 =head1 Elements of index page
  40
  41 =head2 directory
  42
  43  GET /directory
  44
  45 Serves a snippet of HTML that lists the available texts.  This returns texts belonging to the logged-in user if any, otherwise it returns all public texts.
  46
  47 =cut
  48
  49 sub directory :Local :Args(0) {
  50         my( $self, $c ) = @_;
  51     my $m = $c->model('Directory');
  52     # Is someone logged in?
  53     my %usertexts;
  54     if( $c->user_exists ) {
  55         my $user = $c->user->get_object;
  56         my @list = $m->traditionlist( $user );
  57         map { $usertexts{$_->{id}} = 1 } @list;
  58                 $c->stash->{usertexts} = \@list;
  59                 $c->stash->{is_admin} = 1 if $user->is_admin;
  60         }
  61         # List public (i.e. readonly) texts separately from any user (i.e.
  62         # full access) texts that exist. Admin users therefore have nothing
  63         # in this list.
  64         my @plist = grep { !$usertexts{$_->{id}} } $m->traditionlist('public');
  65         $c->stash->{publictexts} = \@plist;
  66         $c->stash->{template} = 'directory.tt';
  67 }
  68
  69 =head1 AJAX methods for traditions and their properties
  70
  71 =head2 newtradition
  72
  73  POST /newtradition,
  74         { name: <name>,
  75           language: <language>,
  76           public: <is_public>,
  77           file: <fileupload> }
  78
  79 Creates a new tradition belonging to the logged-in user, with the given name
  80 and the collation given in the uploaded file. The file type is indicated via
  81 the filename extension (.csv, .txt, .xls, .xlsx, .xml). Returns the ID and
  82 name of the new tradition.
  83
  84 =cut
  85
  86 sub newtradition :Local :Args(0) {
  87         my( $self, $c ) = @_;
  88         return _json_error( $c, 403, 'Cannot save a tradition without being logged in' )
  89                 unless $c->user_exists;
  90
  91         my $user = $c->user->get_object;
  92         # Grab the file upload, check its name/extension, and call the
  93         # appropriate parser(s).
  94         my $upload = $c->request->upload('file');
  95         my $name = $c->request->param('name') || 'Uploaded tradition';
  96         my $lang = $c->request->param( 'language' ) || 'Default';
  97         my $public = $c->request->param( 'public' ) ? 1 : undef;
  98         my( $ext ) = $upload->filename =~ /\.(\w+)$/;
  99         my %newopts = (
 100                 'name' => $name,
 101                 'language' => $lang,
 102                 'public' => $public,
 103                 'file' => $upload->tempname
 104                 );
 105
 106         my $tradition;
 107         my $errmsg;
 108         if( $ext eq 'xml' ) {
 109                 # Try the different XML parsing options to see if one works.
 110                 foreach my $type ( qw/ CollateX CTE TEI / ) {
 111                         try {
 112                                 $tradition = Text::Tradition->new( %newopts, 'input' => $type );
 113                         } catch ( Text::Tradition::Error $e ) {
 114                                 $errmsg = $e->message;
 115                         } catch {
 116                                 $errmsg = "Unexpected parsing error";
 117                         }
 118                         last if $tradition;
 119                 }
 120         } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) {
 121                 # If it's Excel we need to pass excel => $ext;
 122                 # otherwise we need to pass sep_char => [record separator].
 123                 if( $ext =~ /xls/ ) {
 124                         $newopts{'excel'} = $ext;
 125                 } else {
 126                         $newopts{'sep_char'} = $ext eq 'txt' ? "\t" : ',';
 127                 }
 128                 try {
 129                         $tradition = Text::Tradition->new(
 130                                 %newopts,
 131                                 'input' => 'Tabular',
 132                                 );
 133                 } catch ( Text::Tradition::Error $e ) {
 134                         $errmsg = $e->message;
 135                 } catch {
 136                         $errmsg = "Unexpected parsing error";
 137                 }
 138         } else {
 139                 # Error unless we have a recognized filename extension
 140                 return _json_error( $c, 500, "Unrecognized file type extension $ext" );
 141         }
 142
 143         # Save the tradition if we have it, and return its data or else the
 144         # error that occurred trying to make it.
 145         if( $errmsg ) {
 146                 return _json_error( $c, 500, "Error parsing tradition .$ext file: $errmsg" );
 147         } elsif( !$tradition ) {
 148                 return _json_error( $c, 500, "No error caught but tradition not created" );
 149         }
 150
 151         my $m = $c->model('Directory');
 152         $user->add_tradition( $tradition );
 153         my $id = $c->model('Directory')->store( $tradition );
 154         $c->model('Directory')->store( $user );
 155         $c->stash->{'result'} = { 'id' => $id, 'name' => $tradition->name };
 156         $c->forward('View::JSON');
 157 }
 158
 159 =head2 textinfo
 160
 161  GET /textinfo/$textid
 162  POST /textinfo/$textid,
 163         { name: $new_name,
 164           language: $new_language,
 165           public: $is_public,
 166           owner: $new_userid } # only admin users can update the owner
 167
 168 Returns information about a particular text.
 169
 170 =cut
 171
 172 sub textinfo :Local :Args(1) {
 173         my( $self, $c, $textid ) = @_;
 174         my $tradition = $c->model('Directory')->tradition( $textid );
 175         unless( $tradition ) {
 176                 return _json_error( $c, 500, "No tradition with ID $textid" );
 177         }
 178         my $ok = _check_permission( $c, $tradition );
 179         return unless $ok;
 180         if( $c->req->method eq 'POST' ) {
 181                 return _json_error( $c, 403,
 182                         'You do not have permission to update this tradition' )
 183                         unless $ok eq 'full';
 184                 my $params = $c->request->parameters;
 185                 # Handle changes to owner-accessible parameters
 186                 my $m = $c->model('Directory');
 187                 my $changed;
 188                 # Handle scalar params
 189                 foreach my $param ( qw/ name language / ) {
 190                         if( exists $params->{$param} ) {
 191                                 my $newval = delete $params->{$param};
 192                                 unless( $tradition->$param eq $newval ) {
 193                                         try {
 194                                                 $tradition->$param( $newval );
 195                                         } catch {
 196                                                 return _json_error( $c, 500, "Error setting $param to $newval" );
 197                                         }
 198                                         $changed = 1;
 199                                 }
 200                         }
 201                 }
 202                 # Handle our boolean
 203                 if( delete $params->{'public'} ) {  # if it's any true value...
 204                         $tradition->public( 1 );
 205                 }
 206                 # Handle ownership changes
 207                 my $newuser;
 208                 if( exists $params->{'owner'} ) {
 209                         # Only admins can update user / owner
 210                         my $newownerid = delete $params->{'owner'};
 211                         unless( $tradition->has_user && $tradition->user->id eq $newownerid ) {
 212                                 unless( $c->user->get_object->is_admin ) {
 213                                         return _json_error( $c, 403,
 214                                                 "Only admin users can change tradition ownership" );
 215                                 }
 216                                 $newuser = $m->lookup_user( $params->{'owner'} );
 217                                 unless( $newuser ) {
 218                                         return _json_error( $c, 500, "No such user " . $params->{'owner'} );
 219                                 }
 220                                 $newuser->add_tradition( $tradition );
 221                                 $changed = 1;
 222                         }
 223                 }
 224                 # TODO check for rogue parameters
 225                 if( scalar keys %$params ) {
 226                         my $rogueparams = join( ', ', keys %$params );
 227                         return _json_error( $c, 403, "Request parameters $rogueparams not recognized" );
 228                 }
 229                 # If we safely got to the end, then write to the database.
 230                 $m->save( $tradition ) if $changed;
 231                 $m->save( $newuser ) if $newuser;
 232         }
 233
 234         # Now return the current textinfo, whether GET or successful POST.
 235         my $textinfo = {
 236                 textid => $textid,
 237                 name => $tradition->name,
 238                 language => $tradition->language,
 239                 public => $tradition->public,
 240                 owner => $tradition->user ? $tradition->user->id : undef,
 241                 witnesses => [ map { $_->sigil } $tradition->witnesses ],
 242         };
 243         my @stemmasvg = map { $_->as_svg({ size => [ 500, 375 ] }) } $tradition->stemmata;
 244         map { $_ =~ s/\n/ /mg } @stemmasvg;
 245         $textinfo->{stemmata} = \@stemmasvg;
 246         $c->stash->{'result'} = $textinfo;
 247         $c->forward('View::JSON');
 248 }
 249
 250 =head2 variantgraph
 251
 252  GET /variantgraph/$textid
 253
 254 Returns the variant graph for the text specified at $textid, in SVG form.
 255
 256 =cut
 257
 258 sub variantgraph :Local :Args(1) {
 259         my( $self, $c, $textid ) = @_;
 260         my $tradition = $c->model('Directory')->tradition( $textid );
 261         unless( $tradition ) {
 262                 return _json_error( $c, 500, "No tradition with ID $textid" );
 263         }
 264         my $ok = _check_permission( $c, $tradition );
 265         return unless $ok;
 266
 267         my $collation = $tradition->collation;
 268         $c->stash->{'result'} = $collation->as_svg;
 269         $c->forward('View::SVG');
 270 }
 271
 272 =head2 stemma
 273
 274  GET /stemma/$textid/$stemmaseq
 275  POST /stemma/$textid/$stemmaseq, { 'dot' => $dot_string }
 276
 277 Returns an SVG representation of the given stemma hypothesis for the text.
 278 If the URL is called with POST, the stemma at $stemmaseq will be altered
 279 to reflect the definition in $dot_string. If $stemmaseq is 'n', a new
 280 stemma will be added.
 281
 282 =cut
 283
 284 sub stemma :Local :Args(2) {
 285         my( $self, $c, $textid, $stemmaid ) = @_;
 286         my $m = $c->model('Directory');
 287         my $tradition = $m->tradition( $textid );
 288         unless( $tradition ) {
 289                 return _json_error( $c, 500, "No tradition with ID $textid" );
 290         }
 291         my $ok = _check_permission( $c, $tradition );
 292         return unless $ok;
 293
 294         $c->stash->{'result'} = '';
 295         my $stemma;
 296         if( $c->req->method eq 'POST' ) {
 297                 if( $ok eq 'full' ) {
 298                         my $dot = $c->request->body_params->{'dot'};
 299                         try {
 300                                 if( $stemmaid eq 'n' ) {
 301                                         # We are adding a new stemma.
 302                                         $stemma = $tradition->add_stemma( 'dot' => $dot );
 303                                 } elsif( $stemmaid < $tradition->stemma_count ) {
 304                                         # We are updating an existing stemma.
 305                                         $stemma = $tradition->stemma( $stemmaid );
 306                                         $stemma->alter_graph( $dot );
 307                                 } else {
 308                                         # Unrecognized stemma ID
 309                                         return _json_error( $c, 500, "No stemma at index $stemmaid, cannot update" );
 310                                 }
 311                         } catch ( Text::Tradition::Error $e ) {
 312                                 return _json_error( $c, 500, $e->message );
 313                         }
 314                         $m->store( $tradition );
 315                 } else {
 316                         # No permissions to update the stemma
 317                         return _json_error( $c, 403,
 318                                 'You do not have permission to update stemmata for this tradition' );
 319                 }
 320         }
 321
 322         # For a GET or a successful POST request, return the SVG representation
 323         # of the stemma in question, if any.
 324         $c->log->debug( "Received Accept header: " . $c->req->header('Accept') );
 325         if( !$stemma && $tradition->stemma_count > $stemmaid ) {
 326                 $stemma = $tradition->stemma( $stemmaid );
 327         }
 328         $c->stash->{'result'} = $stemma
 329                 ? $stemma->as_svg( { size => [ 500, 375 ] } ) : '';
 330         $c->forward('View::SVG');
 331 }
 332
 333 =head2 stemmadot
 334
 335  GET /stemmadot/$textid/$stemmaseq
 336
 337 Returns the 'dot' format representation of the current stemma hypothesis.
 338
 339 =cut
 340
 341 sub stemmadot :Local :Args(2) {
 342         my( $self, $c, $textid, $stemmaid ) = @_;
 343         my $m = $c->model('Directory');
 344         my $tradition = $m->tradition( $textid );
 345         unless( $tradition ) {
 346                 return _json_error( $c, 500, "No tradition with ID $textid" );
 347         }
 348         my $ok = _check_permission( $c, $tradition );
 349         return unless $ok;
 350         my $stemma = $tradition->stemma( $stemmaid );
 351         unless( $stemma ) {
 352                 return _json_error( $c, 500, "Tradition $textid has no stemma ID $stemmaid" );
 353         }
 354         # Get the dot and transmute its line breaks to literal '|n'
 355         $c->stash->{'result'} = { 'dot' =>  $stemma->editable( { linesep => '|n' } ) };
 356         $c->forward('View::JSON');
 357 }
 358
 359 ####################
 360 ### Helper functions
 361 ####################
 362
 363 # Helper to check what permission, if any, the active user has for
 364 # the given tradition
 365 sub _check_permission {
 366         my( $c, $tradition ) = @_;
 367     my $user = $c->user_exists ? $c->user->get_object : undef;
 368     if( $user ) {
 369         return 'full' if ( $user->is_admin ||
 370                 ( $tradition->has_user && $tradition->user->id eq $user->id ) );
 371     }
 372         # Text doesn't belong to us, so maybe it's public?
 373         return 'readonly' if $tradition->public;
 374
 375         # ...nope. Forbidden!
 376         return _json_error( $c, 403, 'You do not have permission to view this tradition.' );
 377 }
 378
 379 # Helper to throw a JSON exception
 380 sub _json_error {
 381         my( $c, $code, $errmsg ) = @_;
 382         $c->response->status( $code );
 383         $c->stash->{'result'} = { 'error' => $errmsg };
 384         $c->forward('View::JSON');
 385         return 0;
 386 }
 387
 388 =head2 default
 389
 390 Standard 404 error page
 391
 392 =cut
 393
 394 sub default :Path {
 395     my ( $self, $c ) = @_;
 396     $c->response->body( 'Page not found' );
 397     $c->response->status(404);
 398 }
 399
 400 =head2 end
 401
 402 Attempt to render a view, if needed.
 403
 404 =cut
 405
 406 sub end : ActionClass('RenderView') {}
 407
 408 =head1 AUTHOR
 409
 410 Tara L Andrews
 411
 412 =head1 LICENSE
 413
 414 This library is free software. You can redistribute it and/or modify
 415 it under the same terms as Perl itself.
 416
 417 =cut
 418
 419 __PACKAGE__->meta->make_immutable;
 420
 421 1;