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