lib/stemmaweb/Controller/Relation.pm

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