[Bio] / FigKernelPackages / P2P.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/P2P.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (view) (download) (as text)

1 : olson 1.1 #
2 :     # This module contains the code for the P2P update protocol.
3 :     #
4 :     # Package P2P contains the namespace declarations, and possibly toplevel utility
5 :     # routines. (get_relay ?)
6 :     #
7 :     # Package P2P::Relay contains methods for contacting the P2P relay service. The actual
8 :     # implementation of the relay service is not contained here - it is a standalone module
9 :     # that can be installed on a web server that does not have a full SEED installed.
10 :     #
11 :     # Package P2P::Requestor contains the requestor-side code for the update protocol.
12 :     #
13 :     # Package P2P::Service contains the web service implementation routines for the
14 :     # protocol.
15 :     #
16 :    
17 :     package P2P;
18 :    
19 :     use FIG_Config;
20 :    
21 :     use strict;
22 :     use Exporter;
23 :     use base qw(Exporter);
24 :    
25 : olson 1.15 use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
26 :    
27 : olson 1.1 use Data::Dumper;
28 :    
29 :     use vars qw(@EXPORT @EXPORT_OK);
30 :     @EXPORT = ();
31 :     @EXPORT_OK = qw($ns_p2p $ns_relay);
32 :    
33 :     our $ns_p2p = "http://thefig.info/schemas/p2p_update";
34 :     our $ns_relay = "http://thefig.info/schemas/p2p_relay";
35 :    
36 :     =pod
37 :    
38 :     =head1 perform_update($peer)
39 :    
40 :     Perform a peer-to-peer update with the given peer. $peer is an instance of
41 :     P2P::Requestor which can connect to the peer. It is expected that the
42 :     SEED infrastructure will create this requestor appropriately for the
43 :     particular circumstance (direct connection, thru relay, etc).
44 :    
45 :     This code executes the high-level protocol, maintaining state between
46 :     calls to the peer to exchange the actual information.
47 :    
48 :     =cut
49 :    
50 :     sub perform_update
51 :     {
52 :     my($fig, $peer, $last_update) = @_;
53 :    
54 :     my $ret = $peer->request_update($last_update);
55 :    
56 :     if (!$ret or ref($ret) ne "ARRAY")
57 :     {
58 : olson 1.18 die "perform_update: request_update failed\n";
59 : olson 1.1 }
60 :    
61 : olson 1.15 my($session, $target_release, $num_assignments, $num_annos, $num_pegs, $num_genomes,
62 : olson 1.1 $target_time, $compatible) = @$ret;
63 :    
64 : olson 1.18 print "perform_update: session=$session target=@$target_release num_annos=$num_annos\n";
65 : olson 1.1 print " num_pegs=$num_pegs num_genomes=$num_genomes target_time=$target_time compat=$compatible\n";
66 :    
67 :     #
68 :     # We have the information now to begin the update process. Retrieve the pegs.
69 :     #
70 :    
71 :     $ret = $peer->get_pegs($session, 0, $num_pegs);
72 :    
73 :     if (!$ret or ref($ret) ne "ARRAY")
74 :     {
75 :     die "perform_update: get_pegs failed\n";
76 :     }
77 :    
78 :     my($peg_list, $genome_list) = @$ret;
79 :    
80 :     #
81 :     # Walk the peg-list to and generate @pegs_to_finalize.
82 :     #
83 :    
84 :     my(%peg_mapping, %genome_map );
85 :    
86 :     for my $peg_info (@$peg_list)
87 :     {
88 :     my($key, $peg, @rest) = @$peg_info;
89 :    
90 :     if ($key eq 'peg')
91 :     {
92 :     #
93 :     # Peg id is directly usable.
94 :     #
95 : olson 1.6 $peg_mapping{$peg} = $peg;
96 : olson 1.1 }
97 :     elsif ($key eq 'peg_info')
98 :     {
99 :     #
100 :     # Peg id not directly usable.
101 :     #
102 :    
103 :     my($alias_list, $genome_id) = @rest;
104 :    
105 :     for my $alias (@$alias_list)
106 :     {
107 :     my $mapped = $fig->by_alias($alias);
108 : olson 1.3 if ($mapped)
109 : olson 1.1 {
110 :     print "$peg maps to $mapped via $alias\n";
111 :     $peg_mapping{$peg}= $mapped;
112 :     last;
113 :     }
114 :     }
115 :    
116 :     #
117 :     # If we didn't succeed in mapping by alias,
118 :     # stash this in the list of pegs to be mapped by
119 :     # genome.
120 :     #
121 :    
122 :     if (!defined($peg_mapping{$peg}))
123 :     {
124 :     push(@{$genome_map{$genome_id}}, $peg);
125 : olson 1.4 print "$peg did not map\n";
126 : olson 1.1 }
127 :     }
128 :     }
129 :    
130 :     #
131 :     # finished first pass. Now go over the per-genome mappings that need to be made.
132 :     #
133 : olson 1.6 # $genome_map{$genome_id} is a list of pegs that reside on that genome.
134 :     # the pegs and genome id are both target-based identifiers.
135 :     #
136 :    
137 :     my @finalize_req = ();
138 : olson 1.7 my %local_genome;
139 : olson 1.1
140 :     for my $genome_info (@$genome_list)
141 :     {
142 :     my($genome, $n_contigs, $n_nucs, $cksum) = @$genome_info;
143 :    
144 : olson 1.5 next unless defined($genome_map{$genome});
145 : olson 1.1
146 : olson 1.6 #
147 :     # Determine if we have a local genome installed that matches precisely the
148 :     # genome on the target side.
149 :     #
150 : olson 1.1 my $my_genome = $fig->find_genome_by_content($genome, $n_contigs, $n_nucs, $cksum);
151 :    
152 : olson 1.6 my $pegs = $genome_map{$genome};
153 :    
154 : olson 1.1 if ($my_genome)
155 :     {
156 :     #
157 : olson 1.6 # We do have such a local genome. Generate a peg_genome request to
158 :     # get the location information from the target side.
159 : olson 1.1 #
160 : olson 1.7 # Also remember the local genome mapping for this peg.
161 :     #
162 :    
163 : olson 1.6 print "$genome mapped to $my_genome\n";
164 : olson 1.7 for my $peg (@$pegs)
165 :     {
166 :     push(@finalize_req, ['peg_genome', $peg]);
167 :     $local_genome{$peg} = $my_genome;
168 :     }
169 : olson 1.1
170 :     }
171 : olson 1.2 else
172 :     {
173 : olson 1.6 #
174 :     # We don't have such a genome. We need to retrieve the
175 :     # sequence data in order to finish mapping.
176 :     #
177 :     push(@finalize_req, map { ['peg_unknown', $_] } @$pegs);
178 :     }
179 :     }
180 :    
181 :     #
182 :     # If we need to finalize, make the call.
183 :     if (@finalize_req)
184 :     {
185 :     print Dumper(\@finalize_req);
186 :     $ret = $peer->finalize_pegs($session, \@finalize_req);
187 :    
188 :     if (!$ret or ref($ret) ne "ARRAY")
189 :     {
190 :     die "perform_update: finalize_pegs failed\n";
191 : olson 1.2 }
192 : olson 1.6
193 :     #
194 :     # The return is a list of either location entries or
195 : olson 1.7 # sequence data. Attempt to finish up the mapping.
196 : olson 1.6 #
197 :    
198 : olson 1.14 my(%sought, %sought_seq);
199 : olson 1.13
200 : olson 1.9
201 :     my $dbh = $fig->db_handle();
202 : olson 1.7 for my $entry (@$ret)
203 :     {
204 :     my($what, $peg, @rest) = @$entry;
205 :    
206 :     if ($what eq "peg_loc")
207 :     {
208 : olson 1.13 my($strand, $start, $end, $cksum, $seq) = @rest;
209 : olson 1.7
210 :     #
211 :     # We have a contig location. Try to find a matching contig
212 :     # here, and see if it maps to something.
213 :     #
214 :    
215 :     my $my_genome = $local_genome{$peg};
216 :     my $local_contig = $fig->find_contig_with_checksum($my_genome, $cksum);
217 :     if ($local_contig)
218 :     {
219 : olson 1.8 #
220 : olson 1.9 # Now look up the local peg. We match on the end location; depending on the strand
221 :     # the feature is on, we want to look at either minloc or maxloc.
222 : olson 1.8 #
223 : olson 1.9
224 :     my $whichloc = $strand eq '-' ? "minloc" : "maxloc";
225 :    
226 :     my $res = $dbh->SQL(qq!SELECT id from features
227 :     WHERE $whichloc = $end and genome = '$my_genome' and
228 :     contig = '$local_contig'
229 :     !);
230 :    
231 : olson 1.12 if ($res and @$res > 0)
232 : olson 1.9 {
233 : olson 1.12 my(@ids) = map { $_->[0] } @$res;
234 :     my $id = $ids[0];
235 : olson 1.9 $peg_mapping{$peg} = $id;
236 :     print "Mapped $peg to $id via contigs\n";
237 : olson 1.12 if (@$res > 1)
238 :     {
239 :     warn "Multiple mappings found for $peg: @ids\n";
240 :     }
241 : olson 1.9 }
242 :     else
243 :     {
244 : olson 1.11 print "failed: $peg $my_genome and contig $local_contig start=$start end=$end strand=$strand\n";
245 : olson 1.13 $sought{$peg}++;
246 :     $sought_seq{$peg} = $seq;
247 : olson 1.9 }
248 : olson 1.7 }
249 :     else
250 :     {
251 :     print "Mapping failed for $my_genome checksum $cksum\n";
252 : olson 1.13 $sought{$peg}++;
253 :     $sought_seq{$peg} = $seq;
254 : olson 1.7 }
255 :     }
256 : olson 1.13 elsif ($what eq "peg_seq")
257 :     {
258 :     my($seq) = @rest;
259 :    
260 :     $sought{$peg}++;
261 :     $sought_seq{$peg} = $seq;
262 :     }
263 :     }
264 :    
265 :     #
266 :     # Now see if we need to do a tough search.
267 :     #
268 :    
269 :     if (keys(%sought) > 0)
270 :     {
271 :     my %trans;
272 :    
273 :     print "Starting tough search\n";
274 :    
275 :     $fig->tough_search(undef, \%sought_seq, \%trans, \%sought);
276 :     print "Tough search translated: \n";
277 : olson 1.15 while (my($tpeg, $ttrans) = each(%trans))
278 :     {
279 :     print " $tpeg -> $ttrans\n";
280 :     $peg_mapping{$tpeg} = $ttrans;
281 :     }
282 : olson 1.7 }
283 : olson 1.1 }
284 : olson 1.15
285 :     #
286 :     # Retrieve the annotations, and generate a list of mapped annotations.
287 :     #
288 :    
289 :     my $annos = $peer->get_annotations($session, 0, $num_annos > 10 ? 10 : $num_annos);
290 :    
291 :     #
292 :     # Create a list of locally-mapped annotations on a per-genome
293 :     # basis.
294 :     #
295 :    
296 :     my %genome_annos;
297 :    
298 :     for my $anno (@$annos)
299 :     {
300 :     my($his_id, $ts, $author, $anno) = @$anno;
301 :    
302 :     my $my_id = $peg_mapping{$his_id};
303 :     next unless $my_id;
304 :    
305 :     my $genome = $fig->genome_of($my_id);
306 :    
307 :     push(@{$genome_annos{$genome}}, [$my_id, $ts, $author, $anno]);
308 :     }
309 :    
310 :     print Dumper(\%genome_annos);
311 :    
312 :     #
313 :     # Now install annotations.
314 :     #
315 :    
316 :     for my $genome (keys(%genome_annos))
317 :     {
318 :     # _install_genome_annos($fig, $genome, $genome_annos{$genome});
319 :     }
320 : olson 1.1 }
321 :    
322 :    
323 : olson 1.15
324 : olson 1.1 #############
325 :     #
326 :     # P2P Relay
327 :     #
328 :     #############
329 :    
330 :    
331 :     package P2P::Relay;
332 :     use strict;
333 :    
334 :     use Data::Dumper;
335 :     use SOAP::Lite;
336 :    
337 :     use P2P;
338 :    
339 :     sub new
340 :     {
341 :     my($class, $url) = @_;
342 :    
343 :     my $proxy = SOAP::Lite->uri($P2P::ns_relay)->proxy($url);
344 :    
345 :     my $self = {
346 :     url => $url,
347 :     proxy => $proxy,
348 :     };
349 :     return bless($self, $class);
350 :     }
351 :    
352 :     sub enumerate_annotation_systems
353 :     {
354 :     my($self) = @_;
355 :    
356 :     return $self->{proxy}->enumerate_annotation_systems()->result;
357 :     }
358 :    
359 :     sub fetch_queries
360 :     {
361 :     my($self, $id) = @_;
362 :    
363 :     my $reply = $self->{proxy}->fetch_queries($id);
364 :    
365 :     if ($reply->fault)
366 :     {
367 :     print "Failed to fetch queries: ", $reply->faultcode, " ", $reply->faultstring, "\n";
368 :     return undef;
369 :     }
370 :    
371 :     return $reply->result;
372 :     }
373 :    
374 :     sub deposit_answer
375 :     {
376 :     my($self, $id, $key, $answer) = @_;
377 :    
378 :     my $reply = $self->{proxy}->deposit_answer($id, $key,
379 :     SOAP::Data->type('base64')->value($answer));
380 :    
381 :     if ($reply->fault)
382 :     {
383 :     print "deposit_answer got fault: ", $reply->faultcode, " ", $reply->faultstring, "\n";
384 :     return undef;
385 :     }
386 :    
387 :     return $reply;
388 :     }
389 :    
390 :     =pod
391 :    
392 :     =head1 await_result
393 :    
394 :     Await the result from a possibly-asynchronous soap request.
395 :    
396 :     Look at the reply that we have. If it's a deferred reply, loop polling
397 :     the relay for the actual result.
398 :    
399 :     We determine if the reply is a deferred reply by examining the namespace
400 :     URI of the response. A response will be generated from the relay's namespace,
401 :     rather than that of the application itself.
402 :    
403 :     =cut
404 :    
405 :     sub await_result
406 :     {
407 :     my($self, $reply) = @_;
408 :    
409 :     while (1)
410 :     {
411 :     #
412 :     # Retrieve the namespace of the response, which is the first
413 :     # element in the body of the message.
414 :     #
415 :     my $ns = $reply->namespaceuriof('/Envelope/Body/[1]');
416 :     print "Reply ns=$ns want $P2P::ns_relay\n";
417 :    
418 :     if ($ns eq $P2P::ns_relay)
419 :     {
420 :     my $val = $reply->result;
421 :     print "got val=", Dumper($val);
422 :     if ($val->[0] eq 'deferred')
423 :     {
424 :     #
425 :     # Sleep a little, then try to retrieve the response.
426 :     #
427 :    
428 :     sleep(1);
429 :     my $id = $val->[1];
430 :    
431 :     print "Retrieving reply\n";
432 :     $reply = $self->{proxy}->call_completed($id);
433 :     }
434 :     else
435 :     {
436 :     #
437 :     # We're not sure what to do here..
438 :     #
439 :     return undef;
440 :     }
441 :     }
442 :     else
443 :     {
444 :     #
445 :     # We got an actual response. Return it.
446 :     #
447 :    
448 :     return $reply;
449 :     }
450 :     }
451 :     }
452 :    
453 :     #############
454 :     #
455 :     # P2P Requestor
456 :     #
457 :     #############
458 :    
459 :     package P2P::Requestor;
460 :     use strict;
461 :    
462 :     use Data::Dumper;
463 : olson 1.15 use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
464 : olson 1.1
465 :     use SOAP::Lite;
466 : olson 1.15
467 :     #use SOAP::Lite +trace => [qw(transport dispatch result debug)];
468 : olson 1.1 use P2P;
469 :    
470 :     #
471 :     # Create a new Requestor. It contains a reference to the FIG instance
472 :     # so that we can run the protocol completely from in here.
473 :     #
474 :    
475 :     sub new
476 :     {
477 :     my($class, $fig, $url, $peer_id, $relay) = @_;
478 :    
479 : olson 1.17 my $proxy = SOAP::Lite->uri($ns_p2p)->proxy($url, timeout => 3600);
480 : olson 1.1
481 :     my $self = {
482 :     fig => $fig,
483 :     url => $url,
484 :     peer_id => $peer_id,
485 :     proxy => $proxy,
486 :     relay => $relay,
487 :     };
488 :     return bless($self, $class);
489 :     }
490 :    
491 :     #
492 :     # First step: Request an update.
493 :     #
494 :     # We need to determine some notion of what our release is, since we are not
495 :     # currently tagging them explicitly. Until we delve into this more,
496 :     # I am going to return a null release, which means the same-release
497 :     # optimization won't be able to kick in.
498 :     #
499 :     # We also need to determine the last time we got an update from this
500 :     # system.
501 :     #
502 :    
503 :     sub request_update
504 :     {
505 :     my($self, $last_update) = @_;
506 :    
507 : olson 1.18 my $rel = [$self->{fig}->get_release_info()];
508 : olson 1.1
509 :     if (!defined($last_update))
510 :     {
511 :     $last_update = $self->{fig}->get_peer_last_update($self->{peer_id});
512 :     }
513 : olson 1.17
514 :     print "Requesting update via $self->{proxy}\n";
515 : olson 1.1 my $reply = $self->{proxy}->request_update($rel, $last_update);
516 : olson 1.17 print "Got reply ", Dumper($reply);
517 : olson 1.1
518 :     if ($self->{relay})
519 :     {
520 :     $reply = $self->{relay}->await_result($reply);
521 :     }
522 :    
523 :     if ($reply->fault)
524 :     {
525 :     print "request_update triggered fault: ", $reply->faultcode, " ", $reply->faultstring, "\n";
526 :     return undef;
527 :     }
528 :    
529 :     return $reply->result;
530 :     }
531 :    
532 :     =pod
533 :    
534 :     =head1 get_pegs($session_id, $start, $length)
535 :    
536 :    
537 :     =cut
538 :    
539 :     sub get_pegs
540 :     {
541 :     my($self, $session_id, $start, $length) = @_;
542 :    
543 :     return $self->call("get_pegs", $session_id, $start, $length);
544 :     }
545 :    
546 : olson 1.6 sub finalize_pegs
547 :     {
548 :     my($self, $session_id, $request) = @_;
549 :    
550 :     return $self->call("finalize_pegs", $session_id, $request);
551 :     }
552 :    
553 : olson 1.15 sub get_annotations
554 :     {
555 :     my($self, $session_id, $start, $length) = @_;
556 :    
557 :     return $self->call("get_annotations", $session_id, $start, $length);
558 :     }
559 :    
560 : olson 1.1 sub call
561 :     {
562 :     my($self, $func, @args) = @_;
563 : olson 1.15
564 :     my $t0 = [gettimeofday()];
565 :     print "Calling $func\n";
566 : olson 1.1 my $reply = $self->{proxy}->$func(@args);
567 : olson 1.15 my $t1 = [gettimeofday()];
568 :    
569 :     my $elap = tv_interval($t0, $t1);
570 :     print "Call to $func took $elap\n";
571 : olson 1.1
572 :     if ($self->{relay})
573 :     {
574 :     $reply = $self->{relay}->await_result($reply);
575 :     }
576 :    
577 :     if ($reply->fault)
578 :     {
579 :     print "$func triggered fault: ", $reply->faultcode, " ", $reply->faultstring, "\n";
580 :     return undef;
581 :     }
582 :    
583 :     return $reply->result;
584 :     }
585 :    
586 :    
587 :     #############
588 :     #
589 :     # P2P Service
590 :     #
591 :     # Code in this module is invoked on the target on behalf of a requestor.
592 :     #
593 :     #############
594 :    
595 :     package P2P::Service;
596 :    
597 :     use Data::Dumper;
598 :    
599 :     use FIG;
600 :     use FIG_Config;
601 :     use strict;
602 :    
603 :     use File::Temp qw(tempdir);
604 :     use File::Basename;
605 :    
606 :     sub request_update
607 :     {
608 :     my($class, $his_release, $last_update)= @_;
609 :    
610 :     #
611 :     # Verify input.
612 :     #
613 :    
614 :     if ($last_update !~ /^\d+$/)
615 :     {
616 :     die "request_update: last_update must be a number (not '$last_update')\n";
617 :     }
618 :    
619 :     #
620 :     # Create a new session id and a spool directory to use for storage
621 :     # of information about it. This can go in the tempdir since it is
622 :     # not persistent.
623 :     #
624 :    
625 :     &FIG::verify_dir("$FIG_Config::temp/p2p_spool");
626 :     #my $spool_dir = tempdir(DIR => "$FIG_Config::temp/p2p_spool");
627 :    
628 :     my $spool_dir = "$FIG_Config::temp/p2p_spool/test";
629 :     &FIG::verify_dir($spool_dir);
630 :    
631 :     my $session_id = basename($spool_dir);
632 :     my $now = time;
633 :    
634 :     #
635 :     # Gather the list of pegs and annotations for the update.
636 :     #
637 :    
638 :     my $fig = new FIG;
639 :    
640 :     my $all_genomes = [$fig->genomes];
641 :    
642 :     my %all_genomes = map { $_ => 1 } @$all_genomes;
643 :    
644 :     my %pegs;
645 : olson 1.15
646 :     #
647 :     # We keep track of usernames that have been seen, so that
648 :     # we can both update our local user database and
649 :     # we can report them to our peer.
650 :     #
651 :    
652 :     my %users;
653 : olson 1.1
654 :     my $num_annos = 0;
655 :     my $num_genomes = 0;
656 :     my $num_pegs = 0;
657 : olson 1.15 my $num_assignments = 0;
658 : olson 1.1
659 :     my $anno_fh;
660 :     open($anno_fh, ">$spool_dir/annos");
661 :    
662 :     my $peg_fh;
663 :     open($peg_fh, ">$spool_dir/pegs");
664 :    
665 :     my $genome_fh;
666 :     open($genome_fh, ">$spool_dir/genomes");
667 :    
668 : olson 1.15 my $assign_fh;
669 :     open($assign_fh, ">$spool_dir/assignments");
670 :    
671 : olson 1.1 for my $genome (@$all_genomes)
672 :     {
673 :     my $num_annos_for_genome = 0;
674 : olson 1.15 my %assignment;
675 : olson 1.1
676 :     my $genome_dir = "$FIG_Config::organisms/$genome";
677 :     next unless -d $genome_dir;
678 :    
679 :     my $afh;
680 :     if (open($afh, "$genome_dir/annotations"))
681 :     {
682 :     my($fid, $anno_time, $who, $anno_text);
683 :     local($/);
684 :     $/ = "//\n";
685 :     while (my $ann = <$afh>)
686 :     {
687 :     chomp $ann;
688 :    
689 :     if ((($fid, $anno_time, $who, $anno_text) =
690 :     ($ann =~ /^(fig\|\d+\.\d+\.peg\.\d+)\n(\d+)\n(\S+)\n(.*\S)/s)) and
691 :     $anno_time > $last_update)
692 :    
693 :     {
694 :     #
695 : olson 1.15 # Update users list.
696 :     #
697 :    
698 :     $users{$who}++;
699 :    
700 :     #
701 : olson 1.1 # Look up aliases if we haven't seen this fid before.
702 :     #
703 :    
704 :     if (!defined($pegs{$fid}))
705 :     {
706 :     my @aliases = $fig->feature_aliases($fid);
707 :    
708 :     print $peg_fh join("\t", $fid, $genome, @aliases), "\n";
709 :     $num_pegs++;
710 :     }
711 :    
712 :     print $anno_fh "$ann//\n";
713 :    
714 :     $pegs{$fid}++;
715 :    
716 :     $num_annos_for_genome++;
717 :     $num_annos++;
718 : olson 1.15
719 :     #
720 :     # While we're here, see if this is an assignment. We check in the
721 :     # %assignment hash, which is keyed on fid, to see if we already
722 :     # saw an assignment for this fid. If we have, we keep this one only if
723 :     # the assignment time on it is later than the one we saw already.
724 :     #
725 :     # We are only looking at master assignments for now. We will need
726 :     # to return to this issue and reexamine it, but in order to move
727 :     # forward I am only matching master assignments.
728 :     #
729 :    
730 :     if ($anno_text =~ /Set master function to\n(\S[^\n]+\S)/)
731 :     {
732 :     my $func = $1;
733 :    
734 :     my $other = $assignment{$fid};
735 :    
736 :     #
737 :     # If we haven't seen an assignment for this fid,
738 :     # or if it the other assignment has a timestamp that
739 :     # is earlier than this one, set the assignment.
740 :     #
741 :    
742 :     if (!defined($other) or
743 :     ($other->[1] < $anno_time))
744 :     {
745 :     $assignment{$fid} = [$fid, $anno_time, $who, $func];
746 :     }
747 :     }
748 : olson 1.1 }
749 :     }
750 :     close($afh);
751 : olson 1.15
752 :     #
753 :     # Write out the assignments that remain.
754 :     #
755 :    
756 :     for my $fid (sort keys(%assignment))
757 :     {
758 :     print $assign_fh join("\t", @{$assignment{$fid}}), "\n";
759 :     $num_assignments++;
760 :     }
761 : olson 1.1 }
762 : olson 1.15
763 : olson 1.1
764 :     #
765 :     # Determine genome information if we have annotations for this one.
766 :     #
767 :    
768 :     if ($num_annos_for_genome > 0)
769 :     {
770 :     $num_genomes++;
771 :     if (open(my $cfh, "<$genome_dir/COUNTS"))
772 :     {
773 :     if ($_ = <$cfh>)
774 :     {
775 :     chomp;
776 :     my($cgenome, $n_contigs, $total_nucs, $cksum) = split(/\t/, $_);
777 :     if ($cgenome ne $genome)
778 :     {
779 :     warn "Hm, $genome has a COUNTS file with genome=$cgenome that does not match\n";
780 :     }
781 :     else
782 :     {
783 :     print $genome_fh join("\t",
784 :     $genome, $num_annos_for_genome, $n_contigs,
785 :     $total_nucs, $cksum), "\n";
786 :     }
787 :     }
788 :     }
789 :     }
790 :    
791 :     }
792 :     close($anno_fh);
793 :     close($peg_fh);
794 :     close($genome_fh);
795 : olson 1.15 close($assign_fh);
796 : olson 1.1
797 :     print "Pegs: $num_pegs\n";
798 :     print "Genomes: $num_genomes\n";
799 :     print "Annos: $num_annos\n";
800 :    
801 :     #
802 :     # Check compatibility.
803 :     #
804 :    
805 : olson 1.18 my $my_release = [$fig->get_release_info()];
806 :    
807 :     #
808 :     # Release id is $my_release->[1].
809 :     #
810 :    
811 :     my $compatible;
812 :     if ($my_release->[1] ne "" and $his_release->[1] ne "")
813 :     {
814 :     #
815 :     # Both releases must be defined for them to be compatible.
816 :     #
817 :     # At some point we need to consider the derived-release issue.
818 :     #
819 :    
820 :     $compatible = $my_release->[1] eq $his_release->[1];
821 :     }
822 :     else
823 :     {
824 :     $compatible = 0;
825 :     }
826 : olson 1.1
827 :     open(my $fh, ">$spool_dir/INFO");
828 :     print $fh "requestor_release\t$his_release\n";
829 :     print $fh "last_update\t$last_update\n";
830 :     print $fh "cur_update\t$now\n";
831 :     print $fh "target_release\t$my_release\n";
832 :     print $fh "compatible\t$compatible\n";
833 :     print $fh "num_pegs\t$num_pegs\n";
834 :     print $fh "num_genomes\t$num_genomes\n";
835 :     print $fh "num_annos\t$num_annos\n";
836 : olson 1.15 print $fh "num_assignments\t$num_assignments\n";
837 : olson 1.1 close($fh);
838 :    
839 : olson 1.15 #
840 :     # Construct list of users, and pdate local user database.
841 :     #
842 :    
843 :     my @users = keys(%users);
844 : olson 1.17 # $fig->ensure_users(\@users);
845 : olson 1.15
846 :     return [$session_id, $my_release, $num_assignments, $num_annos, $num_pegs, $num_genomes,
847 : olson 1.16 $now, $compatible, \@users];
848 : olson 1.1 }
849 :    
850 :    
851 :     sub get_pegs
852 :     {
853 :     my($self, $session_id, $start, $len) = @_;
854 :     my(%session_info);
855 :    
856 :     my $spool_dir = "$FIG_Config::temp/p2p_spool/$session_id";
857 :    
858 :     -d $spool_dir or die "Invalid session id $session_id";
859 :    
860 :     #
861 :     # Read in the cached information for this session.
862 :     #
863 :    
864 :     open(my $info_fh, "<$spool_dir/INFO") or die "Cannot open INFO file: $!";
865 :     while (<$info_fh>)
866 :     {
867 :     chomp;
868 :     my($var, $val) = split(/\t/, $_, 2);
869 :     $session_info{$var} = $val;
870 :     }
871 :     close($info_fh);
872 :    
873 :     #
874 :     # Sanity check start and length.
875 :     #
876 :    
877 :     if ($start < 0 or $start >= $session_info{num_pegs})
878 :     {
879 :     die "Invalid start position $start";
880 :     }
881 :    
882 :     if ($len < 0 or ($start + $len - 1) >= $session_info{num_pegs})
883 :     {
884 :     die "Invalid length $len";
885 :     }
886 :    
887 :     #
888 :     # Open file, spin to the starting line, then start reading.
889 :     #
890 :    
891 :     open(my $peg_fh, "<$spool_dir/pegs") or die "Cannot open pegs file: $!";
892 :    
893 :     my $peg_output = [];
894 :     my $genome_output = [];
895 :    
896 :     my $peg_num = 0;
897 :     my $genomes_to_show = [];
898 :     my %genomes_to_show;
899 :    
900 :     my($fid, $genome, @aliases);
901 :    
902 :     while (<$peg_fh>)
903 :     {
904 :     next if ($peg_num < $start);
905 :    
906 :     last if ($peg_num > ($start + $len));
907 :    
908 :     chomp;
909 :    
910 :     #
911 :     # OK, this is a peg to process.
912 :     # It's easy if we're compatible.
913 :     #
914 :    
915 :     ($fid, $genome, @aliases) = split(/\t/, $_);
916 :    
917 :     if ($session_info{compatible})
918 :     {
919 :     push(@$peg_output, ['peg', $fid]);
920 :     }
921 :     else
922 :     {
923 :     if (!$genomes_to_show{$genome})
924 :     {
925 :     push(@$genomes_to_show, $genome);
926 :     $genomes_to_show{$genome}++;
927 :     }
928 :     push(@$peg_output, ['peg_info', $fid, [@aliases], $genome]);
929 :     }
930 :     }
931 :     continue
932 :     {
933 :     $peg_num++;
934 :     }
935 :    
936 :     #
937 :     # Read the genomes file, returning information about genomes referenced
938 :     # in the pegs returned.
939 :     #
940 :    
941 :     my $n_left = @$genomes_to_show;
942 :    
943 :     open(my $gfh, "<$spool_dir/genomes") or die "Cannot open genomes file: $!";
944 :     while ($n_left > 0 and $_ = <$gfh>)
945 :     {
946 :     chomp;
947 :    
948 :     my($genome, $n_annos, $n_contigs, $n_nucs, $cksum) = split(/\t/);
949 :    
950 :     if ($genomes_to_show{$genome})
951 :     {
952 :     push(@$genome_output, [$genome, $n_contigs, $n_nucs, $cksum]);
953 :     $n_left--;
954 :     }
955 :     }
956 :     close($gfh);
957 :    
958 :     return [$peg_output, $genome_output];
959 :     }
960 : olson 1.6
961 :     sub finalize_pegs
962 :     {
963 :     my($self, $session, $request) = @_;
964 :     my($out);
965 :    
966 :     my $fig = new FIG;
967 :    
968 :     #
969 :     # Walk the request handling appropriately. This is fairly easy, as it
970 :     # is just a matter of pulling either sequence or location/contig data.
971 :     #
972 :    
973 :     for my $item (@$request)
974 :     {
975 :     my($what, $peg) = @$item;
976 :    
977 :     if ($what eq "peg_genome")
978 :     {
979 :     #
980 :     # Return the location and contig checksum for this peg.
981 :     #
982 : olson 1.13 # We also include the sequence in case the contig mapping doesn't work.
983 :     #
984 : olson 1.6
985 :     my $loc = $fig->feature_location($peg);
986 :     my $contig = $fig->contig_of($loc);
987 : olson 1.7 my $cksum = $fig->contig_checksum($fig->genome_of($peg), $contig);
988 : olson 1.13 my $seq = $fig->get_translation($peg);
989 : olson 1.6
990 :     push(@$out, ['peg_loc', $peg,
991 : olson 1.13 $fig->strand_of($peg),
992 : olson 1.6 $fig->beg_of($loc), $fig->end_of($loc),
993 : olson 1.13 $cksum, $seq]);
994 : olson 1.6
995 :     }
996 : olson 1.7 elsif ($what eq "peg_unknown")
997 : olson 1.6 {
998 :     my $seq = $fig->get_translation($peg);
999 :     push(@$out, ['peg_seq', $peg, $seq]);
1000 :     }
1001 :     }
1002 :     return $out;
1003 :     }
1004 :    
1005 : olson 1.15
1006 :     sub get_annotations
1007 :     {
1008 :     my($self, $session_id, $start, $len) = @_;
1009 :    
1010 :     #
1011 :     # This is now easy; just run thru the saved annotations and return.
1012 :     #
1013 :    
1014 :     my(%session_info);
1015 :    
1016 :     my $spool_dir = "$FIG_Config::temp/p2p_spool/$session_id";
1017 :    
1018 :     -d $spool_dir or die "Invalid session id $session_id";
1019 :    
1020 :     #
1021 :     # Read in the cached information for this session.
1022 :     #
1023 :    
1024 :     open(my $info_fh, "<$spool_dir/INFO") or die "Cannot open INFO file: $!";
1025 :     while (<$info_fh>)
1026 :     {
1027 :     chomp;
1028 :     my($var, $val) = split(/\t/, $_, 2);
1029 :     $session_info{$var} = $val;
1030 :     }
1031 :     close($info_fh);
1032 :    
1033 :     #
1034 :     # Sanity check start and length.
1035 :     #
1036 :    
1037 :     if ($start < 0 or $start >= $session_info{num_annos})
1038 :     {
1039 :     die "Invalid start position $start";
1040 :     }
1041 :    
1042 :     if ($len < 0 or ($start + $len - 1) >= $session_info{num_annos})
1043 :     {
1044 :     die "Invalid length $len";
1045 :     }
1046 :    
1047 :     #
1048 :     # Open file, spin to the starting line, then start reading.
1049 :     #
1050 :    
1051 :     open(my $anno_fh, "<$spool_dir/annos") or die "Cannot open annos file: $!";
1052 :    
1053 :     my $anno_output = [];
1054 :    
1055 :     my $anno_num = 0;
1056 :    
1057 :     local $/ = "//\n";
1058 :     while (<$anno_fh>)
1059 :     {
1060 :     next if ($anno_num < $start);
1061 :    
1062 :     last if ($anno_num > ($start + $len));
1063 :    
1064 :     chomp;
1065 :    
1066 :     my($id, $date, $author, $anno) = split(/\n/, $_, 4);
1067 :    
1068 :     push(@$anno_output, [$id, $date, $author, $anno]);
1069 :     }
1070 :     continue
1071 :     {
1072 :     $anno_num++;
1073 :     }
1074 :    
1075 :     return $anno_output;
1076 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3