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