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 | } |
22bb5720 |
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; |
93daee83 |
71 | my $length = $tradition->collation->end->rank; |
22bb5720 |
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 ) { |
93daee83 |
81 | # Segment the tradition in order not to overload the browser. |
93daee83 |
82 | my @divs; |
83 | my $r = 0; |
22bb5720 |
84 | while( $r + $margin < $length ) { |
93daee83 |
85 | push( @divs, $r ); |
22bb5720 |
86 | $r += $segsize; |
93daee83 |
87 | } |
88 | $c->stash->{'textsegments'} = []; |
22bb5720 |
89 | $c->stash->{'segsize'} = $segsize; |
90 | $c->stash->{'margin'} = $margin; |
0d51383b |
91 | foreach my $i ( 0..$#divs ) { |
92 | my $seg = { 'start' => $divs[$i] }; |
93 | $seg->{'display'} = "Segment " . ($i+1); |
93daee83 |
94 | push( @{$c->stash->{'textsegments'}}, $seg ); |
95 | } |
96 | } |
97 | $c->stash->{'textid'} = $textid; |
98 | $c->stash->{'tradition'} = $tradition; |
72874569 |
99 | } |
100 | |
101 | sub main :Chained('text') :PathPart('') :Args(0) { |
581aee24 |
102 | my( $self, $c ) = @_; |
93daee83 |
103 | my $startseg = $c->req->param('start'); |
1c0900ef |
104 | my $tradition = delete $c->stash->{'tradition'}; |
105 | my $collation = $tradition->collation; |
93daee83 |
106 | my $svgopts; |
107 | if( $startseg ) { |
22bb5720 |
108 | # Only render the subgraph from startseg to endseg or to END, |
93daee83 |
109 | # whichever is less. |
22bb5720 |
110 | my $endseg = $startseg + $c->stash->{'segsize'} + $c->stash->{'margin'}; |
93daee83 |
111 | $svgopts = { 'from' => $startseg }; |
22bb5720 |
112 | $svgopts->{'to'} = $endseg if $endseg < $collation->end->rank; |
93daee83 |
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. |
22bb5720 |
116 | my $endseg = $c->stash->{'segsize'} + $c->stash->{'margin'}; |
0d51383b |
117 | $startseg = 0; |
22bb5720 |
118 | $svgopts = { 'to' => $endseg }; |
93daee83 |
119 | } |
120 | my $svg_str = $collation->as_svg( $svgopts ); |
72874569 |
121 | $svg_str =~ s/\n//gs; |
0d51383b |
122 | $c->stash->{'startseg'} = $startseg if defined $startseg; |
72874569 |
123 | $c->stash->{'svg_string'} = $svg_str; |
124 | $c->stash->{'text_title'} = $tradition->name; |
75ae2b25 |
125 | $c->stash->{'text_lang'} = $tradition->language; |
72874569 |
126 | $c->stash->{'template'} = 'relate.tt'; |
581aee24 |
127 | } |
128 | |
75ae2b25 |
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'); |
148 | $DB::single = 1; |
149 | if( $has_mod ) { |
150 | my $tagset = &$has_mod; |
151 | $c->stash->{'tagset'} = $tagset; |
152 | } |
153 | } |
154 | $c->stash->{'template'} = 'relatehelp.tt'; |
155 | } |
156 | |
581aee24 |
157 | =head2 relationships |
158 | |
93daee83 |
159 | GET relation/$textid/relationships |
72874569 |
160 | |
161 | Returns the list of relationships defined for this text. |
581aee24 |
162 | |
93daee83 |
163 | POST relation/$textid/relationships { request } |
72874569 |
164 | |
165 | Attempts to define the requested relationship within the text. Returns 200 on |
166 | success or 403 on error. |
581aee24 |
167 | |
93daee83 |
168 | DELETE relation/$textid/relationships { request } |
72874569 |
169 | |
581aee24 |
170 | |
171 | =cut |
172 | |
72874569 |
173 | sub relationships :Chained('text') :PathPart :Args(0) { |
581aee24 |
174 | my( $self, $c ) = @_; |
bff7bb42 |
175 | my $tradition = delete $c->stash->{'tradition'}; |
176 | my $collation = $tradition->collation; |
7c280843 |
177 | my $m = $c->model('Directory'); |
72874569 |
178 | if( $c->request->method eq 'GET' ) { |
179 | my @pairs = $collation->relationships; # returns the edges |
180 | my @all_relations; |
181 | foreach my $p ( @pairs ) { |
182 | my $relobj = $collation->relations->get_relationship( @$p ); |
9251a7be |
183 | next if $relobj->type eq 'collated'; # Don't show these |
cccbf476 |
184 | next if $p->[0] eq $p->[1]; # HACK until bugfix |
31aaf446 |
185 | my $relhash = { source => $p->[0], target => $p->[1], |
186 | type => $relobj->type, scope => $relobj->scope }; |
187 | $relhash->{'note'} = $relobj->annotation if $relobj->has_annotation; |
188 | push( @all_relations, $relhash ); |
72874569 |
189 | } |
190 | $c->stash->{'result'} = \@all_relations; |
191 | } elsif( $c->request->method eq 'POST' ) { |
192 | my $node = $c->request->param('source_id'); |
193 | my $target = $c->request->param('target_id'); |
194 | my $relation = $c->request->param('rel_type'); |
195 | my $note = $c->request->param('note'); |
196 | my $scope = $c->request->param('scope'); |
197 | |
198 | my $opts = { 'type' => $relation, |
31aaf446 |
199 | 'scope' => $scope }; |
200 | $opts->{'annotation'} = $note if $note; |
72874569 |
201 | |
202 | try { |
203 | my @vectors = $collation->add_relationship( $node, $target, $opts ); |
204 | $c->stash->{'result'} = \@vectors; |
7c280843 |
205 | $m->save( $tradition ); |
72874569 |
206 | } catch( Text::Tradition::Error $e ) { |
207 | $c->response->status( '403' ); |
208 | $c->stash->{'result'} = { 'error' => $e->message }; |
209 | } |
210 | } elsif( $c->request->method eq 'DELETE' ) { |
211 | my $node = $c->request->param('source_id'); |
212 | my $target = $c->request->param('target_id'); |
213 | |
214 | try { |
215 | my @vectors = $collation->del_relationship( $node, $target ); |
7c280843 |
216 | $m->save( $tradition ); |
72874569 |
217 | $c->stash->{'result'} = \@vectors; |
218 | } catch( Text::Tradition::Error $e ) { |
219 | $c->response->status( '403' ); |
220 | $c->stash->{'result'} = { 'error' => $e->message }; |
221 | } |
581aee24 |
222 | } |
581aee24 |
223 | $c->forward('View::JSON'); |
a8928d1d |
224 | } |
225 | |
226 | =head2 readings |
227 | |
228 | GET relation/$textid/readings |
229 | |
230 | Returns the list of readings defined for this text along with their metadata. |
231 | |
232 | =cut |
233 | |
3ba238d4 |
234 | my %read_write_keys = ( |
235 | 'id' => 0, |
236 | 'text' => 0, |
237 | 'is_meta' => 0, |
238 | 'grammar_invalid' => 1, |
239 | 'is_nonsense' => 1, |
240 | 'normal_form' => 1, |
241 | ); |
242 | |
a8928d1d |
243 | sub _reading_struct { |
244 | my( $reading ) = @_; |
245 | # Return a JSONable struct of the useful keys. Keys meant to be writable |
246 | # have a true value; read-only keys have a false value. |
a8928d1d |
247 | my $struct = {}; |
248 | map { $struct->{$_} = $reading->$_ } keys( %read_write_keys ); |
249 | # Special case |
250 | $struct->{'lexemes'} = [ $reading->lexemes ]; |
3ba238d4 |
251 | # Look up any words related via spelling or orthography |
252 | my $sameword = sub { |
253 | my $t = $_[0]->type; |
254 | return $t eq 'spelling' || $t eq 'orthographic'; |
255 | }; |
256 | my @variants; |
257 | foreach my $sr ( $reading->related_readings( $sameword ) ) { |
258 | push( @variants, $sr->text ); |
259 | } |
260 | $struct->{'variants'} = \@variants; |
a8928d1d |
261 | return $struct; |
262 | } |
263 | |
264 | sub readings :Chained('text') :PathPart :Args(0) { |
265 | my( $self, $c ) = @_; |
266 | my $tradition = delete $c->stash->{'tradition'}; |
267 | my $collation = $tradition->collation; |
268 | my $m = $c->model('Directory'); |
269 | if( $c->request->method eq 'GET' ) { |
270 | my $rdginfo = {}; |
271 | foreach my $rdg ( $collation->readings ) { |
272 | $rdginfo->{$rdg->id} = _reading_struct( $rdg ); |
273 | } |
274 | $c->stash->{'result'} = $rdginfo; |
275 | } |
276 | $c->forward('View::JSON'); |
277 | } |
278 | |
279 | =head2 reading |
280 | |
281 | GET relation/$textid/reading/$id |
282 | |
283 | Returns the list of readings defined for this text along with their metadata. |
284 | |
285 | POST relation/$textid/reading/$id { request } |
286 | |
287 | Alters the reading according to the values in request. Returns 403 Forbidden if |
288 | the alteration isn't allowed. |
289 | |
290 | =cut |
291 | |
292 | sub reading :Chained('text') :PathPart :Args(1) { |
293 | my( $self, $c, $reading_id ) = @_; |
294 | my $tradition = delete $c->stash->{'tradition'}; |
295 | my $collation = $tradition->collation; |
3ba238d4 |
296 | my $rdg = $collation->reading( $reading_id ); |
a8928d1d |
297 | my $m = $c->model('Directory'); |
298 | if( $c->request->method eq 'GET' ) { |
a8928d1d |
299 | $c->stash->{'result'} = $rdg ? _reading_struct( $rdg ) |
300 | : { 'error' => "No reading with ID $reading_id" }; |
301 | } elsif ( $c->request->method eq 'POST' ) { |
3ba238d4 |
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 ); |
4aed7cc5 |
307 | # TODO throw error if lemmatization fails |
3ba238d4 |
308 | $rdg->lemmatize(); |
309 | } else { |
310 | # Set all the values that we have for the reading. |
311 | # TODO error handling |
312 | foreach my $p ( keys %{$c->request->params} ) { |
313 | if( $p =~ /^morphology_(\d+)$/ ) { |
314 | # Set the form on the correct lexeme |
315 | my $midx = $1; |
316 | $c->log->debug( "Fetching lexeme $midx" ); |
317 | my $lx = $rdg->lexeme( $midx ); |
318 | my $strrep = $rdg->language . ' // ' |
319 | . $c->request->param( $p ); |
320 | my $idx = $lx->has_form( $strrep ); |
321 | unless( defined $idx ) { |
322 | # Make the word form and add it to the lexeme. |
323 | $c->log->debug("Adding new form for $strrep"); |
324 | $idx = $lx->add_matching_form( $strrep ) - 1; |
325 | } |
326 | $lx->disambiguate( $idx ); |
327 | } elsif( $read_write_keys{$p} ) { |
4aed7cc5 |
328 | my $val = _clean_booleans( $rdg, $p, $c->request->param( $p ) ); |
329 | $rdg->$p( $val ); |
3ba238d4 |
330 | } |
331 | } |
332 | } |
333 | $m->save( $tradition ); |
334 | $c->stash->{'result'} = _reading_struct( $rdg ); |
335 | |
a8928d1d |
336 | } |
337 | $c->forward('View::JSON'); |
338 | |
339 | } |
581aee24 |
340 | |
4aed7cc5 |
341 | sub _clean_booleans { |
342 | my( $rdg, $param, $val ) = @_; |
343 | if( $rdg->meta->get_attribute( $param )->type_constraint->name eq 'Bool' ) { |
344 | $val = 1 if $val eq 'true'; |
345 | $val = undef if $val eq 'false'; |
346 | } |
347 | return $val; |
348 | } |
349 | |
2376359f |
350 | =head2 end |
351 | |
352 | Attempt to render a view, if needed. |
353 | |
354 | =cut |
355 | |
356 | sub end : ActionClass('RenderView') {} |
357 | |
358 | =head1 AUTHOR |
359 | |
360 | Tara L Andrews |
361 | |
362 | =head1 LICENSE |
363 | |
364 | This library is free software. You can redistribute it and/or modify |
365 | it under the same terms as Perl itself. |
366 | |
367 | =cut |
368 | |
369 | __PACKAGE__->meta->make_immutable; |
370 | |
371 | 1; |