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 | } |
d58766c0 |
67 | # See how big the tradition is. Edges are more important than nodes |
68 | # when it comes to rendering difficulty. |
69 | my $numnodes = scalar $tradition->collation->readings; |
70 | my $numedges = scalar $tradition->collation->paths; |
13aa153c |
71 | my $length = $tradition->collation->end->rank; |
d58766c0 |
72 | # We should display no more than roughly 500 nodes, or roughly 700 |
73 | # edges, at a time. |
74 | my $segments = $numnodes / 500; |
75 | if( $numedges / 700 > $segments ) { |
76 | $segments = $numedges / 700; |
77 | } |
78 | my $segsize = sprintf( "%.0f", $length / $segments ); |
79 | my $margin = sprintf( "%.0f", $segsize / 10 ); |
80 | if( $segments > 1 ) { |
13aa153c |
81 | # Segment the tradition in order not to overload the browser. |
13aa153c |
82 | my @divs; |
83 | my $r = 0; |
d58766c0 |
84 | while( $r + $margin < $length ) { |
13aa153c |
85 | push( @divs, $r ); |
d58766c0 |
86 | $r += $segsize; |
13aa153c |
87 | } |
88 | $c->stash->{'textsegments'} = []; |
d58766c0 |
89 | $c->stash->{'segsize'} = $segsize; |
90 | $c->stash->{'margin'} = $margin; |
ea8e8b3c |
91 | foreach my $i ( 0..$#divs ) { |
92 | my $seg = { 'start' => $divs[$i] }; |
93 | $seg->{'display'} = "Segment " . ($i+1); |
13aa153c |
94 | push( @{$c->stash->{'textsegments'}}, $seg ); |
95 | } |
96 | } |
97 | $c->stash->{'textid'} = $textid; |
98 | $c->stash->{'tradition'} = $tradition; |
9529f69c |
99 | } |
100 | |
101 | sub main :Chained('text') :PathPart('') :Args(0) { |
b28e606e |
102 | my( $self, $c ) = @_; |
13aa153c |
103 | my $startseg = $c->req->param('start'); |
9c2e7b80 |
104 | my $tradition = delete $c->stash->{'tradition'}; |
105 | my $collation = $tradition->collation; |
13aa153c |
106 | my $svgopts; |
107 | if( $startseg ) { |
d58766c0 |
108 | # Only render the subgraph from startseg to endseg or to END, |
13aa153c |
109 | # whichever is less. |
d58766c0 |
110 | my $endseg = $startseg + $c->stash->{'segsize'} + $c->stash->{'margin'}; |
13aa153c |
111 | $svgopts = { 'from' => $startseg }; |
d58766c0 |
112 | $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank; |
13aa153c |
113 | } elsif( exists $c->stash->{'textsegments'} ) { |
114 | # This is the unqualified load of a long tradition. We implicitly start |
115 | # at zero, but go only as far as 550. |
d58766c0 |
116 | my $endseg = $c->stash->{'segsize'} + $c->stash->{'margin'}; |
ea8e8b3c |
117 | $startseg = 0; |
d58766c0 |
118 | $svgopts = { 'to' => $endseg }; |
13aa153c |
119 | } |
120 | my $svg_str = $collation->as_svg( $svgopts ); |
9529f69c |
121 | $svg_str =~ s/\n//gs; |
ea8e8b3c |
122 | $c->stash->{'startseg'} = $startseg if defined $startseg; |
9529f69c |
123 | $c->stash->{'svg_string'} = $svg_str; |
124 | $c->stash->{'text_title'} = $tradition->name; |
cc86fa11 |
125 | $c->stash->{'text_lang'} = $tradition->language; |
9529f69c |
126 | $c->stash->{'template'} = 'relate.tt'; |
b28e606e |
127 | } |
128 | |
cc86fa11 |
129 | =head2 help |
130 | |
131 | GET relation/help/$language |
132 | |
133 | Returns the help window HTML. |
134 | |
135 | =cut |
136 | |
137 | sub help :Local :Args(1) { |
138 | my( $self, $c, $lang ) = @_; |
139 | # Display the morphological help for the language if it is defined. |
140 | if( $lang && $lang ne 'Default' ) { |
141 | my $mod = 'Text::Tradition::Language::' . $lang; |
142 | try { |
143 | load( $mod ); |
144 | } catch { |
145 | $c->log->debug("Warning: could not load $mod"); |
146 | } |
147 | my $has_mod = $mod->can('morphology_tags'); |
cc86fa11 |
148 | if( $has_mod ) { |
149 | my $tagset = &$has_mod; |
150 | $c->stash->{'tagset'} = $tagset; |
151 | } |
152 | } |
153 | $c->stash->{'template'} = 'relatehelp.tt'; |
154 | } |
155 | |
b28e606e |
156 | =head2 relationships |
157 | |
13aa153c |
158 | GET relation/$textid/relationships |
9529f69c |
159 | |
160 | Returns the list of relationships defined for this text. |
b28e606e |
161 | |
13aa153c |
162 | POST relation/$textid/relationships { request } |
9529f69c |
163 | |
164 | Attempts to define the requested relationship within the text. Returns 200 on |
165 | success or 403 on error. |
b28e606e |
166 | |
13aa153c |
167 | DELETE relation/$textid/relationships { request } |
9529f69c |
168 | |
b28e606e |
169 | |
170 | =cut |
171 | |
9529f69c |
172 | sub relationships :Chained('text') :PathPart :Args(0) { |
b28e606e |
173 | my( $self, $c ) = @_; |
6d124a83 |
174 | my $tradition = delete $c->stash->{'tradition'}; |
175 | my $collation = $tradition->collation; |
cdd592f3 |
176 | my $m = $c->model('Directory'); |
9529f69c |
177 | if( $c->request->method eq 'GET' ) { |
178 | my @pairs = $collation->relationships; # returns the edges |
179 | my @all_relations; |
180 | foreach my $p ( @pairs ) { |
181 | my $relobj = $collation->relations->get_relationship( @$p ); |
545163a2 |
182 | next if $relobj->type eq 'collated'; # Don't show these |
7562a27b |
183 | next if $p->[0] eq $p->[1]; # HACK until bugfix |
69a19c91 |
184 | my $relhash = { source => $p->[0], target => $p->[1], |
185 | type => $relobj->type, scope => $relobj->scope }; |
186 | $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation; |
187 | push( @all_relations, $relhash ); |
9529f69c |
188 | } |
189 | $c->stash->{'result'} = \@all_relations; |
190 | } elsif( $c->request->method eq 'POST' ) { |
191 | my $node = $c->request->param('source_id'); |
192 | my $target = $c->request->param('target_id'); |
193 | my $relation = $c->request->param('rel_type'); |
194 | my $note = $c->request->param('note'); |
195 | my $scope = $c->request->param('scope'); |
196 | |
197 | my $opts = { 'type' => $relation, |
69a19c91 |
198 | 'scope' => $scope }; |
199 | $opts->{'annotation'} = $note if $note; |
9529f69c |
200 | |
201 | try { |
202 | my @vectors = $collation->add_relationship( $node, $target, $opts ); |
203 | $c->stash->{'result'} = \@vectors; |
cdd592f3 |
204 | $m->save( $tradition ); |
9529f69c |
205 | } catch( Text::Tradition::Error $e ) { |
206 | $c->response->status( '403' ); |
207 | $c->stash->{'result'} = { 'error' => $e->message }; |
208 | } |
209 | } elsif( $c->request->method eq 'DELETE' ) { |
210 | my $node = $c->request->param('source_id'); |
211 | my $target = $c->request->param('target_id'); |
212 | |
213 | try { |
214 | my @vectors = $collation->del_relationship( $node, $target ); |
cdd592f3 |
215 | $m->save( $tradition ); |
9529f69c |
216 | $c->stash->{'result'} = \@vectors; |
217 | } catch( Text::Tradition::Error $e ) { |
218 | $c->response->status( '403' ); |
219 | $c->stash->{'result'} = { 'error' => $e->message }; |
220 | } |
b28e606e |
221 | } |
b28e606e |
222 | $c->forward('View::JSON'); |
5f15640c |
223 | } |
224 | |
225 | =head2 readings |
226 | |
227 | GET relation/$textid/readings |
228 | |
229 | Returns the list of readings defined for this text along with their metadata. |
230 | |
231 | =cut |
232 | |
0dcdd5ec |
233 | my %read_write_keys = ( |
234 | 'id' => 0, |
235 | 'text' => 0, |
236 | 'is_meta' => 0, |
237 | 'grammar_invalid' => 1, |
238 | 'is_nonsense' => 1, |
239 | 'normal_form' => 1, |
240 | ); |
241 | |
5f15640c |
242 | sub _reading_struct { |
243 | my( $reading ) = @_; |
244 | # Return a JSONable struct of the useful keys. Keys meant to be writable |
245 | # have a true value; read-only keys have a false value. |
5f15640c |
246 | my $struct = {}; |
247 | map { $struct->{$_} = $reading->$_ } keys( %read_write_keys ); |
248 | # Special case |
249 | $struct->{'lexemes'} = [ $reading->lexemes ]; |
0dcdd5ec |
250 | # Look up any words related via spelling or orthography |
251 | my $sameword = sub { |
252 | my $t = $_[0]->type; |
253 | return $t eq 'spelling' || $t eq 'orthographic'; |
254 | }; |
255 | my @variants; |
256 | foreach my $sr ( $reading->related_readings( $sameword ) ) { |
257 | push( @variants, $sr->text ); |
258 | } |
259 | $struct->{'variants'} = \@variants; |
5f15640c |
260 | return $struct; |
261 | } |
262 | |
263 | sub readings :Chained('text') :PathPart :Args(0) { |
264 | my( $self, $c ) = @_; |
265 | my $tradition = delete $c->stash->{'tradition'}; |
266 | my $collation = $tradition->collation; |
267 | my $m = $c->model('Directory'); |
268 | if( $c->request->method eq 'GET' ) { |
269 | my $rdginfo = {}; |
270 | foreach my $rdg ( $collation->readings ) { |
271 | $rdginfo->{$rdg->id} = _reading_struct( $rdg ); |
272 | } |
273 | $c->stash->{'result'} = $rdginfo; |
274 | } |
275 | $c->forward('View::JSON'); |
276 | } |
277 | |
278 | =head2 reading |
279 | |
280 | GET relation/$textid/reading/$id |
281 | |
282 | Returns the list of readings defined for this text along with their metadata. |
283 | |
284 | POST relation/$textid/reading/$id { request } |
285 | |
286 | Alters the reading according to the values in request. Returns 403 Forbidden if |
287 | the alteration isn't allowed. |
288 | |
289 | =cut |
290 | |
291 | sub reading :Chained('text') :PathPart :Args(1) { |
292 | my( $self, $c, $reading_id ) = @_; |
293 | my $tradition = delete $c->stash->{'tradition'}; |
294 | my $collation = $tradition->collation; |
0dcdd5ec |
295 | my $rdg = $collation->reading( $reading_id ); |
5f15640c |
296 | my $m = $c->model('Directory'); |
297 | if( $c->request->method eq 'GET' ) { |
5f15640c |
298 | $c->stash->{'result'} = $rdg ? _reading_struct( $rdg ) |
299 | : { 'error' => "No reading with ID $reading_id" }; |
300 | } elsif ( $c->request->method eq 'POST' ) { |
6666d111 |
301 | my $errmsg; |
0dcdd5ec |
302 | # Are we re-lemmatizing? |
303 | if( $c->request->param('relemmatize') ) { |
304 | my $nf = $c->request->param('normal_form'); |
305 | # TODO throw error unless $nf |
306 | $rdg->normal_form( $nf ); |
997ebe92 |
307 | # TODO throw error if lemmatization fails |
6666d111 |
308 | # TODO skip this if normal form hasn't changed |
0dcdd5ec |
309 | $rdg->lemmatize(); |
310 | } else { |
311 | # Set all the values that we have for the reading. |
312 | # TODO error handling |
313 | foreach my $p ( keys %{$c->request->params} ) { |
314 | if( $p =~ /^morphology_(\d+)$/ ) { |
315 | # Set the form on the correct lexeme |
aafcb75b |
316 | my $morphval = $c->request->param( $p ); |
317 | next unless $morphval; |
0dcdd5ec |
318 | my $midx = $1; |
0dcdd5ec |
319 | my $lx = $rdg->lexeme( $midx ); |
aafcb75b |
320 | my $strrep = $rdg->language . ' // ' . $morphval; |
0dcdd5ec |
321 | my $idx = $lx->has_form( $strrep ); |
322 | unless( defined $idx ) { |
323 | # Make the word form and add it to the lexeme. |
6666d111 |
324 | try { |
325 | $idx = $lx->add_matching_form( $strrep ) - 1; |
326 | } catch( Text::Tradition::Error $e ) { |
327 | $c->response->status( '403' ); |
328 | $errmsg = $e->message; |
465848bc |
329 | } catch { |
330 | # Something else went wrong, probably a Moose error |
331 | $c->response->status( '403' ); |
332 | $errmsg = 'Something went wrong with the request'; |
6666d111 |
333 | } |
0dcdd5ec |
334 | } |
6666d111 |
335 | $lx->disambiguate( $idx ) if defined $idx; |
0dcdd5ec |
336 | } elsif( $read_write_keys{$p} ) { |
997ebe92 |
337 | my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) ); |
338 | $rdg->$p( $val ); |
0dcdd5ec |
339 | } |
340 | } |
341 | } |
19f0f822 |
342 | $m->save( $rdg ); |
6666d111 |
343 | $c->stash->{'result'} = $errmsg ? { 'error' => $errmsg } |
344 | : _reading_struct( $rdg ); |
0dcdd5ec |
345 | |
5f15640c |
346 | } |
347 | $c->forward('View::JSON'); |
348 | |
349 | } |
b28e606e |
350 | |
997ebe92 |
351 | sub _clean_booleans { |
352 | my( $rdg, $param, $val ) = @_; |
353 | if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) { |
354 | $val = 1 if $val eq 'true'; |
355 | $val = undef if $val eq 'false'; |
356 | } |
357 | return $val; |
358 | } |
359 | |
b8a92065 |
360 | =head2 end |
361 | |
362 | Attempt to render a view, if needed. |
363 | |
364 | =cut |
365 | |
366 | sub end : ActionClass('RenderView') {} |
367 | |
368 | =head1 AUTHOR |
369 | |
370 | Tara L Andrews |
371 | |
372 | =head1 LICENSE |
373 | |
374 | This library is free software. You can redistribute it and/or modify |
375 | it under the same terms as Perl itself. |
376 | |
377 | =cut |
378 | |
379 | __PACKAGE__->meta->make_immutable; |
380 | |
381 | 1; |