lib/stemmaweb/Controller/Relation.pm

   1 package stemmaweb::Controller::Relation;
   2 use JSON qw/ to_json from_json /;
   3 use Moose;
   4 use Module::Load;
   5 use namespace::autoclean;
   6 use TryCatch;
   7
   8 BEGIN { extends 'Catalyst::Controller' }
   9
  10
  11 =head1 NAME
  12
  13 stemmaweb::Controller::Relation - Controller for the relationship mapper
  14
  15 =head1 DESCRIPTION
  16
  17 The reading relationship mapper with draggable nodes.
  18
  19 =head1 METHODS
  20
  21 =head2 index
  22
  23  GET relation/$textid
  24
  25 Renders the application for the text identified by $textid.
  26
  27 =cut
  28
  29 sub index :Path :Args(0) {
  30         my( $self, $c ) = @_;
  31         $c->stash->{'template'} = 'relate.tt';
  32 }
  33
  34 =head2 text
  35
  36  GET relation/$textid/
  37
  38  Runs the relationship mapper for the specified text ID.
  39
  40 =cut
  41
  42 sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) {
  43         my( $self, $c, $textid ) = @_;
  44         my $tradition = $c->model('Directory')->tradition( $textid );
  45         unless( $tradition ) {
  46                 $c->response->status('404');
  47                 $c->response->body("No such tradition with ID $textid");
  48                 $c->detach('View::Plain');
  49                 return;
  50         }
  51
  52     # Account for a bad interaction between FastCGI and KiokuDB
  53     unless( $tradition->collation->tradition ) {
  54         $c->log->warn( "Fixing broken tradition link" );
  55         $tradition->collation->_set_tradition( $tradition );
  56         $c->model('Directory')->save( $tradition );
  57     }
  58     # Check permissions. Will return 403 if denied, otherwise will
  59     # put the appropriate value in the stash.
  60     my $ok = _check_permission( $c, $tradition );
  61     return unless $ok;
  62
  63         $c->stash->{'textid'} = $textid;
  64         $c->stash->{'tradition'} = $tradition;
  65 }
  66
  67 sub main :Chained('text') :PathPart('') :Args(0) {
  68         my( $self, $c ) = @_;
  69         my $tradition = delete $c->stash->{'tradition'};
  70         my $collation = $tradition->collation;
  71
  72         # Stash the relationship definitions
  73         $c->stash->{'relationship_scopes'} = to_json( [ qw/ local global / ] );
  74         my @reltypeinfo;
  75         foreach my $type ( sort { _typesort( $a, $b ) } $collation->relations->types ) {
  76                 next if $type->is_weak;
  77                 my $struct = { name => $type->name, description => $type->description };
  78                 push( @reltypeinfo, $struct );
  79         }
  80         $c->stash->{'relationship_types'} = to_json( \@reltypeinfo );
  81
  82         # See how big the tradition is. Edges are more important than nodes
  83         # when it comes to rendering difficulty.
  84         my $numnodes = scalar $collation->readings;
  85         my $numedges = scalar $collation->paths;
  86         my $length = $collation->end->rank;
  87         # We should display no more than roughly 500 nodes, or roughly 700
  88         # edges, at a time.
  89         my $segments = $numnodes / 500;
  90         if( $numedges / 700 > $segments ) {
  91                 $segments = $numedges / 700;
  92         }
  93         my $segsize = sprintf( "%.0f", $length / $segments );
  94         my $margin = sprintf( "%.0f", $segsize / 10 );
  95         if( $segments > 1 ) {
  96                 # Segment the tradition in order not to overload the browser.
  97                 my @divs;
  98                 my $r = 0;
  99                 while( $r + $margin < $length ) {
 100                         push( @divs, $r );
 101                         $r += $segsize;
 102                 }
 103                 $c->stash->{'textsegments'} = [];
 104                 foreach my $i ( 0..$#divs ) {
 105                         my $seg = { 'start' => $divs[$i] };
 106                         $seg->{'display'} = "Segment " . ($i+1);
 107                         push( @{$c->stash->{'textsegments'}}, $seg );
 108                 }
 109         }
 110         my $startseg = $c->req->param('start');
 111         my $svgopts;
 112         if( $startseg ) {
 113                 # Only render the subgraph from startseg to endseg or to END,
 114                 # whichever is less.
 115                 my $endseg = $startseg + $segsize + $margin;
 116                 $svgopts = { 'from' => $startseg };
 117                 $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank;
 118         } elsif( exists $c->stash->{'textsegments'} ) {
 119                 # This is the unqualified load of a long tradition. We implicitly start
 120                 # at zero, but go only as far as our segment size.
 121                 my $endseg = $segsize + $margin;
 122                 $startseg = 0;
 123                 $svgopts = { 'to' => $endseg };
 124         }
 125         # Spit out the SVG
 126         my $svg_str = $collation->as_svg( $svgopts );
 127         $svg_str =~ s/\n//gs;
 128         $c->stash->{'startseg'} = $startseg if defined $startseg;
 129         $c->stash->{'svg_string'} = $svg_str;
 130         $c->stash->{'text_title'} = $tradition->name;
 131         if( $tradition->can('language') ) {
 132                 $c->stash->{'text_lang'} = $tradition->language;
 133                 $c->stash->{'can_morphologize'} = 1;
 134         } else {
 135                 $c->stash->{'text_lang'} = 'Default';
 136         }
 137         $c->stash->{'template'} = 'relate.tt';
 138 }
 139
 140 sub _typesort {
 141         my( $a, $b ) = @_;
 142         my $blsort = $a->bindlevel <=> $b->bindlevel;
 143         return $blsort if $blsort;
 144         return $a->name cmp $b->name;
 145 }
 146
 147 =head2 help
 148
 149  GET relation/help/$language
 150
 151 Returns the help window HTML.
 152
 153 =cut
 154
 155 sub help :Local :Args(1) {
 156         my( $self, $c, $lang ) = @_;
 157         # Display the morphological help for the language if it is defined.
 158         if( $lang && $lang ne 'Default' ) {
 159                 my $mod = 'Text::Tradition::Language::' . $lang;
 160                 try {
 161                         load( $mod );
 162                 } catch {
 163                         $c->log->debug("Warning: could not load $mod");
 164                 }
 165                 my $has_mod = $mod->can('morphology_tags');
 166                 if( $has_mod ) {
 167                         my $tagset = &$has_mod;
 168                         $c->stash->{'tagset'} = $tagset;
 169                 }
 170         }
 171         $c->stash->{'template'} = 'relatehelp.tt';
 172 }
 173
 174 =head2 relationships
 175
 176  GET relation/$textid/relationships
 177
 178 Returns the list of relationships defined for this text.
 179
 180  POST relation/$textid/relationships { request }
 181
 182 Attempts to define the requested relationship within the text. Returns 200 on
 183 success or 403 on error.
 184
 185  DELETE relation/$textid/relationships { request }
 186
 187
 188 =cut
 189
 190 sub relationships :Chained('text') :PathPart :Args(0) {
 191         my( $self, $c ) = @_;
 192         my $tradition = delete $c->stash->{'tradition'};
 193         my $ok = _check_permission( $c, $tradition );
 194         return unless $ok;
 195         my $collation = $tradition->collation;
 196         my $m = $c->model('Directory');
 197         if( $c->request->method eq 'GET' ) {
 198                 my @pairs = $collation->relationships; # returns the edges
 199                 my @all_relations;
 200                 foreach my $p ( @pairs ) {
 201                         my $relobj = $collation->relations->get_relationship( @$p );
 202                         next if $relobj->type eq 'collated'; # Don't show these
 203                         next if $p->[0] eq $p->[1]; # HACK until bugfix
 204                         my $relhash = { source => $p->[0], target => $p->[1],
 205                                   type => $relobj->type, scope => $relobj->scope };
 206                         $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation;
 207                         push( @all_relations, $relhash );
 208                 }
 209                 $c->stash->{'result'} = \@all_relations;
 210         } else {
 211                 # Check write permissions first of all
 212                 if( $c->stash->{'permission'} ne 'full' ) {
 213                         $c->response->status( '403' );
 214                         $c->stash->{'result'} = {
 215                                 'error' => 'You do not have permission to modify this tradition.' };
 216                         $c->detach( 'View::JSON' );
 217                 } elsif( $c->request->method eq 'POST' ) {
 218                         my $node = $c->request->param('source_id');
 219                         my $target = $c->request->param('target_id');
 220                         my $relation = $c->request->param('rel_type');
 221                         my $note = $c->request->param('note');
 222                         my $scope = $c->request->param('scope');
 223
 224                         my $opts = { 'type' => $relation, 'propagate' => 1 };
 225                         $opts->{'scope'} = $scope if $scope;
 226                         $opts->{'annotation'} = $note if $note;
 227
 228                         try {
 229                                 my @vectors = $collation->add_relationship( $node, $target, $opts );
 230                                 $c->stash->{'result'} = \@vectors;
 231                                 $m->save( $tradition );
 232                         } catch( Text::Tradition::Error $e ) {
 233                                 $c->response->status( '403' );
 234                                 $c->stash->{'result'} = { 'error' => $e->message };
 235                         }
 236                 } elsif( $c->request->method eq 'DELETE' ) {
 237                         my $node = $c->request->param('source_id');
 238                         my $target = $c->request->param('target_id');
 239                         my $scopewide = $c->request->param('scopewide')
 240                                 && $c->request->param('scopewide') eq 'true';
 241                         try {
 242                                 my @vectors = $collation->del_relationship( $node, $target, $scopewide );
 243                                 $m->save( $tradition );
 244                                 $c->stash->{'result'} = \@vectors;
 245                         } catch( Text::Tradition::Error $e ) {
 246                                 $c->response->status( '403' );
 247                                 $c->stash->{'result'} = { 'error' => $e->message };
 248                         }
 249                 }
 250         }
 251         $c->forward('View::JSON');
 252 }
 253
 254 =head2 readings
 255
 256  GET relation/$textid/readings
 257
 258 Returns the list of readings defined for this text along with their metadata.
 259
 260 =cut
 261
 262 my %read_write_keys = (
 263         'id' => 0,
 264         'text' => 0,
 265         'is_meta' => 0,
 266         'grammar_invalid' => 1,
 267         'is_nonsense' => 1,
 268         'normal_form' => 1,
 269 );
 270
 271 sub _reading_struct {
 272         my( $reading ) = @_;
 273         # Return a JSONable struct of the useful keys.  Keys meant to be writable
 274         # have a true value; read-only keys have a false value.
 275         my $struct = {};
 276         map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys );
 277         # Special case
 278         $struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : [];
 279         # Look up any words related via spelling or orthography
 280         my $sameword = sub {
 281                 my $t = $_[0]->type;
 282                 return $t eq 'spelling' || $t eq 'orthographic';
 283         };
 284         # Now add the list data
 285         $struct->{'variants'} = [ map { $_->text } $reading->related_readings( $sameword ) ];
 286         $struct->{'witnesses'} = [ $reading->witnesses ];
 287         return $struct;
 288 }
 289
 290 sub readings :Chained('text') :PathPart :Args(0) {
 291         my( $self, $c ) = @_;
 292         my $tradition = delete $c->stash->{'tradition'};
 293         my $ok = _check_permission( $c, $tradition );
 294         return unless $ok;
 295         my $collation = $tradition->collation;
 296         my $m = $c->model('Directory');
 297         if( $c->request->method eq 'GET' ) {
 298                 my $rdginfo = {};
 299                 foreach my $rdg ( $collation->readings ) {
 300                         $rdginfo->{$rdg->id} = _reading_struct( $rdg );
 301                 }
 302                 $c->stash->{'result'} = $rdginfo;
 303         }
 304         $c->forward('View::JSON');
 305 }
 306
 307 =head2 reading
 308
 309  GET relation/$textid/reading/$id
 310
 311 Returns the list of readings defined for this text along with their metadata.
 312
 313  POST relation/$textid/reading/$id { request }
 314
 315 Alters the reading according to the values in request. Returns 403 Forbidden if
 316 the alteration isn't allowed.
 317
 318 =cut
 319
 320 sub reading :Chained('text') :PathPart :Args(1) {
 321         my( $self, $c, $reading_id ) = @_;
 322         my $tradition = delete $c->stash->{'tradition'};
 323         my $collation = $tradition->collation;
 324         my $rdg = $collation->reading( $reading_id );
 325         my $m = $c->model('Directory');
 326         if( $c->request->method eq 'GET' ) {
 327                 $c->stash->{'result'} = $rdg ? _reading_struct( $rdg )
 328                         : { 'error' => "No reading with ID $reading_id" };
 329         } elsif ( $c->request->method eq 'POST' ) {
 330                 if( $c->stash->{'permission'} ne 'full' ) {
 331                         $c->response->status( '403' );
 332                         $c->stash->{'result'} = {
 333                                 'error' => 'You do not have permission to modify this tradition.' };
 334                         $c->detach('View::JSON');
 335                         return;
 336                 }
 337                 my $errmsg;
 338                 if( $rdg && $rdg->does('Text::Tradition::Morphology') ) {
 339                         # Are we re-lemmatizing?
 340                         if( $c->request->param('relemmatize') ) {
 341                                 my $nf = $c->request->param('normal_form');
 342                                 # TODO throw error unless $nf
 343                                 $rdg->normal_form( $nf );
 344                                 # TODO throw error if lemmatization fails
 345                                 # TODO skip this if normal form hasn't changed
 346                                 $rdg->lemmatize();
 347                         } else {
 348                                 # Set all the values that we have for the reading.
 349                                 # TODO error handling
 350                                 foreach my $p ( keys %{$c->request->params} ) {
 351                                         if( $p =~ /^morphology_(\d+)$/ ) {
 352                                                 # Set the form on the correct lexeme
 353                                                 my $morphval = $c->request->param( $p );
 354                                                 next unless $morphval;
 355                                                 my $midx = $1;
 356                                                 my $lx = $rdg->lexeme( $midx );
 357                                                 my $strrep = $rdg->language . ' // ' . $morphval;
 358                                                 my $idx = $lx->has_form( $strrep );
 359                                                 unless( defined $idx ) {
 360                                                         # Make the word form and add it to the lexeme.
 361                                                         try {
 362                                                                 $idx = $lx->add_matching_form( $strrep ) - 1;
 363                                                         } catch( Text::Tradition::Error $e ) {
 364                                                                 $c->response->status( '403' );
 365                                                                 $errmsg = $e->message;
 366                                                         } catch {
 367                                                                 # Something else went wrong, probably a Moose error
 368                                                                 $c->response->status( '403' );
 369                                                                 $errmsg = 'Something went wrong with the request';
 370                                                         }
 371                                                 }
 372                                                 $lx->disambiguate( $idx ) if defined $idx;
 373                                         } elsif( $read_write_keys{$p} ) {
 374                                                 my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) );
 375                                                 $rdg->$p( $val );
 376                                         }
 377                                 }
 378                         }
 379                         $m->save( $rdg );
 380                 } else {
 381                         $errmsg = "Reading does not exist or cannot be morphologized";
 382                 }
 383                 $c->stash->{'result'} = $errmsg ? { 'error' => $errmsg }
 384                         : _reading_struct( $rdg );
 385
 386         }
 387         $c->forward('View::JSON');
 388
 389 }
 390
 391 =head2 merge
 392
 393  POST relation/$textid/merge { data }
 394
 395 Merges the requested readings, combining the witnesses of both readings into
 396 the target reading. All non-conflicting source relationships are inherited by
 397 the target relationship.
 398
 399 =cut
 400
 401 sub merge :Chained('text') :PathPart :Args(0) {
 402         my( $self, $c ) = @_;
 403         my $tradition = delete $c->stash->{'tradition'};
 404         my $collation = $tradition->collation;
 405         my $m = $c->model('Directory');
 406         if( $c->request->method eq 'POST' ) {
 407                 if( $c->stash->{'permission'} ne 'full' ) {
 408                         $c->response->status( '403' );
 409                         $c->stash->{'result'} = {
 410                                 'error' => 'You do not have permission to modify this tradition.' };
 411                         $c->detach('View::JSON');
 412                         return;
 413                 }
 414                 my $errmsg;
 415                 my $response;
 416
 417                 my $main = $c->request->param('target_id');
 418                 my $second = $c->request->param('source_id');
 419                 # Find the common successor of these, so that we can detect other
 420                 # potentially identical readings.
 421                 my $csucc = $collation->common_successor( $main, $second );
 422
 423                 # Try the merge if these are parallel readings.
 424                 if( $csucc->id eq $main || $csucc->id eq $second ) {
 425                         $errmsg = "Cannot merge readings in the same path";
 426                 } else {
 427                         try {
 428                                 $collation->merge_readings( $main, $second );
 429                         } catch( Text::Tradition::Error $e ) {
 430                                 $c->response->status( '403' );
 431                                 $errmsg = $e->message;
 432                         } catch {
 433                                 # Something else went wrong, probably a Moose error
 434                                 $c->response->status( '403' );
 435                                 $errmsg = 'Something went wrong with the request';
 436                         }
 437                 }
 438
 439                 # Look for readings that are now identical.
 440                 if( $errmsg ) {
 441                         $response = { status => 'error', error => $errmsg };
 442                 } else {
 443                         $response = { status => 'ok' };
 444                         my @identical = $collation->identical_readings(
 445                                 start => $main, end => $csucc->id );
 446                         if( @identical ) {
 447                                 $response->{'checkalign'} = [
 448                                         map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
 449                         }
 450                         $m->save( $collation );
 451                 }
 452                 $c->stash->{'result'} = $response;
 453                 $c->forward('View::JSON');
 454         }
 455 }
 456
 457 =head2 duplicate
 458
 459  POST relation/$textid/duplicate { data }
 460
 461 Duplicates the requested readings, detaching the witnesses specified in
 462 the list to use the new reading(s) instead of the old. The data to be
 463 passed should be a JSON structure:
 464
 465  { readings: rid1,rid2,rid3,...
 466    witnesses: [ wit1, ... ] }
 467
 468 =cut
 469
 470 sub duplicate :Chained('text') :PathPart :Args(0) {
 471         my( $self, $c ) = @_;
 472         my $tradition = delete $c->stash->{'tradition'};
 473         my $collation = $tradition->collation;
 474         my $m = $c->model('Directory');
 475         if( $c->request->method eq 'POST' ) {
 476                 if( $c->stash->{'permission'} ne 'full' ) {
 477                         $c->response->status( '403' );
 478                         $c->stash->{'result'} = {
 479                                 'error' => 'You do not have permission to modify this tradition.' };
 480                         $c->detach('View::JSON');
 481                         return;
 482                 }
 483                 my $errmsg;
 484                 my $response = {};
 485                 # Sort out which readings need to be duplicated from the set given, and
 486                 # ensure that all the given wits bear each relevant reading.
 487
 488                 my %wits = ();
 489                 map { $wits{$_} = 1 } $c->request->param('witnesses[]');
 490                 my %rdgranks = ();
 491                 foreach my $rid ( $c->request->param('readings[]') ) {
 492                         my $numwits = 0;
 493                         my $rdg = $collation->reading( $rid );
 494                         foreach my $rwit ( $rdg->witnesses( $rid ) ) {
 495                                 $numwits++ if exists $wits{$rwit};
 496                         }
 497                         next unless $numwits; # Disregard readings with none of our witnesses
 498                         if( $numwits < keys( %wits ) ) {
 499                                 $errmsg = "Reading $rid contains some but not all of the specified witnesses.";
 500                                 last;
 501                         } elsif( exists $rdgranks{ $rdg->rank } ) {
 502                                 $errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
 503                                 last;
 504                         } else {
 505                                 $rdgranks{ $rdg->rank } = $rid;
 506                         }
 507                 }
 508
 509                 # Now check that the readings make a single sequence.
 510                 unless( $errmsg ) {
 511                         my $prior;
 512                         foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
 513                                 my $rid = $rdgranks{$rank};
 514                                 if( $prior ) {
 515                                         # Check that there is only one path between $prior and $rdg.
 516                                         foreach my $wit ( keys %wits ) {
 517                                                 unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
 518                                                         $errmsg = "Diverging witness paths from $prior to $rid at $wit";
 519                                                         last;
 520                                                 }
 521                                         }
 522                                 }
 523                                 $prior = $rid;
 524                         }
 525                 }
 526
 527                 # Abort if we've run into a problem.
 528                 if( $errmsg ) {
 529                         $c->stash->{'result'} = { 'error' => $errmsg };
 530                         $c->response->status( '403' );
 531                         $c->forward('View::JSON');
 532                         return;
 533                 }
 534
 535                 # Otherwise, do the dirty work.
 536                 my @witlist = keys %wits;
 537                 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
 538                         my $newrdg;
 539                         my $reading_id = $rdgranks{$rank};
 540                         try {
 541                                 $newrdg = $collation->duplicate_reading( $reading_id, @witlist );
 542                         } catch( Text::Tradition::Error $e ) {
 543                                 $c->response->status( '403' );
 544                                 $errmsg = $e->message;
 545                         } catch {
 546                                 # Something else went wrong, probably a Moose error
 547                                 $c->response->status( '403' );
 548                                 $errmsg = 'Something went wrong with the request';
 549                         }
 550                         if( $newrdg ) {
 551                                 my $data = _reading_struct( $newrdg );
 552                                 $data->{'orig_rdg'} = $reading_id;
 553                                 $response->{"$newrdg"} = $data;
 554                         }
 555                 }
 556                 if( $errmsg ) {
 557                         $c->stash->{'result'} = { 'error' => $errmsg };
 558                 } else {
 559                         $m->save( $collation );
 560                         $c->stash->{'result'} = $response;
 561                 }
 562         }
 563         $c->forward('View::JSON');
 564 }
 565
 566
 567
 568 sub _check_permission {
 569         my( $c, $tradition ) = @_;
 570     my $user = $c->user_exists ? $c->user->get_object : undef;
 571     # Does this user have access?
 572     if( $user ) {
 573                 if( $user->is_admin ||
 574                         ( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
 575                         $c->stash->{'permission'} = 'full';
 576                         return 1;
 577                 }
 578     }
 579     # Is it public?
 580     if( $tradition->public ) {
 581         $c->stash->{'permission'} = 'readonly';
 582         return 1;
 583     }
 584         # Forbidden!
 585         $c->response->status( 403 );
 586         $c->response->body( 'You do not have permission to view this tradition.' );
 587         $c->detach( 'View::Plain' );
 588         return 0;
 589 }
 590
 591 sub _clean_booleans {
 592         my( $rdg, $param, $val ) = @_;
 593         if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
 594                 $val = 1 if $val eq 'true';
 595                 $val = undef if $val eq 'false';
 596         }
 597         return $val;
 598 }
 599
 600 =head2 end
 601
 602 Attempt to render a view, if needed.
 603
 604 =cut
 605
 606 sub end : ActionClass('RenderView') {}
 607
 608 =head1 AUTHOR
 609
 610 Tara L Andrews
 611
 612 =head1 LICENSE
 613
 614 This library is free software. You can redistribute it and/or modify
 615 it under the same terms as Perl itself.
 616
 617 =cut
 618
 619 __PACKAGE__->meta->make_immutable;
 620
 621 1;