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