Commit | Line | Data |
b8a92065 |
1 | package stemmaweb::Controller::Relation; |
2 | use Moose; |
cc86fa11 |
3 | use Module::Load; |
b8a92065 |
4 | use namespace::autoclean; |
b28e606e |
5 | use TryCatch; |
b8a92065 |
6 | |
7 | BEGIN { extends 'Catalyst::Controller' } |
8 | |
9 | |
10 | =head1 NAME |
11 | |
12 | stemmaweb::Controller::Relation - Controller for the relationship mapper |
13 | |
14 | =head1 DESCRIPTION |
15 | |
b28e606e |
16 | The reading relationship mapper with draggable nodes. |
b8a92065 |
17 | |
18 | =head1 METHODS |
19 | |
b28e606e |
20 | =head2 index |
21 | |
b8a92065 |
22 | GET relation/$textid |
23 | |
24 | Renders the application for the text identified by $textid. |
25 | |
b8a92065 |
26 | =cut |
27 | |
9529f69c |
28 | sub index :Path :Args(0) { |
29 | my( $self, $c ) = @_; |
b28e606e |
30 | $c->stash->{'template'} = 'relate.tt'; |
31 | } |
32 | |
9529f69c |
33 | =head2 definitions |
b28e606e |
34 | |
9c2e7b80 |
35 | GET relation/definitions |
b28e606e |
36 | |
37 | Returns a data structure giving the valid types and scopes for a relationship. |
38 | |
39 | =cut |
40 | |
9c2e7b80 |
41 | sub definitions :Local :Args(0) { |
b28e606e |
42 | my( $self, $c ) = @_; |
17b660e6 |
43 | my $valid_relationships = [ qw/ spelling orthographic grammatical lexical transposition / ]; |
b28e606e |
44 | my $valid_scopes = [ qw/ local global / ]; |
45 | $c->stash->{'result'} = { 'types' => $valid_relationships, 'scopes' => $valid_scopes }; |
46 | $c->forward('View::JSON'); |
b8a92065 |
47 | } |
48 | |
9529f69c |
49 | =head2 text |
b28e606e |
50 | |
9529f69c |
51 | GET relation/$textid/ |
52 | |
53 | Runs the relationship mapper for the specified text ID. |
54 | |
b28e606e |
55 | =cut |
56 | |
9529f69c |
57 | sub text :Chained('/') :PathPart('relation') :CaptureArgs(1) { |
58 | my( $self, $c, $textid ) = @_; |
13aa153c |
59 | # If the tradition has more than 500 ranks or so, split it up. |
60 | my $tradition = $c->model('Directory')->tradition( $textid ); |
7562a27b |
61 | # Account for a bad interaction between FastCGI and KiokuDB |
62 | unless( $tradition->collation->tradition ) { |
63 | $c->log->warn( "Fixing broken tradition link" ); |
64 | $tradition->collation->_set_tradition( $tradition ); |
65 | $c->model('Directory')->save( $tradition ); |
66 | } |
20198e59 |
67 | # Check permissions. Will return 403 if denied, otherwise will |
68 | # put the appropriate value in the stash. |
69 | my $ok = _check_permission( $c, $tradition ); |
70 | return unless $ok; |
71 | |
d58766c0 |
72 | # See how big the tradition is. Edges are more important than nodes |
73 | # when it comes to rendering difficulty. |
74 | my $numnodes = scalar $tradition->collation->readings; |
75 | my $numedges = scalar $tradition->collation->paths; |
13aa153c |
76 | my $length = $tradition->collation->end->rank; |
d58766c0 |
77 | # We should display no more than roughly 500 nodes, or roughly 700 |
78 | # edges, at a time. |
79 | my $segments = $numnodes / 500; |
80 | if( $numedges / 700 > $segments ) { |
81 | $segments = $numedges / 700; |
82 | } |
83 | my $segsize = sprintf( "%.0f", $length / $segments ); |
84 | my $margin = sprintf( "%.0f", $segsize / 10 ); |
85 | if( $segments > 1 ) { |
13aa153c |
86 | # Segment the tradition in order not to overload the browser. |
13aa153c |
87 | my @divs; |
88 | my $r = 0; |
d58766c0 |
89 | while( $r + $margin < $length ) { |
13aa153c |
90 | push( @divs, $r ); |
d58766c0 |
91 | $r += $segsize; |
13aa153c |
92 | } |
93 | $c->stash->{'textsegments'} = []; |
d58766c0 |
94 | $c->stash->{'segsize'} = $segsize; |
95 | $c->stash->{'margin'} = $margin; |
ea8e8b3c |
96 | foreach my $i ( 0..$#divs ) { |
97 | my $seg = { 'start' => $divs[$i] }; |
98 | $seg->{'display'} = "Segment " . ($i+1); |
13aa153c |
99 | push( @{$c->stash->{'textsegments'}}, $seg ); |
100 | } |
101 | } |
102 | $c->stash->{'textid'} = $textid; |
103 | $c->stash->{'tradition'} = $tradition; |
9529f69c |
104 | } |
105 | |
106 | sub main :Chained('text') :PathPart('') :Args(0) { |
b28e606e |
107 | my( $self, $c ) = @_; |
13aa153c |
108 | my $startseg = $c->req->param('start'); |
9c2e7b80 |
109 | my $tradition = delete $c->stash->{'tradition'}; |
110 | my $collation = $tradition->collation; |
13aa153c |
111 | my $svgopts; |
112 | if( $startseg ) { |
d58766c0 |
113 | # Only render the subgraph from startseg to endseg or to END, |
13aa153c |
114 | # whichever is less. |
d58766c0 |
115 | my $endseg = $startseg + $c->stash->{'segsize'} + $c->stash->{'margin'}; |
13aa153c |
116 | $svgopts = { 'from' => $startseg }; |
d58766c0 |
117 | $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank; |
13aa153c |
118 | } elsif( exists $c->stash->{'textsegments'} ) { |
119 | # This is the unqualified load of a long tradition. We implicitly start |
120 | # at zero, but go only as far as 550. |
d58766c0 |
121 | my $endseg = $c->stash->{'segsize'} + $c->stash->{'margin'}; |
ea8e8b3c |
122 | $startseg = 0; |
d58766c0 |
123 | $svgopts = { 'to' => $endseg }; |
13aa153c |
124 | } |
125 | my $svg_str = $collation->as_svg( $svgopts ); |
9529f69c |
126 | $svg_str =~ s/\n//gs; |
ea8e8b3c |
127 | $c->stash->{'startseg'} = $startseg if defined $startseg; |
9529f69c |
128 | $c->stash->{'svg_string'} = $svg_str; |
129 | $c->stash->{'text_title'} = $tradition->name; |
487674b9 |
130 | if( $tradition->can('language') ) { |
131 | $c->stash->{'text_lang'} = $tradition->language; |
132 | $c->stash->{'can_morphologize'} = 1; |
133 | } else { |
134 | $c->stash->{'text_lang'} = 'Default'; |
135 | } |
9529f69c |
136 | $c->stash->{'template'} = 'relate.tt'; |
b28e606e |
137 | } |
138 | |
cc86fa11 |
139 | =head2 help |
140 | |
141 | GET relation/help/$language |
142 | |
143 | Returns the help window HTML. |
144 | |
145 | =cut |
146 | |
147 | sub help :Local :Args(1) { |
148 | my( $self, $c, $lang ) = @_; |
149 | # Display the morphological help for the language if it is defined. |
150 | if( $lang && $lang ne 'Default' ) { |
151 | my $mod = 'Text::Tradition::Language::' . $lang; |
152 | try { |
153 | load( $mod ); |
154 | } catch { |
155 | $c->log->debug("Warning: could not load $mod"); |
156 | } |
157 | my $has_mod = $mod->can('morphology_tags'); |
cc86fa11 |
158 | if( $has_mod ) { |
159 | my $tagset = &$has_mod; |
160 | $c->stash->{'tagset'} = $tagset; |
161 | } |
162 | } |
163 | $c->stash->{'template'} = 'relatehelp.tt'; |
164 | } |
165 | |
b28e606e |
166 | =head2 relationships |
167 | |
13aa153c |
168 | GET relation/$textid/relationships |
9529f69c |
169 | |
170 | Returns the list of relationships defined for this text. |
b28e606e |
171 | |
13aa153c |
172 | POST relation/$textid/relationships { request } |
9529f69c |
173 | |
174 | Attempts to define the requested relationship within the text. Returns 200 on |
175 | success or 403 on error. |
b28e606e |
176 | |
13aa153c |
177 | DELETE relation/$textid/relationships { request } |
9529f69c |
178 | |
b28e606e |
179 | |
180 | =cut |
181 | |
9529f69c |
182 | sub relationships :Chained('text') :PathPart :Args(0) { |
b28e606e |
183 | my( $self, $c ) = @_; |
6d124a83 |
184 | my $tradition = delete $c->stash->{'tradition'}; |
20198e59 |
185 | my $ok = _check_permission( $c, $tradition ); |
186 | return unless $ok; |
6d124a83 |
187 | my $collation = $tradition->collation; |
cdd592f3 |
188 | my $m = $c->model('Directory'); |
9529f69c |
189 | if( $c->request->method eq 'GET' ) { |
190 | my @pairs = $collation->relationships; # returns the edges |
191 | my @all_relations; |
192 | foreach my $p ( @pairs ) { |
193 | my $relobj = $collation->relations->get_relationship( @$p ); |
545163a2 |
194 | next if $relobj->type eq 'collated'; # Don't show these |
7562a27b |
195 | next if $p->[0] eq $p->[1]; # HACK until bugfix |
69a19c91 |
196 | my $relhash = { source => $p->[0], target => $p->[1], |
197 | type => $relobj->type, scope => $relobj->scope }; |
198 | $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation; |
199 | push( @all_relations, $relhash ); |
9529f69c |
200 | } |
201 | $c->stash->{'result'} = \@all_relations; |
20198e59 |
202 | } else { |
203 | # Check write permissions first of all |
204 | if( $c->stash->{'permission'} ne 'full' ) { |
9529f69c |
205 | $c->response->status( '403' ); |
20198e59 |
206 | $c->stash->{'result'} = { |
207 | 'error' => 'You do not have permission to view this tradition.' }; |
208 | } elsif( $c->request->method eq 'POST' ) { |
209 | unless( $c->stash->{'permission'} eq 'full' ) { |
210 | $c->response->status( '403' ); |
211 | $c->stash->{'result'} = { |
212 | 'error' => 'You do not have permission to view this tradition.' }; |
213 | $c->detach( 'View::JSON' ); |
214 | } |
215 | my $node = $c->request->param('source_id'); |
216 | my $target = $c->request->param('target_id'); |
217 | my $relation = $c->request->param('rel_type'); |
218 | my $note = $c->request->param('note'); |
219 | my $scope = $c->request->param('scope'); |
220 | |
221 | my $opts = { 'type' => $relation, |
222 | 'scope' => $scope }; |
223 | $opts->{'annotation'} = $note if $note; |
224 | |
225 | try { |
226 | my @vectors = $collation->add_relationship( $node, $target, $opts ); |
227 | $c->stash->{'result'} = \@vectors; |
228 | $m->save( $tradition ); |
229 | } catch( Text::Tradition::Error $e ) { |
230 | $c->response->status( '403' ); |
231 | $c->stash->{'result'} = { 'error' => $e->message }; |
232 | } |
233 | } elsif( $c->request->method eq 'DELETE' ) { |
234 | my $node = $c->request->param('source_id'); |
235 | my $target = $c->request->param('target_id'); |
236 | |
237 | try { |
238 | my @vectors = $collation->del_relationship( $node, $target ); |
239 | $m->save( $tradition ); |
240 | $c->stash->{'result'} = \@vectors; |
241 | } catch( Text::Tradition::Error $e ) { |
242 | $c->response->status( '403' ); |
243 | $c->stash->{'result'} = { 'error' => $e->message }; |
244 | } |
9529f69c |
245 | } |
b28e606e |
246 | } |
b28e606e |
247 | $c->forward('View::JSON'); |
5f15640c |
248 | } |
249 | |
250 | =head2 readings |
251 | |
252 | GET relation/$textid/readings |
253 | |
254 | Returns the list of readings defined for this text along with their metadata. |
255 | |
256 | =cut |
257 | |
0dcdd5ec |
258 | my %read_write_keys = ( |
259 | 'id' => 0, |
260 | 'text' => 0, |
261 | 'is_meta' => 0, |
262 | 'grammar_invalid' => 1, |
263 | 'is_nonsense' => 1, |
264 | 'normal_form' => 1, |
265 | ); |
266 | |
5f15640c |
267 | sub _reading_struct { |
268 | my( $reading ) = @_; |
269 | # Return a JSONable struct of the useful keys. Keys meant to be writable |
270 | # have a true value; read-only keys have a false value. |
5f15640c |
271 | my $struct = {}; |
2be76d3f |
272 | map { $struct->{$_} = $reading->$_ if $reading->can( $_ ) } keys( %read_write_keys ); |
5f15640c |
273 | # Special case |
2be76d3f |
274 | $struct->{'lexemes'} = $reading->can( 'lexemes' ) ? [ $reading->lexemes ] : []; |
0dcdd5ec |
275 | # Look up any words related via spelling or orthography |
276 | my $sameword = sub { |
277 | my $t = $_[0]->type; |
278 | return $t eq 'spelling' || $t eq 'orthographic'; |
279 | }; |
280 | my @variants; |
281 | foreach my $sr ( $reading->related_readings( $sameword ) ) { |
282 | push( @variants, $sr->text ); |
283 | } |
284 | $struct->{'variants'} = \@variants; |
5f15640c |
285 | return $struct; |
286 | } |
287 | |
288 | sub readings :Chained('text') :PathPart :Args(0) { |
289 | my( $self, $c ) = @_; |
290 | my $tradition = delete $c->stash->{'tradition'}; |
20198e59 |
291 | my $ok = _check_permission( $c, $tradition ); |
292 | return unless $ok; |
5f15640c |
293 | my $collation = $tradition->collation; |
294 | my $m = $c->model('Directory'); |
295 | if( $c->request->method eq 'GET' ) { |
296 | my $rdginfo = {}; |
297 | foreach my $rdg ( $collation->readings ) { |
298 | $rdginfo->{$rdg->id} = _reading_struct( $rdg ); |
299 | } |
300 | $c->stash->{'result'} = $rdginfo; |
301 | } |
302 | $c->forward('View::JSON'); |
303 | } |
304 | |
305 | =head2 reading |
306 | |
307 | GET relation/$textid/reading/$id |
308 | |
309 | Returns the list of readings defined for this text along with their metadata. |
310 | |
311 | POST relation/$textid/reading/$id { request } |
312 | |
313 | Alters the reading according to the values in request. Returns 403 Forbidden if |
314 | the alteration isn't allowed. |
315 | |
316 | =cut |
317 | |
318 | sub reading :Chained('text') :PathPart :Args(1) { |
319 | my( $self, $c, $reading_id ) = @_; |
320 | my $tradition = delete $c->stash->{'tradition'}; |
321 | my $collation = $tradition->collation; |
0dcdd5ec |
322 | my $rdg = $collation->reading( $reading_id ); |
5f15640c |
323 | my $m = $c->model('Directory'); |
324 | if( $c->request->method eq 'GET' ) { |
5f15640c |
325 | $c->stash->{'result'} = $rdg ? _reading_struct( $rdg ) |
326 | : { 'error' => "No reading with ID $reading_id" }; |
327 | } elsif ( $c->request->method eq 'POST' ) { |
20198e59 |
328 | if( $c->stash->{'permission'} ne 'full' ) { |
329 | $c->response->status( '403' ); |
330 | $c->stash->{'result'} = { |
331 | 'error' => 'You do not have permission to view this tradition.' }; |
332 | $c->detach('View::JSON'); |
487674b9 |
333 | return; |
20198e59 |
334 | } |
6666d111 |
335 | my $errmsg; |
487674b9 |
336 | if( $rdg && $rdg->does('Text::Tradition::Morphology') ) { |
337 | # Are we re-lemmatizing? |
338 | if( $c->request->param('relemmatize') ) { |
339 | my $nf = $c->request->param('normal_form'); |
340 | # TODO throw error unless $nf |
341 | $rdg->normal_form( $nf ); |
342 | # TODO throw error if lemmatization fails |
343 | # TODO skip this if normal form hasn't changed |
344 | $rdg->lemmatize(); |
345 | } else { |
346 | # Set all the values that we have for the reading. |
347 | # TODO error handling |
348 | foreach my $p ( keys %{$c->request->params} ) { |
349 | if( $p =~ /^morphology_(\d+)$/ ) { |
350 | # Set the form on the correct lexeme |
351 | my $morphval = $c->request->param( $p ); |
352 | next unless $morphval; |
353 | my $midx = $1; |
354 | my $lx = $rdg->lexeme( $midx ); |
355 | my $strrep = $rdg->language . ' // ' . $morphval; |
356 | my $idx = $lx->has_form( $strrep ); |
357 | unless( defined $idx ) { |
358 | # Make the word form and add it to the lexeme. |
359 | try { |
360 | $idx = $lx->add_matching_form( $strrep ) - 1; |
361 | } catch( Text::Tradition::Error $e ) { |
362 | $c->response->status( '403' ); |
363 | $errmsg = $e->message; |
364 | } catch { |
365 | # Something else went wrong, probably a Moose error |
366 | $c->response->status( '403' ); |
367 | $errmsg = 'Something went wrong with the request'; |
368 | } |
6666d111 |
369 | } |
487674b9 |
370 | $lx->disambiguate( $idx ) if defined $idx; |
371 | } elsif( $read_write_keys{$p} ) { |
372 | my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) ); |
373 | $rdg->$p( $val ); |
0dcdd5ec |
374 | } |
487674b9 |
375 | } |
376 | } |
377 | $m->save( $rdg ); |
378 | } else { |
379 | $errmsg = "Reading does not exist or cannot be morphologized"; |
0dcdd5ec |
380 | } |
6666d111 |
381 | $c->stash->{'result'} = $errmsg ? { 'error' => $errmsg } |
382 | : _reading_struct( $rdg ); |
0dcdd5ec |
383 | |
5f15640c |
384 | } |
385 | $c->forward('View::JSON'); |
386 | |
387 | } |
b28e606e |
388 | |
20198e59 |
389 | sub _check_permission { |
390 | my( $c, $tradition ) = @_; |
391 | my $user = $c->user_exists ? $c->user->get_object : undef; |
b0524272 |
392 | # Does this user have access? |
20198e59 |
393 | if( $user ) { |
b0524272 |
394 | if( $user->is_admin || |
395 | ( $tradition->has_user && $tradition->user->id eq $user->id ) ) { |
396 | $c->stash->{'permission'} = 'full'; |
397 | return 1; |
398 | } |
080f8a02 |
399 | } |
400 | # Is it public? |
401 | if( $tradition->public ) { |
20198e59 |
402 | $c->stash->{'permission'} = 'readonly'; |
403 | return 1; |
080f8a02 |
404 | } |
405 | # Forbidden! |
406 | $c->response->status( 403 ); |
407 | $c->response->body( 'You do not have permission to view this tradition.' ); |
408 | $c->detach( 'View::Plain' ); |
409 | return 0; |
20198e59 |
410 | } |
411 | |
997ebe92 |
412 | sub _clean_booleans { |
413 | my( $rdg, $param, $val ) = @_; |
414 | if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) { |
415 | $val = 1 if $val eq 'true'; |
416 | $val = undef if $val eq 'false'; |
417 | } |
418 | return $val; |
419 | } |
420 | |
b8a92065 |
421 | =head2 end |
422 | |
423 | Attempt to render a view, if needed. |
424 | |
425 | =cut |
426 | |
427 | sub end : ActionClass('RenderView') {} |
428 | |
429 | =head1 AUTHOR |
430 | |
431 | Tara L Andrews |
432 | |
433 | =head1 LICENSE |
434 | |
435 | This library is free software. You can redistribute it and/or modify |
436 | it under the same terms as Perl itself. |
437 | |
438 | =cut |
439 | |
440 | __PACKAGE__->meta->make_immutable; |
441 | |
442 | 1; |