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
 535                 $c->stash->{'result'} = {
 536                         success => 1,
 537                         nodes   => \@nodes,
 538                 };
 539
 540                 $c->forward('View::JSON');
 541         }
 542 }
 543
 544 =head2 merge
 545
 546  POST relation/$textid/merge { data }
 547
 548 Merges the requested readings, combining the witnesses of both readings into
 549 the target reading. All non-conflicting source relationships are inherited by
 550 the target relationship.
 551
 552 =cut
 553
 554 sub merge :Chained('text') :PathPart :Args(0) {
 555         my( $self, $c ) = @_;
 556         my $tradition = delete $c->stash->{'tradition'};
 557         my $collation = $tradition->collation;
 558         my $m = $c->model('Directory');
 559         if( $c->request->method eq 'POST' ) {
 560                 if( $c->stash->{'permission'} ne 'full' ) {
 561                         $c->response->status( '403' );
 562                         $c->stash->{'result'} = {
 563                                 'error' => 'You do not have permission to modify this tradition.' };
 564                         $c->detach('View::JSON');
 565                         return;
 566                 }
 567                 my $errmsg;
 568                 my $response;
 569
 570                 my $main = $c->request->param('target_id');
 571                 my $second = $c->request->param('source_id');
 572                 # Find the common successor of these, so that we can detect other
 573                 # potentially identical readings.
 574                 my $csucc = $collation->common_successor( $main, $second );
 575
 576                 # Try the merge if these are parallel readings.
 577                 if( $csucc->id eq $main || $csucc->id eq $second ) {
 578                         $errmsg = "Cannot merge readings in the same path";
 579                 } else {
 580                         try {
 581                                 $collation->merge_readings( $main, $second );
 582                         } catch( Text::Tradition::Error $e ) {
 583                                 $c->response->status( '403' );
 584                                 $errmsg = $e->message;
 585                         } catch {
 586                                 # Something else went wrong, probably a Moose error
 587                                 $c->response->status( '403' );
 588                                 $errmsg = 'Something went wrong with the request';
 589                         }
 590                 }
 591
 592                 # Look for readings that are now identical.
 593                 if( $errmsg ) {
 594                         $response = { status => 'error', error => $errmsg };
 595                 } else {
 596                         $response = { status => 'ok' };
 597                         unless( $c->request->param('single') ) {
 598                                 my @identical = $collation->identical_readings(
 599                                         start => $main, end => $csucc->id );
 600                                 if( @identical ) {
 601                                         $response->{'checkalign'} = [
 602                                                 map { [ $_->[0]->id, $_->[1]->id ] } @identical ];
 603                                 }
 604                         }
 605                         $m->save( $collation );
 606                 }
 607                 $c->stash->{'result'} = $response;
 608                 $c->forward('View::JSON');
 609         }
 610 }
 611
 612 =head2 duplicate
 613
 614  POST relation/$textid/duplicate { data }
 615
 616 Duplicates the requested readings, detaching the witnesses specified in
 617 the list to use the new reading(s) instead of the old. The data to be
 618 passed should be a JSON structure:
 619
 620  { readings: rid1,rid2,rid3,...
 621    witnesses: [ wit1, ... ] }
 622
 623 =cut
 624
 625 sub duplicate :Chained('text') :PathPart :Args(0) {
 626         my( $self, $c ) = @_;
 627         my $tradition = delete $c->stash->{'tradition'};
 628         my $collation = $tradition->collation;
 629         my $m = $c->model('Directory');
 630         if( $c->request->method eq 'POST' ) {
 631                 if( $c->stash->{'permission'} ne 'full' ) {
 632                         $c->response->status( '403' );
 633                         $c->stash->{'result'} = {
 634                                 'error' => 'You do not have permission to modify this tradition.' };
 635                         $c->detach('View::JSON');
 636                         return;
 637                 }
 638                 my $errmsg;
 639                 my $response = {};
 640                 # Sort out which readings need to be duplicated from the set given, and
 641                 # ensure that all the given wits bear each relevant reading.
 642
 643                 my %wits = ();
 644                 map { $wits{$_} = 1 } $c->request->param('witnesses[]');
 645                 my %rdgranks = ();
 646                 foreach my $rid ( $c->request->param('readings[]') ) {
 647                         my $numwits = 0;
 648                         my $rdg = $collation->reading( $rid );
 649                         foreach my $rwit ( $rdg->witnesses( $rid ) ) {
 650                                 $numwits++ if exists $wits{$rwit};
 651                         }
 652                         next unless $numwits; # Disregard readings with none of our witnesses
 653                         if( $numwits < keys( %wits ) ) {
 654                                 $errmsg = "Reading $rid contains some but not all of the specified witnesses.";
 655                                 last;
 656                         } elsif( exists $rdgranks{ $rdg->rank } ) {
 657                                 $errmsg = "More than one reading would be detached along with $rid at rank " . $rdg->rank;
 658                                 last;
 659                         } else {
 660                                 $rdgranks{ $rdg->rank } = $rid;
 661                         }
 662                 }
 663
 664                 # Now check that the readings make a single sequence.
 665                 unless( $errmsg ) {
 666                         my $prior;
 667                         foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
 668                                 my $rid = $rdgranks{$rank};
 669                                 if( $prior ) {
 670                                         # Check that there is only one path between $prior and $rdg.
 671                                         foreach my $wit ( keys %wits ) {
 672                                                 unless( $collation->prior_reading( $rid, $wit ) eq $prior ) {
 673                                                         $errmsg = "Diverging witness paths from $prior to $rid at $wit";
 674                                                         last;
 675                                                 }
 676                                         }
 677                                 }
 678                                 $prior = $rid;
 679                         }
 680                 }
 681
 682                 # Abort if we've run into a problem.
 683                 if( $errmsg ) {
 684                         $c->stash->{'result'} = { 'error' => $errmsg };
 685                         $c->response->status( '403' );
 686                         $c->forward('View::JSON');
 687                         return;
 688                 }
 689
 690                 # Otherwise, do the dirty work.
 691                 my @witlist = keys %wits;
 692                 my @deleted_relations;
 693                 foreach my $rank ( sort { $a <=> $b } keys %rdgranks ) {
 694                         my $newrdg;
 695                         my $reading_id = $rdgranks{$rank};
 696                         my @delrels;
 697                         try {
 698                                 ( $newrdg, @delrels ) =
 699                                         $collation->duplicate_reading( $reading_id, @witlist );
 700                         } catch( Text::Tradition::Error $e ) {
 701                                 $c->response->status( '403' );
 702                                 $errmsg = $e->message;
 703                         } catch {
 704                                 # Something else went wrong, probably a Moose error
 705                                 $c->response->status( '500' );
 706                                 $errmsg = 'Something went wrong with the request';
 707                         }
 708                         if( $newrdg ) {
 709                                 my $data = _reading_struct( $newrdg );
 710                                 $data->{'orig_rdg'} = $reading_id;
 711                                 $response->{"$newrdg"} = $data;
 712                                 push( @deleted_relations, @delrels );
 713                         }
 714                 }
 715                 if( $errmsg ) {
 716                         $c->stash->{'result'} = { 'error' => $errmsg };
 717                 } else {
 718                         $m->save( $collation );
 719                         $response->{'DELETED'} = \@deleted_relations;
 720                         $c->stash->{'result'} = $response;
 721                 }
 722         }
 723         $c->forward('View::JSON');
 724 }
 725
 726
 727
 728 sub _check_permission {
 729         my( $c, $tradition ) = @_;
 730     my $user = $c->user_exists ? $c->user->get_object : undef;
 731     # Does this user have access?
 732     if( $user ) {
 733                 if( $user->is_admin ||
 734                         ( $tradition->has_user && $tradition->user->id eq $user->id ) ) {
 735                         $c->stash->{'permission'} = 'full';
 736                         return 1;
 737                 }
 738     }
 739     # Is it public?
 740     if( $tradition->public ) {
 741         $c->stash->{'permission'} = 'readonly';
 742         return 1;
 743     }
 744         # Forbidden!
 745         $c->response->status( 403 );
 746         $c->response->body( 'You do not have permission to view this tradition.' );
 747         $c->detach( 'View::Plain' );
 748         return 0;
 749 }
 750
 751 sub _clean_booleans {
 752         my( $obj, $param, $val ) = @_;
 753         if( $obj->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) {
 754                 $val = 1 if $val eq 'true';
 755                 $val = undef if $val eq 'false';
 756         }
 757         return $val;
 758 }
 759
 760 =head2 end
 761
 762 Attempt to render a view, if needed.
 763
 764 =cut
 765
 766 sub end : ActionClass('RenderView') {}
 767
 768 =head1 AUTHOR
 769
 770 Tara L Andrews
 771
 772 =head1 LICENSE
 773
 774 This library is free software. You can redistribute it and/or modify
 775 it under the same terms as Perl itself.
 776
 777 =cut
 778
 779 __PACKAGE__->meta->make_immutable;
 780
 781 1;